diff --git a/assembler/assem.lisp b/assembler/assem.lisp deleted file mode 100644 index 0811ac163aece2131b8d012e4149a6cc96108328..0000000000000000000000000000000000000000 --- a/assembler/assem.lisp +++ /dev/null @@ -1,697 +0,0 @@ -;;; -*- 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))))) - diff --git a/assembler/assembler.lisp b/assembler/assembler.lisp deleted file mode 100644 index 7f4377292ee1808f9352b794d00f2b459342a341..0000000000000000000000000000000000000000 --- a/assembler/assembler.lisp +++ /dev/null @@ -1,1693 +0,0 @@ -;;; -*- Mode: Lisp; Package: Compiler; Log: clc.log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; A user-level assembler for the ROMP. -;;; Written by Skef Wholey. -;;; -;;; This program processes a file of lispy assembly code and produces a Lisp -;;; FASL file. It will be used primarily for coding the assembler support -;;; routines, but later might be used by applications programmers to speed up -;;; inner loops. -;;; -;;; The file to be assembled consists of Lisp forms. Most forms are simply -;;; evaluated -- macro definitions, constant declarations, and things like that -;;; are made this way. Three forms are treated specially: -;;; Define-Miscop, which defines a miscop, -;;; Define-Assembler-Routine, which defines a random piece of assembly code, -;;; Defun-In-Assembly-Code, which defines a Lisp-callable function. -;;; -(in-package "COMPILER") - -(export 'assemble-file) - -(import '(lisp::define-fop lisp::fop-assembler-routine - lisp::fop-fixup-miscop-routine - lisp::fop-fixup-user-miscop-routine - lisp::fop-fixup-assembler-routine - lisp::fop-fun) - (find-package 'compiler)) - -;;; %%% Unixfy external definitions, references -;;; %%% Possibly help enforce 8 character uniqueness lossage -;;; %%% Data blocks -;;; %%% Tied down things - - -(defvar *undefined-labels* () - "List of all undefined labels in the current file.") - -(defvar *defined-labels* () - "List of all defined labels in the current file.") - -(defparameter romp-assembler-version "1.0") - -;;; The ROMP instruction set database for the user-level assembler. - -;;; All the stuff we need to know about an instruction is held in a structure -;;; hanging off of its %Instruction-Info property. - -(defstruct (romp-info (:print-function print-romp-info) - (:constructor make-romp-info (name format opcode))) - name ; symbolic name - format ; ROMP format - opcode) ; numeric opcode - -(defun print-romp-info (structure stream depth) - (declare (ignore depth)) - (format stream "#<The ~S instruction>" (romp-info-name structure))) - -(defmacro def-romp-instr (name format opcode) - `(setf (get ',name '%instruction-info) - (make-romp-info ',name ',format ,opcode))) - - -;;; The half dozen "instruction formats" described in the ROMP architecture -;;; guide aren't really sufficient for our purposes -- we've added a couple. -;;; The formats are: -;;; JI 4 bit opcode, 4 bit N, 8 bits jump offset -;;; X 4 bit opcode, 3 register fields -;;; DS 4 bit opcode, 4 bit N, 2 registers -;;; R 8 bit opcode, 2 registers -;;; R1 8 bit opcode, 4 bit N, 1 register -;;; R2 8 bit opcode, 1 register, 4 bit N -;;; BI 8 bit opcode, 1 register, 20 bits jump offset -;;; BA 8 bit opcode, 24 bits absolute jump address -;;; D 8 bit opcode, 2 registers, 16 bit N -;;; SR 12 bit opcode, 1 register -;;; SN 12 bit opcode, 4 bit N - - -;;; Storage Access instructions: - -(def-romp-instr lcs ds #x04) -(def-romp-instr lc d #xCE) -(def-romp-instr lhas ds #x05) -(def-romp-instr lha d #xCA) -(def-romp-instr lhs r #xEB) -(def-romp-instr lh d #xDA) -(def-romp-instr ls ds #x07) -(def-romp-instr l d #xCD) -(def-romp-instr lm d #xC9) -(def-romp-instr tsh d #xCF) -(def-romp-instr stcs ds #x01) -(def-romp-instr stc d #xDE) -(def-romp-instr sths ds #x02) -(def-romp-instr sth d #xDC) -(def-romp-instr sts ds #x03) -(def-romp-instr st d #xDD) -(def-romp-instr stm d #xD9) - -;;; Address Computation instructions: - -(def-romp-instr cal d #xC8) -(def-romp-instr cal16 d #xC2) -(def-romp-instr cau d #xD8) -(def-romp-instr cas x #x06) -(def-romp-instr ca16 r #xF3) -(def-romp-instr inc r2 #x91) -(def-romp-instr dec r2 #x93) -(def-romp-instr lis r2 #xA4) - -;;; Branching instructions: - -(def-romp-instr bala ba #x8A) -(def-romp-instr balax ba #x8B) -(def-romp-instr bali bi #x8C) -(def-romp-instr balix bi #x8D) -(def-romp-instr balr r #xEC) -(def-romp-instr balrx r #xED) -(def-romp-instr jb ji #x01) -(def-romp-instr bb bi #x8E) -(def-romp-instr bbx bi #x8F) -(def-romp-instr bbr r1 #xEE) -(def-romp-instr bbrx r1 #xEF) -(def-romp-instr jnb ji #x00) -(def-romp-instr bnb bi #x88) -(def-romp-instr bnbx bi #x89) -(def-romp-instr bnbr r #xE8) -(def-romp-instr bnbrx r #xe9) - -;;; Trap instructions: - -(def-romp-instr ti d #xCC) -(def-romp-instr tgte r #xBD) -(def-romp-instr tlt r #xBE) - -;;; Move and Insert instructions. - -(def-romp-instr mc03 r #xF9) -(def-romp-instr mc13 r #xFA) -(def-romp-instr mc23 r #xFB) -(def-romp-instr mc33 r #xFC) -(def-romp-instr mc30 r #xFD) -(def-romp-instr mc31 r #xFE) -(def-romp-instr mc32 r #xFF) -(def-romp-instr mftb r #xBC) -(def-romp-instr mftbil r2 #x9D) -(def-romp-instr mftbiu r2 #x9C) -(def-romp-instr mttb r #xBF) -(def-romp-instr mttbil r2 #x9F) -(def-romp-instr mttbiu r2 #x9E) - -;;; Arithmetic instructions. - -(def-romp-instr a r #xE1) -(def-romp-instr ae r #xF1) -(def-romp-instr aei d #xD1) -(def-romp-instr ai d #xC1) -(def-romp-instr ais r2 #x90) -(def-romp-instr abs r #xE0) -(def-romp-instr onec r #xF4) -(def-romp-instr twoc r #xE4) -(def-romp-instr c r #xB4) -(def-romp-instr cis r2 #x94) -(def-romp-instr ci d #xD4) -(def-romp-instr cl r #xB3) -(def-romp-instr cli d #xD3) -(def-romp-instr exts r #xB1) -(def-romp-instr s r #xE2) -(def-romp-instr sf r #xB2) -(def-romp-instr se r #xF2) -(def-romp-instr sfi d #xD2) -(def-romp-instr sis r2 #x92) -(def-romp-instr d r #xB6) -(def-romp-instr m r #xE6) - -;;; Logical instructions. - -(def-romp-instr clrbl r2 #x99) -(def-romp-instr clrbu r2 #x98) -(def-romp-instr setbl r2 #x9B) -(def-romp-instr setbu r2 #x9A) -(def-romp-instr n r #xE5) -(def-romp-instr nilz d #xC5) -(def-romp-instr nilo d #xC6) -(def-romp-instr niuz d #xD5) -(def-romp-instr niuo d #xD6) -(def-romp-instr o r #xE3) -(def-romp-instr oil d #xC4) -(def-romp-instr oiu d #xC3) -(def-romp-instr x r #xE7) -(def-romp-instr xil d #xC7) -(def-romp-instr xiu d #xD7) -(def-romp-instr clz r #xF5) - -;;; Shifting instructions. - -(def-romp-instr sar r #xB0) -(def-romp-instr sari r2 #xA0) -(def-romp-instr sari16 r2 #xA1) -(def-romp-instr sr r #xB8) -(def-romp-instr sri r2 #xA8) -(def-romp-instr sri16 r2 #xA9) -(def-romp-instr srp r #xB9) -(def-romp-instr srpi r2 #xAC) -(def-romp-instr srpi16 r2 #xAD) -(def-romp-instr sl r #xBA) -(def-romp-instr sli r2 #xAA) -(def-romp-instr sli16 r2 #xAB) -(def-romp-instr slp r #xBB) -(def-romp-instr slpi r2 #xAE) -(def-romp-instr slpi16 r2 #xAF) - -;;; Special Purpose Register Manipulation instructions. - -(def-romp-instr mtmq sr #xB5A) -(def-romp-instr mfmq sr #x96A) -(def-romp-instr mtcsr sr #xB5F) -(def-romp-instr mfcsr sr #x96F) -(def-romp-instr clrcb sn #x95F) -(def-romp-instr setcb sn #x97F) - -;;; Execution Control instructions. - -(def-romp-instr lps d #xD0) -(def-romp-instr svc d #xC0) - -(defvar *produce-unixy-cruft* nil - "If T, the LAP file will have stuff that should be legal food for a unixy - assembler.") - - -;;; PRINT-FILE-HEADER prints assorted information at the start of an -;;; ascii output file. - -(defun print-file-header (stream output-type input-namestring) - (format stream - "~%;;; ~A output for file ~A." - output-type input-namestring) - (format stream - "~%;;; Assembled by assembler version ~A.~%" - romp-assembler-version)) - -(defun assemble-file (input-pathname - &key (output-file t) (error-file t) (listing-file nil) - ((:unixy-lap-file *produce-unixy-cruft*) nil)) - "Assembles the file named by the Input-Pathname." - (declare (optimize (speed 3) (safety 0))) - (let* ((*clc-input-stream* - (open (merge-pathnames input-pathname ".romp") :direction :input)) - (*clc-fasl-stream* - (if output-file - (open (if (eq output-file t) - (make-pathname :defaults input-pathname :type "fasl") - output-file) - :if-exists :new-version - :direction :output - :element-type '(unsigned-byte 8)))) - (error-file-stream - (if error-file - (open (if (eq error-file t) - (make-pathname :defaults input-pathname :type "err") - error-file) - :if-exists :new-version - :direction :output))) - (*clc-err-stream* - (if error-file - (make-broadcast-stream error-file-stream *standard-output*) - *standard-output*)) - (*clc-lap-stream* - (if listing-file - (open (if (eq listing-file t) - (make-pathname :defaults input-pathname - :type (if *produce-unixy-cruft* - "s" - "list")) - listing-file) - :if-exists :new-version - :direction :output))) - (error-count 0) - (warning-count 0) - (assembly-won nil) - (input-namestring (namestring input-pathname)) - (*defined-labels* ()) - (*undefined-labels* ()) - (*package* (find-package "COMPILER"))) - (unwind-protect - (progn - ;; Initialize the files. - (when output-file - (format *clc-fasl-stream* - "FASL FILE output from ~A~%" input-namestring) - (start-fasl-file) - (fasl-dump-cold-load-form '(in-package "COMPILER"))) - (if error-file - (print-file-header error-file-stream "Error" input-namestring)) - (if (and listing-file (not *produce-unixy-cruft*)) - (print-file-header *clc-lap-stream* "Listing" input-namestring)) - ;; All set up. Let the festivities begin. - (clc-mumble "~%Starting assembly of file ~S.~%" input-namestring) - (assembler-loop) - ;; All done. Let the post-mortems begin. - (clc-mumble "~2%Finished assembly of file ~S." input-namestring) - (clc-mumble "~%~S Errors, ~S Warnings." error-count warning-count) - (dolist (label *defined-labels*) - (setq *undefined-labels* - (delete label *undefined-labels* :test #'eq))) - (if (> (length *undefined-labels*) 0) - (clc-mumble "~%~S Undefined labels in file ~S: ~{~% ~S~}." - (length *undefined-labels*) input-namestring - *undefined-labels*)) - (terpri) - (setq assembly-won t)) - ;; Close files. Unwind-Protect makes sure that these get closed even - ;; if compilation is aborted. If the assembly did not win, abort the fasl - ;; file instead of writing out a whole lot of useless stuff. - (close *clc-input-stream*) - (when (streamp *clc-fasl-stream*) - (terminate-fasl-file) - (close *clc-fasl-stream* :abort (not assembly-won))) - (when error-file-stream (close error-file-stream)) - (when (streamp *clc-lap-stream*) (close *clc-lap-stream*))))) - -(defvar *unique-thing* '(*unique-thing*)) - -(defun assembler-loop () - (do ((form (read *clc-input-stream* nil *unique-thing*) - (read *clc-input-stream* nil *unique-thing*))) - ((eq form *unique-thing*)) - (process-assembler-form form))) - -(defun process-assembler-form (form) - (declare (optimize (speed 3) (safety 0))) - (cond ((atom form)) - ((eq (car form) 'define-miscop) - (process-define-miscop form)) - ((eq (car form) 'define-user-miscop) - (process-define-user-miscop form)) - ((eq (car form) 'define-assembler-routine) - (process-define-assembler-routine form)) - ((eq (car form) 'defun-in-assembly-code) - (process-defun-in-assembly-code form)) - ((macro-function (car form)) - (process-assembler-form (macroexpand form))) - ((or (functionp (car form)) (special-form-p (car form))) - (eval form)) - (t - (eval form)))) - -;;; There are three kinds of labels: -;;; Local labels, which are used within a miscop or routine. -;;; External labels, which are used between routines. -;;; Absolute labels, which might not be used at all. -;;; -;;; Labels appear as symbols in the code, and information about a label is -;;; stored on that symbol's property list. The kind of label, either LOCAL, -;;; EXTERNAL, or ABSOLUTE, is store on the %LABEL-KIND property. The location -;;; of the label, is stored on the %LABEL-LOCATION property. For local labels, -;;; the location is the offset in halfwords from the beginning of the routine. -;;; The locations of external labels is left unresolved until load time. The -;;; location of absolute labels the byte address of the code they address. -;;; -;;; Labels may be referenced in one of four ways: -;;; JI, which means the reference is from a JI relative branch instruction. -;;; BI, which means the reference is from a BI relative branch instruction. -;;; BA, which means the reference is from a BA absolute branch instruction. -;;; L, which means the reference is from a pair of CA instructions. -;;; -;;; When each routine is assembled and dumped, the locations of any external -;;; labels defined in it are also dumped. The locations of any external labels -;;; it defines are dumped as well. When all files making up the system are -;;; loaded, the routines are "linked" by resolving the external references. - - -(defvar *local-labels* () - "List of labels local to this routine.") - -(defvar *external-labels* () - "List of external labels defined by this routine. Each definition is of the - form (Label . Location).") - -(defvar *external-references* () - "List of external references made by this routine. Each reference is of the - form (Type Label Location).") - -;;; Define-XXX-Label defines a label at the given location. - -(defun define-local-label (label location) - (declare (optimize (speed 3) (safety 0))) - (when (get label '%label-kind) - (clc-error "~S is already a defined label." label)) - (push label *local-labels*) - (push label *defined-labels*) - (setf (get label '%label-kind) 'local) - (setf (get label '%label-location) location)) - -(defun define-external-label (label location) - (declare (optimize (speed 3) (safety 0))) - (when (get label '%label-kind) - (clc-error "~S is already a defined label." label)) - (push (cons label location) *external-labels*) - (push label *defined-labels*) - (setf (get label '%label-kind) 'external) - (setf (get label '%label-location) location)) - - -;;; Reference-Label references a label in the given way. If a location can -;;; sensibly be returned, it is. Otherwise, 0 is returned and the reference -;;; is added to the list of references to be resolved at load time. The -;;; Location parameter is the halfword offset in the current routine at -;;; which the reference is made. - -(defun reference-label (label how location) - (declare (optimize (speed 3) (safety 0))) - (when (and (not (memq label *defined-labels*)) - (not (memq label *undefined-labels*))) - (push label *undefined-labels*)) - (case (get label '%label-kind) - ((local external) ; treated the same at this point - (case how - ((bi ji) - (get label '%label-location)) - ((ba l) - (push `(,how ,label ,location) - *external-references*) - 0))) - (absolute - (case how - ((bi ji) - (push `(,how ,label ,location) - *external-references*) - 0) - ((ba l) - (get label '%label-location)))) - (T - (push `(,how ,label ,location) *external-references*) - 0))) - - -;;; Short-Jump-P is used by the jump optimizer to determine if a branch can be -;;; turned into a Jump. The Location of the branching instruction and the -;;; label that is the destination of the jump are given. Note that if the thing -;;; is 128 words away, we'll be able to short jump to it after the halfword is -;;; optimizied out of the branching instruction. - -(defun short-jump-p (location label) - (declare (fixnum location)) - (case (get label '%label-kind) - ((local external) - (<= -128 (the fixnum (- (the fixnum (get label '%label-location)) - location)) 128)) - (t - nil))) - - -;;; Clean-Up-Labels nukes the properties of labels defined in the -;;; current routine. - -(defun clean-up-labels () - (declare (optimize (speed 3) (safety 0))) - (dolist (label *local-labels*) - (remprop label '%label-kind) - (remprop label '%label-location)) - (dolist (label *external-labels*) - (remprop (car label) '%label-kind) - (remprop (car label) '%label-location))) - -;;; Process-XXX does a little special stuff and calls Assemble-Top-Level-List -;;; to spit out code. - -(defun process-define-miscop (form) - (let ((function-name (cadr form)) - (*local-labels* '()) - (*external-labels* '()) - (*external-references* '()) - (body (cddr form))) - (define-external-label function-name 0) - (unwind-protect - (assemble-top-level-list function-name body) - (clean-up-labels)) - (dump-fop 'lisp::fop-fixup-miscop-routine) - (clc-mumble "~%~S assembled." function-name))) - -(defun process-define-user-miscop (form) - (let ((function-name (cadr form)) - (*local-labels* '()) - (*external-labels* '()) - (*external-references* '()) - (body (cddr form))) - (define-external-label function-name 0) - (unwind-protect - (assemble-top-level-list function-name body) - (clean-up-labels)) - (dump-fop 'lisp::fop-fixup-user-miscop-routine) - (clc-mumble "~%~S assembled." function-name))) - -(defun process-define-assembler-routine (form) - (let ((function-name (cadr form)) - (*local-labels* '()) - (*external-labels* '()) - (*external-references* '()) - (body (cddr form))) - (define-external-label function-name 0) - (unwind-protect - (assemble-top-level-list function-name body) - (clean-up-labels)) - (dump-fop 'lisp::fop-fixup-assembler-routine) - (clc-mumble "~%~S assembled." function-name))) - -(defun process-defun-in-assembly-code (form) - (declare (ignore form)) - (clc-error "Defun-In-Assembly-Code is not yet implemented.")) - -;;; Pass 1. We just fly down the list, expanding macros and finding addresses -;;; of the labels. The macroexpanded code is put into *pass1-list*. Each -;;; element of that list is either a cons of the instruction's byte offset from -;;; the start of the routine and the instruction or a label. - -(defvar *pass1-list* '()) - -;;; Assemble-Top-Level-List performs both passes, writing out the length in -;;; bytes of the function before anything else. The Process-mumbles count on -;;; the length in bytes to be written out that way. - -(defun assemble-top-level-list (function-name list) - (let ((*pass1-list* '())) - (do ((list list (cdr list)) - (location 0)) - ((null list) - (setq *pass1-list* (nreverse *pass1-list*)) - (setq location (optimize-jumps location)) - (dump-fop 'lisp::fop-assembler-routine) - (quick-dump-number (ash location 1) 4) - (pass2-top-level-list) - (let ((*hands-off-table* t)) - (dump-fop 'lisp::fop-normal-load) - (dump-object function-name) - (dump-object *external-labels*) - (dump-object *external-references*) - (dump-fop 'lisp::fop-maybe-cold-load))) - (setq location (assemble-one-instruction (car list) location))))) - -;;; Symbols in the instruction list are labels -- keywords are external labels. -;;; Lists that don't begin with an instruction mnemonic are macroexpanded and -;;; expected to return a list of instructions. - -(defun assemble-one-instruction (inst location) - (declare (optimize (speed 3) (safety 0))) - (cond ((atom inst) - (if (keywordp inst) - (define-external-label inst location) - (define-local-label inst location)) - (push inst *pass1-list*)) - (t - (let ((info (get (car inst) '%instruction-info))) - (cond (info - (push (cons location inst) *pass1-list*) - (case (romp-info-format info) - ((ji x ds r r1 r2 sr sn) - (setq location (+ location 1))) - ((bi ba d) - (setq location (+ location 2))))) - ((macro-function (car inst)) - (dolist (inst (macroexpand inst)) - (setq location (assemble-one-instruction inst location)))) - (t - (clc-error "~S is a bad instruction list." inst)))))) - location) - -;;; Jump optimizer. We turn BI branches into JI branches if we can. Currently -;;; we punt on the possibility that the halfword saved by optimizing a branch -;;; might make possible optimization of branches already processed, since such -;;; computation chews up a lot of time for relatively little gain. We return -;;; the new number of halfwords in the *Pass1-List*. - -(defun optimize-jumps (length) - (declare (optimize (speed 3) (safety 0))) - (do* ((list *pass1-list* (cdr list)) - (stuff (car list) (car list)) - (instp (consp stuff) (consp stuff)) - (location (if instp (car stuff)) (if instp (car stuff))) - (inst (if instp (cdr stuff)) (if instp (cdr stuff)))) - ((null list) length) - (when (and instp - (or (eq (car inst) 'bb) (eq (car inst) 'bnb)) - (<= 8 (eval (cadr inst)) 15) - (short-jump-p location (caddr inst))) - (setf (car inst) (cdr (assoc (car inst) '((bb . jb) (bnb . jnb))))) - (setf (cadr inst) (- (cadr inst) 8)) - (setq length (1- length)) - (dolist (stiff (cdr list)) - (if (consp stiff) - (setf (car stiff) (1- (car stiff))))) - (dolist (label *local-labels*) - (let ((loc (get label '%label-location))) - (when (> loc location) - (setf (get label '%label-location) (1- loc))))) - (dolist (label *external-labels*) - (let ((loc (cdr label))) - (when (> loc location) - (setf (cdr label) (1- loc)) - (setf (get (car label) '%label-location) (1- loc)))))))) - -;;; Pass 2. We fly down the list created in pass 1, and interpret the -;;; instructions according to their format. We spit the binary code out to the -;;; *Clc-Fasl-Stream*, and listing information out to *Clc-Lap-Stream* using -;;; Dump-Instruction. - -(defun pass2-top-level-list () - (declare (optimize (speed 3) (safety 0))) - (when *clc-lap-stream* - (if *produce-unixy-cruft* - (format *clc-lap-stream* "~2%~(~A~):" (unixfy function-name)) - (format *clc-lap-stream* "~2% ~S~%" function-name))) - (dolist (stuff *pass1-list*) - (if (atom stuff) - (dump-instruction stuff) - (let* ((location (car stuff)) - (inst (cdr stuff)) - (name (car inst)) - (args (cdr inst)) - (info (get name '%instruction-info)) - (opcode (romp-info-opcode info))) - (case (romp-info-format info) - (ji - (let* ((n (car args)) - (n-value (eval n)) - (ji (cadr args)) - (ji-value (reference-label ji 'ji location))) - (cond ((not (and n ji)) - (clc-error "Bad JI format instruction: ~S." inst)) - ((not (<= 0 n-value 7)) - (clc-error "N field out of range in ~S." inst)) - (t - (let ((distance (- ji-value location))) - (unless (<= -128 distance 127) - (clc-error "Out of range JI branch in ~S." inst)) - (dump-instruction - inst (logior (ash opcode 3) n-value) - (logand distance 255))))))) - (x - (let* ((ra (car args)) - (ra-value (eval-register ra)) - (rb (cadr args)) - (rb-value (eval-register rb)) - (rc (caddr args)) - (rc-value (eval-register rc))) - (cond ((not (and ra-value rb-value rc-value)) - (clc-error "Too few or illegal registers specified in ~S." - inst)) - (t - (dump-instruction - inst (logior (ash opcode 4) ra-value) - (logior (ash rb-value 4) rc-value)))))) - (ds - (let* ((rb (car args)) - (rb-value (eval-register rb)) - (rc (cadr args)) - (rc-value (eval-register rc)) - (i (caddr args)) - (i-value (eval i))) - (cond ((not (and i rb rc)) - (clc-error "Bad DS format instruction: ~S." inst)) - ((not (<= 0 i-value 15)) - (clc-error "I field out of range in ~S." inst)) - (t - (dump-instruction - inst (logior (ash opcode 4) i-value) - (logior (ash rb-value 4) rc-value)))))) - (r - (let* ((rb (car args)) - (rb-value (eval-register rb)) - (rc (cadr args)) - (rc-value (eval-register rc))) - (cond ((not (and rb-value rc-value)) - (clc-error "Bad R format instruction: ~S" inst)) - (t - (dump-instruction - inst opcode (logior (ash rb-value 4) rc-value)))))) - (r1 - (let* ((rb (car args)) - (rb-value (eval rb)) - (rc (cadr args)) - (rc-value (eval-register rc))) - (cond ((not (and rb-value rc-value)) - (clc-error "Bad R format instruction: ~S" inst)) - (t - (dump-instruction - inst opcode (logior (ash rb-value 4) rc-value)))))) - (r2 - (let* ((rb (car args)) - (rb-value (eval-register rb)) - (rc (cadr args)) - (rc-value (eval rc))) - (cond ((not (and rb-value rc-value)) - (clc-error "Bad R format instruction: ~S" inst)) - (t - (dump-instruction - inst opcode (logior (ash rb-value 4) rc-value)))))) - (sr - (let* ((rb (car args)) - (rb-value (eval-register rb))) - (cond ((not rb-value) - (clc-error "Bad S format instruction: ~S" inst)) - (t - (dump-instruction - inst (ash opcode -4) - (logior (logand (ash opcode 4) 255) rb-value)))))) - (sn - (let* ((rb (car args)) - (rb-value (eval rb))) - (cond ((not rb-value) - (clc-error "Bad S format instruction: ~S" inst)) - (t - (dump-instruction - inst (ash opcode -4) - (logior (logand (ash opcode 4) 255) rb-value)))))) - (bi - (let* ((rb (car args)) - (rb-value (eval-register rb)) - (bi (cadr args)) - (bi-value (reference-label bi 'bi location))) - (cond ((not (and rb-value bi)) - (clc-error "Bad BI format instruction: ~S." inst)) - (t - (let ((distance (- bi-value location))) - (unless (<= -524288 distance 524287) - (clc-error "Out of range JI branch in ~S." inst)) - (dump-instruction - inst opcode - (logior (ash rb-value 4) - (logand (ash distance -16) 15)) - (logand (ash distance -8) 255) - (logand distance 255))))))) - (ba - (let* ((ba (car args)) - (ba-value (cond ((fixnump ba) ba) - ((and (listp ba) - (eq (car ba) 'symbol-value)) - (symbol-value (cadr ba))) - (T (reference-label ba 'ba location))))) - (cond ((not ba) - (clc-error "Bad BA format instruction: ~S." inst)) - (t - (dump-instruction inst opcode - (logand (ash ba-value -16) 255) - (logand (ash ba-value -8) 255) - (logand ba-value 255)))))) - (d - (let* ((rb (car args)) - (rb-value (eval-register rb)) - (rc (cadr args)) - (rc-value (eval-register rc)) - (i (caddr args)) - (i-value (eval i))) - (cond ((not (and i rb rc)) - (clc-error "Bad D format instruction: ~S." inst)) - ;; Sometimes I is sign extended, sometimes not. Assume the - ;; guy knows what he's doing. - ((not (<= -32768 i-value 65535)) - (clc-error "I field out of range in ~S." inst)) - (t - (dump-instruction - inst opcode - (logior (ash rb-value 4) rc-value) - (logand (ash i-value -8) 255) - (logand i-value 255)))))))))) - (when *clc-lap-stream* - (terpri *clc-lap-stream*))) - - -;;; Dump-Instruction dumps out some bytes to the fasl file and a nice line to -;;; the listing file. - -(defun dump-instruction (inst &rest bytes) - (declare (optimize (speed 3) (safety 0))) - (when *clc-lap-stream* - (if *produce-unixy-cruft* - (output-unixy-instruction inst) - (if (atom inst) - (format *clc-lap-stream* "~% ~S" inst) - (if (cddr bytes) - (format *clc-lap-stream* - "~%~2,'0X ~2,'0X ~2,'0X ~2,'0X ~S" - (car bytes) (cadr bytes) (caddr bytes) - (cadddr bytes) inst) - (format *clc-lap-stream* - "~%~2,'0X ~2,'0X ~S" - (car bytes) (cadr bytes) inst))))) - (dolist (byte bytes) - (dump-byte byte))) - -;;; Compatability for silly Unixy assembler. - -(defun output-unixy-instruction (inst) - (declare (optimize (speed 3) (safety 0))) - (if (atom inst) - (format *clc-lap-stream* "~%~(~A~):" (unixfy inst)) - (let* ((name (car inst)) - (args (cdr inst)) - (info (get name '%instruction-info))) - (case (romp-info-format info) - (ji - (format *clc-lap-stream* "~%~( ~A ~A,~A~)" - (case name (jb 'bb) (jnb 'bnb)) - (+ (eval (car args)) 8) - (unixfy (cadr args)))) - (x - (format *clc-lap-stream* "~%~( ~A ~A,~A,~A~)" - name (unixfy (car args)) (unixfy (cadr args)) - (unixfy (caddr args)))) - (ds - (format *clc-lap-stream* "~%~( ~A ~A,~A(~A)~)" - (get-unixy-long-name name) - (unixfy (car args)) (eval (caddr args)) - (unixfy (cadr args)))) - (r - (if (eq name 'lhs) - (format *clc-lap-stream* "~%~( ~A ~A,0(~A)~)" - 'lh (unixfy (car args)) (unixfy (cadr args))) - (format *clc-lap-stream* "~%~( ~A ~A,~A~)" - name (unixfy (car args)) (unixfy (cadr args))))) - (r1 - (format *clc-lap-stream* "~%~( ~A ~A,~A~)" - name (eval (car args)) (unixfy (cadr args)))) - (r2 - (if (eq name 'cis) (setq name 'ci)) - (cond ((memq name '(sari16 sri16 srpi16 sli16 slpi16)) - (format *clc-lap-stream* "~%~( ~A ~A,~A~)" - (case name - (sari16 'sari) - (sri16 'sri) - (srpi16 'srpi) - (sli16 'sli) - (slpi16 'slpi)) - (unixfy (car args)) (+ 16 (eval (cadr args))))) - ((memq name '(mftbil mttbil)) - (format *clc-lap-stream* "~%~( ~A ~A,~A~)" - (case name - (mftbil 'mftbi) - (mttbil 'mttbi)) - (unixfy (car args)) (- 32 (eval (cadr args))))) - ((memq name '(mftbiu mttbiu)) - (format *clc-lap-stream* "~%~( ~A ~A,~A~)" - (case name - (mftbiu 'mftbi) - (mttbiu 'mttbi)) - (unixfy (car args)) (- 16 (eval (cadr args))))) - (T (format *clc-lap-stream* "~%~( ~A ~A,~A~)" - name (unixfy (car args)) (eval (cadr args)))))) - (bi - (format *clc-lap-stream* "~%~( ~A ~A,~A~)" - name (unixfy (car args)) (unixfy (cadr args)))) - (ba - (format *clc-lap-stream* "~%~( ~A ~A~)" - name (unixfy (car args)))) - (d - (if (memq name '(lc lha lh l lm tsh stc sth st stm cal cal16 cau)) - (format *clc-lap-stream* "~%~( ~A ~A,~A(~A)~)" - name (unixfy (car args)) (eval (caddr args)) - (unixfy (cadr args))) - (if (memq name '(ci cli)) - (format *clc-lap-stream* "~%~( ~A ~A,~A~)" - name (unixfy (cadr args)) (eval (caddr args))) - (format *clc-lap-stream* "~%~( ~A ~A,~A,~A~)" - name (unixfy (car args)) (unixfy (cadr args)) - (eval (caddr args)))))) - (sr - (cond ((memq name '(mtmq mfmq)) - (format *clc-lap-stream* "~%~( ~A ~A,~A~)" - (if (eq name 'mtmq) 'mts 'mfs) - 10 (unixfy (car args)))) - (T (format *clc-lap-stream* "~%~( ~A ~A~)" - name (unixfy (car args)))))) - (sn - (format *clc-lap-stream* "~%~( ~A ~A~)" - name (eval (car args)))))))) - -(defun unixfy (thing) - (if (symbolp thing) - (substitute #\_ #\- - (the string (copy-seq (the string (symbol-name thing))))) - thing)) - -(defun get-unixy-long-name (name) - (case name - (ls 'l) - (sts 'st) - (lhas 'lha) - (sths 'sth) - (lcs 'lc) - (stcs 'stc))) - -;;; Nice branching instructions. - -(defconstant condition-code-alist - '((pz . 8) (lt . 9) (eq . 10) (gt . 11) (c0 . 12) (ov . 14) (tb . 15) - (<0 . 9) (=0 . 10) (>0 . 11))) - -(defconstant not-condition-code-alist - '((po . 8) (ge . 9) (ne . 10) (le . 11) (nc0 . 12) (nov . 14) (ntb . 15) - (>=0 . 9) (<>0 . 10) (<=0 . 11))) - -(defmacro defbranch (name on on-not) - `(defmacro ,name (destination &optional (condition 'po)) - (let ((cc (cdr (assq condition condition-code-alist)))) - (if cc - `((,',on ,cc ,destination)) - (if (setq cc (cdr (assq condition not-condition-code-alist))) - `((,',on-not ,cc ,destination)) - (error "Unknown condition code: ~S.")))))) - -(defbranch branch bb bnb) ; branch -(defbranch branchx bbx bnbx) ; branch with execute -(defbranch rbranch bbr bnbr) ; register branch -(defbranch rbranchx bbrx bnbrx) ; register branch with execute - -(defmacro b (destination) `((branch ,destination))) -(defmacro beq (destination) `((branch ,destination =0))) -(defmacro bne (destination) `((branch ,destination <>0))) -(defmacro blt (destination) `((branch ,destination <0))) -(defmacro bgt (destination) `((branch ,destination >0))) -(defmacro bge (destination) `((branch ,destination >=0))) -(defmacro ble (destination) `((branch ,destination <=0))) -(defmacro bx (destination) `((branchx ,destination))) -(defmacro beqx (destination) `((branchx ,destination =0))) -(defmacro bnex (destination) `((branchx ,destination <>0))) -(defmacro bltx (destination) `((branchx ,destination <0))) -(defmacro bgtx (destination) `((branchx ,destination >0))) -(defmacro bgex (destination) `((branchx ,destination >=0))) -(defmacro blex (destination) `((branchx ,destination <=0))) -(defmacro br (destination) `((rbranch ,destination))) -(defmacro breq (destination) `((rbranch ,destination =0))) -(defmacro brne (destination) `((rbranch ,destination <>0))) -(defmacro brlt (destination) `((rbranch ,destination <0))) -(defmacro brgt (destination) `((rbranch ,destination >0))) -(defmacro brge (destination) `((rbranch ,destination >=0))) -(defmacro brle (destination) `((rbranch ,destination <=0))) -(defmacro brx (destination) `((rbranchx ,destination))) -(defmacro breqx (destination) `((rbranchx ,destination =0))) -(defmacro brnex (destination) `((rbranchx ,destination <>0))) -(defmacro brltx (destination) `((rbranchx ,destination <0))) -(defmacro brgtx (destination) `((rbranchx ,destination >0))) -(defmacro brgex (destination) `((rbranchx ,destination >=0))) -(defmacro brlex (destination) `((rbranchx ,destination <=0))) - -(defmacro bov (destination) `((branch ,destination ov))) -(defmacro bnov (destination) `((branch ,destination nov))) -(defmacro brov (destination) `((rbranch ,destination ov))) -(defmacro brnov (destination) `((rbranch ,destination nov))) -(defmacro bovx (destination) `((branchx ,destination ov))) -(defmacro bnovx (destination) `((branchx ,destination nov))) -(defmacro brovx (destination) `((rbranchx ,destination ov))) -(defmacro brnovx (destination) `((rbranchx ,destination nov))) - -(defmacro btb (destination) `((branch ,destination tb))) -(defmacro bntb (destination) `((branch ,destination ntb))) -(defmacro brtb (destination) `((rbranch ,destination tb))) -(defmacro brntb (destination) `((rbranch ,destination ntb))) -(defmacro btbx (destination) `((branchx ,destination tb))) -(defmacro bntbx (destination) `((branchx ,destination ntb))) -(defmacro brtbx (destination) `((rbranchx ,destination tb))) -(defmacro brntbx (destination) `((rbranchx ,destination ntb))) - -(defmacro bc0 (destination) `((branch ,destination c0))) -(defmacro bnc0 (destination) `((branch ,destination nc0))) -(defmacro brc0 (destination) `((rbranch ,destination c0))) -(defmacro brnc0 (destination) `((rbranch ,destination nc0))) -(defmacro bc0x (destination) `((branchx ,destination c0))) -(defmacro bnc0x (destination) `((branchx ,destination nc0))) -(defmacro brc0x (destination) `((rbranchx ,destination c0))) -(defmacro brnc0x (destination) `((rbranchx ,destination nc0))) - -;;; Lr loads register1 with the contents of register2. Nicer looking than -;;; cas r1,r2,0. - -(defmacro lr (register1 register2) - `((cas ,register1 ,register2 0))) - -;;; Loadi loads the specified Constant into the given Register. - -(defmacro loadi (register constant) - (let ((value (eval constant))) - (cond ((<= 0 value 15) - `((lis ,register ,value))) - ((<= -32768 value 32767) - `((cal ,register 0 ,value))) - ((= (logand value 65535) 0) - `((cau ,register 0 (logand (ash ,value -16) #xFFFF)))) - (t - `((cau ,register 0 (logand (ash ,value -16) #xFFFF)) - (oil ,register ,register (logand ,value 65535))))))) - -(defmacro cmpi (register constant) - (let ((value (eval constant))) - (cond ((<= 0 value 15) - `((cis ,register ,value))) - ((<= -32768 value 32767) - `((ci 0 ,register ,value))) - (T (clc-error "~A is to big for a compare immediate instruction." - value))))) - -(defmacro defmemref (name ds d shift) - `(defmacro ,name (register index-register &optional (offset 0)) - (let ((value (eval offset))) - (cond ((and (eql (logand value (1- (ash 1 (abs ,shift)))) 0) - (<= 0 (ash value ,shift) ,(if (eq name 'loadh) 0 15))) - `((,',ds ,register ,index-register ,(ash value ,shift)))) - (t - `((,',d ,register ,index-register ,value))))))) - -(defmemref loadc lcs lc 0) ; loads a character or byte -(defmemref loadha lhas lha -1) ; loads a halfword, sign-extending -(defmemref loadh lhs lh -1) ; loads a halfword, no sign extend. -(defmemref loadw ls l -2) ; loads a fullword - -(defmemref storec stcs stc 0) ; stores a character or byte -(defmemref storeha sths sth -1) ; stores a halfword -(defmemref storew sts st -2) ; stores a fullword - -;;; (Mulitply Reg1 Reg2) multiplies the contents of Reg1 by Reg2 leaving the high order -;;; result in Reg1 and the low order result in Reg2. This macro could try and play -;;; games, but to reduce the number of multiply steps, but it turns out that the extra -;;; logic becomes pretty hariy, and you end up gaining a small amount. - -(defmacro multiply (Reg1 Reg2) - `((mtmq ,Reg1) - (s ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (m ,Reg1 ,Reg2) - (mfmq ,Reg2))) - -;;; More useful macros. - -(defmacro noop () - `((cas NL0 NL0 NL0))) - -(defmacro pushm (reg) - `((inc cs 4) - (sts ,reg cs 0))) - -(defmacro popm (reg) - `((ls ,reg cs 0) - (dec cs 4))) - -(defmacro verify-type (reg type error &optional ignore-nil) - (let ((label (gensym "Label"))) - (if (or (eq type 'type-+-fixnum) (eq type 'type-negative-fixnum)) - `(,@(if (memq reg '(A0 A1)) - `((srpi16 ,reg ,type-shift-16) - (cmpi ,(if (eq reg 'A0) 'NL0 'NL1) ,type) - (,(if (eq type 'type-+-fixnum) 'bgt 'blt) ,error)) - `((lr NL0 ,reg) - (sri16 NL0 ,type-shift-16) - (cmpi NL0 ,type) - (,(if (eq type 'type-+-fixnum) 'bgt 'blt) ,error)))) - `(,@(if (and (eq type 'type-symbol) (null ignore-nil)) - `((xiu NL0 ,reg nil-16) - (beq ,label))) - ,@(if (memq reg '(A0 A1)) - `((srpi16 ,reg ,type-shift-16) - (cmpi ,(if (eq reg 'A0) 'NL0 'NL1) ,type) - (bne ,error)) - `((niuz NL0 ,reg type-mask-16) - (xiu NL0 NL0 (get-type-mask-16 ,type)) - (bne ,error))) - ,@(if (and (eq type 'type-symbol) (null ignore-nil)) - (list label)))))) - -(defmacro verify-not-type (reg type error) - (if (or (eq type 'type-+-fixnum) (eq type 'type-negative-fixnum)) - `(,@(if (memq reg '(A0 A1)) - `((srpi16 ,reg ,type-shift-16) - (cmpi ,(if (eq reg 'A0) 'NL0 'NL1) ,type) - (,(if (eq type 'type-+-fixnum) 'bgt 'blt) ,error)) - `((lr NL0 ,reg) - (sri16 NL0 ,type-shift-16) - (cmpi NL0 ,type) - (,(if (eq type 'type-+-fixnum) 'bgt 'blt) ,error)))) - `(,@(if (memq reg '(A0 A1)) - `((srpi16 ,reg ,type-shift-16) - (cmpi ,(if (eq reg 'A0) 'NL0 'NL1) ,type) - (beq ,error)) - `((niuz NL0 ,reg type-mask-16) - (xiu NL0 NL0 (get-type-mask-16 ,type)) - (beq ,error)))))) - -(defmacro test-nil (reg label) - `((xiu NL0 ,reg nil-16) - (beq ,label))) - -(defmacro test-not-nil (reg label) - `((xiu NL0 ,reg nil-16) - (bne ,label))) - -(defmacro test-t (reg label) - `((xiu NL0 ,reg t-16) - (beq ,label))) - -(defmacro test-not-t (reg label) - `((xiu ro ,reg t-16) - (bne ,label))) - -(defmacro test-trap (reg label) - `((xiu NL0 ,reg trap-16) - (beq ,label))) - -(defmacro test-not-trap (reg label) - `((xiu NL0 ,reg trap-16) - (bne ,label))) - -(defmacro get-type (reg type-reg) - (cond ((and (eq reg 'A0) (eq type-reg 'NL0)) - `((srpi16 A0 type-shift-16))) - ((and (eq reg 'A1) (eq type-reg 'NL1)) - `((srpi16 A1 type-shift-16))) - ((and (eq reg 'A2) (eq type-reg 'A3)) - `((srpi16 A2 type-shift-16))) - (T `(,@(unless (eq reg type-reg) - `((cas ,type-reg ,reg 0))) - (sri16 ,type-reg type-shift-16))))) - -(defmacro type-equal (reg type label) - `((cmpi ,reg ,type) - ,(cond ((eq type 'type-+-fixnum) - `(ble ,label)) - ((eq type 'type-negative-fixnum) - `(bge ,label)) - (T `(beq ,label))))) - -(defmacro type-not-equal (reg type label) - `((cmpi ,reg ,type) - ,(cond ((eq type 'type-+-fixnum) - `(bgt ,label)) - ((eq type 'type-negative-fixnum) - `(blt ,label)) - (T `(bne ,label))))) - -(defmacro error0 (error-code) - `((bx error0) - (loadi a0 ,error-code))) - -(defmacro error1 (error-code reg) - `(,@(unless (eq reg 'a1) - `((cas a1 ,reg 0))) - (bx error1) - (loadi a0 ,error-code))) - -(defmacro error2 (error-code reg1 reg2) - `(,@(unless (eq reg2 'a2) - `((cas a2 ,reg2 0))) - ,@(unless (eq reg1 'a1) - `((cas a1 ,reg1 0))) - (bx error2) - (loadi a0 ,error-code))) - -;;; Floating Point support on the IBM RT PC. The floating point support -;;; provided assumes that there is hardware support for floating point. -;;; This means the machine must have an FPA card, have an APC (which -;;; has an MC68881 chip on board), or an AFPA card. - -;;; The macros defined below assume that there are only 7 floating point -;;; registers available to Lisp miscops. On the FPA's all register numbers -;;; are shifted left one before being used, since the Mc68881 only has -;;; 8 registers. On the FPA the register 14 and 15 are not useable which -;;; leaves 7 registers for Lisp. - -(float-register FR0 0) -(float-register FR1 1) -(float-register FR2 2) -(float-register FR3 3) -(float-register FR4 4) -(float-register FR5 5) -(float-register FR6 6) -(float-register FR7 7) - -;;; Floatop generates code that checks (at runtime) the type of -;;; floating point hardware available. Shift-code is inserted between -;;; the load of the hardware-type and the comparison. Floatop then -;;; branches to either the mc68881-code or the fpa-code. The code for -;;; each type of hardware should normally return to Lisp code. However, -;;; if the code should fall through, then the optional argument fall-through -;;; should be passed a non-NIL value. - -(defmacro floatop (mc68881-code fpa-code &optional shift-code fall-through) - (let ((tag (gensym "LABEL")) - (tag2 (when fall-through (gensym "LABEL")))) - `((cau A3 0 romp-data-base) - (loadw A3 A3 floating-point-hardware-available) - ,@shift-code - (cmpi A3 float-mc68881) - (bne ,tag) - ,@mc68881-code - ,@(when fall-through `((b ,tag2))) - ,tag - ,@fpa-code - ,@(when fall-through `(,tag2))))) - -;;; Macros to support Floating point operations on the IBM RT PC. -;;; The following code supports the FPA and AFPA. - -(defconstant read-float-register #x0BC) -(defconstant read-status-register #x037) -(defconstant write-float-register #x094) -(defconstant write-status-register #x10F) -(defconstant convert-float-long-to-float-short #x016) -(defconstant convert-float-short-to-float-long #x01B) -(defconstant negate-float-short #x055) -(defconstant negate-float-long #x054) -(defconstant absolute-float-short #x075) -(defconstant absolute-float-long #x074) -(defconstant copy-float-short #x045) -(defconstant copy-float-long #x044) -(defconstant compare-float-short #x049) -(defconstant compare-float-long #x048) -(defconstant divide-float-short #x061) -(defconstant divide-float-long #x060) -(defconstant multiply-float-short #x071) -(defconstant multiply-float-long #x070) -(defconstant subtract-float-short #x051) -(defconstant subtract-float-long #x050) -(defconstant add-float-short #x041) -(defconstant add-float-long #x040) -(defconstant round-float-long-to-word #x023) -(defconstant truncate-float-long-to-word #x02B) -(defconstant floor-float-long-to-word #x03B) -(defconstant round-float-short-to-integer #x027) -(defconstant truncate-float-short-to-integer #x02F) -(defconstant floor-float-short-to-integer #x03F) -(defconstant convert-float-short-immediate-to-float-long #x21B) -(Defconstant convert-word-immediate-to-float-long #x203) -(defconstant convert-word-immediate-to-float-short #x207) -(defconstant compare-float-immediate-short #x249) -(defconstant divide-float-immediate-short #x261) -(defconstant divide-float-short-immediate #x161) -(defconstant multiply-float-immediate-short #x271) -(defconstant multiply-float-short-immediate #x171) -(defconstant subtract-float-immediate-short #x251) -(defconstant subtract-float-short-immediate #x151) -(defconstant add-float-immediate-short #x241) -(defconstant add-float-short-immediate #x141) -(defconstant convert-float-long-immediate-to-float-short #x216) -(defconstant compare-float-immediate-long #x248) -(defconstant divide-float-immediate-long #x260) -(defconstant divide-float-long-immediate #x160) -(defconstant multiply-float-immediate-long #x270) -(defconstant multiply-float-long-immediate #x170) -(defconstant subtract-float-immediate-long #x250) -(defconstant subtract-float-long-immediate #x150) -(defconstant add-float-immediate-long #x240) -(defconstant add-float-long-immediate #x140) -(defconstant afpa-atanl #x0D4) -(defconstant afpa-cosl #x0C2) -(defconstant afpa-expl #x0D8) -(defconstant afpa-log10l #x0DE) -(defconstant afpa-logl #x0DC) -(defconstant afpa-sinl #x0C0) -(defconstant afpa-sqrs #x065) -(defconstant afpa-sqrl #x064) -(defconstant afpa-tanl #x0C4) - -(register float-status-register 14) - -;;; Check-For-Float-Errors checks to make sure a floating point operation -;;; did not overflow or cause some other form of error. The argument -;;; Error-Routine is the label to branch to if an error occurred. There -;;; is one routine for short, single, and long floating pointer errors -;;; respectively. The argument Reg is a general register to use in -;;; the calculations. - -(defmacro fpa-check-for-float-error (underflow overflow reg &optional divide) - `((rdstr ,reg ,reg) ; get float status into register. - (nilz ,reg ,reg #x7) ; Clear useless bits. - (cmpi ,reg 1) ; Underflow ? - (beq ,underflow) ; Yes, go generate error. - (cmpi ,reg 2) ; Overflow ? - (beq ,overflow) ; Yes, go generate error. - ,@(if divide `((cmpi ,reg 3) ; Check for divide by 0. - (beq ,divide))))) - -(defmacro invoke-fpa-float (opcode op1 op2 base - &optional (data-reg 'NL0) (data-op 'storew)) - (let* ((opcode (cond ((integerp opcode) opcode) - ((symbolp opcode) (symbol-value opcode)) - (T (error "Illegal value: ~A." opcode)))) - (high-op (logior #xFF00 (logand (ash opcode -6) #xF))) - (low-op (logior (ash (logand opcode #x3F) 10) - (ash (eval-register op1) 6) - (ash (eval-register op2) 2)))) - (declare (fixnum high-op low-op)) - (if (/= (logand low-op #x8000) 0) - (setq high-op (1+ high-op))) - `((cau ,base 0 ,high-op) - (,data-op ,data-reg ,base ,low-op)))) - -(defmacro rdfr (gpr fpr &optional (base 'NL1)) - `((invoke-fpa-float ,read-float-register ,fpr 0 ,base ,gpr loadw))) - -(defmacro rdstr (gpr &optional (base 'NL1)) - `((invoke-fpa-float ,read-status-register float-status-register - float-status-register ,base ,gpr loadw))) - -(defmacro wtfr (gpr fpr &optional (base 'NL1)) - `((invoke-fpa-float ,write-float-register 0 ,fpr ,base ,gpr))) - -(defmacro wtstr (gpr &optional (base 'NL1)) - `((invoke-fpa-float ,write-status-register float-status-register - float-status-register ,base ,gpr))) - -(defmacro cisl (gr sfr lfr &optional (base 'NL1)) - `((invoke-fpa-float ,convert-float-short-immediate-to-float-long - ,sfr ,lfr ,base ,gr))) - -(defmacro csl (sfr lfr &optional (base 'NL1)) - `((invoke-fpa-float ,convert-float-short-to-float-long ,sfr ,lfr ,base))) - -(defmacro cls (lfr sfr &optional (base 'NL1)) - `((invoke-fpa-float ,convert-float-long-to-float-short ,lfr ,sfr ,base))) - -(defmacro cils (gr lfr sfr &optional (base 'NL1)) - `((invoke-fpa-float ,convert-float-long-immediate-to-float-short - ,lfr ,sfr ,base ,gr))) - -(defmacro fixnum-to-short (ir sr &optional (base 'NL1)) - `((invoke-fpa-float ,convert-word-immediate-to-float-short R0 ,sr ,base ,ir))) - -(defmacro fixnum-to-long (ir lr &optional (base 'NL1)) - `((invoke-fpa-float ,convert-word-immediate-to-float-long R0 ,lr ,base ,ir))) - -(defmacro coms (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,compare-float-short ,fr1 ,fr2 ,base))) - -(defmacro comis (gr fpr1 fpr2 &optional (base 'NL1)) - `((invoke-fpa-float ,compare-float-immediate-short ,fpr1 ,fpr2 ,base ,gr))) - -(defmacro coml (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,compare-float-long ,fr1 ,fr2 ,base))) - -(defmacro comil (gr fpr1 fpr2 &optional (base 'NL1)) - `((invoke-fpa-float ,compare-float-immediate-long ,fpr1 ,fpr2 ,base ,gr))) - -(defmacro cops (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,copy-float-short ,fr1 ,fr2 ,base))) - -(defmacro copl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,copy-float-long ,fr1 ,fr2 ,base))) - -(defmacro abss (fpr1 fpr2 &optional (base 'NL1)) - `((invoke-fpa-float ,absolute-float-short ,fpr1 ,fpr2 ,base))) - -(defmacro absl (fpr1 fpr2 &optional (base 'NL1)) - `((invoke-fpa-float ,absolute-float-long ,fpr1 ,fpr2 ,base))) - -(defmacro negs (fpr1 fpr2 &optional (base 'NL1)) - `((invoke-fpa-float ,negate-float-short ,fpr1 ,fpr2 ,base))) - -(defmacro negl (fpr1 fpr2 &optional (base 'NL1)) - `((invoke-fpa-float ,negate-float-long ,fpr1 ,fpr2 ,base))) - -(defmacro adds (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,add-float-short ,fr1 ,fr2 ,base))) - -(defmacro addis (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,add-float-immediate-short ,fr1 ,fr2 ,base ,gr))) - -(defmacro addsi (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,add-float-short-immediate ,fr1 ,fr2 ,base ,gr))) - -(defmacro addl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,add-float-long ,fr1 ,fr2 ,base))) - -(defmacro addil (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,add-float-immediate-long ,fr1 ,fr2 ,base ,gr))) - -(defmacro addli (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,add-float-long-immediate ,fr1 ,fr2 ,base ,gr))) - -(defmacro subs (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,subtract-float-short ,fr1 ,fr2 ,base))) - -(defmacro subis (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,subtract-float-immediate-short ,fr1 ,fr2 ,base ,gr))) - -(defmacro subsi (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,subtract-float-short-immediate ,fr1 ,fr2 ,base ,gr))) - -(defmacro subl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,subtract-float-long ,fr1 ,fr2 ,base))) - -(defmacro subil (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,subtract-float-immediate-long ,fr1 ,fr2 ,base ,gr))) - -(defmacro subli (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,subtract-float-long-immediate ,fr1 ,fr2 ,base ,gr))) - -(defmacro muls (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,multiply-float-short ,fr1 ,fr2 ,base))) - -(defmacro mulis (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,multiply-float-immediate-short ,fr1 ,fr2 ,base ,gr))) - -(defmacro mulsi (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,multiply-float-short-immediate ,fr1 ,fr2 ,base ,gr))) - -(defmacro mull (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,multiply-float-long ,fr1 ,fr2 ,base))) - -(defmacro mulil (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,multiply-float-immediate-long ,fr1 ,fr2 ,base ,gr))) - -(defmacro mulli (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,multiply-float-long-immediate ,fr1 ,fr2 ,base ,gr))) - -(defmacro divs (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,divide-float-short ,fr1 ,fr2 ,base))) - -(defmacro divis (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,divide-float-immediate-short ,fr1 ,fr2 ,base ,gr))) - -(defmacro divsi (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,divide-float-short-immediate ,fr1 ,fr2 ,base ,gr))) - -(defmacro divl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,divide-float-long ,fr1 ,fr2 ,base))) - -(defmacro divil (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,divide-float-immediate-long ,fr1 ,fr2 ,base ,gr))) - -(defmacro divli (gr fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,divide-float-long-immediate ,fr1 ,fr2 ,base ,gr))) - -(defmacro atanl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,afpa-atanl ,fr1 ,fr2 ,base))) - -(defmacro cosl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,afpa-cosl ,fr1 ,fr2 ,base))) - -(defmacro cosl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,afpa-cosl ,fr1 ,fr2 ,base))) - -(defmacro expl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,afpa-expl ,fr1 ,fr2 ,base))) - -(defmacro logl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,afpa-logl ,fr1 ,fr2 ,base))) - -(defmacro sinl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,afpa-sinl ,fr1 ,fr2 ,base))) - -(defmacro sqrs (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,afpa-sqrs ,fr1 ,fr2 ,base))) - -(defmacro sqrl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,afpa-sqrl ,fr1 ,fr2 ,base))) - -(defmacro tanl (fr1 fr2 &optional (base 'NL1)) - `((invoke-fpa-float ,afpa-tanl ,fr1 ,fr2 ,base))) - -;;; The following code is to support the MC6881 floating point chip on -;;; the APC card. - -;;; MC68881 opcodes. - -(defconstant fop881-move #x00) -(defconstant fop881-int #x01) -(defconstant fop881-sinh #x02) -(defconstant fop881-intrz #x03) -(defconstant fop881-sqrt #x04) -(defconstant fop881-lognp1 #x06) -(defconstant fop881-etoxm1 #x08) -(defconstant fop881-tanh #x09) -(defconstant fop881-atan #x0A) -(defconstant fop881-asin #x0C) -(defconstant fop881-atanh #x0D) -(defconstant fop881-sin #x0E) -(defconstant fop881-tan #x0F) -(defconstant fop881-etox #x10) -(defconstant fop881-twotox #x11) -(defconstant fop881-tentox #x12) -(defconstant fop881-logn #x14) -(defconstant fop881-log10 #x15) -(defconstant fop881-log2 #x16) -(defconstant fop881-abs #x18) -(defconstant fop881-cosh #x19) -(defconstant fop881-neg #x1A) -(defconstant fop881-acos #x1C) -(defconstant fop881-cos #x1D) -(defconstant fop881-getexp #x1E) -(defconstant fop881-getman #x1F) -(defconstant fop881-div #x20) -(defconstant fop881-mod #x21) -(defconstant fop881-add #x22) -(defconstant fop881-mul #x23) -(defconstant fop881-sgldiv #x24) -(defconstant fop881-rem #x25) -(defconstant fop881-scale #x26) -(defconstant fop881-sglmul #x27) -(defconstant fop881-sub #x28) -(defconstant fop881-sincos #x30) -(defconstant fop881-cmp #x38) -(defconstant fop881-tst #x3A) - -;;; Instruction classes. -(defconstant f881-freg-to-freg 0) -(defconstant f881-mem-to-freg 2) -(defconstant f881-freg-to-mem 3) -(defconstant f881-mem-to-scr 4) -(defconstant f881-scr-to-mem 5) - -;;; When going to or from memory, have to specify type of the operand. -(defconstant f881-mem-integer 0) ;; 32 bit integer. -(defconstant f881-mem-single 1) ;; 32 bit float. -(defconstant f881-mem-double 5) ;; 64 bit float. -(defconstant f881-transfer-control-field-table - '#(0 #x3c0000 0 #x3c0000 0 #x3c0000 0 #x3c0000)) - -;;; Control registers on the MC688881 - -(defconstant f881-fpsr 2) -(defconstant f881-fpcr 4) -(defconstant f881-fpiar 1) - - -(defmacro mc68881-check-for-error (under over opr baser &optional divide) - `((f881op ,f881-scr-to-mem ,f881-fpsr 0 ,fop881-move 1 ,opr ,baser) - (setcb 8) - (loadw NL0 ,baser 0) - (nilz ,opr NL0 #x800) - (bne ,under) - (nilz ,opr NL0 #x1000) - (bne ,over) - ,@(when divide - `((nilz ,opr NL0 #x400) - (bne ,divide))))) - -(defmacro f881op (class src dst operation length &optional (opr 'A2) (dtr 'NL1)) - (let* ((ecl (eval class)) - (opcode (logior #xFC000000 - (svref f881-transfer-control-field-table ecl) - (ash ecl 15) - (let ((r (eval-register src))) - (unless r - (setq r (eval src))) - (ash r 12)) - (let ((r (eval-register dst))) - (unless r - (setq r (eval dst))) - (ash r 9)) - (ash (eval operation) 2) - length)) - (low (logand opcode #xFFFF)) - (high (+ (logand (ash opcode -16) #xFFFF) - (if (eql (logand low #x8000) 0) 0 1)))) - `((cau ,opr 0 ,high) - (storew ,dtr ,opr ,low)))) - -;;; Assumes NL0 contains the (now) single floating point number. -;;; Returns result in A0 as well as returning to caller. - -(defmacro short-monadic-f881op (op &optional (opr 'A2) (base 'NL1)) - `((loadi ,base mc68881-float-temporary) - (storew NL0 ,base 0) - (f881op ,f881-mem-to-freg ,f881-mem-single FR0 ,(symbol-value op) - 1 ,opr ,base) - (f881op ,f881-freg-to-mem ,f881-mem-single FR0 ,fop881-move 1 ,opr ,base) - (setcb 8) - (loadw NL0 ,base 0) - (sri NL0 short-float-shift-16) - (brx PC) - (oiu A0 NL0 short-float-4bit-mask-16))) - -;;; Assumes A0 contains a pointer to a long floating point number. -;;; Allocates storage to hold the result of the computation. - -(defmacro long-monadic-f881op (op &optional (opr 'A2) (base 'NL1)) - `((cal ,base A0 long-float-high-data) - (f881op ,f881-mem-to-freg ,f881-mem-double FR0 ,(symbol-value op) - 2 ,opr ,base) - (allocate A0 type-long-float long-float-size ,base NL0) - (cal ,base A0 long-float-high-data) - (f881op ,f881-freg-to-mem ,f881-mem-double FR0 ,fop881-move 2 ,opr ,base) - (setcb 8) - (br PC))) - -;;; Assumes NL0 and NL1 contain the first and second number respectively. - -(defmacro short-dyadic-f881op (op type1 type2 - &optional (opr 'A2) (base 'A3) divide) - (let ((t1 (case type1 - (integer f881-mem-integer) - (short-float f881-mem-single) - (T type1))) - (t2 (case type2 - (integer f881-mem-integer) - (short-float f881-mem-single) - (T type2))) - (fr (if (float-register-p type1) type1 'FR6))) - `((loadi ,base ,mc68881-float-temporary) - (loadi ,opr 0) - (storew ,opr ,base 0) - (f881op ,f881-mem-to-scr ,f881-fpsr 0 ,fop881-move 1 ,opr ,base) - ,@(when (null (float-register-p type1)) - `((storew NL0 ,base 0) - (f881op ,f881-mem-to-freg ,t1 ,fr ,fop881-move 1 ,opr ,base))) - ,@(if (null (float-register-p type2)) - `((storew NL1 ,base 4) - (inc ,base 4) - (f881op ,f881-mem-to-freg ,t2 ,fr ,(symbol-value op) - 1 ,opr ,base)) - `((f881op ,f881-freg-to-freg ,t2 ,fr ,(symbol-value op) - 0 ,opr ,base))) - (f881op ,f881-freg-to-mem ,f881-mem-single ,fr ,fop881-move 1 ,opr ,base) - (setcb 8) - (inc ,base 4) - (mc68881-check-for-error short-float-underflow short-float-overflow - ,opr ,base ,divide) - (loadw NL0 ,base -4) - (sri NL0 short-float-shift-16) - (brx PC) - (oiu A0 NL0 short-float-4bit-mask-16)))) - -;;; Assumes A0 contains the first number, and A1 the second. Type1 and -;;; type2 specify the type of the first and second number respectively. -;;; Allocates storage to hold the result of the computation. - -(defmacro long-dyadic-f881op (op type1 type2 - &optional (opr 'A2) (base 'NL1) divide) - (let ((l1 (if (eq type1 'long-float) 2 1)) - (l2 (if (eq type2 'long-float) 2 1)) - (t1 (case type1 - (integer f881-mem-integer) - (short-float f881-mem-single) - (long-float f881-mem-double) - (T type1))) - (t2 (case type2 - (integer f881-mem-integer) - (short-float f881-mem-single) - (long-float f881-mem-double) - (T type2))) - (fr (if (float-register-p type1) type1 'FR6))) - `(,@(when (null (float-register-p type1)) - `(,@(case type1 - (integer `((loadi ,base ,mc68881-float-temporary) - (storew A0 ,base 0))) - (short-float `((loadi ,base ,mc68881-float-temporary) - (slpi A0 short-float-shift-16) - (storew NL0 ,base 0))) - (long-float `((cal ,base A0 long-float-high-data)))) - (f881op ,f881-mem-to-freg ,t1 ,fr ,fop881-move ,l1 ,opr ,base))) - ,@(case type2 - (integer `((loadi ,base mc68881-float-temporary) - (storew A1 ,base 4) - (inc ,base 4))) - (short-float `((loadi ,base mc68881-float-temporary) - (lr NL0 A1) - (sli NL0 short-float-shift-16) - (storew NL0 ,base 4) - (inc ,base 4))) - (long-float `((cal ,base A1 long-float-high-data)))) - ,@(if (null (float-register-p type2)) - `((f881op ,f881-mem-to-freg ,t2 ,fr ,(symbol-value op) - ,l2 ,opr ,base)) - `((f881op ,f881-freg-to-freg ,t2 ,fr ,(symbol-value op) - 0 ,opr ,base))) - (loadi ,base mc68881-float-temporary) - (mc68881-check-for-error long-float-underflow long-float-overflow - ,opr ,base ,divide) - (allocate A0 type-long-float long-float-size ,base NL0) - (cal ,base A0 long-float-high-data) - (f881op ,f881-freg-to-mem ,f881-mem-double ,fr ,fop881-move - 2 ,opr ,base) - (setcb 8) - (br PC)))) diff --git a/assembler/disassemble.lisp b/assembler/disassemble.lisp deleted file mode 100644 index 720c5a4db0743b9c099c9ccfe4b7ad3935d96807..0000000000000000000000000000000000000000 --- a/assembler/disassemble.lisp +++ /dev/null @@ -1,368 +0,0 @@ -;;; -*- 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). -;;; ********************************************************************** -;;; -;;; The DISASSEMBLE function as described in the Common Lisp manual. -;;; -;;; Written by Don Mathis -;;; -;;; -;;; Modified 11/83 by Robert Rose to put an asterisk before lines -;;; that are branched to. -;;; -;;; Heavily Modified 1/84 to use new instruction set. -;;; -;;; Modified by David B. McDonald to disassemble the Romp instruction -;;; set. -;;; -;;; Hacked by Rob MacLachlan for the interim RT function format. Hopefully -;;; this file will die after the port. -;;; -;;; ********************************************************************** -;;; -(in-package 'compiler :use '("LISP" "SYSTEM")) -(export 'lisp::disassemble (find-package 'lisp)) - -(proclaim '(special romp-4bit-opcode-symbol romp-8bit-opcode-symbol)) - -;;;; The Main function, DISASSEMBLE - -(defun disassemble (function &optional (*standard-output* *standard-output*)) - "The argument should be either a function object, a lambda expression, or - a symbol with a function definition. If the relevant function is not a - compiled function, it is first compiled. In any case, the compiled code - is then 'reverse assembled' and printed out in a symbolic format." - (etypecase function - (function - (ecase (%primitive get-vector-subtype function) - ((#.%function-entry-subtype #.%function-closure-entry-subtype) - (prin-prelim-info function) - (Output-macro-instructions function (branch-list function))) - (#.%function-closure-subtype - (disassemble (%primitive header-ref function %function-name-slot))))) - (symbol - (disassemble (symbol-function function))))) - - - -;;; PRIN-PRELIM-INFO takes a function object and extracts from it and -;;; prints out the following information: -;;; - The argument list of the function. -;;; - The number of Locals allocated by the function. -;;; - Whether the function does or does not evaluate its arguments. - -(defun prin-prelim-info (function) - (format t "~%Disassembly of ~S.~%" - (%primitive header-ref function %function-name-slot)) - (format t "~%Its arg list is: ~A.~%" - (%primitive header-ref function %function-entry-arglist-slot))) - - -;;; OUTPUT-MACRO-INSTRUCTIONS takes a function object and prints out the -;;; corresponding macro. (Not executable macro, just macro that looks good!) - -(defun Output-Macro-Instructions (function branches) - (declare (optimize (speed 3) (safety 0))) - (let* ((byte-vector - (%primitive header-ref function %function-code-slot)) - (offset - (- (%primitive header-ref function %function-offset-slot) - i-vector-header-size)) - (vector-length (length byte-vector))) - (declare (fixnum vector-length)) - (do ((i 0)) - ((= i vector-length)) - (declare (fixnum i)) - (when (= i offset) - (format t "~&*** Enter here:~%")) - (let* ((opcode (aref byte-vector i)) - (symbol (find-symbol-name opcode)) - (inst-type (get symbol 'romp-instruction-type))) - (case inst-type - (ji (print-ji-instruction opcode byte-vector i branches) - (setq i (the fixnum (+ i 2)))) - (x (print-x-instruction opcode byte-vector i branches) - (setq i (the fixnum (+ i 2)))) - (ds (print-ds-instruction opcode byte-vector i branches function) - (setq i (the fixnum (+ i 2)))) - (r (print-r-instruction opcode byte-vector i branches) - (setq i (the fixnum (+ i 2)))) - (bi (print-bi-instruction opcode byte-vector i branches) - (setq i (the fixnum (+ i 4)))) - (ba (print-ba-instruction opcode byte-vector i branches) - (setq i (the fixnum (+ i 4)))) - (d (setq i (the fixnum - (+ i (the fixnum - (print-d-instruction opcode byte-vector i - branches function )))))) - (T (error "Illegal instruction type: ~A for instruction ~A.~%" - inst-type symbol))))))) - - -(defun find-symbol-name (opcode) - (declare (fixnum opcode)) - (let ((symbol (svref romp-4bit-opcode-symbol (logand (the fixnum (ash opcode -4)) #xFF)))) - (if symbol - symbol - (svref romp-8bit-opcode-symbol opcode)))) - - -;;; BRANCH-LIST is very much like output-macro-instructions, -;;; but instead of actually creating all the instructions it just -;;; creates the branch instruction labels. A list of these labels -;;; is returned. - - -(defun branch-list (function) - (let* ((byte-vector - (%primitive header-ref function %function-code-slot)) - (vector-length (length byte-vector)) - (branches nil)) - (declare (fixnum vector-length)) - (do ((i 0)) - ((>= i vector-length)) - (declare (fixnum i)) - (let* ((opcode (aref byte-vector i)) - (symbol (find-symbol-name opcode)) - (inst-type (get symbol 'romp-instruction-type))) - (case inst-type - (ji (push (the fixnum (+ i (the fixnum (sign-extend-ji byte-vector i)))) branches) - (setq i (the fixnum (+ i 2)))) - ((x ds r) (setq i (the fixnum (+ i 2)))) - (bi (push (the fixnum (+ i (the fixnum (sign-extend-bi byte-vector i)))) branches) - (setq i (the fixnum (+ i 4)))) - ((ba d) (setq i (the fixnum (+ i 4)))) - (T (error "Unknown instruction type: ~A, for instruction ~A.~%" - inst-type symbol))))) - branches)) - -(defun print-ji-instruction (opcode byte-vector index branches) - (declare (fixnum opcode index)) - (format t "~6D~A (~A ~A ~A)~%" - index (if (memq index branches) "*" " ") - (if (= (logand opcode #x8) 0) "JNB" "JB") - (romp-condition-code (+ 8 (logand opcode #x7))) - `(**address** ,(the fixnum (+ index (the fixnum (sign-extend-ji byte-vector index))))))) - -(defun print-x-instruction (opcode byte-vector index branches) - (declare (fixnum opcode index)) - (let* ((rega (get-register-name (logand opcode #xF))) - (operand (aref byte-vector (the fixnum (1+ index)))) - (regb (get-register-name (logand (the fixnum (ash operand -4)) #xF))) - (regc (get-register-name (logand operand #xF))) - (star (if (memq index branches) "*" " "))) - (declare (fixnum operand)) - (if (eq regc 'NL0) - (cond ((and (eq rega 'NL0) (eq regb 'NL0)) - (format t "~6D~A (LR NL0 NL0) ; Padding for previous execute instruction.~%" - index star)) - (T (format t "~6D~A (LR ~A ~A)~%" - index (if (memq index branches) "*" " ") - rega regb))) - (format t "~6D~A (CAS ~A ~A ~A)~%" - index (if (memq index branches) "*" " ") - rega regb regc)))) - -(defun print-ds-instruction (opcode byte-vector index branches function) - (declare (fixnum opcode index)) - (let* ((symbol (find-symbol-name opcode)) - (operand (aref byte-vector (the fixnum (1+ index)))) - (rega (get-register-name (logand (the fixnum (ash operand -4)) #xF))) - (regb (get-register-name (logand operand #xF))) - (offset (ash (logand opcode #xF) 2))) - (declare (fixnum offset operand)) - (cond ((and (memq symbol '(ls sts)) - (memq regb '(ENV CONT))) - (print-special-access symbol rega regb offset function - index branches)) - (T (format t "~6D~A (~A ~A ~A ~A)~%" - index (if (memq index branches) "*" " ") - (symbol-name symbol) - (get-register-name (logand (the fixnum (ash operand -4)) #xF)) - (get-register-name (logand operand #xF)) - (case symbol - ((ls sts) (ash (logand opcode #xF) 2)) - ((lhs lhas sths) (ash (logand opcode #xF) 1)) - (T (logand opcode #xF)))))))) - -(defun print-r-instruction (opcode byte-vector index branches) - (declare (fixnum index opcode)) - (let* ((symbol (find-symbol-name opcode)) - (operand (aref byte-vector (the fixnum (1+ index)))) - (rega (logand (the fixnum (ash operand -4)) #xF)) - (regb (logand operand #xF))) - (declare (fixnum operand)) - (cond ((memq symbol '(inc dec lis mftbil mftbiu mttbil mttbiu - ais cis sis clrbl clrbu setbl setbu - sari sari16 sri sri16 srpi srpi16 - sli sli16 slpi slpi16)) - (format t "~6D~A (~A ~A ~A)~%" - index (if (memq index branches) "*" " ") - (symbol-name symbol) - (get-register-name rega) - regb)) - ((memq symbol '(bbr bbrx bnbr bnbrx)) - (format t "~6D~A (~A ~A ~A)~%" - index (if (memq index branches) "*" " ") - (symbol-name symbol) - (romp-condition-code rega) - (get-register-name regb))) - ((memq symbol '(mts mfs)) - (format t "~6D~A (~A ~A ~A)~%" - index (if (memq index branches) "*" " ") - (symbol-name symbol) - rega regb)) - ((memq symbol '(clrsb setsb)) - (format t "~6D~A (~A ~A ~A)~%" - index (if (memq index branches) "*" " ") - (symbol-name symbol) - rega regb)) - (T (format t "~6D~A (~A ~A ~A)~%" - index (if (memq index branches) "*" " ") - (symbol-name symbol) - (get-register-name rega) - (get-register-name regb)))))) - -(defun print-bi-instruction (opcode byte-vector index branches) - (declare (fixnum index opcode)) - (let* ((symbol (find-symbol-name opcode)) - (cc (romp-condition-code - (logand (ash (the fixnum (aref byte-vector (the fixnum (1+ index)))) -4) #xF))) - (label (the fixnum (+ index (the fixnum (sign-extend-bi byte-vector index)))))) - (format t "~6D~A (~A ~A ~A)~%" - index (if (memq index branches) "*" " ") - (symbol-name symbol) cc `(**address** ,label)))) - -(defun print-ba-instruction (opcode byte-vector index branches) - (declare (fixnum index opcode)) - (let* ((symbol (find-symbol-name opcode)) - (operand (the fixnum (logior (ash (the fixnum (aref byte-vector (the fixnum (1+ index)))) 16) - (ash (the fixnum (aref byte-vector (the fixnum (+ index 2)))) 8) - (the fixnum (aref byte-vector (the fixnum (+ index 3))))))) - (miscop (find-miscop-name operand))) - (format t "~6D~A (~A ~A) ; Call miscop ~A.~%" - index (if (memq index branches) "*" " ") - (symbol-name symbol) - miscop - miscop)) - 4) - -(defun print-d-instruction (opcode byte-vector index branches function) - (declare (fixnum index opcode)) - (let* ((symbol (find-symbol-name opcode)) - (operand (aref byte-vector (the fixnum (1+ index)))) - (rega (get-register-name (logand (the fixnum (ash operand -4)) #xF))) - (regb (get-register-name (logand operand #xF))) - (offset (sign-extend-d byte-vector index))) - (declare (fixnum offset operand)) - (cond ((eq symbol 'ci) - (format t"~6D~A (~A ~A ~A)~%" - index (if (memq index branches) "*" " ") - (symbol-name symbol) - rega offset) - 4) - ((and (memq symbol '(l st)) - (memq regb '(ENV CONT))) - (print-special-access symbol rega regb offset function - index branches) - 4) - (T (format t "~6D~A (~A ~A ~A ~A)~A~%" - index (if (memq index branches) "*" " ") - (symbol-name symbol) - rega regb offset - (if (eq (setq offset (logand offset #xFFFF)) nil-16) - " ; NIL." - (if (eq offset t-16) - " ; T." - ""))) - 4)))) - - -(defun print-special-access (symbol rega regb offset function index branches) - (declare (fixnum index offset)) - (let ((star (if (memq index branches) "*" " ")) - (*print-level* 3) - (*print-length* 10)) - (cond - ((not (eq regb 'ENV)) - (format t "~6D~A (~A ~A ~A ~A) ; Stack slot ~D.~%" - index star (symbol-name symbol) - rega regb offset - (ash offset -2))) - ((= offset (ash %function-code-slot 2)) - (format t "~6D~A (~A ~A ~A ~A) ; Function code.~%" - index star (symbol-name symbol) - rega regb offset)) - ((= offset (ash %function-offset-slot 2)) - (format t "~6D~A (~A ~A ~A ~A) ; Function offset.~%" - index star (symbol-name symbol) - rega regb offset)) - (t - (format t "~6D~A (~A ~A ~A ~A) ; Constant: ~S.~%" - index star (symbol-name symbol) - rega regb offset - (%primitive header-ref - (%primitive header-ref function - %function-entry-constants-slot) - (ash (the fixnum - (- offset g-vector-header-size)) -2))))))) - - -(defun sign-extend-ji (byte-vector index) - (declare (fixnum index)) - (let ((byte (aref byte-vector (the fixnum (1+ index))))) - (declare (fixnum byte)) - (ash (if (= (logand byte #x80) 0) - byte - (the fixnum (- (the fixnum (1+ (logand (lognot byte) #x7F)))))) - 1))) - -(defun sign-extend-bi (byte-vector index) - (declare (fixnum index)) - (let ((int (logior (the fixnum (ash (logand (the fixnum (aref byte-vector (the fixnum (1+ index)))) #xF) 16)) - (the fixnum (ash (aref byte-vector (the fixnum (+ index 2))) 8)) - (the fixnum (aref byte-vector (the fixnum (+ index 3))))))) - (declare (fixnum int)) - (ash (if (= (logand int #x80000) 0) - int - (the fixnum (- (the fixnum (1+ (logand (lognot int) #x7FFFF)))))) - 1))) - -(defun sign-extend-d (byte-vector index) - (declare (fixnum index)) - (let ((hword (logior (the fixnum (ash (aref byte-vector (the fixnum (+ index 2))) 8)) - (the fixnum (aref byte-vector (the fixnum (+ index 3))))))) - (declare (fixnum hword)) - (if (= (logand hword #x8000) 0) - hword - (the fixnum (- (the fixnum (1+ (logand (lognot hword) #xFFFF)))))))) - -(defun romp-condition-code (cc) - (if (<= 8 cc 16) - (svref '#(pz lt eq gt cz reserved ov tb) (- cc 8)) - '??)) - -(defun get-register-name (reg) - (svref '#(NL0 A0 NL1 A1 A3 A2 SP L0 L1 L2 L3 L4 BS CONT ENV PC) reg)) - -(defvar miscop-cache NIL) - -(defun find-miscop-name (index) - (if (null miscop-cache) (initialize-miscop-cache)) - (gethash index miscop-cache)) - -(defun initialize-miscop-cache () - (setq miscop-cache (make-hash-table :size 500)) - (do-symbols (x (find-package "CLC")) - (let ((v (get x 'lisp::%loaded-address))) - (when v - (setf (gethash v miscop-cache) x)))) - - (dolist (x lisp::*user-defined-miscops*) - (setf (gethash (get x 'lisp::%loaded-address) miscop-cache) x))) diff --git a/assembler/miscasm.lisp b/assembler/miscasm.lisp deleted file mode 100644 index 346e211f435a88662bb8694f430205f49588ceeb..0000000000000000000000000000000000000000 --- a/assembler/miscasm.lisp +++ /dev/null @@ -1,44 +0,0 @@ -;;; -*- 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")) diff --git a/assembler/rompconst.lisp b/assembler/rompconst.lisp deleted file mode 100644 index b653257d20bc89f8be2208f7c304bf1ba9315efe..0000000000000000000000000000000000000000 --- a/assembler/rompconst.lisp +++ /dev/null @@ -1,1097 +0,0 @@ -;;; -*- Mode: Lisp; Package: Compiler; Log: clc.log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Constants for the Romp. -;;; Written by: David B. McDonald and Skef Wholey. -;;; - -(in-package "COMPILER") - - -;;; Utilities for hacking header objects. - -(defmacro load-slot (value object index) - `(loadw ,value ,object (ash (+ ,index g-vector-header-size-in-words) 2))) - -(defmacro store-slot (value object index) - `(storew ,value ,object (ash (+ ,index g-vector-header-size-in-words) 2))) - - -;;; Pointer manipulation macros. - -(defmacro get-type-mask-16 (type) - `(ash ,type type-shift-16)) - -(defmacro get-address-16 (type space) - `(logior (ash ,type type-shift-16) - (ash ,space space-shift-16))) - - -(defmacro romp-immed-fixnum-p (object) - `(let ((thing ,object)) - (and (fixnump thing) - (>= (the fixnum thing) (the fixnum romp-min-immed-number)) - (<= (the fixnum thing) (the fixnum romp-max-immed-number))))) - -(defmacro romp-short-fixnum-p (object) - `(let ((thing ,object)) - (and (fixnump thing) - (>= (the fixnum thing) (the fixnum romp-min-short-immed-number)) - (<= (the fixnum thing) (the fixnum romp-max-short-immed-number))))) - -(defmacro romp-fixnum-p (object) - `(let ((thing ,object)) - (and (fixnump thing) - (>= (the fixnum thing) (the fixnum romp-min-fixnum)) - (<= (the fixnum thing) (the fixnum romp-max-fixnum))))) - - -;;; Registers are given a separate namespace from the constants. Registers are -;;; defined using the Register macro. Constants can be defined using the Lisp -;;; Defconstant. Numbers may be used in place of registers. - -(defmacro register (name value) - `(setf (get ',name '%assembler-register) ,value)) - -(defun registerp (name) - (and (symbolp name) (get name '%assembler-register))) - -(defmacro float-register (name value) - `(setf (get ',name '%assembler-float-register) ,value)) - -(defun float-register-p (name) - (and (symbolp name) (get name '%assembler-float-register))) - -(defun eval-register (form) - (cond ((numberp form) form) - ((symbolp form) (or (get form '%assembler-register) - (get form '%assembler-float-register))) - (t (clc-error "~S can't be used as a register." form)))) - -(defun translate-romp-type (register type label not-flag) - (case type - (+fixnum `((cmpi ,register type-+-fixnum) - (,(get-branch-to-use label not-flag '+fixnum) ,label))) - (-fixnum `((cmpi ,register type-negative-fixnum) - (,(get-branch-to-use label not-flag '-fixnum) ,label))) - (fixnum `((cmpi ,register type-+-fixnum) - (,(get-branch-to-use label not-flag '+fixnum) ,label) - (cmpi ,register type-negative-fixnum) - (,(get-branch-to-use label not-flag '-fixnum) ,label))) - (bignum `((cmpi ,register type-bignum) - (,(get-branch-to-use label not-flag) ,label))) - (ratio `((cmpi ,register type-ratio) - (,(get-branch-to-use label not-flag) ,label))) - (+short-float `((cmpi ,register type-short-float-low) - (,(get-branch-to-use label not-flag) ,label))) - (-short-float `((cmpi ,register type-short-float-high) - (,(get-branch-to-use label not-flag) ,label))) - (short-float - (let ((tag (gensym "L"))) - `((cmpi ,register type-short-float-low) - (blt ,(if not-flag label tag)) - (cmpi ,register type-short-float-high) - (,(if not-flag 'bgt 'ble) ,label) - ,tag))) -#| - (single-float `((cmpi ,register type-single-float) - (,(get-branch-to-use label not-flag) ,label))) -|# - (long-float `((cmpi ,register type-long-float) - (,(get-branch-to-use label not-flag) ,label))) - (complex `((cmpi ,register type-complex) - (,(get-branch-to-use label not-flag) ,label))) - (string `((cmpi ,register type-string) - (,(get-branch-to-use label not-flag) ,label))) - (bit-vector `((cmpi ,register type-bit-vector) - (,(get-branch-to-use label not-flag) ,label))) - (i-vector `((cmpi ,register type-i-vector) - (,(get-branch-to-use label not-flag) ,label))) - (g-vector `((cmpi ,register type-g-vector) - (,(get-branch-to-use label not-flag) ,label))) - (array `((cmpi ,register type-array) - (,(get-branch-to-use label not-flag) ,label))) - (function `((cmpi ,register type-function) - (,(get-branch-to-use label not-flag) ,label))) - (symbol `((cmpi ,register type-symbol) - (,(get-branch-to-use label not-flag) ,label))) - (list `((cmpi ,register type-list) - (,(get-branch-to-use label not-flag) ,label))) - (control-stack-pointer `((cmpi ,register type-control-stack-pointer) - (,(get-branch-to-use label not-flag) ,label))) - (binding-stack-pointer `((cmpi ,register type-binding-stack-pointer) - (,(get-branch-to-use label not-flag) ,label))) - (gc-forward `((cmpi ,register type-gc-forward) - (,(get-branch-to-use label not-flag) ,label))) - (string-char `((cmpi ,register type-string-char) - (,(get-branch-to-use label not-flag) ,label))) - (trap `((cmpi ,register type-trap) - (,(get-branch-to-use label not-flag) ,label))) - ((T)) - (T (clc-error "Unknow type ~A to type-dispatch macro." type)))) - -(defun get-branch-to-use (label not-flag &optional fixnum) - (cond ((eq label 'PC) - (if (eq fixnum '+fixnum) - (if not-flag 'brgt 'brle) - (if (eq fixnum '-fixnum) - (if not-flag 'brlt 'brge) - (if not-flag 'brne 'breq)))) - (T (if (eq fixnum '+fixnum) - (if not-flag 'bgt 'ble) - (if (eq fixnum '-fixnum) - (if not-flag 'blt 'bge) - (if not-flag 'bne 'beq)))))) - -(defmacro type-dispatch (register &rest forms) - (do* ((form-list forms (cdr form-list)) - (form (car form-list) (car form-list)) - (label (gensym "L") (gensym)) - (type-code NIL) - (clause-code NIL)) - ((null form-list) - (append type-code clause-code)) - (let ((types (cond ((listp (car form)) (car form)) - (t (list (car form))))) - (label (if (and (cadr form) (atom (cadr form))) - (cadr form) label)) - (not-flag (let ((next-form (cadr form-list))) - (cond ((and next-form - (eq (car next-form) 'T) - (cadr next-form) - (atom (cadr next-form)) - (not (and (cadr form) (atom (cadr form))))) - (setq form-list nil) - (cadr next-form)))))) - (if not-flag (setq label not-flag)) - (dolist (x types) - (setq type-code - (append type-code - (translate-romp-type register x label not-flag)))) - (cond ((and (memq T types) (not (null (cdr form))) (atom (cadr form))) - (setq type-code (append type-code `((b ,(cadr form)))))) - ((memq T types) - (setq type-code - (append type-code (cdr form))) - (setq form-list nil)) - ((and (cdr form) (atom (cadr form)))) - ((null not-flag) - (setq clause-code - (append clause-code (list label) (cdr form)))) - (T (setq type-code (append type-code (cdr form)))))))) - -(defmacro access-i-vector (vector index access-code) - (case access-code - ((0 1 2) - `((lr NL1 ,index) - (sri NL1 ,(case access-code (0 3) (1 2) (2 1))) - (cas NL1 NL1 ,vector) - (loadc NL0 NL1 i-vector-header-size) - (nilz NL1 ,index ,(case access-code (0 #x7) (1 #x3) (2 #x1))) - (xil NL1 NL1 ,(case access-code (0 #x7) (1 #x3) (2 #x1))) - ,@(case access-code (0 nil) (1 `((sli NL1 1))) (2 `((sli NL1 2)))) - (sr NL0 NL1) - (brx PC) - (nilz A0 NL0 ,(case access-code (0 #x1) (1 #x3) (2 #xF))))) - (3 - `((cas NL1 ,vector ,index) - (brx PC) - (loadc A0 NL1 i-vector-header-size))) - (4 - `((sli ,index 1) - (cas NL1 ,vector ,index) - (brx PC) - (loadh A0 NL1 i-vector-header-size))) - (5 (let* ((tag1 (gensym)) - (tag2 (gensym))) - `((sli ,index 2) ; Get index to word. - (cas NL1 ,vector ,index) - (loadw NL0 NL1 i-vector-header-size) ; Pickup 32 bit quantity - (srpi16 NL0 fixnum?-shift-16) ; Shift bits to a more useful place. - (bne ,tag1) ; Not a fixnum, go create a bignum - (brx PC) ; Return it as a fixnum. - (cas A0 NL0 0) ; Put into return register. -,tag1 - (xiu NL1 NL0 #x8000) ; 1 or 2 word bignum? - - (bnex ,tag2) - (loadi A1 (+ bignum-header-size 8)) ; Assume two word. - (noop) ; For execute. - - (loadi A1 (+ bignum-header-size 4)) ; A one word bignum. -,tag2 - (allocate A0 type-bignum A1 A2 A3) ; Allocate a bignum. - (storew NL0 A0 bignum-header-size) ; Store result in bignum. - (sri A1 2) - (brx PC) ; Return to caller. - (storew A1 A0 0)))) ; Store word count in bignum header. - (T (clc-error "Illegal access code (~A) in access-i-vector." - access-code)))) - -(defmacro store-i-vector (vector index access-code value) - (case access-code - ((0 1 2) - `((cas NL1 ,index 0) - (sri NL1 ,(case access-code (0 3) (1 2) (2 1))) - (cas NL1 NL1 ,vector) - (loadc NL0 NL1 i-vector-header-size) - (nilz ,index ,index ,(case access-code (0 #x7) (1 #x3) (2 #x1))) - (xil ,index ,index ,(case access-code (0 #x7) (1 #x3) (2 #x1))) - ,@(case access-code (0 nil) (1 `((sli ,index 1))) (2 `((sli ,index 2)))) - (nilz ,value ,value ,(case access-code (0 #x1) (1 #x3) (2 #xF))) - (lr A0 ,value) - (sl ,value ,index) - (lis A3 ,(case access-code (0 #x1) (1 #x3) (2 #xF))) - (sl A3 ,index) - (onec A3 A3) - (n NL0 A3) - (o NL0 ,value) - (brx PC) - (storec NL0 NL1 i-vector-header-size))) - (3 - `((cas NL1 ,vector ,index) - (lr A0 ,value) - (brx PC) - (storec ,value NL1 i-vector-header-size))) - (4 - `((sli ,index 1) - (cas NL1 ,vector ,index) - (lr A0 ,value) - (brx PC) - (storeha ,value NL1 i-vector-header-size))) - (5 (let ((tag1 (gensym))) - `((sli ,index 2) ; Get index to word. - (cas NL1 ,index ,vector) - (get-type ,value NL0) ; Get type of object. - (cmpi NL0 type-bignum) ; Bignum? - (beq ,tag1) ; Yes, go process it. - (storew ,value NL1 i-vector-header-size) ; Assume fixnum and store it. - (brx PC) ; Return to caller. - (lr A0 ,value) ; Put into return register. -,tag1 - (loadw NL0 ,value bignum-header-size) ; Pull out low order 32 bits. - (storew NL0 NL1 i-vector-header-size) ; Store it into vector. - (brx PC) - (lr A0 ,value)))) - (T (clc-error "Illegal access code (~A) in access-i-vector." - access-code)))) - -;;; The bit-bash-loop macro is used to generate code for the various operations -;;; in the bit-bash misc-op. It accepts a list of instructions, that should -;;; only modify NL0 and NL1 leaving the result in NL0. - -(defmacro bit-bash-loop (operation-code) - (let ((loop-label (gensym "LABEL-")) - (done-label (gensym "LABEL-"))) - `((lr A3 NL0) - ,loop-label - (dec A3 4) - (cmpi A3 i-vector-header-size) - (blt ,done-label) - (cas NL1 A0 A3) - (loadw NL0 NL1 0) - (cas NL1 A1 A3) - (loadw NL1 NL1 0) - ,@operation-code - (cas NL1 A2 A3) - (bx ,loop-label) - (storew NL0 NL1 0) - ,done-label - (brx PC) - (lr A0 A2)))) - -;;; Macro to call a conversion routine inside an arithmetic miscop. - -(defmacro call-conversion-routine (conversion-routine register) - `((inc CS 12) ; Make room on for A0, A1, PC. - (storew PC CS 0) ; Store PC - (storew A0 CS -4) ; Store A0. - ,@(unless (eq register 'A0) `((cas A0 ,register 0))) - - (mo-callx ,conversion-routine) ; Convert A0 to whatever. - (storew A1 CS -8) ; while saving A1. - - (cas A2 A0 0) ; Get returned - (loadw PC CS 0) ; Restore PC - (loadw A1 CS -8) ; Get A1 back. - (loadw A0 CS -4) ; Restore A0. - (dec CS 12))) ; Restore Stack pointer. - -(defmacro save-registers (&rest registers) - (let ((amount (ash (length registers) 2))) - (do* ((i 0 (1+ i)) - (reg-list registers (cdr reg-list)) - (register (car reg-list) (car reg-list)) - (inst-list NIL)) - ((null reg-list) - `(,(if (< amount 16) `(inc CS ,amount) `(cal CS CS ,amount)) - ,@(nreverse inst-list))) - (push `(storew ,register CS ,(- (ash (1+ i) 2) amount)) inst-list)))) - -(defmacro restore-registers (&rest registers) - (let ((amount (ash (length registers) 2))) - (do* ((i 0 (1+ i)) - (reg-list registers (cdr reg-list)) - (register (car reg-list) (car reg-list)) - (inst-list NIL)) - ((null reg-list) - `(,@(nreverse inst-list) - ,(if (< amount 16) `(dec CS ,amount) `(cal CS CS ,(- amount))))) - (push `(loadw ,register CS ,(- (ash (1+ i) 2) amount)) inst-list)))) - -(defmacro save-registers-PC (&rest registers) - (let ((amount (+ (ash (length registers) 2) 8))) - (do* ((i 0 (1+ i)) - (reg-list registers (cdr reg-list)) - (register (car reg-list) (car reg-list)) - (inst-list NIL)) - ((null reg-list) - `(,(if (< amount 16) `(inc CS ,amount) `(cal CS CS ,amount)) - ,@(nreverse inst-list) - (stm AF CS -4))) - (push `(storew ,register CS ,(- (ash (1+ i) 2) amount)) inst-list)))) - -(defmacro restore-registers-PC (&rest registers) - (let ((amount (+ (ash (length registers) 2) 8))) - (do* ((i 0 (1+ i)) - (reg-list registers (cdr reg-list)) - (register (car reg-list) (car reg-list)) - (inst-list NIL)) - ((null reg-list) - `(,@(nreverse inst-list) - (lm AF CS -4) - (storew BS CS 0) ; Clobber return PC. - ,(if (< amount 16) `(dec CS ,amount) `(cal CS CS ,(- amount))))) - (if register - (push `(loadw ,register CS ,(- (ash (1+ i) 2) amount)) inst-list))))) - -(defmacro save-registers-internal-PC (&rest registers) - (let ((amount (+ (ash (length registers) 2) 4))) - (do* ((i 0 (1+ i)) - (reg-list registers (cdr reg-list)) - (register (car reg-list) (car reg-list)) - (inst-list NIL)) - ((null reg-list) - `(,(if (< amount 16) `(inc CS ,amount) `(cal CS CS ,amount)) - ,@(nreverse inst-list) - (storew PC CS 0))) - (push `(storew ,register CS ,(- (ash (1+ i) 2) amount)) inst-list)))) - -(defmacro restore-registers-internal-PC (&rest registers) - (let ((amount (+ (ash (length registers) 2) 4))) - (do* ((i 0 (1+ i)) - (reg-list registers (cdr reg-list)) - (register (car reg-list) (car reg-list)) - (inst-list NIL)) - ((null reg-list) - `(,@(nreverse inst-list) - (loadw PC CS 0) - ,(if (< amount 16) `(dec CS ,amount) `(cal CS CS ,(- amount))))) - (if register - (push `(loadw ,register CS ,(- (ash (1+ i) 2) amount)) inst-list))))) - -;;; Macros to call misc-ops and internal assembler routines - -(defmacro mo-call (routine) - `((bali PC ,routine))) - -(defmacro mo-callx (routine) - `((balix PC ,routine))) - -(defmacro load-global-addr (register offset) - `((cau ,register 0 romp-data-base) - (oil ,register ,register ,offset))) - -(defmacro load-global (register offset &optional (base NIL base-defined)) - (if (not base-defined) (setq base register)) - `((cau ,base 0 romp-data-base) - (loadw ,register ,base ,offset))) - -(defmacro load-multiple-global (register offset - &optional (base NIL base-defined)) - (if (not base-defined) (setq base register)) - `((cau ,base 0 romp-data-base) - (lm ,register ,base ,offset))) - -(defmacro store-global (register offset &optional (base 'NL1)) - `((cau ,base 0 romp-data-base) - (storew ,register ,base ,offset))) - -(defmacro store-multiple-global (register offset &optional (base 'NL1)) - `((cau ,base 0 romp-data-base) - (stm ,register ,base ,offset))) - -(defmacro load-symbol-addr (register offset) - `((cau ,register 0 (get-address-16 type-symbol static-space)) - (oil ,register ,register ,offset))) - -(defmacro load-symbol-offset (register symbol-offset offset) - `((cau ,register 0 (get-address-16 type-symbol static-space)) - (loadw ,register ,register (+ ,symbol-offset ,offset)))) - -(defmacro store-symbol-offset (register symbol-offset offset &optional (base 'NL1)) - `((cau ,base 0 (get-address-16 type-symbol static-space)) - (storew ,register ,base (+ ,symbol-offset ,offset)))) - -;;; Escape-Routine -- Interface -;;; -;;; Call the function that is the definition of the symbol at the specifed -;;; offset, passing Nargs arguments. The arguments should already be set up in -;;; A0..A3. The function must take no more than 4 arguments and return no more -;;; than 3 values. We make an "escape frame" and save the entire register set -;;; in it. If the called function returns, we restore the saved registers -;;; *except* for A<N> and NL<N>. This is so that we return the values returned -;;; by the escape routine, rather than restoring whatever garbage was in the -;;; argument registers before the call. We only saved the arg registers for -;;; the benefit of the debugger. -;;; -(defmacro escape-routine (symbol-offset nargs) - (unless (<= 0 nargs 4) - (error "Losing NARGS: ~D." nargs)) - ;; Allocate frame+1 to preserve the assembly-level stack top. - `((cal SP SP (* 4 (1+ %escape-frame-size))) - ;; Clear type bits in unboxed registers so that GC doesn't gag. If these - ;; hold user fixnum or string-char variables, then this won't destroy the - ;; info. - (niuo NL0 NL0 clc::type-not-mask-16) - (niuo NL1 NL1 clc::type-not-mask-16) - ;; Save all registers... - (stm NL0 CS (* 4 (- (- %escape-frame-size - %escape-frame-general-register-start-slot)))) - ;; Save current FP as OLD-FP. - (storew FP SP (* 4 (+ (- %escape-frame-size) c::old-fp-save-offset))) - ;; Compute escape frame start from SP. - (cal FP SP (* 4 (- %escape-frame-size))) - ;; Store escape frame start in to register save area as old SP, since we - ;; trashed SP before saving registers. - (storew FP FP (* 4 (+ %escape-frame-general-register-start-slot - c::sp-offset))) - ;; Zero ENV save area to indicate an escape frame. - (loadi NL1 0) - (storew NL1 FP (* 4 c::env-save-offset)) - ;; Save miscop return PC as PC escape frame is returning to. - (storew PC FP (* 4 c::return-pc-save-offset)) - - ;; Get definition - (load-symbol-offset ENV ,symbol-offset symbol-definition) - ;; Get entry offset (in bytes, including header size). - (loadw PC ENV (+ g-vector-header-size (* 4 %function-offset-slot))) - ;; Get code vector. - (loadw NL1 ENV (+ g-vector-header-size (* 4 %function-code-slot))) - ;; Compute entry PC. - (cas PC PC NL1) - (lr OLD-FP FP) ; OLD-FP gets escape frame. - (lr FP SP) ; So escape frame doesn't get overwritten. - ;; - ;; If 4 args, set up arg frame. - ,@(when (= nargs 4) - '((cal SP SP (* 4 4)) - (storew A3 SP -4))) - ;; - ;; Call, giving this miscop as return PC for escape frame. - (balrx PC PC) - (lis NARGS ,nargs) ; Load argument count - (noop) - (cal 0 0 0) ; 32bit noop for single-value return. - ;; Now restore all registers except for A<N> and NL<N>. - ;; FP should be restored to the escape frame by returning function. - (lm SP FP (* 4 (+ %escape-frame-general-register-start-slot - c::sp-offset))) - ;; Return to caller. - (br PC))) - - -;;; The Allocate macro allocates a chunk of storage, frobing the free pointers -;;; of the correct space and possibly invoking the garbage collector. A newly -;;; allocated object of the given Type and Length is left in the specified -;;; Register. The Length may be a constant or a register. - -;;; We take advantage of the fact that a GC will never happen during execution -;;; of a miscop. Things get significantly hairier if that is not true. - -(defmacro allocate (reg type length temp1 temp2) - `((load-symbol-offset ,temp1 current-allocation-space-offset symbol-value) - (oil ,temp1 ,temp1 (ash ,type 5)) ; or in type - (cau ,temp1 ,temp1 alloc-table-address-16) ; add alloc-type address - (loadw ,reg ,temp1) ; fetch free pointer - ,@(if (registerp length) ; update free pointer - `((cas ,temp2 ,length ,reg)) - `((cal ,temp2 ,reg ,length))) - (storew ,temp2 ,temp1))) ; write free pointer back to memory - -(defmacro static-allocate (reg type length temp1 temp2) - `((cau ,temp1 0 alloc-table-address-16) - (oil ,temp1 ,temp1 (+ (ash ,type 5) 16)) - (loadw ,reg ,temp1) - ,@(if (registerp length) - `((cas ,temp2 ,reg ,length)) - `((cal ,temp2 ,reg ,length))) - (storew ,temp2 ,temp1))) - -;;; Check-pc-for-interrupt checks to see if a miscops got interrupted -;;; before it entered an interruptable state. - -(defmacro check-pc-for-interrupt () - (let ((l (gensym))) - `((srpi16 PC type-shift-16) - (bne ,l) - (load-global PC interrupt-pc) - (cau L0 0 interrupted-16) - ,l))) - -(defmacro service-interrupt () - `((xiu L0 L0 interrupted-16) - (brnex PC) - (cau L0 0 nil-16) - (store-global PC interrupt-pc NL1) - (load-global PC interrupt-routine))) - -;;; Various ranges for fixnums on the Romp. - -(eval-when (compile load eval) - (defconstant romp-code-base #x0020) - (defconstant romp-data-base #x0010) -) - -(defconstant romp-min-immed-number (1- (- #x7fff))) -(defconstant romp-max-immed-number #x7fff) - -(defconstant romp-min-short-immed-number 0) -(defconstant romp-max-short-immed-number 15) - -(defconstant romp-max-fixnum #x7FFFFFF) -(defconstant romp-min-fixnum (1- (- romp-max-fixnum))) - -(defconstant Page-Size 8192) -(defconstant Page-Mask-16 #x1FFF) -(defconstant Page-Not-Mask-16 #xE000) -(defconstant Page-Shift-16 13) - -;;; Type codes: - -(eval-when (compile load eval) - (defconstant type-+-fixnum 0) - (defconstant type-gc-forward 1) - (defconstant type-trap 4) - (defconstant type-bignum 5) - (defconstant type-ratio 6) - (defconstant type-complex 7) - (defconstant type-+-short-float 8) - (defconstant type---short-float 9) - (defconstant type-double-float 10) - (defconstant type-long-float 10) - (defconstant type-string 11) - (defconstant type-bit-vector 12) - (defconstant type-i-vector 13) - (defconstant type-code-vector 14) - (defconstant type-g-vector 15) - (defconstant type-array 16) - (defconstant type-function 17) - (defconstant type-symbol 18) - (defconstant type-list 19) - (defconstant type-control-stack-pointer 20) - (defconstant type-binding-stack-pointer 21) - (defconstant type-assembler-code 0) - - - (defconstant type-short-float 8) - (defconstant type-short-float-low 8) - (defconstant type-short-float-high 9) - - (defconstant type-string-char 26) - (defconstant type-bitsy-char 27) - (defconstant type-interruptable 28) - - (defconstant type-negative-fixnum 31) - - (defconstant first-pointer-type 4) - (defconstant last-pointer-type 19) - (defconstant first-lisp-pointer-type 4) - (defconstant last-lisp-pointer-type 21) -) - -;;; Header sizes and offsets to access words in Lisp objects. - -(defconstant bignum-header-size 4) -(defconstant bignum-header-size-in-words 1) -(defconstant bignum-header-words 0) - -(defconstant ratio-numerator 0) -(defconstant ratio-denominator 4) - -(defconstant float-header-size 4) -(defconstant float-header-size-in-words 1) -(defconstant long-float-size 12) -#| -(defconstant single-float-size 8) -(defconstant single-float-data 4) -|# -(defconstant long-float-high-data 4) -(defconstant long-float-low-data 8) -(defconstant short-float-shift-16 4) -(defconstant short-float-4bit-type #x4) -(defconstant short-float-4bit-mask-16 #x4000) -(defconstant float-compare-shift-16 9) -(defconstant mc68881-compare-shift-16 10) -(defconstant float-compare-mask-16 #x3) -(defconstant mc68881-compare-mask-16 #x3) -(defconstant float-compare-equal 1) - -(defconstant short-float-zero-16 #x4000) -(defconstant single-float-one #x3F80) -(defconstant long-float-one #x3FF0) -(defconstant short-float-one - (logior (ash short-float-4bit-type (- 16 short-float-shift-16)) - (ash single-float-one (- short-float-shift-16)))) -(defconstant single-float-minus-one #xBF80) -(defconstant long-float-minus-one #xBFF0) -(defconstant short-float-minus-one - (logior (ash short-float-4bit-type (- 16 short-float-shift-16)) - (ash single-float-minus-one (- short-float-shift-16)))) - -(defconstant complex-realpart 0) -(defconstant complex-imagpart 4) -(defconstant complex-size 8) - -(defconstant vector-subtype-byte 0) - -(defconstant string-header-size 8) -(defconstant string-header-words 0) -(defconstant string-header-entries 4) - -(defconstant bit-vector-header-size 8) -(defconstant bit-vector-header-words 0) -(defconstant bit-vector-header-entries 4) - -(defconstant i-vector-header-size 8) -(defconstant i-vector-header-size-in-words 2) -(defconstant i-vector-header-words 0) -(defconstant i-vector-header-entries 4) -(defconstant i-vector-access-byte 4) - -(defconstant iv-access-code-1 0) -(defconstant iv-access-code-2 1) -(defconstant iv-access-code-4 2) -(defconstant iv-access-code-8 3) -(defconstant iv-access-code-16 4) -(defconstant iv-access-code-32 5) - -(defconstant g-vector-header-size 4) -(defconstant g-vector-header-size-in-words 1) -(defconstant g-vector-header-words 0) - -(defconstant array-header-size 20) -(defconstant array-header-size-in-words 5) -(defconstant array-header-words 0) -(defconstant array-data-vector 4) -(defconstant array-nelements 8) -(defconstant array-fill-pointer 12) -(defconstant array-displacement 16) - -(defconstant function-header-size 24) -(defconstant function-header-size-in-words 6) -(defconstant function-header-words 0) -(defconstant function-nconstants 4) -(defconstant function-code 8) -(defconstant function-arginfo 12) -(defconstant min-arg-count-mask-16 #xFF) -(defconstant max-arg-count-mask-16 #xFF00) -(defconstant max-arg-shift-16 8) -(defconstant function-symbol 16) -(defconstant function-arguments 20) - -(defconstant symbol-size 20) -(defconstant symbol-value 0) -(defconstant symbol-definition 4) -(defconstant symbol-property-list 8) -(defconstant symbol-print-name 12) -(defconstant symbol-package 16) - -(defconstant cons-size 8) -(defconstant list-size 8) -(defconstant list-car 0) -(defconstant list-cdr 4) - -(defconstant frame-size 36) -(defconstant frame-size-in-words 9) -(defconstant frame-saved-l0 0) -(defconstant frame-saved-l1 4) -(defconstant frame-saved-l2 8) -(defconstant frame-saved-l3 12) -(defconstant frame-saved-l4 16) -(defconstant frame-binding-stack 20) -(defconstant frame-active-frame 24) -(defconstant frame-active-function 28) -(defconstant frame-pc 32) - -(defconstant catch-frame-size 24) -(defconstant catch-frame-size-in-words 6) -(defconstant catch-binding-stack 0) -(defconstant catch-active-frame 4) -(defconstant catch-active-function 8) -(defconstant catch-pc 12) -(defconstant catch-tag-caught 16) -(defconstant catch-prev-catch 20) - -(defconstant binding-symbol 4) -(defconstant binding-value 0) - -;;; Structure for the link table. - -(defconstant lt-vector-size 5) -(defconstant lt-access-code 5) -(defconstant lt-nargs-ac 4) - -(defconstant lt-link-table-size 8192) -(defconstant lt-log-table-size 13) -(defconstant link-table-end-in-bytes - (+ i-vector-header-size (ash lt-link-table-size 3))) -(defconstant lt-table-count 4) -(defconstant lt-symbol-table 8) -(defconstant lt-nargs-table 12) -(defconstant lt-link-table 16) -(defconstant lt-next-table 20) - -;;; Masks and shifts for various operations on the ROMP. - -(eval-when (compile load eval) - (defconstant type-mask-16 #xF800) - (defconstant type-not-mask-16 #x7FF) - (defconstant type-shift-16 11) - - (defconstant space-mask-16 #x0600) - (defconstant space-shift-16 9) - (defconstant dynamic-space-mask-16 #x0200) -) - -(defconstant space-mask-result-16 #x3) - -(defconstant dynamic-0-space 0) -(defconstant dynamic-1-space 1) -(defconstant static-space 2) -(defconstant read-only-space 3) - -(defconstant nil-16 (get-address-16 type-list static-space)) -(defconstant t-16 (get-address-16 type-symbol static-space)) -(defconstant trap-16 (ash type-trap type-shift-16)) - -(defconstant interruptable-16 (get-type-mask-16 type-interruptable)) -(defconstant interrupted-16 (+ (get-type-mask-16 type-interruptable) 1)) - -(defconstant g-vector-words-mask-16 #x00FF) -(defconstant right-shifted-subtype-mask-16 #x0007) -(defconstant subtype-shift-16 8) -(defconstant subtype-mask-16 #x0700) -(defconstant g-vector-must-rehash #x0400) -(defconstant i-vector-entries-mask-16 #x0FFF) -(defconstant i-vector-words-mask-16 #x00FF) -(defconstant access-code-shift-byte-16 4) -(defconstant access-code-shift-word-16 12) - -(defconstant access-code-1-mask-16 #x0000) -(defconstant access-code-2-mask-16 #x1000) -(defconstant access-code-4-mask-16 #x2000) -(defconstant access-code-8-mask-16 #x3000) -(defconstant access-code-16-mask-16 #x4000) -(defconstant access-code-32-mask-16 #x5000) - -(defconstant fixnum-mask-16 #xF800) -(defconstant fixnum-not-mask-16 #x07FF) -(defconstant fixnum-bits 28) -(defconstant fixnum-sign-bit-16 4) -(defconstant fixnum-shift-16 4) -(defconstant fixnum?-shift-16 11) -(defconstant most-negative-fixnum-16 #xF800) -(defconstant smallest-+-bignum-16 #x0800) -(defconstant smallest-positive-bignum-address-16 - (get-address-16 type-bignum static-space)) -(defconstant least-negative-bignum-offset 8) - -;;; Define values for the boole operations. - -(defconstant boole-clr 0) -(defconstant boole-set 1) -(defconstant boole-1 2) -(defconstant boole-2 3) -(defconstant boole-c1 4) -(defconstant boole-c2 5) -(defconstant boole-and 6) -(defconstant boole-ior 7) -(defconstant boole-xor 8) -(defconstant boole-eqv 9) -(defconstant boole-nand 10) -(defconstant boole-nor 11) -(defconstant boole-andc1 12) -(defconstant boole-andc2 13) -(defconstant boole-orc1 14) -(defconstant boole-orc2 15) - -;;; Register definitions. - -(register r0 0) -(register r1 1) -(register r2 2) -(register r3 3) -(register r4 4) -(register r5 5) -(register r6 6) -(register r7 7) -(register r8 8) -(register r9 9) -(register r10 10) -(register r11 11) -(register r12 12) -(register r13 13) -(register r14 14) -(register r15 15) - -(register NArgs 0) ; Number of arguments to a function. -(register nl0 0) ; Unboxed scratch -(register a0 1) ; First argument and return value -(register nl1 2) ; Unboxed scratch -(register a1 3) ; Second argument -(register t0 4) ; Boxed scratch -(register a3 4) ; Fourth arg to some misc-ops. -(register a2 5) ; Third argument -(register cs 6) ; Control Stack Pointer (old name) -(register sp 6) ; Stack pointer -(register l0 7) ; Boxed Temporary -(register l1 8) ; Boxed Temporary -(register l2 9) ; Boxed Temporary -(register name 9) ; Name of function we are trying to call -(register l3 10) ; Boxed Temporary -(register old-fp 10) ; Fp to return to -(register old-cont 10) ; Fp to return to (old name) -(register l4 11) ; Boxed Temporary -(register args 11) ; Pointer to stack arguments -(register bs 12) ; Binding Stack Pointer -(register fp 13) ; Frame Pointer -(register cont 13) ; Current Fp (old name) -(register af 14) ; Active Function Pointer (old name) -(register env 14) ; Current constant pool, called function. -(register pc 15) ; PC, Return PC for misc-ops, and -(register st 15) ; Super Temporary (old name) -(register t1 15) ; Boxed scratch - -;;; Floating point hardware types. - -(defconstant float-none 0) -(defconstant float-fpa 2) -(defconstant float-afpa 4) -(defconstant float-mc68881 1) - -;;; Error codes. - -(defconstant error-not-list 1) -(defconstant error-not-symbol 2) -(defconstant error-object-not-number 3) -(defconstant error-object-not-integer 4) -(defconstant error-object-not-ratio 5) -(defconstant error-object-not-complex 6) -(defconstant error-object-not-vector 7) -(defconstant error-object-not-simple-vector 8) -(defconstant error-illegal-function 9) -(defconstant error-object-not-header 10) -(defconstant error-object-not-i-vector 11) -(defconstant error-object-not-simple-bit-vector 12) -(defconstant error-object-not-simple-string 13) -(defconstant error-object-not-character 14) -(defconstant error-not-control-stack-pointer 15) -(defconstant error-not-binding-stack-pointer 16) -(defconstant error-object-not-array 17) -(defconstant error-object-not-non-negative-fixnum 18) -(defconstant error-object-not-sap-pointer 19) -(defconstant error-object-not-system-pointer 20) -(defconstant error-object-not-float 21) -(defconstant error-object-not-rational 22) -(defconstant error-object-not-non-complex-number 23) - -(defconstant error-symbol-unbound 25) -(defconstant error-symbol-undefined 26) -(defconstant error-modify-nil 27) -(defconstant error-modify-t 28) - -(defconstant error-bad-access-code 30) -(defconstant error-bad-vector-length 31) -(defconstant error-index-out-of-range 32) -(defconstant error-illegal-index 33) -(defconstant error-illegal-shrink-value 34) -(defconstant error-not-a-shrink 35) -(defconstant error-illegal-data-vector 36) -(defconstant error-too-few-indices 37) -(defconstant error-too-many-indices 38) - -(defconstant error-illegal-byte-specifier 40) -(defconstant error-illegal-position-in-byte-spec 41) -(defconstant error-illegal-size-in-byte-spec 42) -(defconstant error-illegal-shift-count 43) -(defconstant error-illegal-boole-operation 44) - -(defconstant error-wrong-number-args 50) - -(defconstant error-not-<= 55) - -(defconstant error-divide-by-zero 60) -(defconstant error-unseen-throw-tag 61) -(defconstant error-short-float-underflow 62) -(defconstant error-short-float-overflow 63) -#| -(defconstant error-single-float-underflow 64) -(defconstant error-single-float-overflow 65) -|# -(defconstant error-long-float-underflow 66) -(defconstant error-long-float-overflow 67) -(defconstant error-monadic-short-underflow 68) -(defconstant error-monadic-short-overflow 69) -(defconstant error-monadic-long-underflow 70) -(defconstant error-monadic-long-overflow 71) - -(defconstant error-log-of-zero 72) - -(defconstant error-object-not-string-char 73) -(defconstant error-object-not-short-float 74) -(defconstant error-object-not-long-float 75) -(defconstant error-object-not-fixnum 76) -(defconstant error-object-not-cons 77) - -(defconstant error-invalid-exit 78) - -(defconstant error-odd-keyword-arguments 79) -(defconstant error-unknown-keyword-argument 80) -(defconstant error-object-not-type 81) -(defconstant error-object-not-function-or-symbol 82) -(defconstant error-not-= 83) - - -;;; Addresses of memory blocks used by the assembler routines. - -(defconstant alloc-table-address-16 romp-data-base) -(defconstant alloc-table-address (ash alloc-table-address-16 16)) -(defconstant mc68881-float-temporary (+ (ash romp-data-base 16) #x10000)) -(defconstant get-real-time (+ (ash romp-data-base 16) #x20000)) -(defconstant get-run-time (+ (ash romp-data-base 16) #x20008)) -(defconstant alloc-table-size 2048) - -(defconstant prime-table-offset (+ alloc-table-size 0)) -(defconstant mo-nargs-nil-routine-addr (+ alloc-table-size 64)) -(defconstant mo-nargs-t-routine-addr (+ alloc-table-size 68)) -(defconstant check-nargs-t-addr (+ alloc-table-size 72)) -(defconstant current-catch-block (+ alloc-table-size 76)) -(defconstant space-address (+ alloc-table-size 80)) -(defconstant newspace-address (+ alloc-table-size 84)) -(defconstant gc-save-NL0 (+ alloc-table-size 88)) -(defconstant gc-save-NL1 (+ alloc-table-size 92)) -(defconstant gc-save-CS (+ alloc-table-size 96)) -(defconstant gc-save-BS (+ alloc-table-size 100)) -(defconstant mo-no-entry-routine-addr (+ alloc-table-size 104)) -(defconstant save-c-stack-pointer (+ alloc-table-size 108)) -(defconstant current-unwind-protect-block (+ alloc-table-size 112)) -(defconstant interrupt-signal (+ alloc-table-size 116)) -(defconstant interrupt-code (+ alloc-table-size 120)) -(defconstant interrupt-scp (+ alloc-table-size 124)) -(defconstant interrupt-pc (+ alloc-table-size 128)) -(defconstant interrupt-routine (+ alloc-table-size 132)) -(defconstant interrupt-reset-pc (+ alloc-table-size 136)) -(defconstant interrupt-old-r5 (+ alloc-table-size 140)) -(defconstant in-call-foreign (+ alloc-table-size 144)) -(defconstant in-cf-save-regs-ptr (+ alloc-table-size 148)) -(defconstant software-interrupt-offset (+ alloc-table-size 152)) -(defconstant floating-point-hardware-available (+ alloc-table-size 156)) -(defconstant bignum-cache-timestamp (+ alloc-table-size 160)) -(defconstant bignum-cache-hits (+ alloc-table-size 164)) -(defconstant bignum-cache-table (+ alloc-table-size 168)) -(defconstant bignum-cache-bignums (+ alloc-table-size 172)) -(defconstant get-time-buffer (+ alloc-table-size 300)) - -;;; Define offsets from the begining of static symbol space for all the symbols -;;; that the assembler code needs to know about. - -(defconstant %sp-t-offset 0) -(defconstant %sp-internal-apply-offset 20) -(defconstant %sp-internal-error-offset 40) -(defconstant %sp-software-interrupt-handler-offset 60) -(defconstant %sp-internal-throw-tag-offset 80) -(defconstant %sp-initial-function-offset 100) -(defconstant %link-table-header-offset 120) -(defconstant current-allocation-space-offset 140) -(defconstant %sp-bignum/fixnum 160) -(defconstant %sp-bignum/bignum 180) -(defconstant %sp-fixnum/bignum 200) -(defconstant %sp-abs-ratio 220) -(defconstant %sp-abs-complex 240) -(defconstant %sp-negate-ratio 260) -(defconstant %sp-negate-complex 280) -(defconstant %sp-integer+ratio 300) -(defconstant %sp-ratio+ratio 320) -(defconstant %sp-complex+number 340) -(defconstant %sp-number+complex 360) -(defconstant %sp-complex+complex 380) -(defconstant %sp-1+ratio 400) -(defconstant %sp-1+complex 420) -(defconstant %sp-integer-ratio 440) -(defconstant %sp-ratio-integer 460) -(defconstant %sp-ratio-ratio 480) -(defconstant %sp-complex-number 500) -(defconstant %sp-number-complex 520) -(defconstant %sp-complex-complex 540) -(defconstant %sp-1-ratio 560) -(defconstant %sp-1-complex 580) -(defconstant %sp-integer*ratio 600) -(defconstant %sp-ratio*ratio 620) -(defconstant %sp-number*complex 640) -(defconstant %sp-complex*number 660) -(defconstant %sp-complex*complex 680) -(defconstant %sp-integer/ratio 700) -(defconstant %sp-ratio/integer 720) -(defconstant %sp-ratio/ratio 740) -(defconstant %sp-number/complex 760) -(defconstant %sp-complex/number 780) -(defconstant %sp-complex/complex 800) -(defconstant %sp-integer-truncate-ratio 820) -(defconstant %sp-ratio-truncate-integer 840) -(defconstant %sp-ratio-truncate-ratio 860) -(defconstant %sp-number-truncate-complex 880) -(defconstant %sp-complex-truncate-number 900) -(defconstant %sp-complex-truncate-complex 920) -(defconstant maybe-gc 940) -(defconstant lisp-environment-list 960) -(defconstant call-lisp-from-c 980) -(defconstant lisp-command-line-list 1000) -(defconstant *nameserverport*-offset 1020) -(defconstant *ignore-floating-point-underflow*-offset 1040) -(defconstant lisp::%sp-sin-rational 1060) -(defconstant lisp::%sp-sin-short 1080) -(defconstant lisp::%sp-sin-long 1100) -(defconstant lisp::%sp-sin-complex 1120) -(defconstant lisp::%sp-cos-rational 1140) -(defconstant lisp::%sp-cos-short 1160) -(defconstant lisp::%sp-cos-long 1180) -(defconstant lisp::%sp-cos-complex 1200) -(defconstant lisp::%sp-tan-rational 1220) -(defconstant lisp::%sp-tan-short 1240) -(defconstant lisp::%sp-tan-long 1260) -(defconstant lisp::%sp-tan-complex 1280) -(defconstant lisp::%sp-atan-rational 1300) -(defconstant lisp::%sp-atan-short 1320) -(defconstant lisp::%sp-atan-long 1340) -(defconstant lisp::%sp-atan-complex 1360) -(defconstant lisp::%sp-exp-rational 1380) -(defconstant lisp::%sp-exp-short 1400) -(defconstant lisp::%sp-exp-long 1420) -(defconstant lisp::%sp-exp-complex 1440) -(defconstant lisp::%sp-log-rational 1460) -(defconstant lisp::%sp-log-short 1480) -(defconstant lisp::%sp-log-long 1500) -(defconstant lisp::%sp-log-complex 1520) -(defconstant lisp::%sp-sqrt-rational 1540) -(defconstant lisp::%sp-sqrt-short 1560) -(defconstant lisp::%sp-sqrt-long 1580) -(defconstant lisp::%sp-sqrt-complex 1600) -(defconstant *eval-stack-top*-offset 1620) diff --git a/assembler/ropdefs.lisp b/assembler/ropdefs.lisp deleted file mode 100644 index 37bf970f136e0e9e2d7ac2eab70daf6badf95b7a..0000000000000000000000000000000000000000 --- a/assembler/ropdefs.lisp +++ /dev/null @@ -1,221 +0,0 @@ -;;; -*- 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. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). -;;; ********************************************************************** - -;;; This file defines the instruction set for the Common Lisp Romp Assembler -;;; used by the compiler. - -;;; Written by David B. McDonald. - -(in-package 'Compiler) - -(defvar romp-4bit-opcode-symbol (make-array 16)) -(defvar romp-8bit-opcode-symbol (make-array 256)) - -;;; Define-Romp-Instruction defines a Romp instruction to the assembler. -;;; It accepts three arguments: -;;; romp-instruction is a symbol whose pname is the name of a Romp instruction -;;; romp-inst-type specifies the underlying type of the Romp instruction. -;;; it must have one of the following values: JI, X, DS, R, BI, BA, -;;; or D. -;;; romp-code specifies the numeric op code for the instruction. - - -(defmacro Define-Romp-Instruction (romp-instruction romp-inst-type romp-code) - `(progn (setf (get ',romp-instruction 'romp-instruction-type) - ',romp-inst-type) - (setf (get ',romp-instruction 'romp-operation-code) - ,romp-code) - ,(case romp-inst-type - (ji - `(setf (svref romp-4bit-opcode-symbol 0) ',romp-instruction)) - ((x ds) - `(setf (svref romp-4bit-opcode-symbol ,romp-code) ',romp-instruction)) - ((r bi ba d) - `(setf (svref romp-8bit-opcode-symbol ,romp-code) ',romp-instruction)) - (T - (error "Illegal instruction type: ~A, for instruction ~A (~A).~%" - romp-inst-type romp-instruction romp-code))))) - -;;; Define-Romp-Branch defines a Romp branch instruction to the assembler. It -;;; accepts three arguments: -;;; romp-branch is a symbol whose pname is the name of a branch instruction. -;;; romp-instruction is the underlying romp-instruction that should be used -;;; used to implement the branch instruction. -;;; condition-code specifies the bit of the condition code that should be -;;; be tested to implement the branch. - -(defmacro Define-Romp-Branch (romp-branch romp-instruction condition-code) - `(progn (setf (get ',romp-branch 'romp-branch-instruction) - ',romp-instruction) - (setf (get ',romp-branch 'romp-condition-code) - ,condition-code))) - -;;; Define-Condition-Code associates the integer code for a particular condition -;;; code bit with a symbol. It accepts a symbol and a value. - -(defmacro Define-Condition-Code (condition-code value) - `(setf (get ',condition-code 'condition-code) ,value)) - -;;; Storage Access Instructions. - -(define-romp-instruction lcs ds #x4) -(define-romp-instruction lc d #xCE) -(define-romp-instruction lhas ds #x5) -(define-romp-instruction lha d #xCA) -(define-romp-instruction lhs r #xEB) -(define-romp-instruction lh d #xDA) -(define-romp-instruction ls ds #x7) -(define-romp-instruction l d #xCD) -(define-romp-instruction lm d #xC9) -(define-romp-instruction tsh d #xCF) -(define-romp-instruction stcs ds #x1) -(define-romp-instruction stc d #xDE) -(define-romp-instruction sths ds #x2) -(define-romp-instruction sth d #xDC) -(define-romp-instruction sts ds #x3) -(define-romp-instruction st d #xDD) -(define-romp-instruction stm d #xD9) - -;;; Address Computation Instructions. - -(define-romp-instruction cal d #xC8) -(define-romp-instruction cal16 d #xC2) -(define-romp-instruction cau d #xD8) -(define-romp-instruction cas x #x6) -(define-romp-instruction ca16 r #xF3) -(define-romp-instruction inc r #x91) -(define-romp-instruction dec r #x93) -(define-romp-instruction lis r #xA4) - -;;; Basic Romp Branch Instructions. - -(define-romp-instruction bala ba #x8A) -(define-romp-instruction balax ba #x8B) -(define-romp-instruction bali bi #x8C) -(define-romp-instruction balix bi #x8D) -(define-romp-instruction balr r #xEC) -(define-romp-instruction balrx r #xED) -(define-romp-instruction jb ji #x1) -(define-romp-instruction bb bi #x8E) -(define-romp-instruction bbx bi #x8F) -(define-romp-instruction bbr r #xEE) -(define-romp-instruction bbrx r #xEF) -(define-romp-instruction jnb ji #x0) -(define-romp-instruction bnb bi #x88) -(define-romp-instruction bnbx bi #x89) -(define-romp-instruction bnbr r #xE8) -(define-romp-instruction bnbrx r #xE9) - -;;; Romp Trap Instrunctions. - -(define-romp-instruction ti d #xCC) -(define-romp-instruction tgte r #xBD) -(define-romp-instruction tlt r #xBE) - -;;; Romp Move and Insert Instructions. - -(define-romp-instruction mc03 r #xF9) -(define-romp-instruction mc13 r #xFA) -(define-romp-instruction mc23 r #xFB) -(define-romp-instruction mc33 r #xFC) -(define-romp-instruction mc30 r #xFD) -(define-romp-instruction mc31 r #xFE) -(define-romp-instruction mc32 r #xFF) -(define-romp-instruction mftb r #xBC) -(define-romp-instruction mftbil r #x9D) -(define-romp-instruction mftbiu r #x9C) -(define-romp-instruction mttb r #xBF) -(define-romp-instruction mttbil r #x9F) -(define-romp-instruction mttbiu r #x9E) - -;;; Romp Arithmetic Instructions. - -(define-romp-instruction a r #xE1) -(define-romp-instruction ae r #xF1) -(define-romp-instruction aei d #xD1) -(define-romp-instruction ai d #xC1) -(define-romp-instruction ais r #x90) -(define-romp-instruction abs r #xE0) -(define-romp-instruction onec r #xF4) -(define-romp-instruction twoc r #xE4) -(define-romp-instruction c r #xB4) -(define-romp-instruction cis r #x94) -(define-romp-instruction ci d #xD4) -(define-romp-instruction cl r #xB3) -(define-romp-instruction cli d #xD3) -(define-romp-instruction exts r #xB1) -(define-romp-instruction s r #xE2) -(define-romp-instruction sf r #xB2) -(define-romp-instruction se r #xF2) -(define-romp-instruction sfi d #xD2) -(define-romp-instruction sis r #x92) -(define-romp-instruction d r #xB6) -(define-romp-instruction m r #xE6) - -;;; Romp Logical Operations - -(define-romp-instruction clrbl r #x99) -(define-romp-instruction clrbu r #x98) -(define-romp-instruction setbl r #x9B) -(define-romp-instruction setbu r #x9A) -(define-romp-instruction n r #xE5) -(define-romp-instruction nilz d #xC5) -(define-romp-instruction nilo d #xC6) -(define-romp-instruction niuz d #xD5) -(define-romp-instruction niuo d #xD6) -(define-romp-instruction o r #xE3) -(define-romp-instruction oil d #xC4) -(define-romp-instruction oiu d #xC3) -(define-romp-instruction x r #xE7) -(define-romp-instruction xil d #xC7) -(define-romp-instruction xiu d #xD7) -(define-romp-instruction clz r #xF5) - -;;; Romp Shift Instructions - -(define-romp-instruction sar r #xB0) -(define-romp-instruction sari r #xA0) -(define-romp-instruction sari16 r #xA1) -(define-romp-instruction sr r #xB8) -(define-romp-instruction sri r #xA8) -(define-romp-instruction sri16 r #xA9) -(define-romp-instruction srp r #xB9) -(define-romp-instruction srpi r #xAC) -(define-romp-instruction srpi16 r #xAD) -(define-romp-instruction sl r #xBA) -(define-romp-instruction sli r #xAA) -(define-romp-instruction sli16 r #xAB) -(define-romp-instruction slp r #xBB) -(define-romp-instruction slpi r #xAE) -(define-romp-instruction slpi16 r #xAF) - -;;; Romp System Control Instructions. - -(define-romp-instruction mts r #xB5) -(define-romp-instruction mfs r #x96) -(define-romp-instruction clrsb r #x95) -(define-romp-instruction setsb r #x97) -(define-romp-instruction lps d #xD0) -(define-romp-instruction wait r #xF0) -(define-romp-instruction svc d #xC0) - -;;; Romp Input/Output Instructions. - -(define-romp-instruction ior d #xCB) -(define-romp-instruction iow d #xDB) - -;;; Define bit setting for examining condition codes. - -(define-condition-code pz 8) -(define-condition-code lt 9) -(define-condition-code eq 10) -(define-condition-code gt 11) -(define-condition-code cz 12) -(define-condition-code ov 14) -(define-condition-code tb 15) diff --git a/assembly/assemfile.lisp b/assembly/assemfile.lisp deleted file mode 100644 index 215e4af42dde6d13a0a76ef4db8b175cb428747c..0000000000000000000000000000000000000000 --- a/assembly/assemfile.lisp +++ /dev/null @@ -1,218 +0,0 @@ -;;; -*- Package: C -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/assemfile.lisp,v 1.33 1992/08/03 12:50:33 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the extra code necessary to feed an entire file of -;;; assembly code to the assembler. -;;; -(in-package "C") - -(export '(define-assembly-routine)) - - -(defvar *do-assembly* nil - "If non-NIL, emit assembly code. If NIL, emit VOP templates.") - -(defvar *lap-output-file* nil - "The FASL file currently being output to.") - -(defvar *assembler-routines* nil - "A List of (name . label) for every entry point.") - -(defun assemble-file (name &key - (output-file - (make-pathname :defaults name - :type "assem")) - trace-file) - (let* ((*do-assembly* t) - (name (pathname name)) - (*lap-output-file* (open-fasl-file (pathname output-file) name)) - (*assembler-routines* nil) - (*load-verbose* nil) - (won nil) - (*code-segment* nil) - (*elsewhere* nil) - (*assembly-optimize* nil) - (*compiler-trace-output* nil) - (*fixups* nil)) - (unwind-protect - (progn - (pushnew :assembler *features*) - (when trace-file - (setf *compiler-trace-output* - (open (if (eq trace-file t) - (make-pathname :defaults name - :type "trace") - trace-file) - :direction :output - :if-exists :supersede))) - (init-assembler) - (load (merge-pathnames name (make-pathname :type "lisp"))) - (fasl-dump-cold-load-form `(in-package ,(package-name *package*)) - *lap-output-file*) - (new-assem:append-segment *code-segment* *elsewhere*) - (setf *elsewhere* nil) - (let ((length (new-assem:finalize-segment *code-segment*))) - (dump-assembler-routines *code-segment* - length - *fixups* - *assembler-routines* - *lap-output-file*)) - (setq won t)) - (deletef :assembler *features*) - (new-assem:release-segment *code-segment*) - (when *elsewhere* - (new-assem:release-segment *elsewhere*)) - (when *compiler-trace-output* - (close *compiler-trace-output*)) - (close-fasl-file *lap-output-file* (not won))) - won)) - - - -(defstruct (reg-spec - (:print-function %print-reg-spec)) - (kind :temp :type (member :arg :temp :res)) - (name nil :type symbol) - (temp nil :type symbol) - (scs nil :type (or list symbol)) - (offset nil)) - -(defun %print-reg-spec (spec stream depth) - (declare (ignore depth)) - (format stream - "#<reg ~S ~S scs=~S offset=~S>" - (reg-spec-kind spec) - (reg-spec-name spec) - (reg-spec-scs spec) - (reg-spec-offset spec))) - -(defun reg-spec-sc (spec) - (if (atom (reg-spec-scs spec)) - (reg-spec-scs spec) - (car (reg-spec-scs spec)))) - -(defun parse-reg-spec (kind name sc offset) - (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset))) - (ecase kind - (:temp) - ((:arg :res) - (setf (reg-spec-temp reg) (make-symbol (symbol-name name))))) - reg)) - - -(defun emit-assemble (name options regs code) - (collect ((decls)) - (loop - (if (and (consp code) (consp (car code)) (eq (caar code) 'declare)) - (decls (pop code)) - (return))) - `(let (,@(mapcar - #'(lambda (reg) - `(,(reg-spec-name reg) - (make-random-tn - :kind :normal - :sc (sc-or-lose ',(reg-spec-sc reg)) - :offset ,(reg-spec-offset reg)))) - regs)) - ,@(decls) - (new-assem:assemble (*code-segment* ',name) - ,name - (push (cons ',name ,name) *assembler-routines*) - ,@code - ,@(generate-return-sequence - (or (cadr (assoc :return-style options)) :raw))) - (when *compile-print* - (format *error-output* "~S assembled~%" ',name))))) - -(defun arg-or-res-spec (reg) - `(,(reg-spec-name reg) - :scs ,(if (atom (reg-spec-scs reg)) - (list (reg-spec-scs reg)) - (reg-spec-scs reg)) - ,@(unless (eq (reg-spec-kind reg) :res) - `(:target ,(reg-spec-temp reg))))) - -(defun emit-vop (name options vars) - (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq)) - (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq)) - (results (remove :res vars :key #'reg-spec-kind :test-not #'eq)) - (return-style (or (cadr (assoc :return-style options)) :raw)) - (cost (or (cadr (assoc :cost options)) 247)) - (vop (make-symbol "VOP"))) - (unless (member return-style '(:raw :full-call :none)) - (error "Unknown return-style for ~S: ~S" name return-style)) - (multiple-value-bind - (call-sequence call-temps) - (let ((*backend* *target-backend*)) - (generate-call-sequence name return-style vop)) - `(define-vop ,(if (atom name) (list name) name) - (:args ,@(mapcar #'arg-or-res-spec args)) - ,@(let ((index -1)) - (mapcar #'(lambda (arg) - `(:temporary (:sc ,(reg-spec-sc arg) - :offset ,(reg-spec-offset arg) - :from (:argument ,(incf index)) - :to (:eval 2)) - ,(reg-spec-temp arg))) - args)) - ,@(mapcar #'(lambda (temp) - `(:temporary (:sc ,(reg-spec-sc temp) - :offset ,(reg-spec-offset temp) - :from (:eval 1) - :to (:eval 3)) - ,(reg-spec-name temp))) - temps) - ,@call-temps - (:vop-var ,vop) - ,@(let ((index -1)) - (mapcar #'(lambda (res) - `(:temporary (:sc ,(reg-spec-sc res) - :offset ,(reg-spec-offset res) - :from (:eval 2) - :to (:result ,(incf index)) - :target ,(reg-spec-name res)) - ,(reg-spec-temp res))) - results)) - (:results ,@(mapcar #'arg-or-res-spec results)) - (:ignore ,@(mapcar #'reg-spec-name temps)) - ,@(remove-if #'(lambda (x) - (member x '(:return-style :cost))) - options - :key #'car) - (:generator ,cost - ,@(mapcar #'(lambda (arg) - (if (target-featurep :hppa) - `(move ,(reg-spec-name arg) - ,(reg-spec-temp arg)) - `(move ,(reg-spec-temp arg) - ,(reg-spec-name arg)))) - args) - ,@call-sequence - ,@(mapcar #'(lambda (res) - (if (target-featurep :hppa) - `(move ,(reg-spec-temp res) - ,(reg-spec-name res)) - `(move ,(reg-spec-name res) - ,(reg-spec-temp res)))) - results)))))) - -(defmacro define-assembly-routine (name&options vars &rest code) - (multiple-value-bind (name options) - (if (atom name&options) - (values name&options nil) - (values (car name&options) - (cdr name&options))) - (let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars))) - (if *do-assembly* - (emit-assemble name options regs code) - (emit-vop name options regs))))) diff --git a/assembly/hppa/alloc.lisp b/assembly/hppa/alloc.lisp deleted file mode 100644 index b4dc39007dc0aeb8088fcc44d8b2d9906c09d9dc..0000000000000000000000000000000000000000 --- a/assembly/hppa/alloc.lisp +++ /dev/null @@ -1,24 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/hppa/alloc.lisp,v 1.1 1992/06/12 04:00:00 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to handle allocation of stuff we don't want to do inline. -;;; -;;; Written by William Lott. -;;; - -(in-package "HPPA") - -;;; Given that the pseudo-atomic sequence is so short, there is -;;; nothing that qualifies. But we want to keep the file around -;;; in case we decide to add something later. - diff --git a/assembly/hppa/arith.lisp b/assembly/hppa/arith.lisp deleted file mode 100644 index 06f8a1cbccf7cc805add589f855745836ba1ff60..0000000000000000000000000000000000000000 --- a/assembly/hppa/arith.lisp +++ /dev/null @@ -1,282 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/hppa/arith.lisp,v 1.7 1992/07/13 01:47:53 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to handle simple cases for generic arithmetic. -;;; -;;; Written by William Lott. -;;; - -(in-package "HPPA") - - -;;;; Multiplication and Division helping routines. - -#+assembler -(define-assembly-routine - multiply - ((:arg x (signed-reg) nl0-offset) - (:arg y (signed-reg) nl1-offset) - - (:res res (signed-reg) nl2-offset) - - (:temp tmp (unsigned-reg) nl3-offset) - (:temp sign (unsigned-reg) nl4-offset)) - - ;; Determine the sign of the result. - (inst extrs x 0 1 sign :=) - (inst sub zero-tn x x) - (inst extrs y 0 1 tmp :=) - (inst sub zero-tn y y) - (inst xor sign tmp sign) - - ;; Make sure X is less then Y. - (inst comclr x y tmp :<<) - (inst xor x y tmp) - (inst xor x tmp x) - (inst xor y tmp y) - ;; Blow out of here if the result is zero. - (inst comb := x zero-tn done) - (inst li 0 res) - - LOOP - (inst extru x 31 1 zero-tn :ev) - (inst add y res res) - (inst extru x 30 1 zero-tn :ev) - (inst sh1add y res res) - (inst extru x 29 1 zero-tn :ev) - (inst sh2add y res res) - (inst extru x 28 1 zero-tn :ev) - (inst sh3add y res res) - - (inst srl x 4 x) - (inst comb :<> x zero-tn loop) - (inst sll y 4 y) - - DONE - (inst xor res sign res) - (inst add res sign res)) - - -#+assembler -(define-assembly-routine - (truncate) - ((:arg dividend signed-reg nl0-offset) - (:arg divisor signed-reg nl1-offset) - - (:res quo signed-reg nl2-offset) - (:res rem signed-reg nl3-offset)) - - ;; Move abs(divident) into quo. - (inst move dividend quo :>=) - (inst sub zero-tn quo quo) - ;; Do one divive-step with -divisor to prime V (use rem as a temp) - (inst sub zero-tn divisor rem) - (inst ds zero-tn rem zero-tn) - ;; Shift the divident/quotient one bit, setting the carry flag. - (inst add quo quo quo) - ;; The first real divive-step. - (inst ds zero-tn divisor rem) - (inst addc quo quo quo) - ;; And 31 more of them. - (dotimes (i 31) - (inst ds rem divisor rem) - (inst addc quo quo quo)) - ;; If the remainder is negative, we need to add the absolute value of the - ;; divisor. - (inst comb :>= rem zero-tn remainder-positive) - (inst comclr divisor zero-tn zero-tn :<) - (inst add rem divisor rem :tr) - (inst sub rem divisor rem) - REMAINDER-POSITIVE - ;; Now we have to fix the signs of quo and rem. - (inst xor divisor dividend zero-tn :>=) - (inst sub zero-tn quo quo) - (inst move dividend zero-tn :>=) - (inst sub zero-tn rem rem)) - - - -;;;; Generic arithmetic. - -(define-assembly-routine (generic-+ - (:cost 10) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst extru x 31 2 zero-tn :=) - (inst b do-static-fun :nullify t) - (inst extru y 31 2 zero-tn :=) - (inst b do-static-fun :nullify t) - (inst addo x y res) - (lisp-return lra :offset 1) - - DO-STATIC-FUN - (inst ldw (static-function-offset 'two-arg-+) null-tn lip) - (inst li (fixnum 2) nargs) - (inst move cfp-tn ocfp) - (inst bv lip) - (inst move csp-tn cfp-tn)) - -(define-assembly-routine (generic-- - (:cost 10) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst extru x 31 2 zero-tn :=) - (inst b do-static-fun :nullify t) - (inst extru y 31 2 zero-tn :=) - (inst b do-static-fun :nullify t) - (inst subo x y res) - (lisp-return lra :offset 1) - - DO-STATIC-FUN - (inst ldw (static-function-offset 'two-arg--) null-tn lip) - (inst li (fixnum 2) nargs) - (inst move cfp-tn ocfp) - (inst bv lip) - (inst move csp-tn cfp-tn)) - - - -;;;; Comparison routines. - -(macrolet - ((define-cond-assem-rtn (name translate static-fn cond) - `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst extru x 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - (inst extru y 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - - (inst comclr x y zero-tn ,cond) - (inst move null-tn res :tr) - (load-symbol res t) - (lisp-return lra :offset 1) - - DO-STATIC-FN - (inst ldw (static-function-offset ',static-fn) null-tn lip) - (inst li (fixnum 2) nargs) - (inst move cfp-tn ocfp) - (inst bv lip) - (inst move csp-tn cfp-tn)))) - - (define-cond-assem-rtn generic-< < two-arg-< :<) - (define-cond-assem-rtn generic-> > two-arg-> :>)) - - -(define-assembly-routine - (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - - (inst comb := x y return-t :nullify t) - (inst extru x 31 2 zero-tn :<>) - (inst b return-nil :nullify t) - (inst extru y 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - - RETURN-NIL - (inst move null-tn res) - (lisp-return lra :offset 1) - - DO-STATIC-FN - (inst ldw (static-function-offset 'eql) null-tn lip) - (inst li (fixnum 2) nargs) - (inst move cfp-tn ocfp) - (inst bv lip) - (inst move csp-tn cfp-tn) - - RETURN-T - (load-symbol res t)) - -(define-assembly-routine - (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - - (inst comb := x y return-t :nullify t) - (inst extru x 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - (inst extru y 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - - (inst move null-tn res) - (lisp-return lra :offset 1) - - DO-STATIC-FN - (inst ldw (static-function-offset 'two-arg-=) null-tn lip) - (inst li (fixnum 2) nargs) - (inst move cfp-tn ocfp) - (inst bv lip) - (inst move csp-tn cfp-tn) - - RETURN-T - (load-symbol res t)) diff --git a/assembly/hppa/array.lisp b/assembly/hppa/array.lisp deleted file mode 100644 index df222e0eab8d56c35eb78c2706211e2975000c0b..0000000000000000000000000000000000000000 --- a/assembly/hppa/array.lisp +++ /dev/null @@ -1,112 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/hppa/array.lisp,v 1.4 1992/07/08 03:09:54 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the support routines for arrays and vectors. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - -(define-assembly-routine - (allocate-vector - (:policy :fast-safe) - (:translate allocate-vector) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) - ((:arg type any-reg a0-offset) - (:arg length any-reg a1-offset) - (:arg words any-reg a2-offset) - (:res result descriptor-reg a0-offset) - - (:temp ndescr non-descriptor-reg nl0-offset) - (:temp vector descriptor-reg a3-offset)) - (pseudo-atomic () - (move alloc-tn vector) - (inst dep other-pointer-type 31 3 vector) - (inst addi (* (1+ vector-data-offset) word-bytes) words ndescr) - (inst dep 0 31 3 ndescr) - (inst add ndescr alloc-tn alloc-tn) - (inst srl type word-shift ndescr) - (storew ndescr vector 0 other-pointer-type) - (storew length vector vector-length-slot other-pointer-type)) - (move vector result)) - - - -;;;; Hash primitives - -#+assembler -(defparameter *sxhash-simple-substring-entry* (gen-label)) - -(define-assembly-routine - (sxhash-simple-string - (:translate %sxhash-simple-string) - (:policy :fast-safe) - (:result-types positive-fixnum)) - ((:arg string descriptor-reg a0-offset) - (:res result any-reg a0-offset) - - (:temp length any-reg a1-offset) - (:temp accum non-descriptor-reg nl0-offset) - (:temp data non-descriptor-reg nl1-offset) - (:temp offset non-descriptor-reg nl2-offset)) - - (declare (ignore result accum data offset)) - - ;; Save the return address. - (inst b *sxhash-simple-substring-entry*) - (loadw length string vector-length-slot other-pointer-type)) - -(define-assembly-routine - (sxhash-simple-substring - (:translate %sxhash-simple-substring) - (:policy :fast-safe) - (:arg-types * positive-fixnum) - (:result-types positive-fixnum)) - - ((:arg string descriptor-reg a0-offset) - (:arg length any-reg a1-offset) - (:res result any-reg a0-offset) - - (:temp accum non-descriptor-reg nl0-offset) - (:temp data non-descriptor-reg nl1-offset) - (:temp offset non-descriptor-reg nl2-offset)) - - (emit-label *sxhash-simple-substring-entry*) - - (inst li (- (* vector-data-offset word-bytes) other-pointer-type) offset) - (inst b test) - (move zero-tn accum) - - LOOP - (inst xor accum data accum) - (inst shd accum accum 5 accum) - - TEST - (inst ldwx offset string data) - (inst addib :>= (fixnum -4) length loop) - (inst addi (fixnum 1) offset offset) - - (inst addi (fixnum 4) length length) - (inst comb := zero-tn length done :nullify t) - (inst sub zero-tn length length) - (inst sll length 1 length) - (inst mtctl length :sar) - (inst shd zero-tn data :variable data) - (inst xor accum data accum) - - DONE - - (inst sll accum 5 result) - (inst srl result 3 result)) diff --git a/assembly/hppa/assem-rtns.lisp b/assembly/hppa/assem-rtns.lisp deleted file mode 100644 index 14b6af7c66fc14b43e294b1093d8007e1f738e26..0000000000000000000000000000000000000000 --- a/assembly/hppa/assem-rtns.lisp +++ /dev/null @@ -1,218 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/hppa/assem-rtns.lisp,v 1.3 1992/07/08 01:40:27 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains a handful of random assembly routines. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - - -;;;; Return-multiple with other than one value - -#+assembler ;; we don't want a vop for this one. -(define-assembly-routine - (return-multiple - (:return-style :none)) - - ;; These four are really arguments. - ((:temp nvals any-reg nargs-offset) - (:temp vals any-reg nl0-offset) - (:temp old-fp any-reg nl1-offset) - (:temp lra descriptor-reg lra-offset) - - ;; These are just needed to facilitate the transfer - (:temp count any-reg nl2-offset) - (:temp src any-reg nl3-offset) - (:temp dst any-reg nl4-offset) - (:temp temp descriptor-reg l0-offset) - - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset) - (:temp a4 descriptor-reg a4-offset) - (:temp a5 descriptor-reg a5-offset)) - - (inst movb := nvals count default-a0-and-on :nullify t) - (loadw a0 vals 0) - (inst addib := (fixnum -1) count default-a1-and-on :nullify t) - (loadw a1 vals 1) - (inst addib := (fixnum -1) count default-a2-and-on :nullify t) - (loadw a2 vals 2) - (inst addib := (fixnum -1) count default-a3-and-on :nullify t) - (loadw a3 vals 3) - (inst addib := (fixnum -1) count default-a4-and-on :nullify t) - (loadw a4 vals 4) - (inst addib := (fixnum -1) count default-a5-and-on :nullify t) - (loadw a5 vals 5) - - ;; Copy the remaining args to the top of the stack. - (inst addi (* 6 word-bytes) vals src) - (inst addi (* 6 word-bytes) cfp-tn dst) - - LOOP - (inst ldwm 4 src temp) - (inst addib :< (fixnum -1) count loop) - (inst stwm temp 4 dst) - - (inst b done :nullify t) - - DEFAULT-A0-AND-ON - (inst move null-tn a0) - DEFAULT-A1-AND-ON - (inst move null-tn a1) - DEFAULT-A2-AND-ON - (inst move null-tn a2) - DEFAULT-A3-AND-ON - (inst move null-tn a3) - DEFAULT-A4-AND-ON - (inst move null-tn a4) - DEFAULT-A5-AND-ON - (inst move null-tn a5) - - DONE - ;; Clear the stack. - (move cfp-tn ocfp-tn) - (move old-fp cfp-tn) - (inst add ocfp-tn nvals csp-tn) - - ;; Return. - (lisp-return lra)) - - - -;;;; tail-call-variable. - -#+assembler ;; no vop for this one either. -(define-assembly-routine - (tail-call-variable - (:return-style :none)) - - ;; These are really args. - ((:temp args any-reg nl0-offset) - (:temp lexenv descriptor-reg lexenv-offset) - - ;; We need to compute this - (:temp nargs any-reg nargs-offset) - - ;; These are needed by the blitting code. - (:temp src any-reg nl1-offset) - (:temp dst any-reg nl2-offset) - (:temp count any-reg nl3-offset) - (:temp temp descriptor-reg l0-offset) - - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset) - (:temp a4 descriptor-reg a4-offset) - (:temp a5 descriptor-reg a5-offset)) - - - ;; Calculate NARGS (as a fixnum) - (inst sub csp-tn args nargs) - - ;; Load the argument regs (must do this now, 'cause the blt might - ;; trash these locations) - (loadw a0 args 0) - (loadw a1 args 1) - (loadw a2 args 2) - (loadw a3 args 3) - (loadw a4 args 4) - (loadw a5 args 5) - - ;; Calc SRC, DST, and COUNT - (inst addi (fixnum (- register-arg-count)) nargs count) - (inst comb :<= count zero-tn done :nullify t) - (inst addi (* word-bytes register-arg-count) args src) - (inst addi (* word-bytes register-arg-count) cfp-tn dst) - - LOOP - ;; Copy one arg. - (inst ldwm 4 src temp) - (inst addib :> (fixnum -1) count loop) - (inst stwm temp 4 dst) - - DONE - ;; We are done. Do the jump. - (loadw temp lexenv closure-function-slot function-pointer-type) - (lisp-jump temp)) - - - -;;;; Non-local exit noise. - -#+assembler -(defparameter *unwind-entry-point* (gen-label)) - -(define-assembly-routine - (unwind - (:translate %continue-unwind) - (:policy :fast-safe)) - ((:arg block (any-reg descriptor-reg) a0-offset) - (:arg start (any-reg descriptor-reg) ocfp-offset) - (:arg count (any-reg descriptor-reg) nargs-offset) - (:temp lra descriptor-reg lra-offset) - (:temp cur-uwp any-reg nl0-offset) - (:temp next-uwp any-reg nl1-offset) - (:temp target-uwp any-reg nl2-offset)) - (declare (ignore start count)) - - (emit-label *unwind-entry-point*) - - (let ((error (generate-error-code nil invalid-unwind-error))) - (inst bc := nil block zero-tn error)) - - (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) - (loadw target-uwp block unwind-block-current-uwp-slot) - (inst bc :<> nil cur-uwp target-uwp do-uwp) - - (move block cur-uwp) - - DO-EXIT - - (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) - (loadw code-tn cur-uwp unwind-block-current-code-slot) - (loadw lra cur-uwp unwind-block-entry-pc-slot) - (lisp-return lra :frob-code nil) - - DO-UWP - - (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) - (inst b do-exit) - (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)) - - -(define-assembly-routine - throw - ((:arg target descriptor-reg a0-offset) - (:arg start any-reg ocfp-offset) - (:arg count any-reg nargs-offset) - (:temp catch any-reg a1-offset) - (:temp tag descriptor-reg a2-offset)) - (declare (ignore start count)) ; We just need them in the registers. - - (load-symbol-value catch lisp::*current-catch-block*) - - LOOP - (let ((error (generate-error-code nil unseen-throw-tag-error target))) - (inst bc := nil catch zero-tn error)) - (loadw tag catch catch-block-tag-slot) - (inst comb :<> tag target loop :nullify t) - (loadw catch catch catch-block-previous-catch-slot) - - (inst b *unwind-entry-point*) - (inst move catch target)) diff --git a/assembly/hppa/support.lisp b/assembly/hppa/support.lisp deleted file mode 100644 index 1ed87574ffcf8da0aba409992965f2419835fdf6..0000000000000000000000000000000000000000 --- a/assembly/hppa/support.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/hppa/support.lisp,v 1.1 1992/07/13 03:49:21 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the machine specific support routines needed by -;;; the file assembler. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - - -(def-vm-support-routine generate-call-sequence (name style vop) - (ecase style - (:raw - (let ((fixup (gensym "FIXUP-"))) - (values - `((let ((fixup (make-fixup ',name :assembly-routine))) - (inst ldil fixup ,fixup) - (inst ble fixup lisp-heap-space ,fixup :nullify t)) - (inst nop)) - `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) - ,fixup))))) - (:full-call - (let ((temp (make-symbol "TEMP")) - (nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) - (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn ,nfp-save cur-nfp)) - (inst compute-lra-from-code code-tn lra-label ,temp ,lra) - (note-this-location ,vop :call-site) - (let ((fixup (make-fixup ',name :assembly-routine))) - (inst ldil fixup ,temp) - (inst be fixup lisp-heap-space ,temp :nullify t)) - (emit-return-pc lra-label) - (note-this-location ,vop :single-value-return) - (move ocfp-tn csp-tn) - (inst compute-code-from-lra code-tn lra-label ,temp code-tn) - (when cur-nfp - (load-stack-tn cur-nfp ,nfp-save)))) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save) - (:save-p :compute-only))))) - (:none - (let ((fixup (gensym "FIXUP-"))) - (values - `((let ((fixup (make-fixup ',name :assembly-routine))) - (inst ldil fixup ,fixup) - (inst be fixup lisp-heap-space ,fixup :nullify t))) - `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) - ,fixup))))))) - - -(def-vm-support-routine generate-return-sequence (style) - (ecase style - (:raw - `((inst bv lip-tn :nullify t))) - (:full-call - `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset lra-offset) - :offset 1))) - (:none))) diff --git a/assembly/mips/alloc.lisp b/assembly/mips/alloc.lisp deleted file mode 100644 index 4d4bc61dbdc9b8044d013f64c4e16d409f24429b..0000000000000000000000000000000000000000 --- a/assembly/mips/alloc.lisp +++ /dev/null @@ -1,21 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/mips/alloc.lisp,v 1.3 1992/07/28 20:41:49 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to handle allocating simple objects. -;;; -;;; Written by William Lott. -;;; - -(in-package "MIPS") - -;;; But we do everything inline now that we have a better pseudo-atomic. diff --git a/assembly/mips/arith.lisp b/assembly/mips/arith.lisp deleted file mode 100644 index ce1d09d242a646adfed17680af821915170e5b1a..0000000000000000000000000000000000000000 --- a/assembly/mips/arith.lisp +++ /dev/null @@ -1,307 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/mips/arith.lisp,v 1.11 1992/07/28 20:42:28 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to handle simple cases for generic arithmetic. -;;; -;;; Written by William Lott. -;;; - -(in-package "MIPS") - - -(define-assembly-routine (generic-+ - (:cost 10) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst and temp x 3) - (inst bne temp DO-STATIC-FUN) - (inst and temp y 3) - (inst bne temp DO-STATIC-FUN) - (inst nop) - (inst add res x y) - (lisp-return lra lip :offset 2) - - DO-STATIC-FUN - (inst lw lip null-tn (static-function-offset 'two-arg-+)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j lip) - (inst move cfp-tn csp-tn)) - - -(define-assembly-routine (generic-- - (:cost 10) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst and temp x 3) - (inst bne temp DO-STATIC-FUN) - (inst and temp y 3) - (inst bne temp DO-STATIC-FUN) - (inst nop) - (inst sub res x y) - (lisp-return lra lip :offset 2) - - DO-STATIC-FUN - (inst lw lip null-tn (static-function-offset 'two-arg--)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j lip) - (inst move cfp-tn csp-tn)) - - -(define-assembly-routine (generic-* - (:cost 25) - (:return-style :full-call) - (:translate *) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lo non-descriptor-reg nl1-offset) - (:temp hi non-descriptor-reg nl2-offset) - (:temp pa-flag non-descriptor-reg nl4-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - ;; If either arg is not a fixnum, call the static function. - (inst and temp x 3) - (inst bne temp DO-STATIC-FUN) - (inst and temp y 3) - (inst bne temp DO-STATIC-FUN) - (inst nop) - - ;; Remove the tag from one arg so that the result will have the correct - ;; fixnum tag. - (inst sra temp x 2) - (inst mult temp y) - (inst mflo res) - (inst mfhi hi) - ;; Check to see if the result will fit in a fixnum. (I.e. the high word - ;; is just 32 copies of the sign bit of the low word). - (inst sra temp res 31) - (inst xor temp hi) - (inst beq temp DONE) - ;; Shift the double word hi:res down two bits into hi:low to get rid of the - ;; fixnum tag. - (inst srl lo res 2) - (inst sll temp hi 30) - (inst or lo temp) - (inst sra hi 2) - ;; Allocate a BIGNUM for the result. - (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset))) - (let ((one-word (gen-label))) - (inst or res alloc-tn other-pointer-type) - ;; Do we need one word or two? - (inst sra temp lo 31) - (inst xor temp hi) - (inst beq temp one-word) - (inst li temp (logior (ash 1 type-bits) bignum-type)) - ;; Nope, we need two. - (inst li temp (logior (ash 2 type-bits) bignum-type)) - (storew hi res (1+ bignum-digits-offset) other-pointer-type) - (emit-label one-word) - (storew temp res 0 other-pointer-type) - (storew lo res bignum-digits-offset other-pointer-type))) - ;; Out of here - (lisp-return lra lip :offset 2) - - DO-STATIC-FUN - (inst lw lip null-tn (static-function-offset 'two-arg-*)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j lip) - (inst move cfp-tn csp-tn) - - DONE) - - - -;;;; Comparison routines. - -(macrolet - ((define-cond-assem-rtn (name translate static-fn cmp not-p) - `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst and temp x 3) - (inst bne temp DO-STATIC-FN) - (inst and temp y 3) - (inst beq temp DO-COMPARE) - ,cmp - - DO-STATIC-FN - (inst lw lip null-tn (static-function-offset ',static-fn)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j lip) - (inst move cfp-tn csp-tn) - - DO-COMPARE - (inst ,(if not-p 'bne 'beq) temp done) - (inst move res null-tn) - (load-symbol res t) - DONE))) - - (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) nil) - (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) nil)) - - -(define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst beq x y RETURN-T) - (inst and temp x 3) - (inst beq temp RETURN-NIL) - (inst and temp y 3) - (inst bne temp DO-STATIC-FN) - (inst nop) - - RETURN-NIL - (inst move res null-tn) - (lisp-return lra lip :offset 2) - - DO-STATIC-FN - (inst lw lip null-tn (static-function-offset 'eql)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j lip) - (inst move cfp-tn csp-tn) - - RETURN-T - (load-symbol res t)) - -(define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst beq x y RETURN-T) - (inst and temp x 3) - (inst bne temp DO-STATIC-FN) - (inst and temp y 3) - (inst bne temp DO-STATIC-FN) - (inst nop) - - (inst move res null-tn) - (lisp-return lra lip :offset 2) - - DO-STATIC-FN - (inst lw lip null-tn (static-function-offset 'two-arg-=)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j lip) - (inst move cfp-tn csp-tn) - - RETURN-T - (load-symbol res t)) - -(define-assembly-routine (generic-/= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate /=) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst beq x y RETURN-NIL) - (inst and temp x 3) - (inst bne temp DO-STATIC-FN) - (inst and temp y 3) - (inst bne temp DO-STATIC-FN) - (inst nop) - - (load-symbol res t) - (lisp-return lra lip :offset 2) - - DO-STATIC-FN - (inst lw lip null-tn (static-function-offset 'two-arg-=)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j lip) - (inst move cfp-tn csp-tn) - - RETURN-NIL - (inst move res null-tn)) diff --git a/assembly/mips/array.lisp b/assembly/mips/array.lisp deleted file mode 100644 index 3e159ce5852e0b25ffd6d89f7988493ed2ecab47..0000000000000000000000000000000000000000 --- a/assembly/mips/array.lisp +++ /dev/null @@ -1,252 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/mips/array.lisp,v 1.19 1992/07/28 20:42:50 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the support routines for arrays and vectors. -;;; -;;; Written by William Lott. -;;; -(in-package "MIPS") - - -(define-assembly-routine (allocate-vector - (:policy :fast-safe) - (:translate allocate-vector) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) - ((:arg type any-reg a0-offset) - (:arg length any-reg a1-offset) - (:arg words any-reg a2-offset) - (:res result descriptor-reg a0-offset) - - (:temp ndescr non-descriptor-reg nl0-offset) - (:temp pa-flag non-descriptor-reg nl4-offset) - (:temp vector descriptor-reg a3-offset)) - (pseudo-atomic (pa-flag) - (inst or vector alloc-tn other-pointer-type) - ;; This is kinda sleezy, changing words like this. But we can because - ;; the vop thinks it is temporary. - (inst addu words (+ (1- (ash 1 lowtag-bits)) - (* vector-data-offset word-bytes))) - (inst li ndescr (lognot lowtag-mask)) - (inst and words ndescr) - (inst addu alloc-tn words) - (inst srl ndescr type word-shift) - (storew ndescr vector 0 other-pointer-type) - (storew length vector vector-length-slot other-pointer-type)) - (move result vector)) - - - -;;;; Hash primitives - -(define-assembly-routine (sxhash-simple-string - (:translate %sxhash-simple-string) - (:policy :fast-safe) - (:result-types positive-fixnum)) - ((:arg string descriptor-reg a0-offset) - (:res result any-reg a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp length any-reg a2-offset) - (:temp accum non-descriptor-reg nl0-offset) - (:temp data non-descriptor-reg nl1-offset) - (:temp byte non-descriptor-reg nl2-offset) - (:temp retaddr non-descriptor-reg nl3-offset)) - - ;; Save the return address. - (inst subu retaddr lip-tn code-tn) - - (loadw length string vector-length-slot other-pointer-type) - (inst addu lip string - (- (* vector-data-offset word-bytes) other-pointer-type)) - (inst b test) - (move accum zero-tn) - - loop - - (inst and byte data #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - (inst srl byte data 8) - (inst and byte byte #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - (inst srl byte data 16) - (inst and byte byte #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - (inst srl byte data 24) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - (inst addu lip lip 4) - - test - - (inst addu length length (fixnum -4)) - (inst lw data lip 0) - (inst bgez length loop) - (inst nop) - - (inst addu length length (fixnum 3)) - (inst beq length zero-tn one-more) - (inst addu length length (fixnum -1)) - (inst beq length zero-tn two-more) - (inst addu length length (fixnum -1)) - (inst bne length zero-tn done) - (inst nop) - - (inst srl byte data 16) - (inst and byte byte #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - two-more - - (inst srl byte data 8) - (inst and byte byte #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - one-more - - (inst and byte data #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - done - - (inst sll result accum 5) - (inst srl result result 3) - - ;; Restore the return address. - (inst addu lip-tn retaddr code-tn)) - - -(define-assembly-routine (sxhash-simple-substring - (:translate %sxhash-simple-substring) - (:policy :fast-safe) - (:arg-types * positive-fixnum) - (:result-types positive-fixnum)) - ((:arg string descriptor-reg a0-offset) - (:arg length any-reg a1-offset) - (:res result any-reg a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp accum non-descriptor-reg nl0-offset) - (:temp data non-descriptor-reg nl1-offset) - (:temp byte non-descriptor-reg nl2-offset) - (:temp retaddr non-descriptor-reg nl3-offset)) - ;; Save the return address. - (inst subu retaddr lip-tn code-tn) - - (inst addu lip string - (- (* vector-data-offset word-bytes) other-pointer-type)) - (inst b test) - (move accum zero-tn) - - loop - - (inst and byte data #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - (inst srl byte data 8) - (inst and byte byte #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - (inst srl byte data 16) - (inst and byte byte #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - (inst srl byte data 24) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - (inst addu lip lip 4) - - test - - (inst addu length length (fixnum -4)) - (inst lw data lip 0) - (inst bgez length loop) - (inst nop) - - (inst addu length length (fixnum 3)) - (inst beq length zero-tn one-more) - (inst addu length length (fixnum -1)) - (inst beq length zero-tn two-more) - (inst addu length length (fixnum -1)) - (inst bne length zero-tn done) - (inst nop) - - (inst srl byte data 16) - (inst and byte byte #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - two-more - - (inst srl byte data 8) - (inst and byte byte #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - one-more - - (inst and byte data #xff) - (inst xor accum accum byte) - (inst sll byte accum 5) - (inst srl accum accum 27) - (inst or accum accum byte) - - done - - (inst sll result accum 5) - (inst srl result result 3) - - ;; Restore the return address. - (inst addu lip-tn retaddr code-tn)) - diff --git a/assembly/mips/assem-rtns.lisp b/assembly/mips/assem-rtns.lisp deleted file mode 100644 index 8a9bad2b260b5769649f1a0dd55ee0bb0af5572d..0000000000000000000000000000000000000000 --- a/assembly/mips/assem-rtns.lisp +++ /dev/null @@ -1,238 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/mips/assem-rtns.lisp,v 1.28 1992/07/28 20:43:19 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -(in-package "MIPS") - - -;;;; Return-multiple with other than one value - -#+assembler ;; we don't want a vop for this one. -(define-assembly-routine - (return-multiple - (:return-style :none)) - - ;; These four are really arguments. - ((:temp nvals any-reg nargs-offset) - (:temp vals any-reg nl0-offset) - (:temp ocfp any-reg nl1-offset) - (:temp lra descriptor-reg lra-offset) - - ;; These are just needed to facilitate the transfer - (:temp lip interior-reg lip-offset) - (:temp count any-reg nl2-offset) - (:temp src any-reg nl3-offset) - (:temp dst any-reg nl4-offset) - (:temp temp descriptor-reg l0-offset) - - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset) - (:temp a4 descriptor-reg a4-offset) - (:temp a5 descriptor-reg a5-offset)) - - ;; Note, because of the way the return-multiple vop is written, we can - ;; assume that we are never called with nvals == 1 and that a0 has already - ;; been loaded. - (inst blez nvals default-a0-and-on) - (inst subu count nvals (fixnum 2)) - (inst blez count default-a2-and-on) - (inst lw a1 vals (* 1 vm:word-bytes)) - (inst subu count (fixnum 1)) - (inst blez count default-a3-and-on) - (inst lw a2 vals (* 2 vm:word-bytes)) - (inst subu count (fixnum 1)) - (inst blez count default-a4-and-on) - (inst lw a3 vals (* 3 vm:word-bytes)) - (inst subu count (fixnum 1)) - (inst blez count default-a5-and-on) - (inst lw a4 vals (* 4 vm:word-bytes)) - (inst subu count (fixnum 1)) - (inst blez count done) - (inst lw a5 vals (* 5 vm:word-bytes)) - - ;; Copy the remaining args to the top of the stack. - (inst addu src vals (* 6 vm:word-bytes)) - (inst addu dst cfp-tn (* 6 vm:word-bytes)) - - LOOP - (inst lw temp src) - (inst addu src vm:word-bytes) - (inst sw temp dst) - (inst subu count (fixnum 1)) - (inst bne count zero-tn loop) - (inst addu dst vm:word-bytes) - - (inst b done) - (inst nop) - - DEFAULT-A0-AND-ON - (inst move a0 null-tn) - (inst move a1 null-tn) - DEFAULT-A2-AND-ON - (inst move a2 null-tn) - DEFAULT-A3-AND-ON - (inst move a3 null-tn) - DEFAULT-A4-AND-ON - (inst move a4 null-tn) - DEFAULT-A5-AND-ON - (inst move a5 null-tn) - DONE - - ;; Clear the stack. - (move ocfp-tn cfp-tn) - (move cfp-tn ocfp) - (inst addu csp-tn ocfp-tn nvals) - - ;; Return. - (lisp-return lra lip)) - - - -;;;; tail-call-variable. - -#+assembler ;; no vop for this one either. -(define-assembly-routine - (tail-call-variable - (:return-style :none)) - - ;; These are really args. - ((:temp args any-reg nl0-offset) - (:temp lexenv descriptor-reg lexenv-offset) - - ;; We need to compute this - (:temp nargs any-reg nargs-offset) - - ;; These are needed by the blitting code. - (:temp src any-reg nl1-offset) - (:temp dst any-reg nl2-offset) - (:temp count any-reg nl3-offset) - (:temp temp descriptor-reg l0-offset) - - ;; Needed for the jump - (:temp lip interior-reg lip-offset) - - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset) - (:temp a4 descriptor-reg a4-offset) - (:temp a5 descriptor-reg a5-offset)) - - - ;; Calculate NARGS (as a fixnum) - (inst subu nargs csp-tn args) - - ;; Load the argument regs (must do this now, 'cause the blt might - ;; trash these locations) - (inst lw a0 args (* 0 vm:word-bytes)) - (inst lw a1 args (* 1 vm:word-bytes)) - (inst lw a2 args (* 2 vm:word-bytes)) - (inst lw a3 args (* 3 vm:word-bytes)) - (inst lw a4 args (* 4 vm:word-bytes)) - (inst lw a5 args (* 5 vm:word-bytes)) - - ;; Calc SRC, DST, and COUNT - (inst addu count nargs (fixnum (- register-arg-count))) - (inst blez count done) - (inst addu src args (* vm:word-bytes register-arg-count)) - (inst addu dst cfp-tn (* vm:word-bytes register-arg-count)) - - LOOP - ;; Copy one arg. - (inst lw temp src) - (inst addu src src vm:word-bytes) - (inst sw temp dst) - (inst addu count (fixnum -1)) - (inst bgtz count loop) - (inst addu dst dst vm:word-bytes) - - DONE - ;; We are done. Do the jump. - (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type) - (lisp-jump temp lip)) - - - -;;;; Non-local exit noise. - -(define-assembly-routine (unwind - (:translate %continue-unwind) - (:policy :fast-safe)) - ((:arg block (any-reg descriptor-reg) a0-offset) - (:arg start (any-reg descriptor-reg) ocfp-offset) - (:arg count (any-reg descriptor-reg) nargs-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp cur-uwp any-reg nl0-offset) - (:temp next-uwp any-reg nl1-offset) - (:temp target-uwp any-reg nl2-offset)) - (declare (ignore start count)) - - (let ((error (generate-error-code nil invalid-unwind-error))) - (inst beq block zero-tn error)) - - (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) - (loadw target-uwp block vm:unwind-block-current-uwp-slot) - (inst bne cur-uwp target-uwp do-uwp) - (inst nop) - - (move cur-uwp block) - - do-exit - - (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot) - (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) - (loadw lra cur-uwp vm:unwind-block-entry-pc-slot) - (lisp-return lra lip :frob-code nil) - - do-uwp - - (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot) - (inst b do-exit) - (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)) - - -(define-assembly-routine throw - ((:arg target descriptor-reg a0-offset) - (:arg start any-reg ocfp-offset) - (:arg count any-reg nargs-offset) - (:temp catch any-reg a1-offset) - (:temp tag descriptor-reg a2-offset)) - - (progn start count) ; We just need them in the registers. - - (load-symbol-value catch lisp::*current-catch-block*) - - loop - - (let ((error (generate-error-code nil unseen-throw-tag-error target))) - (inst beq catch zero-tn error) - (inst nop)) - - (loadw tag catch vm:catch-block-tag-slot) - (inst beq tag target exit) - (inst nop) - (loadw catch catch vm:catch-block-previous-catch-slot) - (inst b loop) - (inst nop) - - exit - - (move target catch) - (inst j (make-fixup 'unwind :assembly-routine)) - (inst nop)) - - diff --git a/assembly/mips/bit-bash.lisp b/assembly/mips/bit-bash.lisp deleted file mode 100644 index 6137424653e5aa0d6139de4d60d9eb5982b23933..0000000000000000000000000000000000000000 --- a/assembly/mips/bit-bash.lisp +++ /dev/null @@ -1,527 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/bit-bash.lisp,v 1.13 1991/02/02 22:50:15 wlott Exp $ -;;; -;;; Stuff to implement bit bashing. -;;; -;;; Written by William Lott. -;;; - -(in-package "MIPS") - - -;;;; Blitting macros. Used only at assemble time. - -#+assembler -(eval-when (compile eval) - -;;; The main dispatch. Assumes that the following TNs are bound: -;;; dst, dst-offset -- where to put the stuff. -;;; src, src-offset -- where to get the stuff. -;;; dst-bit-offset, src-bit-offset -;;; length -- the number of bits to move. -;;; temp1, temp2 -- random descriptor temp -;;; ntemp1, ntemp2, ntemp3 -- random non-descriptor temps. - -(defmacro do-copy () - '(let ((wide-copy (gen-label)) - (copy-left (gen-label)) - (copy-right (gen-label))) - (compute-bit/word-offsets src src-offset src-bit-offset) - (compute-bit/word-offsets dst dst-offset dst-bit-offset) - - (inst addu temp1 dst-bit-offset length) - (inst subu temp1 (fixnum 32)) - (inst bgez temp1 wide-copy) - (inst sltu ntemp1 src dst) - - (narrow-copy) - - (emit-label wide-copy) - (inst bne ntemp1 copy-right) - (inst nop) - (inst bne src dst copy-left) - (inst sltu ntemp1 src-bit-offset dst-bit-offset) - (inst bne ntemp1 copy-right) - (inst beq src-bit-offset dst-bit-offset done) - (inst nop) - - (emit-label copy-left) - (wide-copy-left) - - (emit-label copy-right) - (wide-copy-right))) - -(defmacro compute-bit/word-offsets (ptr offset bit) - `(progn - (inst and ,bit ,offset (fixnum 31)) - (inst sra ntemp1 ,offset 7) - (inst sll ntemp1 2) - (inst addu ,ptr ntemp1))) - - -(defmacro narrow-copy () - '(let ((aligned (gen-label)) - (only-one-src-word (gen-label)) - (merge-and-write (gen-label))) - (inst beq src-bit-offset dst-bit-offset aligned) - (inst lw ntemp1 src) - - ;; It's not aligned, so get the source bits and align them. - (inst sra ntemp2 src-bit-offset 2) - (inst add temp1 src-bit-offset length) - (inst sub temp1 (fixnum 32)) - (inst blez temp1 only-one-src-word) - (inst srl ntemp1 ntemp2) - - (inst lw ntemp3 src 4) - (inst subu ntemp2 zero-tn ntemp2) - (inst sll ntemp3 ntemp2) - (inst or ntemp1 ntemp3) - - (emit-label only-one-src-word) - (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) - (inst addu ntemp3 length) - (inst lw ntemp3 ntemp3) - (inst sra ntemp2 dst-bit-offset 2) - (inst and ntemp1 ntemp3) - (inst sll ntemp1 ntemp2) - (inst b merge-and-write) - (inst sll ntemp3 ntemp2) - - (emit-label aligned) - (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) - (inst addu ntemp3 length) - (inst lw ntemp3 ntemp3) - (inst sra ntemp2 dst-bit-offset 2) - (inst sll ntemp3 ntemp2) - (inst and ntemp1 ntemp3) - - (emit-label merge-and-write) - ;; ntemp1 has the bits we need to deposit, and ntemp3 has the mask. - ;; Both are aligned with dst. - (inst lw ntemp2 dst) - (inst nor ntemp3 ntemp3 zero-tn) - (inst and ntemp2 ntemp3) - (inst or ntemp1 ntemp2) - (inst b done) - (inst sw ntemp1 dst))) - - -(defmacro wide-copy-left () - '(let ((aligned (gen-label))) - ;; Check to see if they are aligned. - (inst beq src-bit-offset dst-bit-offset aligned) - - ;; Calc src-shift - (inst subu src-shift dst-offset src-offset) - (inst and src-shift (fixnum 31)) - - (macrolet - ((middle (&rest before-last-inst) - `(progn - (inst lw ntemp1 src) - (inst lw ntemp2 src 4) - (inst addu src 4) - (inst sra ntemp3 src-shift 2) - (inst sll ntemp2 ntemp2 ntemp3) - (inst subu ntemp3 zero-tn ntemp3) - (inst srl ntemp1 ntemp1 ntemp3) - ,@before-last-inst - (inst or ntemp1 ntemp2))) - (get-src (where) - (ecase where - (:left - '(let ((dont-load (gen-label)) - (done-load (gen-label))) - (inst sltu ntemp1 src-bit-offset dst-bit-offset) - (inst bne ntemp1 dont-load) - (middle (inst b done-load)) - (emit-label dont-load) - (inst sra ntemp3 src-shift 2) - (inst sll ntemp1 ntemp3) - (emit-label done-load))) - (:middle '(middle)) - (:right - '(let ((dont-load (gen-label)) - (done-load (gen-label))) - (inst sltu ntemp1 src-shift final-bits) - (inst beq ntemp1 dont-load) - (middle (inst b done-load)) - (emit-label dont-load) - (inst sra ntemp3 src-shift 2) - (inst subu ntemp3 zero-tn ntemp3) - (inst srl ntemp1 ntemp3) - (emit-label done-load)))))) - (wide-copy-left-aux)) - - (macrolet - ((get-src (where) - (declare (ignore where)) - '(progn - (inst lw ntemp1 src) - (inst addu src 4)))) - (emit-label aligned) - (wide-copy-left-aux)))) - -(defmacro wide-copy-left-aux () - '(let ((left-aligned (gen-label)) - (loop (gen-label)) - (check-right (gen-label)) - (final-bits temp1) - (interior temp2)) - (inst beq dst-bit-offset left-aligned) - (inst nop) - - (get-src :left) - (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) - (inst addu ntemp3 dst-bit-offset) - (inst lw ntemp3 ntemp3) - (inst lw ntemp2 dst) - (inst addu dst 4) - (inst and ntemp2 ntemp3) - (inst nor ntemp3 ntemp3 zero-tn) - (inst and ntemp1 ntemp3) - (inst or ntemp2 ntemp1) - (inst sw ntemp2 dst -4) - - (emit-label left-aligned) - - (inst addu final-bits length dst-bit-offset) - (inst and final-bits (fixnum 31)) - (inst subu ntemp1 length final-bits) - (inst srl ntemp1 7) - (inst beq ntemp1 check-right) - (inst sll interior ntemp1 2) - - (emit-label loop) - (get-src :middle) - (inst sw ntemp1 dst) - (check-for-interrupts) - (inst subu interior 4) - (inst bgtz interior loop) - (inst addu dst 4) - - (emit-label check-right) - (inst beq final-bits done) - (inst nop) - - (get-src :right) - (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) - (inst addu ntemp3 final-bits) - (inst lw ntemp3 ntemp3) - (inst lw ntemp2 dst) - (inst and ntemp1 ntemp3) - (inst nor ntemp3 zero-tn ntemp3) - (inst and ntemp2 ntemp3) - (inst or ntemp1 ntemp2) - (inst b done) - (inst sw ntemp1 dst))) - - -(defmacro wide-copy-right () - '(let ((aligned (gen-label)) - (final-bits temp1)) - ;; Compute final-bits, the number of bits in the final dst word. - (inst addu ntemp3 dst-bit-offset length) - (inst and final-bits ntemp3 (fixnum 31)) - - ;; Increase src and dst so they point to the end of the buffers instead - ;; of the beginning. - ;; - (inst srl ntemp3 7) - (inst sll ntemp3 2) - (inst addu dst ntemp3) - - (inst addu ntemp3 src-bit-offset length) - (inst subu ntemp3 final-bits) - (inst srl ntemp3 7) - (inst sll ntemp3 2) - (inst add src ntemp3) - - ;; Check to see if they are aligned. - (inst beq src-bit-offset dst-bit-offset aligned) - - ;; Calc src-shift - (inst subu src-shift dst-bit-offset src-bit-offset) - (inst and src-shift (fixnum 31)) - - (macrolet - ((merge (&rest before-last-inst) - `(progn - (inst sra ntemp3 src-shift 2) - (inst sll ntemp2 ntemp3) - (inst subu ntemp3 zero-tn ntemp3) - (inst srl ntemp1 ntemp3) - ,@before-last-inst - (inst or ntemp1 ntemp2))) - (get-src (where) - (ecase where - (:left - '(let ((dont-load (gen-label)) - (done-load (gen-label))) - (inst sltu ntemp1 src-bit-offset dst-bit-offset) - (inst bne ntemp1 dont-load) - (inst lw ntemp2 src 4) - (inst lw ntemp1 src) - (merge (inst b done-load)) - (emit-label dont-load) - (inst sra ntemp3 src-shift 2) - (inst sll ntemp1 ntemp2 ntemp3) - (emit-label done-load))) - (:middle - '(progn - (inst lw ntemp1 src) - (inst lw ntemp2 src 4) - (merge) - (inst subu src 4))) - (:right - '(let ((dont-load (gen-label)) - (done-load (gen-label))) - (inst sltu ntemp1 src-shift final-bits) - (inst beq ntemp1 dont-load) - (inst lw ntemp1 src) - (inst lw ntemp2 src 4) - (merge (inst b done-load)) - (emit-label dont-load) - (inst sra ntemp3 src-shift 2) - (inst subu ntemp3 zero-tn ntemp3) - (inst srl ntemp1 ntemp3) - (emit-label done-load)))))) - (wide-copy-right-aux) - (inst b done) - (inst nop)) - - (macrolet - ((get-src (where) - `(progn - (inst lw ntemp1 src) - ,@(unless (eq where :right) - '((inst subu src 4)))))) - (emit-label aligned) - (wide-copy-right-aux)))) - -(defmacro wide-copy-right-aux () - '(let ((right-aligned (gen-label)) - (loop (gen-label)) - (check-left (gen-label)) - (interior temp2)) - (inst beq final-bits right-aligned) - (inst nop) - - (get-src :right) - (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) - (inst addu ntemp3 final-bits) - (inst lw ntemp3 ntemp3) - (inst lw ntemp2 dst) - (inst and ntemp1 ntemp3) - (inst nor ntemp3 ntemp3 zero-tn) - (inst and ntemp2 ntemp3) - (inst or ntemp2 ntemp1) - (inst sw ntemp2 dst) - - (emit-label right-aligned) - (inst subu dst 4) - (inst subu src 4) - - (inst subu ntemp1 length final-bits) - (inst srl ntemp1 7) - (inst beq ntemp1 check-left) - (inst sll interior ntemp1 2) - - (emit-label loop) - (get-src :middle) - (inst sw ntemp1 dst) - (check-for-interrupts) - (inst subu interior 4) - (inst bgtz interior loop) - (inst subu dst 4) - - (emit-label check-left) - (inst beq dst-bit-offset done) - (inst nop) - - (get-src :left) - (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) - (inst addu ntemp3 dst-bit-offset) - (inst lw ntemp3 ntemp3) - (inst lw ntemp2 dst) - (inst nop) - (inst and ntemp2 ntemp3) - (inst nor ntemp3 zero-tn ntemp3) - (inst and ntemp1 ntemp3) - (inst or ntemp1 ntemp2) - (inst sw ntemp1 dst))) - -(defmacro check-for-interrupts () - nil) - -) ; eval-when (compile eval) - - - -;;;; The actual routines. - -(define-assembly-routine (copy-to-system-area - (:policy :fast-safe) - (:translate copy-to-system-area) - (:arg-types * tagged-num - system-area-pointer tagged-num - tagged-num)) - ((:arg src-arg descriptor-reg a0-offset) - (:arg src-offset any-reg a1-offset) - (:arg dst sap-reg nl0-offset) - (:arg dst-offset any-reg a2-offset) - (:arg length any-reg a3-offset) - (:res res descriptor-reg null-offset) - - (:temp src interior-reg lip-offset) - (:temp temp1 descriptor-reg a4-offset) - (:temp temp2 descriptor-reg a5-offset) - (:temp src-shift descriptor-reg cname-offset) - (:temp src-bit-offset descriptor-reg lexenv-offset) - (:temp dst-bit-offset descriptor-reg l0-offset) - (:temp ntemp1 non-descriptor-reg nl1-offset) - (:temp ntemp2 non-descriptor-reg nl2-offset) - (:temp ntemp3 non-descriptor-reg nl3-offset) - (:temp retaddr non-descriptor-reg nargs-offset)) - - (progn res) ; don't complain that it's unused. - - ;; Save the return address. - (inst subu retaddr lip-tn code-tn) - - (inst subu src src-arg vm:other-pointer-type) - (inst and ntemp1 dst 3) - (inst xor dst ntemp1) - (inst sll ntemp1 5) - (inst addu dst-offset ntemp1) - (do-copy) - done - - ;; Restore the return address. - (inst addu lip-tn retaddr code-tn)) - -(define-assembly-routine (copy-from-system-area - (:policy :fast-safe) - (:translate copy-from-system-area) - (:arg-types system-area-pointer tagged-num - * tagged-num tagged-num)) - ((:arg src sap-reg nl0-offset) - (:arg src-offset any-reg a0-offset) - (:arg dst-arg descriptor-reg a1-offset) - (:arg dst-offset any-reg a2-offset) - (:arg length any-reg a3-offset) - (:res res descriptor-reg null-offset) - - (:temp dst interior-reg lip-offset) - (:temp temp1 descriptor-reg a4-offset) - (:temp temp2 descriptor-reg a5-offset) - (:temp src-shift descriptor-reg cname-offset) - (:temp src-bit-offset descriptor-reg lexenv-offset) - (:temp dst-bit-offset descriptor-reg l0-offset) - (:temp ntemp1 non-descriptor-reg nl1-offset) - (:temp ntemp2 non-descriptor-reg nl2-offset) - (:temp ntemp3 non-descriptor-reg nl3-offset) - (:temp retaddr non-descriptor-reg nargs-offset)) - (progn res) ; don't complain that it's unused. - - ;; Save the return address. - (inst sub retaddr lip-tn code-tn) - - (inst and ntemp1 src 3) - (inst xor src ntemp1) - (inst sll ntemp1 5) - (inst addu src-offset ntemp1) - (inst subu dst dst-arg vm:other-pointer-type) - (do-copy) - done - - ;; Restore the return address. - (inst add lip-tn retaddr code-tn)) - -(define-assembly-routine (system-area-copy - (:policy :fast-safe) - (:translate system-area-copy) - (:arg-types system-area-pointer tagged-num - system-area-pointer tagged-num - tagged-num)) - ((:arg src sap-reg nl1-offset) - (:arg src-offset any-reg a0-offset) - (:arg dst sap-reg nl0-offset) - (:arg dst-offset any-reg a1-offset) - (:arg length any-reg a2-offset) - (:res res descriptor-reg null-offset) - - (:temp temp1 descriptor-reg a4-offset) - (:temp temp2 descriptor-reg a5-offset) - (:temp src-shift descriptor-reg cname-offset) - (:temp src-bit-offset descriptor-reg lexenv-offset) - (:temp dst-bit-offset descriptor-reg l0-offset) - (:temp ntemp1 non-descriptor-reg nl2-offset) - (:temp ntemp2 non-descriptor-reg nl3-offset) - (:temp ntemp3 non-descriptor-reg nl4-offset)) - (progn res) ; don't complain that it's unused. - - (inst and ntemp1 src 3) - (inst xor src ntemp1) - (inst sll ntemp1 5) - (inst addu src-offset ntemp1) - (inst and ntemp1 dst 3) - (inst xor dst ntemp1) - (inst sll ntemp1 5) - (inst addu dst-offset ntemp1) - (do-copy) - done) - -(define-assembly-routine (bit-bash-copy - (:policy :fast-safe) - (:translate bit-bash-copy) - (:arg-types * tagged-num * tagged-num tagged-num)) - ((:arg src-arg descriptor-reg a0-offset) - (:arg src-offset any-reg a1-offset) - (:arg dst-arg descriptor-reg a2-offset) - (:arg dst-offset any-reg a3-offset) - (:arg length any-reg a4-offset) - (:res res descriptor-reg null-offset) - - (:temp src non-descriptor-reg nl0-offset) - (:temp dst non-descriptor-reg nl1-offset) - (:temp temp1 descriptor-reg a5-offset) - (:temp temp2 descriptor-reg l0-offset) - (:temp src-shift descriptor-reg cname-offset) - (:temp src-bit-offset descriptor-reg lexenv-offset) - (:temp dst-bit-offset descriptor-reg l1-offset) - (:temp ntemp1 non-descriptor-reg nl2-offset) - (:temp ntemp2 non-descriptor-reg nl3-offset) - (:temp ntemp3 non-descriptor-reg nl4-offset)) - (progn res) ; don't complain that it's unused. - - (let ((done (gen-label))) - (pseudo-atomic (ntemp1) - (inst subu src src-arg vm:other-pointer-type) - (inst subu dst dst-arg vm:other-pointer-type) - (macrolet - ((check-for-interrupts () - '(let ((label (gen-label))) - (inst and ntemp1 flags-tn (ash 1 interrupted-flag)) - (inst beq ntemp1 label) - (inst nop) - (inst subu src src-arg) - (inst subu dst dst-arg) - (inst and flags-tn (logxor (ash 1 atomic-flag) #Xffff)) - (inst break vm:pending-interrupt-trap) - (inst and flags-tn (logxor (ash 1 interrupted-flag) #Xffff)) - (inst or flags-tn flags-tn (ash 1 atomic-flag)) - (inst addu src src-arg) - (inst addu dst dst-arg) - (emit-label label)))) - (do-copy)) - (emit-label done)))) diff --git a/assembly/mips/support.lisp b/assembly/mips/support.lisp deleted file mode 100644 index e54c65e956785a3de42226d63f0fd1aa422e23a7..0000000000000000000000000000000000000000 --- a/assembly/mips/support.lisp +++ /dev/null @@ -1,72 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/support.lisp,v 1.9 1992/07/31 21:54:14 wlott Exp $ -;;; -;;; This file contains the machine specific support routines needed by -;;; the file assembler. -;;; -(in-package "MIPS") - -(def-vm-support-routine generate-call-sequence (name style vop) - (ecase style - (:raw - (values - `((inst jal (make-fixup ',name :assembly-routine)) - (inst nop)) - nil)) - (:full-call - (let ((temp (make-symbol "TEMP")) - (nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) - (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn ,nfp-save cur-nfp)) - (inst compute-lra-from-code ,lra code-tn lra-label ,temp) - (note-next-instruction ,vop :call-site) - (inst j (make-fixup ',name :assembly-routine)) - (inst nop) - (emit-return-pc lra-label) - (note-this-location ,vop :single-value-return) - (without-scheduling () - (move csp-tn ocfp-tn) - (inst nop)) - (inst compute-code-from-lra code-tn code-tn - lra-label ,temp) - (when cur-nfp - (load-stack-tn cur-nfp ,nfp-save)))) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save) - (:save-p :compute-only))))) - (:none - (values - `((inst j (make-fixup ',name :assembly-routine)) - (inst nop)) - nil)))) - - -(def-vm-support-routine generate-return-sequence (style) - (ecase style - (:raw - `((inst j lip-tn) - (inst nop))) - (:full-call - `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose - 'descriptor-reg) - :offset lra-offset) - lip-tn :offset 2))) - (:none))) diff --git a/assembly/mips/wrlist.lisp b/assembly/mips/wrlist.lisp deleted file mode 100644 index f8ee79666a2318f0ec5dd2c578403bdf34c933c6..0000000000000000000000000000000000000000 --- a/assembly/mips/wrlist.lisp +++ /dev/null @@ -1,304 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/mips/wrlist.lisp,v 1.6 1992/03/12 16:28:31 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the assembly routines for write-list support. -;;; - -(in-package "MIPS") - -(define-assembly-routine - (write-list-record) - ((:arg object descriptor-reg a0-offset) - (:arg offset non-descriptor-reg nl2-offset) - (:arg value descriptor-reg a1-offset) - - (:temp nl0 non-descriptor-reg nl0-offset) - (:temp nl1 non-descriptor-reg nl1-offset) - - (:temp nl3 non-descriptor-reg nl3-offset) - (:temp nl4 non-descriptor-reg nl4-offset) - (:temp nl5 non-descriptor-reg nl5-offset) - (:temp nargs non-descriptor-reg nargs-offset) - - (:temp a2 any-reg a2-offset) - (:temp a3 any-reg a3-offset) - (:temp a4 any-reg a4-offset) - (:temp a5 any-reg a5-offset) - (:temp cname any-reg cname-offset) - (:temp lexenv any-reg lexenv-offset) - (:temp l0 any-reg l0-offset) - (:temp l1 any-reg l1-offset) - (:temp l2 any-reg l2-offset) - (:temp l3 any-reg l3-offset) - (:temp nfp any-reg nfp-offset) - (:temp ocfp any-reg ocfp-offset) - (:temp lra any-reg lra-offset)) - - ;; The write into memory and the write into the write-list have to be atomic. - (start-pseudo-atomic) - - TRY-AGAIN - - ;; First, make sure there is space available in the write list. - (inst lw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) - (inst lw nl1 mutator-tn (* mutator-write-list-end-slot word-bytes)) - (inst nop) - (inst bne nl0 nl1 space-available) - (inst nop) - - ;; No space, so we have to call out to gengc_FlushWriteList. - - ;; We have to save all the descriptor registers on the stack in case - ;; we end up collecting garbage while in C. - - ;; Save all lisp regs on the stack, so the garbage collector can find them. - (save-regs-on-stack (object value a2 a3 a4 a5 cname lexenv - l0 l1 l2 l3 nfp ocfp code-tn lra null-tn) - - ;; Convert the return address into an offset. We don't have to save l0 - ;; across the call-out because it is one of the saved regs. - (inst subu l0 lip-tn code-tn) - - ;; Decache all the lisp state from the mutator structure. - (storew csp-tn mutator-tn mutator-control-stack-pointer-slot) - (storew cfp-tn mutator-tn mutator-control-frame-pointer-slot) - - ;; Indicate that we are now in foreign-function-call land. - (storew csp-tn mutator-tn mutator-foreign-fn-call-active-slot) - - ;; Turn off pseudo-atomic. - (end-pseudo-atomic nl0) - - ;; Move offset to one of the saved registers. - (inst move l1 offset) - - ;; Move the other non-descriptor regs into saved regs. - (inst move l2 nl3) - (inst move l3 nl4) - (inst move nfp nl5) - (inst move ocfp nargs) - - ;; Allocate the stack frame. - (inst subu nsp-tn nsp-tn (* 4 word-bytes)) - - ;; Restore GP - (inst li null-tn (make-fixup "_gp" :foreign)) - - ;; Call-out to gengc_Allocate, setting up the single argument. - (inst jal (make-fixup "gengc_FlushWriteList" :foreign)) - (inst move nl0 mutator-tn) - - ;; Deallocate the stack frame. - (inst addu nsp-tn nsp-tn (* 4 word-bytes)) - - ;; Restore offset from the saved reg. - (inst move offset l1) - - ;; Restore the other non-descriptor regs. - (inst move nl3 l2) - (inst move nl4 l3) - (inst move nl5 nfp) - (inst move nargs ocfp) - - ;; Turn pseudo-atomic back on. - (start-pseudo-atomic) - - ;; No longer in foreign-foreign-call land. - (storew zero-tn mutator-tn mutator-foreign-fn-call-active-slot) - - ;; Cache lisp state from the mutator structure. - (loadw csp-tn mutator-tn mutator-control-stack-pointer-slot) - (loadw cfp-tn mutator-tn mutator-control-frame-pointer-slot) - - ;; We can't restore the return address yet, because code hasn't been - ;; restored. But if we wait until after code has been restored, - ;; then l0 will have been trashed. So we have to move the value - ;; out of l0 and into nl0. - (inst move nl0 l0) - - ;; Restore all the saved regs. (by dropping out of the save-regs-on-stack) - ) - - ;; Regenerate the return address from the saved offset. - (inst addu lip-tn nl0 code-tn) - - ;; Because we turned off pseudo-atomic, we might have taken an interrupt, - ;; so we can't be sure the write-list will be empty. - (inst b try-again) - (inst nop) - - SPACE-AVAILABLE - - (inst addu nl1 object offset) - (inst sw nl1 nl0) - (inst sw value nl1) - (inst addu nl0 4) - (inst sw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) - - (end-pseudo-atomic nl0)) - - -(define-assembly-routine - (set-fdefn-function) - ((:arg fdefn descriptor-reg a0-offset) - (:arg function descriptor-reg a1-offset) - - (:temp nl0 non-descriptor-reg nl0-offset) - (:temp nl1 non-descriptor-reg nl1-offset) - - (:temp nl2 non-descriptor-reg nl2-offset) - (:temp nl3 non-descriptor-reg nl3-offset) - (:temp nl4 non-descriptor-reg nl4-offset) - (:temp nl5 non-descriptor-reg nl5-offset) - (:temp nargs non-descriptor-reg nargs-offset) - - (:temp a2 any-reg a2-offset) - (:temp a3 any-reg a3-offset) - (:temp a4 any-reg a4-offset) - (:temp a5 any-reg a5-offset) - (:temp cname any-reg cname-offset) - (:temp lexenv any-reg lexenv-offset) - (:temp l0 any-reg l0-offset) - (:temp l1 any-reg l1-offset) - (:temp l2 any-reg l2-offset) - (:temp l3 any-reg l3-offset) - (:temp nfp any-reg nfp-offset) - (:temp ocfp any-reg ocfp-offset) - (:temp lra any-reg lra-offset)) - - ;; The write into memory and the write into the write-list have to be atomic. - (start-pseudo-atomic) - - ;; First, check to see if we don't need to make a write-list entry because - ;; the fdefn object is ephemeral. - (inst srl nl0 fdefn 30) - (inst bne nl0 zero-tn just-do-write) - (inst nop) - - TRY-AGAIN - - ;; Now make sure there is space available in the write list. - (inst lw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) - (inst lw nl1 mutator-tn (* mutator-write-list-end-slot word-bytes)) - (inst nop) - (inst bne nl0 nl1 space-available) - (inst nop) - - ;; No space, so we have to call out to gengc_FlushWriteList. - - ;; We have to save all the descriptor registers on the stack in case - ;; we end up collecting garbage while in C. - - ;; Save all lisp regs on the stack, so the garbage collector can find them. - (save-regs-on-stack (fdefn function a2 a3 a4 a5 cname lexenv - l0 l1 l2 l3 nfp ocfp code-tn lra null-tn) - - ;; Convert the return address into an offset. We don't have to save l0 - ;; across the call-out because it is one of the saved regs. - (inst subu l0 lip-tn code-tn) - - ;; Decache all the lisp state from the mutator structure. - (storew csp-tn mutator-tn mutator-control-stack-pointer-slot) - (storew cfp-tn mutator-tn mutator-control-frame-pointer-slot) - - ;; Indicate that we are now in foreign-function-call land. - (storew csp-tn mutator-tn mutator-foreign-fn-call-active-slot) - - ;; Turn off pseudo-atomic. - (end-pseudo-atomic nl0) - - ;; Move the non-descriptor regs into saved regs. - (inst move l1 nl2) - (inst move l2 nl3) - (inst move l3 nl4) - (inst move nfp nl5) - (inst move ocfp nargs) - - ;; Allocate the stack frame. - (inst subu nsp-tn nsp-tn (* 4 word-bytes)) - - ;; Restore GP - (inst li null-tn (make-fixup "_gp" :foreign)) - - ;; Call-out to gengc_Allocate, setting up the single argument. - (inst jal (make-fixup "gengc_FlushWriteList" :foreign)) - (inst move nl0 mutator-tn) - - ;; Deallocate the stack frame. - (inst addu nsp-tn nsp-tn (* 4 word-bytes)) - - ;; Restore the non-descriptor regs. - (inst move nl2 l1) - (inst move nl3 l2) - (inst move nl4 l3) - (inst move nl5 nfp) - (inst move nargs ocfp) - - ;; Turn pseudo-atomic back on. - (start-pseudo-atomic) - - ;; No longer in foreign-foreign-call land. - (storew zero-tn mutator-tn mutator-foreign-fn-call-active-slot) - - ;; Cache lisp state from the mutator structure. - (loadw csp-tn mutator-tn mutator-control-stack-pointer-slot) - (loadw cfp-tn mutator-tn mutator-control-frame-pointer-slot) - - ;; We can't restore the return address yet, because code hasn't been - ;; restored. But if we wait until after code has been restored, - ;; then l0 will have been trashed. So we have to move the value - ;; out of l0 and into nl0. - (inst move nl0 l0) - - ;; Restore all the saved regs. (by dropping out of the save-regs-on-stack) - ) - - ;; Regenerate the return address from the saved offset. - (inst addu lip-tn nl0 code-tn) - - ;; Because we turned off pseudo-atomic, we might have taken an interrupt, - ;; so we can't be sure the write-list will be empty. - (inst b try-again) - (inst nop) - - SPACE-AVAILABLE - - (inst subu nl1 fdefn other-pointer-type) - (inst sw nl1 nl0) - (inst addu nl0 4) - (inst sw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) - - JUST-DO-WRITE - - (load-type nl0 function (- vm:function-pointer-type)) - (inst nop) - (inst xor nl0 vm:closure-header-type) - (inst beq nl0 zero-tn closure) - (inst xor nl0 (logxor closure-header-type funcallable-instance-header-type)) - (inst beq nl0 zero-tn closure) - (inst xor nl0 (logxor funcallable-instance-header-type function-header-type)) - (inst beq nl0 zero-tn normal-fn) - (inst addu nl1 function - (- (ash vm:function-header-code-offset vm:word-shift) - vm:function-pointer-type)) - (end-pseudo-atomic nl0) - (error-call nil kernel:object-not-function-error function) - - CLOSURE - (inst li nl1 (make-fixup "closure_tramp" :foreign)) - - NORMAL-FN - (storew function fdefn fdefn-function-slot other-pointer-type) - (storew nl1 fdefn fdefn-raw-addr-slot other-pointer-type) - - (end-pseudo-atomic nl0)) diff --git a/assembly/rt/alloc.lisp b/assembly/rt/alloc.lisp deleted file mode 100644 index 2d129bbee1873fee4d80938d17d02e37557021b7..0000000000000000000000000000000000000000 --- a/assembly/rt/alloc.lisp +++ /dev/null @@ -1,95 +0,0 @@ -;;; -*- 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/alloc.lisp,v 1.5 1991/10/22 19:07:16 wlott Exp $ -;;; -;;; Stuff to handle allocating simple objects. -;;; -;;; Written by William Lott. -;;; Converted to the IBM RT by Bill Chiles. -;;; - -(in-package "RT") - - -(define-for-each-primitive-object (obj) - (let* ((options (primitive-object-options obj)) - (alloc-trans (getf options :alloc-trans)) - (alloc-vop (getf options :alloc-vop alloc-trans)) - (header (primitive-object-header obj)) - (lowtag (primitive-object-lowtag obj)) - (size (primitive-object-size obj)) - (variable-length (primitive-object-variable-length obj)) - (need-unbound-marker nil)) - (collect ((args) (init-forms)) - (when (and alloc-vop variable-length) - (args 'extra-words)) - (dolist (slot (primitive-object-slots obj)) - (let* ((name (slot-name slot)) - (offset (slot-offset slot))) - (ecase (getf (slot-options slot) :init :zero) - (:zero) - (:null - (init-forms `(storew null-tn result ,offset ,lowtag))) - (:unbound - (setf need-unbound-marker t) - (init-forms `(storew temp result ,offset ,lowtag))) - (:arg - (args name) - (init-forms `(storew ,name result ,offset ,lowtag)))))) - (when (and (null alloc-vop) (args)) - (error "Slots ~S want to be initialized, but there is no alloc vop ~ - defined for ~S." - (args) (primitive-object-name obj))) - (when alloc-vop - `(define-assembly-routine - (,alloc-vop - (:cost 35) - ,@(when alloc-trans - `((:translate ,alloc-trans))) - (:policy :fast-safe)) - (,@(let ((arg-offsets (cdr register-arg-offsets))) - (mapcar #'(lambda (name) - (unless arg-offsets - (error "Too many args in ~S" alloc-vop)) - `(:arg ,name (descriptor-reg any-reg) - ,(pop arg-offsets))) - (args))) - (:temp alloc non-descriptor-reg nl0-offset) - (:temp temp non-descriptor-reg ocfp-offset) - (:res result descriptor-reg a0-offset)) - (pseudo-atomic (temp) - (load-symbol-value alloc *allocation-pointer*) - (inst cal result alloc ,lowtag) - ,@(cond ((and header variable-length) - `((inst cal temp extra-words (fixnum (1- ,size))) - (inst cas alloc temp alloc) - (inst sl temp (- type-bits word-shift)) - (inst oil temp ,header) - (storew temp result 0 ,lowtag) - (inst cal alloc alloc (+ (fixnum 1) lowtag-mask)) - (inst li temp (lognot lowtag-mask)) - (inst n alloc temp))) - (variable-length - (error ":REST-P T with no header in ~S?" - (primitive-object-name obj))) - (header - `((inst cal alloc alloc (pad-data-block ,size)) - (inst li temp - ,(logior (ash (1- size) type-bits) - (symbol-value header))) - (storew temp result 0 ,lowtag))) - (t - `((inst cal alloc alloc (pad-data-block ,size))))) - ,@(when need-unbound-marker - `((inst li temp unbound-marker-type))) - ,@(init-forms) - (store-symbol-value alloc *allocation-pointer*)) - (load-symbol-value temp *internal-gc-trigger*) - (inst tlt temp alloc)))))) diff --git a/assembly/rt/arith.lisp b/assembly/rt/arith.lisp deleted file mode 100644 index 01c092fc23360714d54627863216bb557fc7687b..0000000000000000000000000000000000000000 --- a/assembly/rt/arith.lisp +++ /dev/null @@ -1,478 +0,0 @@ -;;; -*- Package: RT -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/arith.lisp,v 1.6 1991/10/24 09:49:02 wlott Exp $ -;;; -;;; Stuff to handle simple cases for generic arithmetic. -;;; -;;; Written by William Lott. -;;; Converted to IBM RT by Bill Chiles. - -(in-package "RT") - - -(define-assembly-routine (generic-+ - (:cost 25) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp cname descriptor-reg cname-offset) - (:temp ocfp any-reg ocfp-offset)) - ;; If either arg is not a fixnum, call the static function. - (move temp x) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - (move temp y) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - ;; Use ocfp as a temporary result. - (move ocfp x) - (inst a ocfp y) - (inst bnc :ov fixnum-result) - ;; If we overflowed, shift the operands down to lose the fixnum lowtag bits - ;; and do the add again. - (move ocfp x) - (inst sar ocfp 2) - (move temp y) - (inst sar temp 2) - (inst a ocfp temp) - ;; Allocate a bignum for sum. - (with-fixed-allocation (res temp cname bignum-type - (1+ bignum-digits-offset)) - (storew ocfp res bignum-digits-offset other-pointer-type)) - ;; Now get out of here. - (lisp-return lra lip :offset 1) - - DO-STATIC-FUN - (load-symbol cname 'two-arg-+) - (inst li nargs (fixnum 2)) - (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) - (move ocfp cfp-tn) - ;; Tail call TWO-ARG-+. - (inst bx lip) - (move cfp-tn csp-tn) - - FIXNUM-RESULT - ;; Ocfp was used for the temporary result. - (move res ocfp)) - -(define-assembly-routine (generic-- - (:cost 25) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp cname descriptor-reg cname-offset) - (:temp ocfp any-reg ocfp-offset)) - ;; If either arg is not a fixnum, call the static function. - (move temp x) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - (move temp y) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - ;; Use ocfp as a temporary result. - (move ocfp x) - (inst s ocfp y) - (inst bnc :ov fixnum-result) - ;; If we overflowed, shift the operands down to lose the fixnum lowtag bits - ;; and do the subtract again. - (move ocfp x) - (inst sar ocfp 2) - (move temp y) - (inst sar temp 2) - (inst s ocfp temp) - ;; Allocate a bignum for sum. - (with-fixed-allocation (res temp cname bignum-type - (1+ bignum-digits-offset)) - (storew ocfp res bignum-digits-offset other-pointer-type)) - ;; Now get out of here. - (lisp-return lra lip :offset 1) - - DO-STATIC-FUN - (load-symbol cname 'two-arg--) - (inst li nargs (fixnum 2)) - (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) - (move ocfp cfp-tn) - ;; Tail call TWO-ARG-+. - (inst bx lip) - (move cfp-tn csp-tn) - - FIXNUM-RESULT - ;; Ocfp was used for the temporary result. - (move res ocfp)) - -(define-assembly-routine (generic-* - (:cost 70) - (:return-style :full-call) - (:translate *) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp alloc word-pointer-reg a2-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs/high non-descriptor-reg nargs-offset) - (:temp ocfp/low non-descriptor-reg ocfp-offset) - (:temp cname descriptor-reg cname-offset)) - ;; If either arg is not a fixnum, call the static function. - (move temp x) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - (move temp y) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - - ;; Remove the tag from one arg so that the result will have the correct - ;; fixnum lowtag. Without this, the result if off by a factor of 16, but we - ;; want it off by a factor of 4 (the fixnum lowtag). - (move temp x) - (inst sar temp 2) - ;; Setup system register for multiply. - (inst mtmqscr temp) - - ;; Do the multiply. - ;; Subtract high from high to set it to zero and to set the C0 condition - ;; bit appropriately for the m instruction. - (inst s nargs/high nargs/high) - (dotimes (i 16) - (inst m nargs/high y)) - (inst mfmqscr res) - - ;; Check to see if the result will fit in a fixnum. (I.e. the high word is - ;; just 32 copies of the sign bit of the low word). - (move temp res) - (inst sar temp 31) - (inst c temp nargs/high) - (inst bc :eq DONE) - ;; Build two bignum-digits by shifting the double word high:res down two bits - ;; into high:low to get rid of the fixnum lowtag. - (move ocfp/low res) - (inst sr ocfp/low 2) - (move temp nargs/high) - (inst sl temp 30) - (inst o ocfp/low temp) - (inst sar nargs/high 2) - ;; Allocate a bignum for the result. - (pseudo-atomic (temp) - (let ((one-word (gen-label))) - (load-symbol-value alloc *allocation-pointer*) - (inst cal res alloc other-pointer-type) - ;; Assume we need one word. - (inst cal alloc alloc (pad-data-block (1+ bignum-digits-offset))) - ;; Is that correct? - (move temp ocfp/low) - (inst sar temp 31) - (inst c temp nargs/high) - (inst bcx :eq one-word) - (inst li temp (logior (ash 1 type-bits) bignum-type)) - ;; Nope, we need two, so allocate the addition space. - (inst cal alloc alloc (- (pad-data-block (+ 2 bignum-digits-offset)) - (pad-data-block (1+ bignum-digits-offset)))) - (inst li temp (logior (ash 2 type-bits) bignum-type)) - (storew nargs/high res (1+ bignum-digits-offset) other-pointer-type) - (emit-label one-word) - (store-symbol-value alloc *allocation-pointer*) - (storew temp res 0 other-pointer-type) - (storew ocfp/low res bignum-digits-offset other-pointer-type))) - (load-symbol-value temp *internal-gc-trigger*) - (inst tlt temp alloc) - ;; Out of here - (lisp-return lra lip :offset 1) - - DO-STATIC-FUN - (load-symbol cname 'two-arg-*) - (inst li nargs/high (fixnum 2)) - (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) - (move ocfp/low cfp-tn) - (inst bx lip) - (move cfp-tn csp-tn) - - DONE) - -(define-assembly-routine (generic-truncate - (:cost 95) - (:return-style :full-call) - (:translate truncate) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res quo (descriptor-reg any-reg) a0-offset) - (:res rem (descriptor-reg any-reg) a1-offset) - - (:temp temp1 non-descriptor-reg nl0-offset) - (:temp alloc word-pointer-reg a2-offset) - (:temp lip interior-reg lip-offset) - - ;; High holds the sign of x and becomes the remainder. - (:temp nargs/high non-descriptor-reg nargs-offset) - (:temp cname descriptor-reg cname-offset) - (:temp ocfp/temp2 non-descriptor-reg ocfp-offset)) - ;; If either arg is not a fixnum, call the static function. - (move temp1 x) - (inst nilz temp1 3) - (inst bnc :eq DO-STATIC-FUN) - (move temp1 y) - (inst nilz temp1 3) - (inst bnc :eq DO-STATIC-FUN) - - ;; Make sure y is not 0, 1, or -1. - (inst c y 0) - (inst bcx :eq zero-divisor) - (inst c y (fixnum 1)) - (inst bcx :eq one-divisor) - (inst c y (fixnum -1)) - (inst bc :eq neg-one-divisor) - - ;; Do the division. - (move nargs/high x) - (inst sar nargs/high 31) - (inst mtmqscr x) - (dotimes (i 32) - (inst d nargs/high y)) - ;; Check preliminary remainder by considering signs of high and y. - ;; This is an extra step to account for the non-restoring divide-step instr. - ;; We don't actually have to check this since the d instruction set :c0 - ;; when the signs of high and y are the same. - (inst bc :c0 rem-okay) - (inst a nargs/high y) - REM-OKAY - - ;; The RT gives us some random division concept, but we're writing TRUNCATE. - ;; The fixup involves adding one to the quotient and subtracting the divisor - ;; from the remainder under certain circumstances: - ;; IF the remainder is zero, we're done. - (inst c nargs/high 0) - (inst bc :eq move-results) - ;; ELSE-IF the remainder is equal to the divisor, we can obviously take - ;; one more divisor out of the dividend, so do it. - (inst c nargs/high y) - (inst bc :eq do-it) - ;; ELSE-IF the divisor and dividend had different signs, adjust the results. - (move temp1 x) - (inst x temp1 y) - (inst bnc :lt move-results) - - DO-IT - ;; Add 1 to quotient and subtract divisor from remainder. - (inst mfmqscr temp1) - (inst sl temp1 2) - (inst a quo temp1 (fixnum 1)) - ;; Since rem and y are the same register, this subtracts the divisor from - ;; the remainder, putting the result in our rem result register. - (inst sf y nargs/high) - - (inst b done) - - MOVE-RESULTS - (inst mfmqscr temp1) - (inst sl temp1 2) - (move quo temp1) - ;; The remainder is always on the same order of magnitude as the dividend, - ;; so it already has fixnum lowtag bits. - (move rem nargs/high) - (inst b done) - - DO-STATIC-FUN - (load-symbol cname 'truncate) - (inst li nargs/high (fixnum 2)) - (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) - (move ocfp/temp2 cfp-tn) - ;; Get out of here, doing a tail call. - (inst bx lip) - (move cfp-tn csp-tn) - - - ZERO-DIVISOR - ;; signal an error somehow. - - NEG-ONE-DIVISOR - (inst li rem 0) - (inst neg quo x) - ;; If quo still fits in a fixnum, go to done. - (inst bnc :ov done) - ;; Allocate a bignum for quo. - (with-fixed-allocation (temp1 ocfp/temp2 alloc bignum-type - (+ 2 bignum-digits-offset)) - ;; If we overflowed quo, then we must have made a positive value from a - ;; negative one. The overflow would be one bit and some zero's for sign. - (inst li ocfp/temp2 0) - (storew quo temp1 bignum-digits-offset other-pointer-type) - (storew ocfp/temp2 temp1 (1+ bignum-digits-offset) other-pointer-type)) - (move quo temp1) - - (inst b done) - - ONE-DIVISOR - (inst li rem 0) - (move quo x) - - DONE) - - - -;;;; Conditionals - -(define-assembly-routine (generic-< - (:cost 25) - (:return-style :full-call) - (:translate <) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp cname descriptor-reg cname-offset) - (:temp ocfp any-reg ocfp-offset)) - ;; If either arg is not a fixnum, call the static function. - (move temp x) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - (move temp y) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - - ;; They are both fixnums, we can compare them. - (inst c x y) - (inst bcx :lt DONE) - (load-symbol res t) - - (inst bx DONE) - (move res null-tn) - - DO-STATIC-FUN - (load-symbol cname 'two-arg-<) - (inst li nargs (fixnum 2)) - (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) - (move ocfp cfp-tn) - ;; Tail call TWO-ARG->. - (inst bx lip) - (move cfp-tn csp-tn) - - DONE) - -(define-assembly-routine (generic-> - (:cost 25) - (:return-style :full-call) - (:translate >) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp cname descriptor-reg cname-offset) - (:temp ocfp any-reg ocfp-offset)) - ;; If either arg is not a fixnum, call the static function. - (move temp x) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - (move temp y) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - - ;; They are both fixnums, we can compare them. - (inst c x y) - (inst bcx :gt DONE) - (load-symbol res t) - - (inst bx DONE) - (move res null-tn) - - DO-STATIC-FUN - (load-symbol cname 'two-arg->) - (inst li nargs (fixnum 2)) - (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) - (move ocfp cfp-tn) - ;; Tail call TWO-ARG->. - (inst bx lip) - (move cfp-tn csp-tn) - - DONE) - - -(define-assembly-routine (generic-= - (:cost 25) - (:return-style :full-call) - (:translate =) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp cname descriptor-reg cname-offset) - (:temp ocfp any-reg ocfp-offset)) - ;; If they are eq, they must be = - (inst c x y) - (inst bc :eq TRUE) - - ;; If both args are fixnums, we know the result is NIL. Otherwise, we - ;; have to hit the static fun. - (move temp x) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - (move temp y) - (inst nilz temp 3) - (inst bnc :eq DO-STATIC-FUN) - - (inst bx DONE) - (move res null-tn) - - DO-STATIC-FUN - (load-symbol cname 'two-arg-=) - (inst li nargs (fixnum 2)) - (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) - (move ocfp cfp-tn) - ;; Tail call TWO-ARG-=. - (inst bx lip) - (move cfp-tn csp-tn) - - TRUE - (load-symbol res t) - DONE) diff --git a/assembly/rt/array.lisp b/assembly/rt/array.lisp deleted file mode 100644 index da95439f0abebffac1cc934a904f3765c0c2835c..0000000000000000000000000000000000000000 --- a/assembly/rt/array.lisp +++ /dev/null @@ -1,124 +0,0 @@ -;;; -*- 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/array.lisp,v 1.4 1991/10/22 16:50:36 wlott Exp $ -;;; -;;; This file contains the support routines for arrays and vectors. -;;; -;;; Written by William Lott. -;;; - -(in-package "RT") - - -(define-assembly-routine (allocate-vector - (:policy :fast-safe) - (:translate allocate-vector) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) - ((:arg type any-reg a0-offset) - (:arg length any-reg a1-offset) - (:arg words any-reg a2-offset) - (:res result descriptor-reg a0-offset) - - (:temp ndescr non-descriptor-reg nl0-offset) - (:temp alloc word-pointer-reg ocfp-offset) - (:temp vector descriptor-reg cname-offset)) - (pseudo-atomic (ndescr) - (load-symbol-value alloc *allocation-pointer*) - (inst cal vector alloc vm:other-pointer-type) - (inst cal alloc alloc (+ (1- (ash 1 vm:lowtag-bits)) - (* vm:vector-data-offset vm:word-bytes))) - (inst cas alloc alloc words) - (inst li ndescr (lognot vm:lowtag-mask)) - (inst n alloc ndescr) - (move ndescr type) - (inst sr ndescr vm:word-shift) - (storew ndescr vector 0 vm:other-pointer-type) - (storew length vector vm:vector-length-slot vm:other-pointer-type) - (store-symbol-value alloc *allocation-pointer*)) - (load-symbol-value ndescr *internal-gc-trigger*) - (inst tlt ndescr alloc) - (move result vector)) - - - -;;;; Hash primitives - -(defparameter sxhash-simple-substring-entry (gen-label)) - -(define-assembly-routine (sxhash-simple-string - (:translate %sxhash-simple-string) - (:policy :fast-safe) - (:result-types positive-fixnum)) - ((:arg string descriptor-reg a0-offset) - (:res result any-reg a0-offset) - (:temp length any-reg a1-offset) - (:temp accum non-descriptor-reg nl0-offset) - (:temp data non-descriptor-reg nargs-offset) - (:temp temp non-descriptor-reg ocfp-offset)) - (declare (ignore result accum data temp)) - (inst bx sxhash-simple-substring-entry) - (loadw length string vm:vector-length-slot vm:other-pointer-type)) - - -(define-assembly-routine (sxhash-simple-substring - (:translate %sxhash-simple-substring) - (:policy :fast-safe) - (:arg-types * positive-fixnum) - (:result-types positive-fixnum)) - ((:arg string descriptor-reg a0-offset) - (:arg length any-reg a1-offset) - (:res result any-reg a0-offset) - (:temp accum non-descriptor-reg nl0-offset) - (:temp data non-descriptor-reg nargs-offset) - (:temp temp non-descriptor-reg ocfp-offset) - (:temp lip interior-reg lip-offset)) - (emit-label sxhash-simple-substring-entry) - ;; Get a stack slot to save the return-pc. - (inst inc csp-tn word-bytes) - ;; Save the return-pc as a byte offset from the component start, shifted - ;; left to look like a fixnum. - (inst s lip code-tn) - (inst sl lip 2) - (storew lip csp-tn (* -1 word-bytes)) - ;; Compute start of string as interior pointer. - (inst a lip string (- (* vector-data-offset word-bytes) other-pointer-type)) - (inst bx test) - (inst li accum 0) - LOOP - (inst x accum data) - (move temp accum) - (inst sl temp 27) - (inst sr accum 5) - (inst o accum temp) - (inst inc lip 4) - TEST - (inst s length (fixnum 4)) - (inst bncx :lt loop) - (loadw data lip) - (inst a length (fixnum 4)) - (inst bc :eq done) - (inst neg length) - (inst sl length 1) - (inst nilz length #x1f) - (inst sr data length) - (inst x accum data) - DONE - ;; Give it fixnum low-tag bits. - (inst sl accum 3) - (move result accum) - ;; Make it positive. - (inst sr result 1) - - (loadw lip csp-tn (* -1 word-bytes)) - (inst dec csp-tn word-bytes) - (inst sr lip 2) - (inst cas lip lip code-tn)) diff --git a/assembly/rt/assem-rtns.lisp b/assembly/rt/assem-rtns.lisp deleted file mode 100644 index 5b06012e337a4ac7c075041785b8f089ea6beda7..0000000000000000000000000000000000000000 --- a/assembly/rt/assem-rtns.lisp +++ /dev/null @@ -1,319 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/assem-rtns.lisp,v 1.5 1991/10/26 05:48:13 wlott Exp $ -;;; - -(in-package "RT") - - - -;;;; Non-local exit noise. - -(define-assembly-routine (unwind (:translate %continue-unwind) - (:return-style :none) - (:policy :fast-safe)) - ((:arg block (word-pointer-reg any-reg descriptor-reg) - a0-offset) - (:arg start (word-pointer-reg any-reg descriptor-reg) - ocfp-offset) - (:arg count (any-reg descriptor-reg) nargs-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp cur-uwp any-reg nl0-offset) - (:temp next-uwp any-reg cname-offset) - (:temp target-uwp any-reg lexenv-offset)) - (declare (ignore start count)) - - (let ((error (generate-error-code nil invalid-unwind-error))) - (inst c block 0) - (inst bc :eq error)) - - (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) - (loadw target-uwp block unwind-block-current-uwp-slot) - (inst c cur-uwp target-uwp) - (inst bnc :eq do-uwp) - - (move cur-uwp block) - - DO-EXIT - - (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) - (loadw code-tn cur-uwp unwind-block-current-code-slot) - (loadw lra cur-uwp unwind-block-entry-pc-slot) - (lisp-return lra lip :frob-code nil) - - DO-UWP - - (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) - (inst bx do-exit) - (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)) - -(define-assembly-routine (throw - (:return-style :none)) - ((:arg target descriptor-reg a0-offset) - (:arg start word-pointer-reg ocfp-offset) - (:arg count any-reg nargs-offset) - (:temp catch any-reg a1-offset) - (:temp tag descriptor-reg a2-offset) - (:temp ndescr non-descriptor-reg nl0-offset)) - - ;; These are needed by UNWIND, but not by us directly. - (declare (ignore start count)) - - (load-symbol-value catch lisp::*current-catch-block*) - - LOOP - - (let ((error (generate-error-code nil unseen-throw-tag-error target))) - (inst c catch 0) - (inst bc :eq error)) - - (loadw tag catch catch-block-tag-slot) - (inst c tag target) - (inst bc :eq exit) - (loadw catch catch catch-block-previous-catch-slot) - (inst b loop) - - EXIT - - (move target catch) - (inst cai ndescr (make-fixup 'unwind :assembly-routine)) - (inst b ndescr)) - - - -;;;; Return unknown multiple values (known not to be one value). - -(define-assembly-routine really-return-multiple - ((:arg ocfp any-reg nl0-offset) - (:arg lra descriptor-reg lra-offset) - ;; Pointer into cstack, so looks like fixnum. - (:arg src any-reg cname-offset) - (:arg nvals any-reg nargs-offset) - - (:temp lip interior-reg lip-offset) - (:temp count any-reg ocfp-offset) - ;; Pointer into cstack, so looks like fixnum. - (:temp dst any-reg lexenv-offset) - (:temp temp any-reg nfp-offset) - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset)) - ;; - ;; Load the register args, bailing out when we are done. - (inst c nvals 0) - (inst bc :eq default-a0-and-on) - (loadw a0 src 0) - (inst c nvals (fixnum 1)) - (inst bc :eq default-a1-and-on) - (loadw a1 src 1) - (inst c nvals (fixnum 2)) - (inst bc :eq default-a2-and-on) - (loadw a2 src 2) - ;; - ;; Copy the remaining args to the top of the stack. - (inst inc src (* word-bytes register-arg-count)) - (inst cal dst cfp-tn (* word-bytes register-arg-count)) - (inst s count nvals (fixnum 3)) - (inst bnc :gt done) - LOOP - (loadw temp src) - (inst inc src word-bytes) - (storew temp dst) - (inst inc dst word-bytes) - (inst s count (fixnum 1)) - (inst bc :gt loop) - (inst b done) - ;; - ;; Default some number of registers. - DEFAULT-A0-AND-ON - (move a0 null-tn) - DEFAULT-A1-AND-ON - (move a1 null-tn) - DEFAULT-A2-AND-ON - (move a2 null-tn) - ;; - ;; Clear the stack. - DONE - (move count cfp-tn) ;Put pointer to the start of values in ocfp. - (inst cas csp-tn nvals count) ;Adjust the stack top: <ptr-to-vals>+<nvals>. - (move cfp-tn ocfp) ;Restore returnee's fp. - ;; - ;; Return. - (lisp-return lra lip)) - - - -;;;; Copying more args on call (known to be at least one more arg.) - -;;; REALLY-COPY-MORE-ARGS -- Assembler Routine. -;;; -;;; This miscop has weird register usage conventions, since it is called at the -;;; very beginning of entry to a more-arg XEP. All of the registers used -;;; by the full call convention are in use, and must not be trashed, but none -;;; of the normal local & temporary registers are in use, since we haven't done -;;; anything yet. The number of fixed arguments is passed in a3, since we -;;; can't trash a0..a2. -;;; -;;; The VOP COPY-MORE-ARG has allocated some temporaries for us: a3, l0, l1. - -;;; The registers we can use are NL1, A3, L0 and L1. We save L2 and L3 to give -;;; us some more registers to work with. The caller saves the function return -;;; PC in L2 (the now unused NAME) so that it can be used for the miscop return -;;; PC. -;;; -;;; What we do is fairly simple: we copy the incoming more arguments (index >= -;;; a3) onto the top of the stack. The loop runs backwards, since we are -;;; copying args upward on the stack, and the source and destination can -;;; overlap. -;;; -;;; This loop terminates when we either run out of more args to copy or we run -;;; out of stack arguments. If we run out of stack arguments before we finish, -;;; then there are register more args. In this case, we dispatch off of the -;;; number of fixed arguments (A3) to determine how many argument registers to -;;; store. -;;; -(define-assembly-routine really-copy-more-args - ;; Fixedargs contains the number of fixed arguments. - ((:arg fixedargs any-reg cname-offset) - (:temp count/src any-reg nfp-offset) - (:temp ocsp any-reg nl0-offset) - ;; Temporaries to get my hands on argument registers. - (:temp a0 any-reg a0-offset) - (:temp a1 any-reg a1-offset) - (:temp a2 any-reg a2-offset) - ;; We save the contents of these registers before - ;; using them. - (:temp srcstart any-reg lexenv-offset) - (:temp dstend any-reg lra-offset) - (:temp temp any-reg ocfp-offset)) - ;; First, save count/src (the NFP) on the number stack. We need to do this - ;; instead of with the other saves, because we need to use this register to - ;; figure out where to save the others. We can't same them all there, - ;; because some of the others hold descriptor values. - (storew count/src nsp-tn -1) - ;; How many more args are there to copy to the stack? - (move count/src nargs-tn) - (inst s count/src fixedargs) - ;; Save the current stack top as the start of the more args. - (move ocsp csp-tn) - ;; Bump the stack by the number of more args. - (inst cas csp-tn csp-tn count/src) - ;; Bump the stack three for the registers we have to save. - (inst cal csp-tn csp-tn (* 3 word-bytes)) - - ;; Dump the registers to make room for the temporaries we need. - (storew srcstart csp-tn -3) - (storew dstend csp-tn -2) - (storew temp csp-tn -1) - - ;; Compute the source start, but remember we are copying from the end. - ;; The start location is the last one we copy. - (inst cal srcstart cfp-tn (* register-arg-count word-bytes)) - ;; Compute the source location of the last more arg. - (inst cas count/src nargs-tn cfp-tn) - (inst dec count/src word-bytes) ;not an exclusive end. - ;; Compute destination end, which is the stack pointer minus three register - ;; slots we saved and minus one to make it an inclusive end. - (inst cal dstend csp-tn (* -4 word-bytes)) - - ;; Copy some args. - (inst b cma-test) - CMA-LOOP - (loadw temp count/src) - (storew temp dstend) - (inst dec count/src word-bytes) - (inst dec dstend word-bytes) - CMA-TEST - ;; Are we totally done? - (inst c dstend ocsp) - (inst bc :lt CMA-DONE) - ;; Are we done copying stack more args? - (inst c count/src srcstart) - (inst bnc :lt CMA-LOOP) - - ;; Figure out which argument registers may be more args. - (inst c fixedargs (fixnum 2)) - (inst bc :eq two-fixed-args) - (inst c fixedargs (fixnum 1)) - (inst bc :eq one-fixed-arg) - - ;; Copy register more args being careful to stop before running out of args. - (storew a0 ocsp) - (inst c nargs-tn (fixnum 1)) - (inst bc :eq CMA-DONE) - (inst inc ocsp word-bytes) - ONE-FIXED-ARG - (storew a1 ocsp) - (inst c nargs-tn (fixnum 2)) - (inst bc :eq CMA-DONE) - (inst inc ocsp word-bytes) - TWO-FIXED-ARGS - (storew a2 ocsp) - - ;; Restore registers we dumped. - CMA-DONE - (loadw srcstart csp-tn -3) - (loadw dstend csp-tn -2) - (loadw temp csp-tn -1) - (inst dec csp-tn (* 3 word-bytes)) - (loadw count/src nsp-tn -1) - (inst b lip-tn)) - - - -;;;; Tail call variable. - -(define-assembly-routine (really-tail-call-variable (:return-style :none)) - ;; These are really args. - ((:temp args any-reg nl0-offset) - ;; These are needed by the blitting code. - (:temp count any-reg lra-offset) - (:temp dst any-reg lexenv-offset) - (:temp nargs any-reg nargs-offset) - (:temp temp descriptor-reg cname-offset) - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset)) - ;; Calculate NARGS (as a fixnum). - (move nargs csp-tn) - (inst s nargs args) - ;; Load the argument registers now because the argument moving might trash - ;; these locations. - (loadw a0 args 0) - (loadw a1 args 1) - (loadw a2 args 2) - ;; Are we done? - (inst c nargs (fixnum register-arg-count)) - (inst bnc :gt done) - ;; Calc DST and COUNT after saving those registers. - (inst inc csp-tn (* word-bytes 2)) - (storew count csp-tn -1) - (storew dst csp-tn -2) - (inst a count nargs (fixnum (- register-arg-count))) - (inst a args (* vm:word-bytes register-arg-count)) - (inst a dst cfp-tn (* vm:word-bytes register-arg-count)) - LOOP - ;; Copy one arg. - (loadw temp args) - (inst inc args vm:word-bytes) - (storew temp dst) - (inst s count (fixnum 1)) - (inst bcx :gt loop) - (inst inc dst vm:word-bytes) - ;; Restore - (loadw count csp-tn -1) - (loadw dst csp-tn -2) - (inst dec csp-tn (* word-bytes 2)) - DONE - ;; We are done. Do the jump. - (loadw temp dst vm:closure-function-slot vm:function-pointer-type) - (lisp-jump temp lip-tn)) diff --git a/assembly/rt/support.lisp b/assembly/rt/support.lisp deleted file mode 100644 index 1cc9de630b54baa2acd0da091ded880bc0a6219c..0000000000000000000000000000000000000000 --- a/assembly/rt/support.lisp +++ /dev/null @@ -1,65 +0,0 @@ -;;; -*- 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/rt/support.lisp,v 1.2 1991/04/22 10:13:28 chiles Exp $ -;;; -;;; This file contains the machine specific support routines needed by -;;; the file assembler. -;;; - -(in-package "RT") - -(def-vm-support-routine generate-call-sequence (name style vop) - (ecase style - (:raw - (values - `((inst bala (make-fixup ',name :assembly-routine))) - nil)) - (:full-call - (let ((nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) - (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn cur-nfp ,nfp-save)) - (inst compute-lra-from-code ,lra code-tn lra-label) - ;; This absolute branch trashes the LIP register, but we don't use - ;; it when calling assembly routines. - (inst bala (make-fixup ',name :assembly-routine)) - (emit-return-pc lra-label) - (note-this-location ,vop :unknown-return) - ;; Don't use MOVE. Use a known 32-bit long instruction, so the - ;; returner can know how many bytes we used here in the - ;; multiple-value return case. The returner wants to add a known - ;; quantity to LRA indicating how many values it returned. - (inst cal csp-tn ocfp-tn 0) - (inst compute-code-from-lra code-tn code-tn lra-label) - (when cur-nfp - (load-stack-tn cur-nfp ,nfp-save)))) - `((:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save))))) - (:none - (values - ;; This absolute branch trashes the LIP register, but we don't use it - ;; when calling assembly routines. - `((inst bala (make-fixup ',name :assembly-routine))) - nil)))) - - -(def-vm-support-routine generate-return-sequence (style) - (ecase style - (:raw - `((inst b lip-tn))) - (:full-call - `((lisp-return lra-tn lip-tn :offset 1))) - (:none))) diff --git a/assembly/sparc/alloc.lisp b/assembly/sparc/alloc.lisp deleted file mode 100644 index 7f461e625863c0df4ff8832c8496e387b09a00e5..0000000000000000000000000000000000000000 --- a/assembly/sparc/alloc.lisp +++ /dev/null @@ -1,21 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/sparc/alloc.lisp,v 1.4 1992/12/13 15:24:14 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to handle allocating simple objects. -;;; -;;; Written by William Lott. -;;; - -(in-package "SPARC") - -;;; But we do everything inline now that we have a better pseudo-atomic. diff --git a/assembly/sparc/arith.lisp b/assembly/sparc/arith.lisp deleted file mode 100644 index 205e4f439b8139c5b087e8f2b5605f3878dccac3..0000000000000000000000000000000000000000 --- a/assembly/sparc/arith.lisp +++ /dev/null @@ -1,512 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/sparc/arith.lisp,v 1.11 1992/12/17 09:45:50 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to handle simple cases for generic arithmetic. -;;; -;;; Written by William Lott. -;;; - -(in-package "SPARC") - - - -;;;; Addition and subtraction. - -(define-assembly-routine (generic-+ - (:cost 10) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp2 non-descriptor-reg nl1-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst andcc zero-tn x 3) - (inst b :ne DO-STATIC-FUN) - (inst andcc zero-tn y 3) - (inst b :ne DO-STATIC-FUN) - (inst nop) - (inst addcc temp x y) - (inst b :vc done) - (inst nop) - - (inst sra temp x 2) - (inst sra temp2 y 2) - (inst add temp2 temp) - (with-fixed-allocation (res temp bignum-type (1+ bignum-digits-offset)) - (storew temp2 res bignum-digits-offset other-pointer-type)) - (lisp-return lra :offset 2) - - DO-STATIC-FUN - (inst ld code-tn null-tn (static-function-offset 'two-arg-+)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (inst move cfp-tn csp-tn) - - DONE - (move res temp)) - - -(define-assembly-routine (generic-- - (:cost 10) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp2 non-descriptor-reg nl1-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst andcc zero-tn x 3) - (inst b :ne DO-STATIC-FUN) - (inst andcc zero-tn y 3) - (inst b :ne DO-STATIC-FUN) - (inst nop) - (inst subcc temp x y) - (inst b :vc done) - (inst nop) - - (inst sra temp x 2) - (inst sra temp2 y 2) - (inst sub temp2 temp temp2) - (with-fixed-allocation (res temp bignum-type (1+ bignum-digits-offset)) - (storew temp2 res bignum-digits-offset other-pointer-type)) - (lisp-return lra :offset 2) - - DO-STATIC-FUN - (inst ld code-tn null-tn (static-function-offset 'two-arg--)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (inst move cfp-tn csp-tn) - - DONE - (move res temp)) - - - -;;;; Multiplication - - -(define-assembly-routine (generic-* - (:cost 50) - (:return-style :full-call) - (:translate *) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lo non-descriptor-reg nl1-offset) - (:temp hi non-descriptor-reg nl2-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - ;; If either arg is not a fixnum, call the static function. - (inst andcc zero-tn x 3) - (inst b :ne DO-STATIC-FUN) - (inst andcc zero-tn y 3) - (inst b :ne DO-STATIC-FUN) - (inst nop) - - ;; Remove the tag from one arg so that the result will have the correct - ;; fixnum tag. - (inst sra temp x 2) - (inst wry temp) - (inst andcc hi zero-tn) - (inst nop) - (inst nop) - (dotimes (i 32) - (inst mulscc hi y)) - (inst mulscc hi zero-tn) - (inst cmp x) - (inst b :ge MULTIPLIER-POSITIVE) - (inst nop) - (inst sub hi y) - MULTIPLIER-POSITIVE - (inst rdy lo) - - ;; Check to see if the result will fit in a fixnum. (I.e. the high word - ;; is just 32 copies of the sign bit of the low word). - (inst sra temp lo 31) - (inst xorcc temp hi) - (inst b :eq LOW-FITS-IN-FIXNUM) - ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag. - (inst sll temp hi 30) - (inst srl lo 2) - (inst or lo temp) - (inst sra hi 2) - ;; Allocate a BIGNUM for the result. - (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset))) - (let ((one-word (gen-label))) - (inst or res alloc-tn other-pointer-type) - ;; We start out assuming that we need one word. Is that correct? - (inst sra temp lo 31) - (inst xorcc temp hi) - (inst b :eq one-word) - (inst li temp (logior (ash 1 type-bits) bignum-type)) - ;; Nope, we need two, so allocate the addition space. - (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset)) - (pad-data-block (1+ bignum-digits-offset)))) - (inst li temp (logior (ash 2 type-bits) bignum-type)) - (storew hi res (1+ bignum-digits-offset) other-pointer-type) - (emit-label one-word) - (storew temp res 0 other-pointer-type) - (storew lo res bignum-digits-offset other-pointer-type))) - ;; Out of here - (lisp-return lra :offset 2) - - DO-STATIC-FUN - (inst ld code-tn null-tn (static-function-offset 'two-arg-*)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (inst move cfp-tn csp-tn) - - LOW-FITS-IN-FIXNUM - (move res lo)) - -(macrolet - ((frob (name note cost type sc) - `(define-assembly-routine (,name - (:note ,note) - (:cost ,cost) - (:translate *) - (:policy :fast-safe) - (:arg-types ,type ,type) - (:result-types ,type)) - ((:arg x ,sc nl0-offset) - (:arg y ,sc nl1-offset) - (:res res ,sc nl0-offset) - (:temp temp ,sc nl2-offset)) - ,@(when (eq type 'tagged-num) - `((inst sra x 2))) - (inst wry x) - (inst andcc temp zero-tn) - (inst nop) - (inst nop) - (dotimes (i 32) - (inst mulscc temp y)) - (inst mulscc temp zero-tn) - (inst rdy res)))) - (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg) - (frob signed-* "unsigned *" 41 signed-num signed-reg) - (frob fixnum-* "fixnum *" 30 tagged-num any-reg)) - - - -;;;; Division. - -#+assembler -(defun emit-divide-loop (divisor rem quo tagged) - (inst li quo 0) - (labels - ((do-loop (depth) - (cond - ((zerop depth) - (inst unimp 0)) - (t - (let ((label-1 (gen-label)) - (label-2 (gen-label))) - (inst cmp divisor rem) - (inst b :geu label-1) - (inst nop) - (inst sll divisor 1) - (do-loop (1- depth)) - (inst srl divisor 1) - (inst cmp divisor rem) - (emit-label label-1) - (inst b :gtu label-2) - (inst sll quo 1) - (inst add quo (if tagged (fixnum 1) 1)) - (inst sub rem divisor) - (emit-label label-2)))))) - (do-loop (if tagged 30 32)))) - -(define-assembly-routine (positive-fixnum-truncate - (:note "unsigned fixnum truncate") - (:cost 45) - (:translate truncate) - (:policy :fast-safe) - (:arg-types positive-fixnum positive-fixnum) - (:result-types positive-fixnum positive-fixnum)) - ((:arg dividend any-reg nl0-offset) - (:arg divisor any-reg nl1-offset) - - (:res quo any-reg nl2-offset) - (:res rem any-reg nl0-offset)) - - (move rem dividend) - (emit-divide-loop divisor rem quo t)) - - -(define-assembly-routine (fixnum-truncate - (:note "fixnum truncate") - (:cost 50) - (:policy :fast-safe) - (:translate truncate) - (:arg-types tagged-num tagged-num) - (:result-types tagged-num tagged-num)) - ((:arg dividend any-reg nl0-offset) - (:arg divisor any-reg nl1-offset) - - (:res quo any-reg nl2-offset) - (:res rem any-reg nl0-offset) - - (:temp quo-sign any-reg nl5-offset) - (:temp rem-sign any-reg nargs-offset)) - - (inst xor quo-sign dividend divisor) - (inst move rem-sign dividend) - (let ((label (gen-label))) - (inst cmp dividend) - (inst ba :lt label) - (inst neg dividend) - (emit-label label)) - (let ((label (gen-label))) - (inst cmp divisor) - (inst ba :lt label) - (inst neg divisor) - (emit-label label)) - (move rem dividend) - (emit-divide-loop divisor rem quo t) - (let ((label (gen-label))) - ;; If the quo-sign is negative, we need to negate quo. - (inst cmp quo-sign) - (inst ba :lt label) - (inst neg quo) - (emit-label label)) - (let ((label (gen-label))) - ;; If the rem-sign is negative, we need to negate rem. - (inst cmp rem-sign) - (inst ba :lt label) - (inst neg rem) - (emit-label label))) - - -(define-assembly-routine (signed-truncate - (:note "(signed-byte 32) truncate") - (:cost 60) - (:policy :fast-safe) - (:translate truncate) - (:arg-types signed-num signed-num) - (:result-types signed-num signed-num)) - - ((:arg dividend signed-reg nl0-offset) - (:arg divisor signed-reg nl1-offset) - - (:res quo signed-reg nl2-offset) - (:res rem signed-reg nl0-offset) - - (:temp quo-sign signed-reg nl5-offset) - (:temp rem-sign signed-reg nargs-offset)) - - (inst xor quo-sign dividend divisor) - (inst move rem-sign dividend) - (let ((label (gen-label))) - (inst cmp dividend) - (inst ba :lt label) - (inst neg dividend) - (emit-label label)) - (let ((label (gen-label))) - (inst cmp divisor) - (inst ba :lt label) - (inst neg divisor) - (emit-label label)) - (move rem dividend) - (emit-divide-loop divisor rem quo nil) - (let ((label (gen-label))) - ;; If the quo-sign is negative, we need to negate quo. - (inst cmp quo-sign) - (inst ba :lt label) - (inst neg quo) - (emit-label label)) - (let ((label (gen-label))) - ;; If the rem-sign is negative, we need to negate rem. - (inst cmp rem-sign) - (inst ba :lt label) - (inst neg rem) - (emit-label label))) - - -;;;; Comparison - -(macrolet - ((define-cond-assem-rtn (name translate static-fn cmp) - `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst andcc zero-tn x 3) - (inst b :ne DO-STATIC-FN) - (inst andcc zero-tn y 3) - (inst b :eq DO-COMPARE) - (inst cmp x y) - - DO-STATIC-FN - (inst ld code-tn null-tn (static-function-offset ',static-fn)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (inst move cfp-tn csp-tn) - - DO-COMPARE - (inst b ,cmp done) - (load-symbol res t) - (inst move res null-tn) - DONE))) - - (define-cond-assem-rtn generic-< < two-arg-< :lt) - (define-cond-assem-rtn generic-<= <= two-arg-<= :le) - (define-cond-assem-rtn generic-> > two-arg-> :gt) - (define-cond-assem-rtn generic->= >= two-arg->= :ge)) - - -(define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst cmp x y) - (inst b :eq RETURN-T) - (inst andcc zero-tn x 3) - (inst b :eq RETURN-NIL) - (inst andcc zero-tn y 3) - (inst b :ne DO-STATIC-FN) - (inst nop) - - RETURN-NIL - (inst move res null-tn) - (lisp-return lra :offset 2) - - DO-STATIC-FN - (inst ld code-tn null-tn (static-function-offset 'eql)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (inst move cfp-tn csp-tn) - - RETURN-T - (load-symbol res t)) - -(define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst cmp x y) - (inst b :eq RETURN-T) - (inst andcc zero-tn x 3) - (inst b :ne DO-STATIC-FN) - (inst andcc zero-tn y 3) - (inst b :ne DO-STATIC-FN) - (inst nop) - - (inst move res null-tn) - (lisp-return lra :offset 2) - - DO-STATIC-FN - (inst ld code-tn null-tn (static-function-offset 'two-arg-=)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (inst move cfp-tn csp-tn) - - RETURN-T - (load-symbol res t)) - -(define-assembly-routine (generic-/= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate /=) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst cmp x y) - (inst b :eq RETURN-NIL) - (inst andcc zero-tn x 3) - (inst b :ne DO-STATIC-FN) - (inst andcc zero-tn y 3) - (inst b :ne DO-STATIC-FN) - (inst nop) - - (load-symbol res t) - (lisp-return lra :offset 2) - - DO-STATIC-FN - (inst ld code-tn null-tn (static-function-offset 'two-arg-=)) - (inst li nargs (fixnum 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* function-code-offset word-bytes) function-pointer-type)) - (inst move cfp-tn csp-tn) - - RETURN-NIL - (inst move res null-tn)) diff --git a/assembly/sparc/array.lisp b/assembly/sparc/array.lisp deleted file mode 100644 index 69a0513b2d321ca184e683d4213321e928dba3ce..0000000000000000000000000000000000000000 --- a/assembly/sparc/array.lisp +++ /dev/null @@ -1,111 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.3 1992/03/11 21:41:02 wlott Exp $ -;;; -;;; This file contains the support routines for arrays and vectors. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") - - -(define-assembly-routine (allocate-vector - (:policy :fast-safe) - (:translate allocate-vector) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) - ((:arg type any-reg a0-offset) - (:arg length any-reg a1-offset) - (:arg words any-reg a2-offset) - (:res result descriptor-reg a0-offset) - - (:temp ndescr non-descriptor-reg nl0-offset) - (:temp vector descriptor-reg a3-offset)) - (pseudo-atomic () - (inst or vector alloc-tn vm:other-pointer-type) - (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes)) - (inst andn ndescr 7) - (inst add alloc-tn ndescr) - (inst srl ndescr type vm:word-shift) - (storew ndescr vector 0 vm:other-pointer-type) - (storew length vector vm:vector-length-slot vm:other-pointer-type)) - (move result vector)) - - - -;;;; Hash primitives - -#+assembler -(defparameter sxhash-simple-substring-entry (gen-label)) - -(define-assembly-routine (sxhash-simple-string - (:translate %sxhash-simple-string) - (:policy :fast-safe) - (:result-types positive-fixnum)) - ((:arg string descriptor-reg a0-offset) - (:res result any-reg a0-offset) - - (:temp length any-reg a1-offset) - (:temp accum non-descriptor-reg nl0-offset) - (:temp data non-descriptor-reg nl1-offset) - (:temp temp non-descriptor-reg nl2-offset) - (:temp offset non-descriptor-reg nl3-offset)) - - (declare (ignore result accum data temp offset)) - - (inst b sxhash-simple-substring-entry) - (loadw length string vm:vector-length-slot vm:other-pointer-type)) - - -(define-assembly-routine (sxhash-simple-substring - (:translate %sxhash-simple-substring) - (:policy :fast-safe) - (:arg-types * positive-fixnum) - (:result-types positive-fixnum)) - ((:arg string descriptor-reg a0-offset) - (:arg length any-reg a1-offset) - (:res result any-reg a0-offset) - - (:temp accum non-descriptor-reg nl0-offset) - (:temp data non-descriptor-reg nl1-offset) - (:temp temp non-descriptor-reg nl2-offset) - (:temp offset non-descriptor-reg nl3-offset)) - (emit-label sxhash-simple-substring-entry) - - (inst li offset (- (* vector-data-offset word-bytes) other-pointer-type)) - (inst b test) - (move accum zero-tn) - - LOOP - - (inst xor accum data) - (inst sll temp accum 27) - (inst srl accum 5) - (inst or accum temp) - (inst add offset 4) - - TEST - - (inst subcc length (fixnum 4)) - (inst b :ge loop) - (inst ld data string offset) - - (inst addcc length (fixnum 4)) - (inst b :eq done) - (inst neg length) - (inst sll length 1) - (inst srl data length) - (inst xor accum data) - - DONE - - (inst sll result accum 5) - (inst srl result result 3)) diff --git a/assembly/sparc/assem-rtns.lisp b/assembly/sparc/assem-rtns.lisp deleted file mode 100644 index 32b1afd2697a2a4d28d1bd9f3d682ebdb7076e5a..0000000000000000000000000000000000000000 --- a/assembly/sparc/assem-rtns.lisp +++ /dev/null @@ -1,242 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/assem-rtns.lisp,v 1.1 1990/11/22 11:51:05 wlott Exp $ -;;; -;;; -(in-package "SPARC") - - -;;;; Return-multiple with other than one value - -#+assembler ;; we don't want a vop for this one. -(define-assembly-routine - (return-multiple - (:return-style :none)) - - ;; These four are really arguments. - ((:temp nvals any-reg nargs-offset) - (:temp vals any-reg nl0-offset) - (:temp ocfp any-reg nl1-offset) - (:temp lra descriptor-reg lra-offset) - - ;; These are just needed to facilitate the transfer - (:temp count any-reg nl2-offset) - (:temp src any-reg nl3-offset) - (:temp dst any-reg nl4-offset) - (:temp temp descriptor-reg l0-offset) - - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset) - (:temp a4 descriptor-reg a4-offset) - (:temp a5 descriptor-reg a5-offset)) - - ;; Note, because of the way the return-multiple vop is written, we can - ;; assume that we are never called with nvals == 1 and that a0 has already - ;; been loaded. - (inst cmp nvals) - (inst b :le default-a0-and-on) - (inst cmp nvals (fixnum 2)) - (inst b :le default-a2-and-on) - (inst ld a1 vals (* 1 vm:word-bytes)) - (inst cmp nvals (fixnum 3)) - (inst b :le default-a3-and-on) - (inst ld a2 vals (* 2 vm:word-bytes)) - (inst cmp nvals (fixnum 4)) - (inst b :le default-a4-and-on) - (inst ld a3 vals (* 3 vm:word-bytes)) - (inst cmp nvals (fixnum 5)) - (inst b :le default-a5-and-on) - (inst ld a4 vals (* 4 vm:word-bytes)) - (inst cmp nvals (fixnum 6)) - (inst b :le done) - (inst ld a5 vals (* 5 vm:word-bytes)) - - ;; Copy the remaining args to the top of the stack. - (inst add src vals (* 6 vm:word-bytes)) - (inst add dst cfp-tn (* 6 vm:word-bytes)) - (inst subcc count nvals (fixnum 6)) - - LOOP - (inst ld temp src) - (inst add src vm:word-bytes) - (inst st temp dst) - (inst add dst vm:word-bytes) - (inst b :gt loop) - (inst subcc count (fixnum 1)) - - (inst b done) - (inst nop) - - DEFAULT-A0-AND-ON - (inst move a0 null-tn) - (inst move a1 null-tn) - DEFAULT-A2-AND-ON - (inst move a2 null-tn) - DEFAULT-A3-AND-ON - (inst move a3 null-tn) - DEFAULT-A4-AND-ON - (inst move a4 null-tn) - DEFAULT-A5-AND-ON - (inst move a5 null-tn) - DONE - - ;; Clear the stack. - (move ocfp-tn cfp-tn) - (move cfp-tn ocfp) - (inst add csp-tn ocfp-tn nvals) - - ;; Return. - (lisp-return lra)) - - - -;;;; tail-call-variable. - -#+assembler ;; no vop for this one either. -(define-assembly-routine - (tail-call-variable - (:return-style :none)) - - ;; These are really args. - ((:temp args any-reg nl0-offset) - (:temp lexenv descriptor-reg lexenv-offset) - - ;; We need to compute this - (:temp nargs any-reg nargs-offset) - - ;; These are needed by the blitting code. - (:temp src any-reg nl1-offset) - (:temp dst any-reg nl2-offset) - (:temp count any-reg nl3-offset) - (:temp temp descriptor-reg l0-offset) - - ;; These are needed so we can get at the register args. - (:temp a0 descriptor-reg a0-offset) - (:temp a1 descriptor-reg a1-offset) - (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset) - (:temp a4 descriptor-reg a4-offset) - (:temp a5 descriptor-reg a5-offset)) - - - ;; Calculate NARGS (as a fixnum) - (inst sub nargs csp-tn args) - - ;; Load the argument regs (must do this now, 'cause the blt might - ;; trash these locations) - (inst ld a0 args (* 0 vm:word-bytes)) - (inst ld a1 args (* 1 vm:word-bytes)) - (inst ld a2 args (* 2 vm:word-bytes)) - (inst ld a3 args (* 3 vm:word-bytes)) - (inst ld a4 args (* 4 vm:word-bytes)) - (inst ld a5 args (* 5 vm:word-bytes)) - - ;; Calc SRC, DST, and COUNT - (inst addcc count nargs (fixnum (- register-arg-count))) - (inst b :le done) - (inst add src args (* vm:word-bytes register-arg-count)) - (inst add dst cfp-tn (* vm:word-bytes register-arg-count)) - - LOOP - ;; Copy one arg. - (inst ld temp src) - (inst add src src vm:word-bytes) - (inst st temp dst) - (inst addcc count (fixnum -1)) - (inst b :gt loop) - (inst add dst dst vm:word-bytes) - - DONE - ;; We are done. Do the jump. - (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type) - (lisp-jump temp)) - - - -;;;; Non-local exit noise. - -(define-assembly-routine (unwind - (:return-style :none) - (:translate %continue-unwind) - (:policy :fast-safe)) - ((:arg block (any-reg descriptor-reg) a0-offset) - (:arg start (any-reg descriptor-reg) ocfp-offset) - (:arg count (any-reg descriptor-reg) nargs-offset) - (:temp lra descriptor-reg lra-offset) - (:temp cur-uwp any-reg nl0-offset) - (:temp next-uwp any-reg nl1-offset) - (:temp target-uwp any-reg nl2-offset)) - (declare (ignore start count)) - - (let ((error (generate-error-code nil invalid-unwind-error))) - (inst cmp block) - (inst b :eq error)) - - (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) - (loadw target-uwp block vm:unwind-block-current-uwp-slot) - (inst cmp cur-uwp target-uwp) - (inst b :ne do-uwp) - (inst nop) - - (move cur-uwp block) - - DO-EXIT - - (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot) - (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) - (loadw lra cur-uwp vm:unwind-block-entry-pc-slot) - (lisp-return lra :frob-code nil) - - DO-UWP - - (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot) - (inst b do-exit) - (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)) - - -(define-assembly-routine (throw - (:return-style :none)) - ((:arg target descriptor-reg a0-offset) - (:arg start any-reg ocfp-offset) - (:arg count any-reg nargs-offset) - (:temp catch any-reg a1-offset) - (:temp tag descriptor-reg a2-offset) - (:temp temp non-descriptor-reg nl0-offset)) - - (declare (ignore start count)) - - (load-symbol-value catch lisp::*current-catch-block*) - - loop - - (let ((error (generate-error-code nil unseen-throw-tag-error target))) - (inst cmp catch) - (inst b :eq error) - (inst nop)) - - (loadw tag catch vm:catch-block-tag-slot) - (inst cmp tag target) - (inst b :eq exit) - (inst nop) - (loadw catch catch vm:catch-block-previous-catch-slot) - (inst b loop) - (inst nop) - - exit - - (move target catch) - (inst li temp (make-fixup 'unwind :assembly-routine)) - (inst j temp) - (inst nop)) - - diff --git a/assembly/sparc/support.lisp b/assembly/sparc/support.lisp deleted file mode 100644 index 372dfe55b0e62e78cae9ec63e1050afe701e0166..0000000000000000000000000000000000000000 --- a/assembly/sparc/support.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/assembly/sparc/support.lisp,v 1.7 1992/07/31 21:55:12 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -(in-package "SPARC") - -(def-vm-support-routine generate-call-sequence (name style vop) - (ecase style - (:raw - (let ((temp (make-symbol "TEMP")) - (lip (make-symbol "LIP"))) - (values - `((inst jali ,lip ,temp (make-fixup ',name :assembly-routine)) - (inst nop)) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:scs (interior-reg) :from (:eval 0) :to (:eval 1)) - ,lip))))) - (:full-call - (let ((temp (make-symbol "TEMP")) - (nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) - (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn ,nfp-save cur-nfp)) - (inst compute-lra-from-code ,lra code-tn lra-label ,temp) - (note-next-instruction ,vop :call-site) - (inst ji ,temp (make-fixup ',name :assembly-routine)) - (inst nop) - (emit-return-pc lra-label) - (note-this-location ,vop :single-value-return) - (without-scheduling () - (move csp-tn ocfp-tn) - (inst nop)) - (inst compute-code-from-lra code-tn code-tn - lra-label ,temp) - (when cur-nfp - (load-stack-tn cur-nfp ,nfp-save)))) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save) - (:save-p :compute-only))))) - (:none - (let ((temp (make-symbol "TEMP"))) - (values - `((inst ji ,temp (make-fixup ',name :assembly-routine)) - (inst nop)) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp))))))) - -(def-vm-support-routine generate-return-sequence (style) - (ecase style - (:raw - `((inst j - (make-random-tn :kind :normal - :sc (sc-or-lose 'interior-reg *backend*) - :offset lip-offset) - 8) - (inst nop))) - (:full-call - `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg *backend*) - :offset lra-offset) - :offset 2))) - (:none))) diff --git a/benchmarks/cascor1.lisp b/benchmarks/cascor1.lisp deleted file mode 100644 index 02e38795512418a32bafd74547a4287274f6e294..0000000000000000000000000000000000000000 --- a/benchmarks/cascor1.lisp +++ /dev/null @@ -1,1470 +0,0 @@ -;;; -*- Mode: Lisp; Package: User -*- -;;; *************************************************************************** -;;; Common Lisp implementation of Cascade-Correlation learning algorithm. -;;; This version for export. Non-portable user-interface stuff excised. -;;; -;;; Written by: Scott E. Fahlman -;;; School of Computer Science -;;; Carnegie-Mellon University -;;; Pittsburgh, PA 15217 -;;; -;;; Phone: (412) 268-2575 -;;; Internet: fahlman@cs.cmu.edu -;;; -;;; This code has been placed in the public domain by the author. As a -;;; matter of simple courtesy, anyone using or adapting this code is -;;; expected to acknowledge the source. The author would like to hear -;;; about any attempts to use this system, successful or not. -;;; -;;; For an explanation of this algorithm and some results, see "The -;;; Cascade-Correlation Learning Architecture" by Scott E. Fahlman and -;;; Christian Lebiere in D. S. Touretzky (ed.), "Advances in Neural -;;; Information Processing Systems 2", Morgan Kaufmann, 1990. A somewhat -;;; longer version is available as CMU Computer Science Tech Report -;;; CMU-CS-90-100. -;;; -;;; *************************************************************************** -;;; EDIT HISTORY SINCE FIRST RELEASE: -;;; -;;; 8/24/90: -;;; Modified TEST-EPOCH so that it wouldn't mess up error statistics being -;;; passed from the output-training to input-training phase. Thanks to -;;; Scott Crowder for spotting this. -;;; -;;; 6/1/90: -;;; Fixed bug in INSTALL-NEW-UNIT. New unit's initial weight was being -;;; computed using *CAND-COR* values of the successful candidate, which is -;;; already zero. Now uses *CAND-PREV-COR*. Thanks to Tim Howells for -;;; spotting this. -;;; -;;; Modify BUILD-NET to check that *MAX-UNITS* is large enough. A couple of -;;; people got mysterious failures the first time they used lots of inputs. -;;; -;;; Made a small change in QUICKPROP-UPDATE to prevent rare divide-by-zero -;;; errors when p = s = 0.0. Thanks to Tom Dietterich. -;;; -;;; Added CHANGED-TRAINING-SET, which should be called when the training set -;;; is changed but you don't want to reinitialize the net. This rebuilds -;;; the caches. -;;; -;;; 11/9/90: -;;; Added some additional type declarations for maximum speed under certain -;;; Common Lisp compilers. -;;; *************************************************************************** -;;; -(in-package "USER") - -;;; This proclamation buys a certain amount of overall speed at the expense -;;; of runtime checking. Comment it out when debugging new, bug-infested code. -;;; -#+declare-unsafe -(proclaim '(optimize (speed 3) (space 0) (safety 0))) - -;;; Style note: Because some of these runs take a long time, this code is -;;; extensively hacked for good performance under a couple of Common Lisp -;;; systems, some of which have poor performance on multi-dimensional -;;; arrays and some of which have weak type-inference in the compiler. -;;; Elegance and clarity have in some cases been sacrificed for speed. - -;;; In some problems, floating point underflow errors may occur as a result -;;; of weight-decay and other operations. Most Common Lisp implementations -;;; have an option to turn floating underflows into zero values without -;;; signalling an error. You should enable this facility if it is -;;; available. If not, you'll either have to write a condition handler for -;;; floating underflows or live with the occasional underflow error. - -;;; In CMU Common Lisp, we use the following incantation: -;;; (setq extensions:*ignore-floating-point-underflow* t) - - -;;; Compensate for the clumsy Common Lisp declaration system and weak -;;; type-inference in some Common Lisp compilers. - -;;; INCF-SF, *SF, etc. are like INCF, *, etc., but they declare their -;;; operands and results to be short-floats. The code gets unreadable -;;; quickly if you insert all these declarations by hand. - -(defmacro incf-sf (place &optional (increment 1.0)) - `(the short-float (incf (the short-float ,place) - (the short-float ,increment)))) - -(defmacro decf-sf (place &optional (increment 1.0)) - `(the short-float (decf (the short-float ,place) - (the short-float ,increment)))) - -(defmacro *sf (&rest args) - `(the short-float - (* ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args)))) - -(defmacro +sf (&rest args) - `(the short-float - (+ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args)))) - -(defmacro -sf (&rest args) - `(the short-float - (- ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args)))) - -(defmacro /sf (&rest args) - `(the short-float - (/ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args)))) - -;;; DOTIMES1 is like DOTIMES, only with the loop counter declared as a -;;; fixnum. This is for compilers with weak type inference. - -(defmacro dotimes1 (form1 &body body) - `(dotimes ,form1 (declare (fixnum ,(car form1))) . ,body)) - -;;; Create vector-access forms similar to SVREF, but for vectors of -;;; element-type SHORT-FLOAT and FIXNUM. - -(eval-when (compile load eval) - (defconstant fvector-type - (array-element-type (make-array '(1) :element-type 'short-float))) - (defconstant ivector-type - (array-element-type (make-array '(1) :element-type 'fixnum)))) - -(defmacro fvref (a i) - "Like SVREF, but with vectors of element-type SHORT-FLOAT." - (if (eq fvector-type t) - `(the short-float (svref ,a ,i)) - `(the short-float - (aref (the (simple-array ,fvector-type (*)) ,a) ,i)))) - -(defmacro ivref (a i) - "Like SVREF, but with vectors of element-type FIXNUM." - (if (eq ivector-type t) - `(the fixnum (svref ,a ,i)) - `(the fixnum - (aref (the (simple-array ,ivector-type (*)) ,a) ,i)))) - - -;;;; Assorted Parameters and Controls. - -;;; Thse parameters and switches control the quickprop learning algorithm -;;; used to train the output weights and candidate units. - -(defvar *unit-type* :sigmoid - "The type of activation function used by the hidden units. Options - currently implemented are :sigmoid, :asigmoid, and :gaussian. Sigmoid is - symmetric in range -0.5 to +0.5, while Asigmoid is asymmetric, 0.0 to - 1.0.") - -(defvar *output-type* :sigmoid - "The activation function to use on the output units. Options currently - implemented are :linear and :sigmoid.") - -(defvar *raw-error* nil - "If T, candidate units will try to correlate with the raw difference - between actual and desired outputs. Else, they use the difference modified - by the derivative of the output unit activation function.") - -(defvar *sigmoid-prime-offset* 0.1 - "This is added to the derivative of the sigmoid function to prevent the - system from getting stuck at the points where sigmoid-prime goes to - zero.") -(proclaim '(short-float *sigmoid-prime-offset*)) - -(defvar *weight-range* 1.0 - "Input weights in the network get inital random values between plus and - minus *weight-range*. This parameter also controls the initial weights - on direct input-to-output links.") -(proclaim '(short-float *weight-range*)) - -(defvar *weight-multiplier* 1.0 - "The output weights for cadidate units get an initial value that is the - negative of the correlation times this factor.") -(proclaim '(short-float *weight-multiplier*)) - -(defvar *output-mu* 2.0 - "Mu parmater used for quickprop training of output weights. The - step size is limited to mu times the previous step.") -(proclaim '(short-float *output-mu*)) - -(defvar *output-shrink-factor* (/ *output-mu* (+ 1.0 *output-mu*)) - "Derived from *output-mu*. Used in computing whether the proposed step is - too large.") -(proclaim '(short-float *output-shrink-factor*)) - -(defvar *output-epsilon* 0.35 - "Controls the amount of linear gradient descent to use in updating - output weights.") -(proclaim '(short-float *output-epsilon*)) - -(defvar *output-decay* 0.0001 - "This factor times the current weight is added to the slope at the - start of each output-training epoch. Keeps weights from growing too big.") -(proclaim '(short-float *output-decay*)) - -(defvar *output-patience* 8 - "If we go for this many epochs with no significant change, it's time to - stop tuning. If 0, go on forever.") -(proclaim '(fixnum *output-patience*)) - -(defvar *output-change-threshold* 0.01 - "The error must change by at least this fraction of its old value in - order to count as a significant change.") -(proclaim '(short-float *output-change-threshold*)) - -(defvar *input-mu* 2.0 - "Mu parmater used for quickprop training of input weights. The - step size is limited to mu times the previous step.") -(proclaim '(short-float *input-mu*)) - -(defvar *input-shrink-factor* (/ *input-mu* (+ 1.0 *input-mu*)) - "Derived from *input-mu*. Used in computing whether the proposed step is - too large.") -(proclaim '(short-float *input-shrink-factor*)) - -(defvar *input-epsilon* 1.0 - "Controls the amount of linear gradient descent to use in updating - unit input weights.") -(proclaim '(short-float *input-epsilon*)) - -(defvar *input-decay* 0.0 - "This factor times the current weight is added to the slope at the - start of each output-training epoch. Keeps weights from growing too big.") -(proclaim '(short-float *input-decay*)) - -(defvar *input-patience* 8 - "If we go for this many epochs with no significant change, it's time to - stop tuning. If 0, go on forever.") -(proclaim '(fixnum *input-patience*)) - -(defvar *input-change-threshold* 0.03 - "The correlation score for the best unit must change by at least - this fraction of its old value in order to count as a significant - change.") -(proclaim '(short-float *input-change-threshold*)) - -;;; Variables related to error and correlation. - -(defvar *score-threshold* 0.4 - "An output is counted as correct for a given case if the difference - between that output and the desired value is smaller in magnitude than - this value.") -(proclaim '(short-float *score-threshold*)) - -(defvar *error-bits* 0 - "Count number of bits in epoch that are wrong by more than - *SCORE-THRESHOLD*") -(proclaim '(fixnum *error-bits*)) - -(defvar *true-error* 0.0 - "The sum-squared error at the network outputs. This is the value the - algorithm is ultimately trying to minimize.") -(proclaim '(short-float *true-error*)) - -(defvar *sum-error* 0.0 - "Accumulate the sum of the error values after output training phase.") -(proclaim '(short-float *sum-error*)) - -(defvar *sum-sq-error* 0.0 - "Accumulate the sum of the squared error values after output - training phase.") -(proclaim '(short-float *sum-sq-error*)) - -(defvar *avg-error* 0.0 - "Holds the average of error values after output training phase.") -(proclaim '(short-float *avg-error*)) - -(defvar *best-candidate-score* 0.0 - "The best correlation score found among all candidate units being - trained.") -(proclaim '(short-float *best-candidate-score*)) - -(defvar *best-candidate* 0 - "The index of the candidate unit whose correlation score is best - at present.") -(proclaim '(fixnum *best-candidate*)) - -;;; These variables and switches control the simulation and display. - -(defvar *use-cache* t - "If T, cache the forward-pass values instead of repeatedly - computing them. This can save a *lot* of time if all the cached values - fit into memory.") - -(defparameter *epoch* 0 - "Count of the number of times the entire training set has been presented.") -(proclaim '(fixnum *epoch*)) - -(defvar *test* nil - "If T, run a test epoch every so often during output training.") - -(defvar *test-interval* 0 - "Run a test epoch every *test-interval* output training cycles.") -(proclaim '(fixnum *test-interval*)) - -(defvar *single-pass* nil - "When on, pause after next forward/backward cycle.") - -(defvar *single-epoch* nil - "When on, pause after next training epoch.") - -(defparameter *step* nil - "Turned briefly to T in order to continue after a pause.") - -;;; The sets of training inputs and outputs are stored in parallel vectors. -;;; Each element is a SIMPLE-VECTOR holding short-float values, one for -;;; each input or output. Note: this is a simple vector, not a specialized -;;; vector of element-type short-float. - -(defvar *training-inputs* (make-array 0) - "Vector of input patterns for training the net.") -(proclaim '(simple-vector *training-inputs*)) - -(defvar *training-outputs* (make-array 0) - "Vector of output patterns for training the net.") -(proclaim '(simple-vector *training-outputs*)) - -(defvar *goal* (make-array 0) - "The goal vector for the current training or testing case.") -(proclaim '(simple-vector *goal*)) - -(defvar *max-cases* 0 - "Maximum number of training cases that can be accommdated by the current - data structures.") -(proclaim '(fixnum *max-cases*)) - -(defvar *ncases* 0 - "Number of training cases currently in use. Assume a contiguous block - beginning with *FIRST-CASE*.") -(proclaim '(fixnum *ncases*)) - -(defvar *first-case* 0 - "Address of the first training case in the currently active set. Usually - zero, but may differ if we are training on different chunks of the training - set at different times.") -(proclaim '(fixnum *first-case*)) - -;;; For some benchmarks there is a separate set of values used for testing -;;; the network's ability to generalize. These values are not used during -;;; training. - -(defvar *test-inputs* '#() - "Vector of input patterns for testing the net.") -(proclaim '(simple-vector *test-inputs*)) - -(defvar *test-outputs* '#() - "Vector of output patterns for testing the net.") -(proclaim '(simple-vector *test-outputs*)) - - -;;;; Fundamental data structures. - -;;; Unit values and weights are short flonums. - -;;; Instead of representing each unit by a structure, we represent the -;;; unit by a fixnum. This is used to index into various vectors that hold -;;; per-unit information, such as the activation value of each unit. -;;; So the information concerning a given unit is found in a slice of values -;;; across many vectors, all with the same unit-index. - -;;; Per-connection information for each connection COMING INTO unit is -;;; stored in a vector of vectors. The outer vector is indexed by the unit -;;; number, and the inner vector is then indexed by connection number. -;;; This is a sleazy way of implementing a 2-D array, faster in most Lisp -;;; systems than multiplying to do the index arithmetic, and more efficient -;;; if the units are sparsely connected. - -;;; Unit 0, the "bias unit" is always at a maximum-on value. Next come -;;; some input "units", then some hidden units. - -;;; Output units have their own separate set of data structures and -;;; indices. The units and outputs together form the "active" network. -;;; There are also separate data structures and indices for the "candidate" -;;; units that have not yet been added to the network. - -(defvar *max-units* 30 - "Maximum number of input values and hidden units in the network.") -(proclaim '(fixnum *max-units*)) - -(defvar *ninputs* 0 - "Number of inputs for this problem.") -(proclaim '(fixnum *ninputs*)) - -(defvar *noutputs* 0 - "Number of outputs for this problem.") -(proclaim '(fixnum *noutputs*)) - -(defvar *nunits* 0 - "Current number of active units in the network. This count includes all - inputs to the network and the bias unit.") -(proclaim '(fixnum *nunits*)) - -(defvar *ncandidates* 8 - "Number of candidate units whose inputs will be trained at once.") -(proclaim '(fixnum *ncandidates*)) - -;;; The following vectors hold values related to hidden units in the active -;;; net and their input weights. The vectors are created by BUILD-NET, after -;;; the dimension variables have been set up. - -(defvar *values* nil - "Vector holding the current activation value for each unit and input in - the active net.") - -(defvar *values-cache* nil - "Holds a distinct *VALUES* vector for each of the *MAX-CASES* training - cases. Once we have computed the *VALUES* vector for each training case, - we can use it repeatedly until the weights or training cases change.") - -(defvar *extra-values* nil - "Extra values vector to use when not using the cache.") - -;;; Note: the *NCONNECTIONS* and *CONNECTIONS* vectors could be eliminated -;;; if we wanted to commit to total connectivity for all units. -;;; For now, we want to allow for sparse or irregular connectivity. - -(defvar *nconnections* nil - "Vector holding the number of incoming connections for each unit.") - -(defvar *connections* nil - "Vector that holds a connection vector for each unit J. - Each entry in the connection vector holds a unit index I, - indicating that this connection is from I to J.") - -(defvar *weights* nil - "Vector of vectors with structure parallel to the *connections* vector. - Each entry gives the weight associated with an incoming connection.") - -;;; The following vectors hold values for the outputs of the active -;;; network and the output-side weights. - -(defvar *outputs* nil - "Vector holding the network output values.") - -(defvar *errors* nil - "Vector holding the current error value for each output.") - -(defvar *errors-cache* nil - "Holds a distinct *ERRORS* vector for each of the *MAX-CASES* training - cases. Once we have computed the *ERRORS* vector for a given training - case, we can use it repeatedly until the weights of the training cases - change.") - -(defvar *extra-errors* nil - "Extra errors vector to use when not using the cache.") - -(defvar *output-weights* nil - "Vector of vectors. For each output, we have a vector of output weights - coming from the unit indicated by the index.") - -(defvar *output-deltas* nil - "Vector of vectors, parallel with output weights. Each entry is the - amount by which the corresponding output weight was changed last time.") - -(defvar *output-slopes* nil - "Vector of vectors, parallel with output weights. Each entry is the - partial derivative of the total error with repsect to the corresponding - weight.") - -(defvar *output-prev-slopes* nil - "Vector of vectors, parallel with output weights. Each entry is the - previous value of the corresponding *OUTPUT-SLOPES* entry.") - -(defvar *output-weights-record* nil - "The vector of output weights is recorded here after each output-training - phase and just prior to the addition of the next unit. This record - allows us to reconstruct the network's performance at each of these - points in time.") - -;;; The following vectors have one entry for each candidate unit in the -;;; pool of trainees. - -(defvar *cand-sum-values* nil - "For each candidate unit, the sum of its values over an entire - training set.") - -(defvar *cand-cor* nil - "A vector with one entry for each candidate unit. This entry is a vector - that holds the correlation between this unit's value and the residual - error at each of the outputs, computed over a whole epoch.") - -(defvar *cand-prev-cor* nil - "Holds the *cand-cor* values computed in the previous candidate training - epoch.") - -(defvar *cand-weights* nil - "A vector with one entry for each candidate unit. This entry is a vector - that holds the current input weights for that candidate unit.") - -(defvar *cand-deltas* nil - "A vector with one entry for each candidate unit. This entry is a vector - that holds the input weights deltas for that candidate unit.") - -(defvar *cand-slopes* nil - "A vector with one entry for each candidate unit. This entry is a vector - that holds the input weights slopes for that candidate unit.") - -(defvar *cand-prev-slopes* nil - "A vector with one entry for each candidate unit. This entry is a vector - that holds the previous values of the input weight slopes for that - candidate unit.") - -;;; At present, each candidate receives a connection from every input and -;;; pre-existing unit. Rather than cons up a new *connections* vector for -;;; each of these, we can just use this one for all of them. - -(defvar *all-connections* nil - "A *CONNECTIONS* vector that can be used by any unit that connects to - all lower-numbered units, in order.") - - -;;;; Network-building utilities. - -(defun build-net (ninputs noutputs) - "Create the network data structures, given the number of input and output - connections. Get *MAX-UNITS* and other dimesntions from variables." - (declare (fixnum ninputs noutputs)) - ;; Check to make sure *MAX-UNITS* is big enough. - (unless (> *max-units* (+ ninputs 1)) - (error "*MAX-UNITS* must be greater than number of inputs plus 1.")) - ;; Fill in assorted variables and create top-level vectors. - (setq *ninputs* ninputs - *noutputs* noutputs - *max-cases* (length *training-inputs*) - *ncases* *max-cases* - *first-case* 0 - *nunits* (+ 1 *ninputs*) - *values-cache* (make-array *max-cases* :initial-element nil) - *extra-values* (make-array *max-units* - :element-type 'short-float - :initial-element 0.0) - *values* *extra-values* - *nconnections* (make-array *max-units* - :element-type 'fixnum - :initial-element 0) - *connections* (make-array *max-units* :initial-element nil) - *weights* (make-array *max-units* :initial-element nil) - *outputs* (make-array *noutputs* - :element-type 'short-float - :initial-element 0.0) - *errors-cache* (make-array *max-cases* :initial-element nil) - *extra-errors* (make-array *noutputs* - :element-type 'short-float - :initial-element 0.0) - *errors* *extra-errors* - *output-weights* (make-array *noutputs* :initial-element nil) - *output-weights-record* (make-array *max-units* :initial-element nil) - *output-deltas* (make-array *noutputs* :initial-element nil) - *output-slopes* (make-array *noutputs* :initial-element nil) - *output-prev-slopes* (make-array *noutputs* :initial-element nil) - *cand-sum-values* (make-array *ncandidates* - :element-type 'short-float - :initial-element 0.0) - *cand-cor* (make-array *ncandidates* :initial-element nil) - *cand-prev-cor* (make-array *ncandidates* :initial-element nil) - *cand-weights* (make-array *ncandidates* :initial-element nil) - *cand-deltas* (make-array *ncandidates* :initial-element nil) - *cand-slopes* (make-array *ncandidates* :initial-element nil) - *cand-prev-slopes* (make-array *ncandidates* :initial-element nil)) - ;; Only create the caches if *USE-CACHE* is on -- may not always have room. - (when *use-cache* - (dotimes1 (i *max-cases*) - (setf (svref *values-cache* i) - (make-array *max-units* - :element-type 'short-float - :initial-element 0.0)) - (setf (svref *errors-cache* i) - (make-array *noutputs* - :element-type 'short-float - :initial-element 0.0)))) - ;; For each output, create the vectors holding per-weight information. - (dotimes1 (i *noutputs*) - (setf (svref *output-weights* i) - (make-array *max-units* - :element-type 'short-float - :initial-element 0.0)) - (setf (svref *output-deltas* i) - (make-array *max-units* - :element-type 'short-float - :initial-element 0.0)) - (setf (svref *output-slopes* i) - (make-array *max-units* - :element-type 'short-float - :initial-element 0.0)) - (setf (svref *output-prev-slopes* i) - (make-array *max-units* - :element-type 'short-float - :initial-element 0.0))) - ;; For each candidate unit, create the vectors holding the correlations, - ;; incoming weights, and other stats. - (dotimes1 (i *ncandidates*) - (setf (svref *cand-cor* i) - (make-array *noutputs* - :element-type 'short-float - :initial-element 0.0)) - (setf (svref *cand-prev-cor* i) - (make-array *noutputs* - :element-type 'short-float - :initial-element 0.0)) - (setf (svref *cand-weights* i) - (make-array *max-units* - :element-type 'short-float - :initial-element 0.0)) - (setf (svref *cand-deltas* i) - (make-array *max-units* - :element-type 'short-float - :initial-element 0.0)) - (setf (svref *cand-slopes* i) - (make-array *max-units* - :element-type 'short-float - :initial-element 0.0)) - (setf (svref *cand-prev-slopes* i) - (make-array *max-units* - :element-type 'short-float - :initial-element 0.0)))) - -(defun random-weight () - "Select a random weight, uniformly distributed over the - interval from minus to plus *weight-range*." - (-sf (random (*sf 2.0 *weight-range*)) *weight-range*)) - -(defun init-net () - "Set up the network for a learning problem. Clean up all the data - structures that may have become corrupted. Initialize the output weights - to random values controlled by *weight-range*." - ;; Set up the *ALL-CONNECTIONS* vector. - (setq *all-connections* - (make-array *max-units* :element-type 'fixnum)) - (dotimes1 (i *max-units*) - (setf (ivref *all-connections* i) i)) - ;; Initialize the active unit data structures. - (dotimes1 (i *max-units*) - (setf (fvref *extra-values* i) 0.0) - (setf (ivref *nconnections* i) 0) - (setf (svref *connections* i) nil) - (setf (svref *weights* i) nil) - (setf (svref *output-weights-record* i) nil)) - ;; Initialize the per-output data structures. - (dotimes1 (i *noutputs*) - (setf (fvref *outputs* i) 0.0) - (setf (fvref *extra-errors* i) 0.0) - (let ((ow (svref *output-weights* i)) - (od (svref *output-deltas* i)) - (os (svref *output-slopes* i)) - (op (svref *output-prev-slopes* i))) - (dotimes1 (j *max-units*) - (setf (fvref ow j) 0.0) - (setf (fvref od j) 0.0) - (setf (fvref os j) 0.0) - (setf (fvref op j) 0.0)) - ;; Set up initial random weights for the input-to-output connections. - (dotimes1 (j (1+ *ninputs*)) - (setf (fvref ow j) (random-weight))))) - ;; Initialize the caches if they are in use. - (when *use-cache* - (dotimes1 (j *max-cases*) - (let ((v (svref *values-cache* j)) - (e (svref *errors-cache* j))) - (dotimes1 (i *max-units*) - (setf (fvref v i) 0.0)) - (dotimes1 (i *noutputs*) - (setf (fvref e i) 0.0))))) - ;; Candidate units get initialized in a separate routine. - (init-candidates) - ;; Do some other assorted housekeeping. - (setf (fvref *extra-values* 0) 1.0) - (setq *epoch* 0) - (setq *nunits* (+ 1 *ninputs*)) - (setq *error-bits* 0) - (setq *true-error* 0.0) - (setq *sum-error* 0.0) - (setq *sum-sq-error* 0.0) - (setq *best-candidate-score* 0.0) - (setq *best-candidate* 0)) - -(defun changed-training-set () - "Call this instead of BUILD-NET and INIT-NET if you want to leave - existing hidden units in place and start from here with new training - examples. Assumes that the number of net inputs and outputs remains the - same, but the number of cases may have changed. Rebuilds the caches." - (setq *max-cases* (length *training-inputs*) - *ncases* *max-cases* - *first-case* 0 - *values-cache* (make-array *max-cases* :initial-element nil) - *errors-cache* (make-array *max-cases* :initial-element nil)) - ;; Only create the caches if *USE-CACHE* is on -- may not always have room. - (when *use-cache* - (dotimes1 (i *max-cases*) - (setf (svref *errors-cache* i) - (make-array *noutputs* - :element-type 'short-float - :initial-element 0.0)) - (setq *values* (make-array *max-units* - :element-type 'short-float - :initial-element 0.0)) - (setf (svref *values-cache* i) *values*) - (set-up-inputs (svref *training-inputs* i)) - (do ((j (1+ *ninputs*) (1+ j))) - ((= j *nunits*)) - (declare (fixnum j)) - (compute-unit-value j))))) - -;;;; Utilities for learning. - -(proclaim '(inline activation activation-prime)) - -(defun activation (sum) - "Given the sum of weighted inputs, compute the unit's activation value. - Defined unit types are :sigmoid, :asigmoid, and :gaussian." - (declare (short-float sum)) - (ecase *unit-type* - (:sigmoid - ;; Symmetric sigmoid function in range -0.5 to +0.5. - (cond ((< sum -15.0) -0.5) - ((> sum 15.0) +0.5) - (t (-sf (/sf (+sf 1.0 (exp (-sf sum)))) 0.5)))) - (:asigmoid - ;; Asymmetric sigmoid in range 0.0 to 1.0. - (cond ((< sum -15.0) 0.0) - ((> sum 15.0) 1.0) - (t (/sf 1.0 (+sf 1.0 (exp (-sf sum))))))) - (:gaussian - ;; Gaussian activation function in range 0.0 to 1.0. - (let ((x (*sf -0.5 sum sum))) - (if (< x -75.0) 0.0 (exp x)))))) - -;;; Note: do not use *SIGMOID-PRIME-OFFSET* here, as it confuses the -;;; correlation machinery. But do use it in output-prime, since it does no -;;; harm there and the output units often get stuck at extreme values. - -(defun activation-prime (value sum) - "Given the unit's activation value and sum of weighted inputs, compute - the derivative of the activation with respect to the sum. Defined unit - types are :sigmoid, :asigmoid, and :gaussian." - (declare (short-float value sum)) - (ecase *unit-type* - (:sigmoid - (-sf 0.25 (*sf value value))) - (:asigmoid - (*sf value (-sf 1.0 value))) - (:gaussian - (*sf (-sf value) sum)))) - -(proclaim '(inline output-function output-prime)) - -(defun output-function (sum) - "Compute the value of an output, given the weighted sum of incoming values. - Defined output types are :sigmoid and :linear." - (declare (short-float sum)) - (ecase *output-type* - (:sigmoid (cond ((< sum -15.0) -0.5) - ((> sum 15.0) +0.5) - (t (-sf (/sf 1.0 (+sf 1.0 (exp (-sf sum)))) 0.5)))) - (:linear sum))) - -(defun output-prime (output) - "Compute the derivative of an output with respect to the weighted sum of - incoming values. Defined output types are :sigmoid and :linear." - (declare (short-float output)) - (ecase *output-type* - (:sigmoid - (+sf *sigmoid-prime-offset* (-sf 0.25 (*sf output output)))) - (:linear 1.0))) - -;;; The basic routine for doing Quickprop-style update of weights. -;;; Distilled essence of a year's work... - -(proclaim '(inline quickprop-update)) - -(defun quickprop-update (i weights deltas slopes prevs - epsilon decay mu shrink-factor) - "Given vectors holding weights, deltas, slopes, and previous slopes, - and an index i, update weight(i) and delta(i) appropriately. Move - slope(i) to prev(i) and zero out slope(i). Add weight decay term to - each slope before doing the update." - (let* ((w (fvref weights i)) - (d (fvref deltas i)) - (s (+sf (fvref slopes i) (*sf decay w))) - (p (fvref prevs i)) - (next-step 0.0)) - (declare (short-float w p s d next-step)) - ;; The step must always be downhill. - (cond - ;; If last step was negative... - ((minusp d) - ;; First, add in linear term if current slope is still positive. - (when (plusp s) - (decf-sf next-step (*sf epsilon s))) - (cond - ;; If current slope is close to or larger than prev slope... - ((>= s (*sf shrink-factor p)) - ;; Take maximum size negative step. - (incf-sf next-step (*sf mu d))) - ;; Else, use quadratic estimate. - (t (incf-sf next-step (*sf d (/sf s (-sf p s))))))) - ;; If last step was positive... - ((plusp d) - ;; First, add in linear term if current slope is still negative. - (when (minusp s) - (decf-sf next-step (*sf epsilon s))) - (cond - ;; If current slope is close to or more neg than prev slope... - ((<= s (*sf shrink-factor p)) - ;; Take maximum size positive step. - (incf-sf next-step (*sf mu d))) - ;; Else, use quadratic estimate. - (t (incf-sf next-step (*sf d (/sf s (-sf p s))))))) - ;; Last step was zero, so use only linear term. - (t (decf-sf next-step (*sf epsilon s)))) - ;; Having computed the next step, update the data vectors. - (setf (fvref deltas i) next-step) - (setf (fvref weights i) (+sf w next-step)) - (setf (fvref prevs i) s) - (setf (fvref slopes i) 0.0) - nil)) - - -;;;; Machinery for training output weights. - -(defun set-up-inputs (input) - "Set up all the inputs from the INPUT vector as the first few entries in - in the values vector." - (declare (simple-vector input)) - (setf (fvref *values* 0) 1.0) - (dotimes1 (i *ninputs*) - (setf (fvref *values* (1+ i)) - (the short-float (svref input i))))) - -(defun output-forward-pass () - "Assume the *VALUES* vector has been set up. Just compute the network's - outputs." - (dotimes1 (j *noutputs*) - (let ((ow (svref *output-weights* j)) - (sum 0.0)) - (declare (short-float sum)) - (dotimes1 (i *nunits*) - (incf-sf sum (*sf (fvref *values* i) (fvref ow i)))) - (setf (fvref *outputs* j) - (output-function sum))))) - -(defun compute-unit-value (j) - "Assume that *VALUES* vector has been set up for all units with index less - than J. Compute and record the value for unit J." - (declare (fixnum j)) - (let* ((c (svref *connections* j)) - (w (svref *weights* j)) - (sum 0.0)) - (declare (short-float sum)) - (dotimes1 (i (ivref *nconnections* j)) - (incf-sf sum (*sf (fvref *values* (ivref c i)) - (fvref w i)))) - (setf (fvref *values* j) (activation sum)) - nil)) - -(defun full-forward-pass (input) - "Set up the inputs from the INPUT vector, then propagate activation values - forward through all hidden units and output units." - (set-up-inputs input) - ;; For each hidden unit J, compute the activation value. - (do ((j (1+ *ninputs*) (1+ j))) - ((= j *nunits*)) - (declare (fixnum j)) - (compute-unit-value j)) - ;; Now compute outputs. - (output-forward-pass)) - -;;; Note: We fill the *ERRORS* vector and related statistics with either -;;; the raw error or the error after modification by output-prime, -;;; depending on the *RAW-ERROR* switch. This controls what form of error -;;; the candidate units try to correlate with. All experiments reported in -;;; TR CMU-CS-90-100 assume *RAW-ERROR* is NIL, but this might not always -;;; be the best choice. - -(defun compute-errors (goal output-slopes-p stats-p) - "GOAL is a vector of desired values for the output units. Compute and - record the output errors for the current training case. If - OUTPUT-SLOPES-P is T, then use errors to compute slopes for output - weights. If STATS-P is T, accumulate error statistics." - (declare (simple-vector goal)) - (dotimes1 (j *noutputs*) - (let* ((out (fvref *outputs* j)) - (dif (-sf out (svref goal j))) - (err-prime (*sf dif (output-prime out))) - (os (svref *output-slopes* j))) - (declare (short-float dif err-prime)) - (when stats-p - (unless (< (abs dif) *score-threshold*) - (incf *error-bits*)) - (incf-sf *true-error* (*sf dif dif))) - (cond (*raw-error* - (setf (fvref *errors* j) dif) - (incf-sf *sum-error* dif) - (incf-sf *sum-sq-error* (*sf dif dif))) - (t - (setf (fvref *errors* j) err-prime) - (incf-sf *sum-error* err-prime) - (incf-sf *sum-sq-error* (*sf err-prime err-prime)))) - (when output-slopes-p - (dotimes1 (i *nunits*) - (incf-sf (fvref os i) (*sf err-prime (fvref *values* i)))))))) - -;;; Note: Scaling *OUTPUT-EPSILON* by the number of cases seems to keep the -;;; quickprop update in a good range across many different-sized training -;;; sets, but it's something of a hack. Choosing good epsilon values -;;; still requires some trial and error. - -(defun update-output-weights () - "Update the output weights, using the pre-computed slopes, prev-slopes, - and delta values. Uses the quickprop update function." - (let ((eps (/ *output-epsilon* *ncases*))) - (dotimes1 (j *noutputs*) - (let ((ow (svref *output-weights* j)) - (od (svref *output-deltas* j)) - (os (svref *output-slopes* j)) - (op (svref *output-prev-slopes* j))) - (dotimes1 (i *nunits*) - (quickprop-update i ow od os op eps *output-decay* - *output-mu* *output-shrink-factor*)))))) - - -;;;; Outer loops for training output weights. - -(defun train-outputs-epoch () - "Perform forward propagation once for each set of weights in the - training vectors, computing errors and slopes. Then update the output - weights." - ;; Zero error accumulators. - (setq *error-bits* 0) - (setq *true-error* 0.0) - (setq *sum-error* 0.0) - (setq *sum-sq-error* 0.0) - ;; User may have changed mu between epochs, so fix shrink-factor. - (setq *output-shrink-factor* - (/sf *output-mu* (+sf 1.0 *output-mu*))) - ;; Now run through the training examples. - (do ((i *first-case* (1+ i))) - ((= i (the fixnum (+ *first-case* *ncases*)))) - (declare (fixnum i)) - (setq *goal* (svref *training-outputs* i)) - (cond (*use-cache* - (setq *values* (svref *values-cache* i)) - (setq *errors* (svref *errors-cache* i)) - (output-forward-pass)) - (t (setq *values* *extra-values*) - (setq *errors* *extra-errors*) - (full-forward-pass (svref *training-inputs* i)))) - (compute-errors *goal* t t)) - ;; Do not change weights or count epoch if this run was perfect. - (unless (= 0 *error-bits*) - (update-output-weights) - (incf *epoch*))) - -(defun record-output-weights () - "Store the output weights developed after each output-training phase - in the *ouput-weights-record* vector." - (let ((record (make-array *noutputs* :initial-element nil))) - (dotimes1 (o *noutputs*) - (let ((original (svref *output-weights* o)) - (copy (make-array *nunits* :element-type 'short-float - :initial-element 0.0))) - (dotimes1 (u *nunits*) - (setf (fvref copy u) (fvref original u))) - (setf (svref record o) copy))) - (setf (svref *output-weights-record* (1- *nunits*)) record))) - -(defun train-outputs (max-epochs) - "Train the output weights. If we exhaust MAX-EPOCHS, stop with value - :TIMEOUT. If there are zero error bits, stop with value :WIN. Else, - keep going until the true error has not changed by a significant amount - for *OUTPUT-PATIENCE* epochs. Then return :STAGNANT. If - *OUTPUT-PATIENCE* is zero, we do not stop until victory or until - MAX-EPOCHS is used up." - (declare (fixnum max-epochs)) - (let ((last-error 0.0) - (quit-epoch (+ *epoch* *output-patience*)) - (first-time t)) - (declare (fixnum quit-epoch) - (short-float last-error)) - (dotimes1 (i max-epochs (progn - (record-output-weights) - :timeout)) - ;; Maybe run a test epoch to see how we're doing. - (when (and *test* - (not (= 0 *test-interval*)) - (= 0 (mod i *test-interval*))) - (test-epoch)) - (train-outputs-epoch) - (cond ((zerop *error-bits*) - (record-output-weights) - (return :win)) - ((zerop *output-patience*)) - (first-time - (setq first-time nil) - (setq last-error *true-error*)) - ((> (abs (- *true-error* last-error)) - (* last-error *output-change-threshold*)) - (setq last-error *true-error*) - (setq quit-epoch (+ *epoch* *output-patience*))) - ((>= *epoch* quit-epoch) - (record-output-weights) - (return :stagnant)))))) - - -;;;; Machinery for Training, Selecting, and Installing Candidate Units. - -(defun init-candidates () - "Give new random weights to all of the candidate units. Zero the other - candidate-unit statistics." - (dotimes1 (i *ncandidates*) - (setf (fvref *cand-sum-values* i) 0.0) - (let ((cw (svref *cand-weights* i)) - (cd (svref *cand-deltas* i)) - (cs (svref *cand-slopes* i)) - (cp (svref *cand-prev-slopes* i)) - (cc (svref *cand-cor* i)) - (cpc (svref *cand-prev-cor* i))) - (dotimes1 (j *nunits*) - (setf (fvref cw j) (random-weight)) - (setf (fvref cd j) 0.0) - (setf (fvref cs j) 0.0) - (setf (fvref cp j) 0.0)) - (dotimes1 (o *noutputs*) - (setf (fvref cc o) 0.0) - (setf (fvref cpc o) 0.0))))) - -(defun install-new-unit () - "Add the candidate-unit with the best correlation score to the active - network. Then reinitialize the candidate pool." - (when (>= *nunits* *max-units*) - (error "Cannot add any more units.")) - ;; For now, assume total connectivity. - (setf (ivref *nconnections* *nunits*) *nunits*) - (setf (svref *connections* *nunits*) *all-connections*) - ;; Copy the weight vector for the new unit. - (let ((w (make-array *nunits* :element-type 'short-float)) - (cw (svref *cand-weights* *best-candidate*))) - (dotimes1 (i *nunits*) - (setf (fvref w i) (fvref cw i))) - (setf (svref *weights* *nunits*) w) - ;; Tell user about the new unit. - (format t " Add unit ~S: ~S~%" - (+ 1 *nunits*) w)) - ;; Fix up output weights for candidate unit. - ;; Use minus the correlation times the *weight-multiplier* as an - ;; initial guess. At least the sign should be right. - (dotimes1 (o *noutputs*) - (setf (fvref (svref *output-weights* o) *nunits*) - (*sf (-sf (fvref (svref *cand-prev-cor* *best-candidate*) o)) - *weight-multiplier*))) - ;; If using cache, run an epoch to compute this unit's values. - (when *use-cache* - (dotimes1 (i *max-cases*) - (setq *values* (svref *values-cache* i)) - (compute-unit-value *nunits*))) - ;; Reinitialize candidate units with random weights. - (incf *nunits*) - (init-candidates)) - -;;; Note: Ideally, after each adjustment of the candidate weights, we would -;;; run two epochs. The first would just determine the correlations -;;; between the candidate unit outputs and the residual error. Then, in a -;;; second pass, we would adjust each candidate's input weights so as to -;;; maximize the absolute value of the correlation. We need to know the -;;; sign of the correlation for each candidate-output pair so that we know -;;; which direction to tune the input weights. - -;;; Since this ideal method doubles the number of epochs required for -;;; training candidates, we cheat slightly and use the correlation values -;;; computed BEFORE the most recent weight update. This combines the two -;;; epochs, saving us almost a factor of two. To bootstrap the process, we -;;; begin with a single epoch that computes only the correlation. - -;;; Since we look only at the sign of the correlation and since that sign -;;; should change very infrequently, this probably is OK. But keep a -;;; lookout for pathological situations in which this might cause -;;; oscillation. - - -;;; This function is used only once at the start of each output-training -;;; phase to prime the pump. After that, each call to compute-slopes also -;;; computes the error-value products for the next epoch. - -(defun compute-correlations () - "For the current training pattern, compute the value of each candidate - unit and begin to compute the correlation between that unit's value and - the error at each output. We have already done a forward-prop and - computed the error values for active units." - (dotimes1 (u *ncandidates*) - (let ((sum 0.0) - (v 0.0) - (cw (svref *cand-weights* u)) - (cc (svref *cand-cor* u))) - (declare (short-float sum v)) - ;; Determine activation value of each candidate unit. - (dotimes1 (i *nunits*) - (incf-sf sum (*sf (fvref cw i) - (fvref *values* i)))) - (setq v (activation sum)) - (incf-sf (fvref *cand-sum-values* u) v) - ;; Accumulate value of each unit times error at each output. - (dotimes1 (o *noutputs*) - (incf-sf (fvref cc o) (*sf v (fvref *errors* o))))))) - -;;; Note: When we were computing true correlations between candidates and -;;; outputs, this is where the normalization factors went in. Currently we -;;; are just using covariances, as explained in the tech report. So we -;;; make only two adjustments here. First, we subtract out the product of -;;; the mean error and the mean candidate value to keep things from -;;; exploding when the error has a non-zero mean. Second, we effectively -;;; scale the error values by the sum-squared error over all training -;;; cases. This just keeps us from having to adjust *input-epsilon* -;;; repeatedly as the error is gradually reduced to a small fraction of its -;;; initial size. - -(defun adjust-correlations () - "Normalize each accumulated correlation value, and stuff the normalized - form into the *cand-prev-cor* data structure. Then zero *cand-cor* to - prepare for the next round. Note the unit with the best total - correlation score." - (setq *best-candidate* 0) - (setq *best-candidate-score* 0.0) - (dotimes1 (u *ncandidates*) - (let* ((cc (svref *cand-cor* u)) - (cpc (svref *cand-prev-cor* u)) - (offset (*sf (fvref *cand-sum-values* u) *avg-error*)) - (cor 0.0) - (score 0.0)) - (declare (short-float offset cor score)) - (dotimes1 (o *noutputs*) - (setq cor (/sf (-sf (fvref cc o) offset) *sum-sq-error*)) - (setf (fvref cpc o) cor) - (setf (fvref cc o) 0.0) - (incf-sf score (abs cor))) - ;; Keep track of the candidate with the best overall correlation. - (when (> score *best-candidate-score*) - (setq *best-candidate-score* score) - (setq *best-candidate* u))))) - -;;; This is the key function in the candidate training process. - -(defun compute-slopes () - "Given the correlation values for each candidate-output pair, compute - the derivative of the candidate's score with respect to each incoming - weight." - (dotimes1 (u *ncandidates*) - (let* ((sum 0.0) - (value 0.0) - (actprime 0.0) - (direction 0.0) - (cw (svref *cand-weights* u)) - (cs (svref *cand-slopes* u)) - (cc (svref *cand-cor* u)) - (cpc (svref *cand-prev-cor* u))) - (declare (short-float sum value actprime direction)) - ;; Forward pass through each candidate unit to compute activation-prime. - (dotimes1 (i *nunits*) - (incf-sf sum (*sf (fvref cw i) - (fvref *values* i)))) - (setq value (activation sum)) - (setq actprime (activation-prime value sum)) - ;; Now compute which way we want to adjust each unit's incoming - ;; activation. - (dotimes1 (o *noutputs*) - (let ((error (fvref *errors* o))) - (decf-sf direction - (*sf (if (minusp (fvref cpc o)) -1.0 1.0) - (*sf actprime - (/sf (-sf error *avg-error*) - *sum-sq-error*)))) - ;; Also accumulate the error-value products for use next epoch. - (incf-sf (fvref cc o) (*sf error value)))) - ;; Given the direction we want to push the candidate, compute - ;; which way we want to tweak each incoming weight. - (dotimes1 (i *nunits*) - (incf-sf (fvref cs i) - (*sf direction (fvref *values* i))))))) - -;;; Note: Scaling *INPUT-EPSILON* by the number of cases and number of -;;; inputs to each unit seems to keep the quickprop update in a good range, -;;; as the network goes from small to large, and across many -;;; different-sized training sets. Still, choosing a good epsilon value -;;; requires some trial and error. - -(defun update-input-weights () - "Update the input weights, using the pre-computed slopes, prev-slopes, - and delta values. Uses the quickprop update function." - (let ((eps (/ *input-epsilon* (* *ncases* *nunits*)))) - (dotimes1 (u *ncandidates*) - (let ((cw (svref *cand-weights* u)) - (cd (svref *cand-deltas* u)) - (cs (svref *cand-slopes* u)) - (cp (svref *cand-prev-slopes* u))) - (dotimes1 (i *nunits*) - (quickprop-update i cw cd cs cp eps *input-decay* - *input-mu* *input-shrink-factor*)))))) - -;;; Outer loop for training the candidate unit(s). - -(defun train-inputs-epoch () - "For each training pattern, perform a forward pass. Tune the candidate units' - weights to maximize the correlation score of each." - (do ((i *first-case* (1+ i))) - ((= i (the fixnum (+ *first-case* *ncases*)))) - (declare (fixnum i)) - (setq *goal* (svref *training-outputs* i)) - ;; Compute values and errors, or recall cached values. - (cond (*use-cache* - (setq *values* (svref *values-cache* i)) - (setq *errors* (svref *errors-cache* i))) - (t (setq *values* *extra-values*) - (setq *errors* *extra-errors*) - (full-forward-pass (svref *training-inputs* i)) - (compute-errors *goal* nil nil))) - ;; Compute the slopes we will use to adjust candidate weights. - (compute-slopes)) - ;; User may have changed mu between epochs, so fix shrink-factor. - (setq *input-shrink-factor* (/sf *input-mu* - (+sf 1.0 *input-mu*))) - ;; Now adjust the candidate unit input weights using quickprop. - (update-input-weights) - ;; Fix up the correlation values for the next epoch. - (adjust-correlations) - (incf *epoch*)) - -(defun correlations-epoch () - "Do an epoch through all active training patterns just to compute the - initial correlations. After this one pass, we will update the - correlations as we train." - (do ((i *first-case* (1+ i))) - ((= i (the fixnum (+ *first-case* *ncases*)))) - (declare (fixnum i)) - (setq *goal* (svref *training-outputs* i)) - (cond (*use-cache* - (setq *values* (svref *values-cache* i)) - (setq *errors* (svref *errors-cache* i))) - (t (setq *values* *extra-values*) - (setq *errors* *extra-errors*) - (full-forward-pass (svref *training-inputs* i)) - (compute-errors *goal* nil nil))) - (compute-correlations)) - (adjust-correlations) - (incf *epoch*)) - -(defun train-inputs (max-epochs) - "Train the input weights of all candidates. If we exhaust MAX-EPOCHS, - stop with value :TIMEOUT. Else, keep going until the best candidate - unit's score has changed by a significant amount, and then until it does - not change significantly for PATIENCE epochs. Then return :STAGNANT. If - PATIENCE is zero, we do not stop until victory or until MAX-EPOCHS is - used up." - (declare (fixnum max-epochs)) - (setq *avg-error* (/ *sum-error* (* *ncases* *noutputs*))) - (correlations-epoch) - (let ((last-score 0.0) - (quit max-epochs) - (first-time t)) - (declare (fixnum quit) - (short-float last-score)) - (dotimes1 (i max-epochs :timeout) - (train-inputs-epoch) - (cond ((zerop *input-patience*)) - (first-time - (setq first-time nil) - (setq last-score *best-candidate-score*)) - ((> (abs (-sf *best-candidate-score* last-score)) - (* last-score *input-change-threshold*)) - (setq last-score *best-candidate-score*) - (setq quit (+ i *input-patience*))) - ((>= i quit) - (return :stagnant)))))) - -;;;; Outer Loop. - -(defun list-parameters () - "Print out the current training parameters in abbreviated form." - (format t "SigOff ~,2F, WtRng ~,2F, WtMul ~,2F~%" - *sigmoid-prime-offset* *weight-range* *weight-multiplier*) - (format t "OMu ~,2F, OEps ~,2F, ODcy ~,4F, OPat ~D, OChange ~,3F~%" - *output-mu* *output-epsilon* *output-decay* *output-patience* - *output-change-threshold*) - (format t "IMu ~,2F, IEps ~,2F, IDcy ~,4F, IPat ~D, IChange ~,3F~%" - *input-mu* *input-epsilon* *input-decay* *input-patience* - *input-change-threshold*) - (format t "Utype ~S, Otype ~S, RawErr ~S, Pool ~D~%" - *unit-type* *output-type* *raw-error* *ncandidates*)) - -(defun train (outlimit inlimit rounds &optional (restart nil)) - "Train the output weights until stagnation or victory is reached. Then - train the input weights to stagnation or victory. Then install the best - candidate unit and repeat. OUTLIMIT and INLIMIT are upper limits on the number - of cycles in each output and input phase. ROUNDS is an upper limit on - the number of unit-installation cycles. If RESTART is non-nil, we are - restarting training from the current point -- do not reinitialize the net." - (declare (fixnum outlimit inlimit rounds)) - (unless restart (init-net)) - (list-parameters) - (when *use-cache* - (dotimes1 (i *max-cases*) - (setq *values* (svref *values-cache* i)) - (set-up-inputs (svref *training-inputs* i)))) - (dotimes1 (r rounds :lose) - (case (train-outputs outlimit) - (:win - (list-parameters) - (format t "Victory at ~S epochs, ~S units, ~S hidden, Error ~S.~%" - *epoch* *nunits* (- *nunits* *ninputs* 1) *true-error*) - (return nil)) - (:timeout - (format t "Epoch ~D: Out Timeout ~D bits wrong, error ~S.~2%" - *epoch* *error-bits* *true-error*)) - (:stagnant - (format t "Epoch ~D: Out Stagnant ~D bits wrong, error ~S.~2%" - *epoch* *error-bits* *true-error*))) - (when *test* (test-epoch)) - (case (train-inputs inlimit) - (:timeout - (format t "Epoch ~D: In Timeout. Cor: ~D~%" - *epoch* *best-candidate-score*)) - (:stagnant - (format t "Epoch ~D: In Stagnant. Cor: ~D~%" - *epoch* *best-candidate-score*))) - (install-new-unit))) - -(defun test-epoch (&optional (*score-threshold* 0.49999)) - "Perform forward propagation once for each set of weights in the training - and testing vectors. Reporting the performance. Do not change any - weights. Do not use the caches." - (let ((*use-cache* nil) - (*values* *extra-values*) - (*errors* *extra-errors*) - (*error-bits* 0) - (*true-error* 0.0) - (*sum-error* 0.0) - (*sum-sq-error* 0.0)) - ;; Run all training patterns and count errors. - (dotimes1 (i (length *training-inputs*)) - (setq *goal* (svref *training-outputs* i)) - (full-forward-pass (svref *training-inputs* i)) - (compute-errors *goal* nil t)) - (format t "Training: ~D of ~D wrong, error ~S." - *error-bits* (length *training-inputs*) *true-error*) - ;; Zero some accumulators again. - (setq *error-bits* 0) - (setq *true-error* 0.0) - (setq *sum-error* 0.0) - (setq *sum-sq-error* 0.0) - ;; Now run all test patterns and report the results. - (when *test-inputs* - (dotimes1 (i (length *test-inputs*)) - (setq *goal* (svref *test-outputs* i)) - (full-forward-pass (svref *test-inputs* i)) - (compute-errors *goal* nil t))) - (format t " Test: ~D of ~D wrong, error ~S.~%" - *error-bits* (length *test-inputs*) *true-error*))) - -(defun test-setup (nunits weights output-weights) - "Set up a network for testing, given stored weights and output weights." - (init-net) - (setq *weights* weights) - (setq *output-weights* output-weights) - (setq *nunits* nunits) - (do ((i (1+ *ninputs*) (1+ i))) - ((= i *nunits*)) - (declare (fixnum i)) - (setf (ivref *nconnections* i) i) - (setf (svref *connections* i) *all-connections*))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Example Applications ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Zig-Zag problem. An easy one, useful for testing the code. - -(defun build-zig-zag (n) - "Build N pairs of 1-D zig-zag." - (declare (fixnum n)) - (setq *ninputs* 1) - (setq *noutputs* 1) - (let ((ti (make-array (* 2 n))) - (to (make-array (* 2 n)))) - (dotimes1 (i n) - (setf (svref ti (* i 2)) - (vector (+ i 1.0))) - (setf (svref to (* i 2)) - (vector (if (evenp i) 0.5 -0.5))) - (setf (svref ti (1+ (* i 2))) - (vector (- (+ i 1.0)))) - (setf (svref to (1+ (* i 2))) - (vector (if (evenp i) -0.5 0.5)))) - (setq *training-inputs* ti) - (setq *training-outputs* to) - (setq *test-inputs* ti) - (setq *test-outputs* to)) - (build-net 1 1) - (init-net)) - -;;; Call this with something like (BUILD-ZIG-ZAG 4), then call -;;; something like (train 100 100 25). - - -;;; Two spirals problem. - -(defun build-two-spirals (&optional (n 97)) - "Build N point-pairs of the two-spiral problem, with standard default - of 97 pairs." - (declare (fixnum n)) - (setq *ninputs* 2) - (setq *noutputs* 1) - (let ((ti (make-array (* 2 n))) - (to (make-array (* 2 n)))) - (dotimes1 (i n) - (let* ((angle (/ (* i (coerce pi 'short-float)) 16.0)) - (radius (/ (* 6.5 (- 104.0 i)) 104)) - (x (* radius (sin angle))) - (y (* radius (cos angle)))) - (setf (svref ti (* i 2)) - (vector x y)) - (setf (svref to (* i 2)) - (vector 0.5)) - (setf (svref ti (1+ (* i 2))) - (vector (- x) (- y))) - (setf (svref to (1+ (* i 2))) - (vector -0.5)))) - ;; Put the inner part of the spiral first on the list. - (setq ti (nreverse ti)) - (setq to (nreverse to)) - (setq *training-inputs* ti) - (setq *training-outputs* to) - (setq *test-inputs* ti) - (setq *test-outputs* to)) - (build-net 2 1) - (init-net)) - -;;; To run this, call (BUILD-TWO-SPIRALS), set various control parameters, -;;; and then call something like (TRAIN 100 100 25). - -;;; For parameters, try these: -;;; SigOff 0.10, WtRng 1.00, WtMul 1.00 -;;; OMu 2.00, OEps 1.00, ODcy 0.0001, OPat 12, OChange 0.010 -;;; IMu 2.00, IEps 100.00, IDcy 0.00000, IPat 8, IChange 0.030 -;;; Utype :SIGMOID, Otype :SIGMOID, RawErr NIL, Pool 8 - -(defvar *save-random-state* - #+cmu - #S(RANDOM-STATE - J 6 - K 37 - SEED #(495959915 319289337 100972028 135321524 137984323 - 177928266 385820814 500959740 328846885 254554634 - 354844676 133704123 362896421 217869951 380210131 - 323670005 366246053 40575617 346460653 10417936 - 34276234 300730891 211595838 199986777 291429322 - 1196272 425488031 328015953 24567252 297307474 - 82341400 29130711 247126684 98716216 478723257 - 47355455 81983578 248879315 97829219 533448623 - 148633156 77868250 28344376 162872116 404460195 - 321766796 8557425 441861346 455213668 302826847 - 256874625 271153816 11749650 277043774 234844262)) - #-cmu (make-random-state)) - -(defun time-two-spirals () - (setq *random-state* (make-random-state *save-random-state*)) - (build-two-spirals) - (time (train 100 100 25))) - -;;; The End. - diff --git a/benchmarks/gabriel/bmarks.lisp b/benchmarks/gabriel/bmarks.lisp deleted file mode 100644 index cc73b619d5c9a17ac2544376f83bfb2039789366..0000000000000000000000000000000000000000 --- a/benchmarks/gabriel/bmarks.lisp +++ /dev/null @@ -1,2385 +0,0 @@ -;;;; -*- Mode: Lisp; Package: User -*- -;;;; -;;;; This file contains the common lisp version of the lisp performance -;;;; benchmarks from Stanford. These were translated and tested using -;;;; Symbolics Common Lisp on a Symbolics 3600. The benchmarks in this -;;;; file have not been "tuned" to any particular implementation. -;;;; -;;;; The benchmarks have been substantially cleaned up and made truly -;;;; Common Lisp at CMU by Rob Maclachlan and Skef Wholey. Timing -;;;; functions for each benchmark have been added. Declarations have -;;;; been added by David B. McDonald. Declarations should only affect -;;;; performance on general purpose hardware. Also, this reduces or -;;;; eliminates the error checking and may allow the system to be -;;;; corrupted if incorrect programs are run. -;;;; -;;;; Suggestions or problems to PW@SAIL. - -(in-package "USER") -#+proclaim-unsafe -(proclaim '(optimize (safety 0) (speed 3) (space 0))) -(proclaim '(inline assoc member)) -#-cmu -(proclaim '(declaration start-block end-block)) - - -(proclaim '(start-block boyer)) -;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer. -;;; Fairly CONS intensive. - -(defvar unify-subst) -(defvar temp-temp) - -(defun add-lemma (term) - (cond ((and (not (atom term)) - (eq (car term) - (quote equal)) - (not (atom (cadr term)))) - (setf (get (car (cadr term)) (quote lemmas)) - (cons term (get (car (cadr term)) (quote lemmas))))) - (t (error "~%ADD-LEMMA did not like term: ~a" term)))) - -(defun add-lemma-lst (lst) - (cond ((null lst) - t) - (t (add-lemma (car lst)) - (add-lemma-lst (cdr lst))))) - -(defun apply-subst (alist term) - (cond ((atom term) - (cond ((setq temp-temp (assoc term alist :test #'eq)) - (cdr temp-temp)) - (t term))) - (t (cons (car term) - (apply-subst-lst alist (cdr term)))))) - -(defun apply-subst-lst (alist lst) - (cond ((null lst) - nil) - (t (cons (apply-subst alist (car lst)) - (apply-subst-lst alist (cdr lst)))))) - -(defun falsep (x lst) - (or (equal x (quote (f))) - (member x lst :test #'eq))) - -(defun one-way-unify (term1 term2) - (progn (setq unify-subst nil) - (one-way-unify1 term1 term2))) - -(defun one-way-unify1 (term1 term2) - (cond ((atom term2) - (cond ((setq temp-temp (assoc term2 unify-subst :test #'eq)) - (equal term1 (cdr temp-temp))) - (t (setq unify-subst (cons (cons term2 term1) - unify-subst)) - t))) - ((atom term1) - nil) - ((eq (car term1) - (car term2)) - (one-way-unify1-lst (cdr term1) - (cdr term2))) - (t nil))) - -(defun one-way-unify1-lst (lst1 lst2) - (cond ((null lst1) - t) - ((one-way-unify1 (car lst1) - (car lst2)) - (one-way-unify1-lst (cdr lst1) - (cdr lst2))) - (t nil))) - -(defun rewrite (term) - (cond ((atom term) - term) - (t (rewrite-with-lemmas (cons (car term) - (rewrite-args (cdr term))) - (get (car term) - (quote lemmas)))))) - -(defun rewrite-args (lst) - (cond ((null lst) - nil) - (t (cons (rewrite (car lst)) - (rewrite-args (cdr lst)))))) - -(defun rewrite-with-lemmas (term lst) - (cond ((null lst) - term) - ((one-way-unify term (cadr (car lst))) - (rewrite (apply-subst unify-subst (caddr (car lst))))) - (t (rewrite-with-lemmas term (cdr lst))))) - -(defun setup-boyer () - (add-lemma-lst - (quote ((equal (compile form) - (reverse (codegen (optimize form) - (nil)))) - (equal (eqp x y) - (equal (fix x) - (fix y))) - (equal (greaterp x y) - (lessp y x)) - (equal (lesseqp x y) - (not (lessp y x))) - (equal (greatereqp x y) - (not (lessp x y))) - (equal (boolean x) - (or (equal x (t)) - (equal x (f)))) - (equal (iff x y) - (and (implies x y) - (implies y x))) - (equal (even1 x) - (if (zerop x) - (t) - (odd (1- x)))) - (equal (countps- l pred) - (countps-loop l pred (zero))) - (equal (fact- i) - (fact-loop i 1)) - (equal (reverse- x) - (reverse-loop x (nil))) - (equal (divides x y) - (zerop (remainder y x))) - (equal (assume-true var alist) - (cons (cons var (t)) - alist)) - (equal (assume-false var alist) - (cons (cons var (f)) - alist)) - (equal (tautology-checker x) - (tautologyp (normalize x) - (nil))) - (equal (falsify x) - (falsify1 (normalize x) - (nil))) - (equal (prime x) - (and (not (zerop x)) - (not (equal x (add1 (zero)))) - (prime1 x (1- x)))) - (equal (and p q) - (if p (if q (t) - (f)) - (f))) - (equal (or p q) - (if p (t) - (if q (t) - (f)) - (f))) - (equal (not p) - (if p (f) - (t))) - (equal (implies p q) - (if p (if q (t) - (f)) - (t))) - (equal (fix x) - (if (numberp x) - x - (zero))) - (equal (if (if a b c) - d e) - (if a (if b d e) - (if c d e))) - (equal (zerop x) - (or (equal x (zero)) - (not (numberp x)))) - (equal (plus (plus x y) - z) - (plus x (plus y z))) - (equal (equal (plus a b) - (zero)) - (and (zerop a) - (zerop b))) - (equal (difference x x) - (zero)) - (equal (equal (plus a b) - (plus a c)) - (equal (fix b) - (fix c))) - (equal (equal (zero) - (difference x y)) - (not (lessp y x))) - (equal (equal x (difference x y)) - (and (numberp x) - (or (equal x (zero)) - (zerop y)))) - (equal (meaning (plus-tree (append x y)) - a) - (plus (meaning (plus-tree x) - a) - (meaning (plus-tree y) - a))) - (equal (meaning (plus-tree (plus-fringe x)) - a) - (fix (meaning x a))) - (equal (append (append x y) - z) - (append x (append y z))) - (equal (reverse (append a b)) - (append (reverse b) - (reverse a))) - (equal (times x (plus y z)) - (plus (times x y) - (times x z))) - (equal (times (times x y) - z) - (times x (times y z))) - (equal (equal (times x y) - (zero)) - (or (zerop x) - (zerop y))) - (equal (exec (append x y) - pds envrn) - (exec y (exec x pds envrn) - envrn)) - (equal (mc-flatten x y) - (append (flatten x) - y)) - (equal (member x (append a b)) - (or (member x a) - (member x b))) - (equal (member x (reverse y)) - (member x y)) - (equal (length (reverse x)) - (length x)) - (equal (member a (intersect b c)) - (and (member a b) - (member a c))) - (equal (nth (zero) - i) - (zero)) - (equal (exp i (plus j k)) - (times (exp i j) - (exp i k))) - (equal (exp i (times j k)) - (exp (exp i j) - k)) - (equal (reverse-loop x y) - (append (reverse x) - y)) - (equal (reverse-loop x (nil)) - (reverse x)) - (equal (count-list z (sort-lp x y)) - (plus (count-list z x) - (count-list z y))) - (equal (equal (append a b) - (append a c)) - (equal b c)) - (equal (plus (remainder x y) - (times y (quotient x y))) - (fix x)) - (equal (power-eval (big-plus1 l i base) - base) - (plus (power-eval l base) - i)) - (equal (power-eval (big-plus x y i base) - base) - (plus i (plus (power-eval x base) - (power-eval y base)))) - (equal (remainder y 1) - (zero)) - (equal (lessp (remainder x y) - y) - (not (zerop y))) - (equal (remainder x x) - (zero)) - (equal (lessp (quotient i j) - i) - (and (not (zerop i)) - (or (zerop j) - (not (equal j 1))))) - (equal (lessp (remainder x y) - x) - (and (not (zerop y)) - (not (zerop x)) - (not (lessp x y)))) - (equal (power-eval (power-rep i base) - base) - (fix i)) - (equal (power-eval (big-plus (power-rep i base) - (power-rep j base) - (zero) - base) - base) - (plus i j)) - (equal (gcd x y) - (gcd y x)) - (equal (nth (append a b) - i) - (append (nth a i) - (nth b (difference i (length a))))) - (equal (difference (plus x y) - x) - (fix y)) - (equal (difference (plus y x) - x) - (fix y)) - (equal (difference (plus x y) - (plus x z)) - (difference y z)) - (equal (times x (difference c w)) - (difference (times c x) - (times w x))) - (equal (remainder (times x z) - z) - (zero)) - (equal (difference (plus b (plus a c)) - a) - (plus b c)) - (equal (difference (add1 (plus y z)) - z) - (add1 y)) - (equal (lessp (plus x y) - (plus x z)) - (lessp y z)) - (equal (lessp (times x z) - (times y z)) - (and (not (zerop z)) - (lessp x y))) - (equal (lessp y (plus x y)) - (not (zerop x))) - (equal (gcd (times x z) - (times y z)) - (times z (gcd x y))) - (equal (value (normalize x) - a) - (value x a)) - (equal (equal (flatten x) - (cons y (nil))) - (and (nlistp x) - (equal x y))) - (equal (listp (gopher x)) - (listp x)) - (equal (samefringe x y) - (equal (flatten x) - (flatten y))) - (equal (equal (greatest-factor x y) - (zero)) - (and (or (zerop y) - (equal y 1)) - (equal x (zero)))) - (equal (equal (greatest-factor x y) - 1) - (equal x 1)) - (equal (numberp (greatest-factor x y)) - (not (and (or (zerop y) - (equal y 1)) - (not (numberp x))))) - (equal (times-list (append x y)) - (times (times-list x) - (times-list y))) - (equal (prime-list (append x y)) - (and (prime-list x) - (prime-list y))) - (equal (equal z (times w z)) - (and (numberp z) - (or (equal z (zero)) - (equal w 1)))) - (equal (greatereqpr x y) - (not (lessp x y))) - (equal (equal x (times x y)) - (or (equal x (zero)) - (and (numberp x) - (equal y 1)))) - (equal (remainder (times y x) - y) - (zero)) - (equal (equal (times a b) - 1) - (and (not (equal a (zero))) - (not (equal b (zero))) - (numberp a) - (numberp b) - (equal (1- a) - (zero)) - (equal (1- b) - (zero)))) - (equal (lessp (length (delete x l)) - (length l)) - (member x l)) - (equal (sort2 (delete x l)) - (delete x (sort2 l))) - (equal (dsort x) - (sort2 x)) - (equal (length (cons x1 - (cons x2 - (cons x3 (cons x4 - (cons x5 - (cons x6 x7))))))) - (plus 6 (length x7))) - (equal (difference (add1 (add1 x)) - 2) - (fix x)) - (equal (quotient (plus x (plus x y)) - 2) - (plus x (quotient y 2))) - (equal (sigma (zero) - i) - (quotient (times i (add1 i)) - 2)) - (equal (plus x (add1 y)) - (if (numberp y) - (add1 (plus x y)) - (add1 x))) - (equal (equal (difference x y) - (difference z y)) - (if (lessp x y) - (not (lessp y z)) - (if (lessp z y) - (not (lessp y x)) - (equal (fix x) - (fix z))))) - (equal (meaning (plus-tree (delete x y)) - a) - (if (member x y) - (difference (meaning (plus-tree y) - a) - (meaning x a)) - (meaning (plus-tree y) - a))) - (equal (times x (add1 y)) - (if (numberp y) - (plus x (times x y)) - (fix x))) - (equal (nth (nil) - i) - (if (zerop i) - (nil) - (zero))) - (equal (last (append a b)) - (if (listp b) - (last b) - (if (listp a) - (cons (car (last a)) - b) - b))) - (equal (equal (lessp x y) - z) - (if (lessp x y) - (equal t z) - (equal f z))) - (equal (assignment x (append a b)) - (if (assignedp x a) - (assignment x a) - (assignment x b))) - (equal (car (gopher x)) - (if (listp x) - (car (flatten x)) - (zero))) - (equal (flatten (cdr (gopher x))) - (if (listp x) - (cdr (flatten x)) - (cons (zero) - (nil)))) - (equal (quotient (times y x) - y) - (if (zerop y) - (zero) - (fix x))) - (equal (get j (set i val mem)) - (if (eqp j i) - val - (get j mem))))))) - -(defun tautologyp (x true-lst false-lst) - (cond ((truep x true-lst) - t) - ((falsep x false-lst) - nil) - ((atom x) - nil) - ((eq (car x) - (quote if)) - (cond ((truep (cadr x) - true-lst) - (tautologyp (caddr x) - true-lst false-lst)) - ((falsep (cadr x) - false-lst) - (tautologyp (cadddr x) - true-lst false-lst)) - (t (and (tautologyp (caddr x) - (cons (cadr x) - true-lst) - false-lst) - (tautologyp (cadddr x) - true-lst - (cons (cadr x) - false-lst)))))) - (t nil))) - -(defun tautp (x) - (tautologyp (rewrite x) - nil nil)) - -(defun boyer () - (prog (ans term) - (setq term - (apply-subst - (quote ((x f (plus (plus a b) - (plus c (zero)))) - (y f (times (times a b) - (plus c d))) - (z f (reverse (append (append a b) - (nil)))) - (u equal (plus a b) - (difference x y)) - (w lessp (remainder a b) - (member a (length b))))) - (quote (implies (and (implies x y) - (and (implies y z) - (and (implies z u) - (implies u w)))) - (implies x w))))) - (setq ans (tautp term)))) - -(defun trans-of-implies (n) - (list (quote implies) - (trans-of-implies1 n) - (list (quote implies) - 0 n))) - -(defun trans-of-implies1 (n) - (declare (fixnum n)) - (cond ((eql n 1) - (list (quote implies) - 0 1)) - (t (list (quote and) - (list (quote implies) - (1- n) - n) - (trans-of-implies1 (1- n)))))) - -(defun truep (x lst) - (or (equal x (quote (t))) - (member x lst :test #'eq))) - -(eval-when (load eval) - (setup-boyer)) - -(defun time-boyer () - (time (boyer))) - -(proclaim '(start-block browse)) -;;; BROWSE -- Benchmark to create and browse through an AI-like data base of units. - -;;; n is # of symbols -;;; m is maximum amount of stuff on the plist -;;; npats is the number of basic patterns on the unit -;;; ipats is the instantiated copies of the patterns - -(defvar browse-rand 21.) - -(defmacro char1 (x) `(aref (string ,x) 0)) - -(defun init-browse (n m npats ipats) - (declare (fixnum n m npats)) - (let ((ipats (copy-tree ipats))) - (do ((p ipats (cdr p))) - ((null (cdr p)) (rplacd p ipats))) - (do ((n n (1- n)) - (i m (cond ((= (the fixnum i) 0) m) - (t (1- i)))) - (name (gentemp) (gentemp)) - (a ())) - ((= (the fixnum n) 0) a) - (declare (fixnum n i m)) - (push name a) - (do ((i i (1- i))) - ((= (the fixnum i) 0)) - (declare (fixnum i)) - (setf (get name (gensym)) nil)) - (setf (get name 'pattern) - (do ((i npats (1- i)) - (ipats ipats (cdr ipats)) - (a ())) - ((= (the fixnum i) 0) a) - (declare (fixnum i)) - (push (car ipats) a))) - (do ((j (- m i) (1- j))) - ((= (the fixnum j) 0)) - (declare (fixnum j)) - (setf (get name (gensym)) nil))))) - -(defun browse-random () - (setq browse-rand (mod (the fixnum (* (the fixnum browse-rand) 17.)) 251.))) - -(defun randomize (l) - (do ((a ())) - ((null l) a) - (let ((n (mod (browse-random) (length l)))) - (declare (fixnum n)) - (cond ((= (the fixnum n) 0) - (push (car l) a) - (setq l (cdr l))) - (t - (do ((n n (1- n)) - (x l (cdr x))) - ((= n 1) - (push (cadr x) a) - (rplacd x (cddr x))) - (declare (fixnum n)))))))) - -(defun match (pat dat alist) - (cond ((null pat) - (null dat)) - ((null dat) ()) - ((or (eq (car pat) '?) - (eq (car pat) - (car dat))) - (match (cdr pat) (cdr dat) alist)) - ((eq (car pat) '*) - (or (match (cdr pat) dat alist) - (match (cdr pat) (cdr dat) alist) - (match pat (cdr dat) alist))) - (t (cond ((atom (car pat)) - (cond ((eq (char1 (car pat)) #\?) - (let ((val (assoc (car pat) alist))) - (cond (val (match (cons (cdr val) - (cdr pat)) - dat alist)) - (t (match (cdr pat) - (cdr dat) - (cons (cons (car pat) - (car dat)) - alist)))))) - ((eq (char1 (car pat)) #\*) - (let ((val (assoc (car pat) alist))) - (cond (val (match (append (cdr val) - (cdr pat)) - dat alist)) - (t - (do ((l () (nconc l (cons (car d) nil))) - (e (cons () dat) (cdr e)) - (d dat (cdr d))) - ((null e) ()) - (cond ((match (cdr pat) d - (cons (cons (car pat) l) - alist)) - (return t)))))))))) - (t (and - (not (atom (car dat))) - (match (car pat) - (car dat) alist) - (match (cdr pat) - (cdr dat) alist))))))) - -(defun browse () - (investigate (randomize - (init-browse 100. 10. 4. '((a a a b b b b a a a a a b b a a a) - (a a b b b b a a - (a a)(b b)) - (a a a b (b a) b a b a)))) - '((*a ?b *b ?b a *a a *b *a) - (*a *b *b *a (*a) (*b)) - (? ? * (b a) * ? ?)))) - -(defun investigate (units pats) - (do ((units units (cdr units))) - ((null units)) - (do ((pats pats (cdr pats))) - ((null pats)) - (do ((p (get (car units) 'pattern) - (cdr p))) - ((null p)) - (match (car pats) (car p) ()))))) - -(defun time-browse () - (time (browse))) - -(proclaim '(start-block ctak)) -;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility. - -(defun ctak (x y z) - (declare (fixnum x y z)) - (catch 'ctak (ctak-aux x y z))) - -(defun ctak-aux (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) - (throw 'ctak z)) - (t (ctak-aux - (catch 'ctak - (ctak-aux (the fixnum (1- x)) - y - z)) - (catch 'ctak - (ctak-aux (the fixnum (1- y)) - z - x)) - (catch 'ctak - (ctak-aux (the fixnum (1- z)) - x - y)))))) - -(defun time-ctak () - (format t "Note: 10 iterations.~%") - (time (dotimes (i 10) (ctak 18 12 6)))) - -(proclaim '(start-block dderiv-run)) -;;; DDERIV -- The Common Lisp version of a symbolic derivative benchmark, written -;;; by Vaughn Pratt. - -;;; This benchmark is a variant of the simple symbolic derivative program -;;; (DERIV). The main change is that it is `table-driven.' Instead of using a -;;; large COND that branches on the CAR of the expression, this program finds -;;; the code that will take the derivative on the property list of the atom in -;;; the CAR position. So, when the expression is (+ . <rest>), the code -;;; stored under the atom '+ with indicator DERIV will take <rest> and -;;; return the derivative for '+. The way that MacLisp does this is with the -;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an -;;; atomic name in that it expects an argument list and the compiler compiles -;;; code, but the name of the function with that code is stored on the -;;; property list of FOO under the indicator BAR, in this case. You may have -;;; to do something like: - -;;; :property keyword is not Common Lisp. - -(defun dderiv-aux (a) - (list '/ (dderiv a) a)) - -(defun +-dderiv (a) - (cons '+ (mapcar #'dderiv a))) -(setf (get '+ 'dderiv) #'+-dderiv) - -(defun --dderiv (a) - (cons '- (mapcar #'dderiv a))) -(setf (get '- 'dderiv) #'--dderiv) - -(defun *-dderiv (a) - (list '* (cons '* a) - (cons '+ (mapcar #'dderiv-aux a)))) -(setf (get '* 'dderiv) #'*-dderiv) - -(defun /-dderiv (a) - (list '- - (list '/ - (dderiv (car a)) - (cadr a)) - (list '/ - (car a) - (list '* - (cadr a) - (cadr a) - (dderiv (cadr a)))))) -(setf (get '/ 'dderiv) #'/-dderiv) - -(defun dderiv (a) - (cond - ((atom a) - (cond ((eq a 'x) 1) (t 0))) - (t (let ((dderiv (get (car a) 'dderiv))) - (cond (dderiv (funcall (the function dderiv) (cdr a))) - (t 'error)))))) - -(defun dderiv-run () - (do ((i 0 (1+ i))) - ((= i 1000.)) - (declare (fixnum i)) - (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)))) - -(defun time-dderiv () - (time (dderiv-run))) - -(proclaim '(start-block deriv-run)) -;;; DERIV -- This is the Common Lisp version of a symbolic derivative benchmark -;;; written by Vaughn Pratt. It uses a simple subset of Lisp and does a lot of -;;; CONSing. - -(defun deriv-aux (a) (list '/ (deriv a) a)) - -(defun deriv (a) - (cond - ((atom a) - (cond ((eq a 'x) 1) (t 0))) - ((eq (car a) '+) - (cons '+ (mapcar #'deriv (cdr a)))) - ((eq (car a) '-) - (cons '- (mapcar #'deriv - (cdr a)))) - ((eq (car a) '*) - (list '* - a - (cons '+ (mapcar #'deriv-aux (cdr a))))) - ((eq (car a) '/) - (list '- - (list '/ - (deriv (cadr a)) - (caddr a)) - (list '/ - (cadr a) - (list '* - (caddr a) - (caddr a) - (deriv (caddr a)))))) - (t 'error))) - -(defun deriv-run () -#| (declare (fixnum i)) ;improves the code a little -Why, pray tell? -|# - (do ((i 0 (1+ i))) - ((= i 1000.)) ;runs it 5000 times - (declare (fixnum i)) - (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)))) - -(defun time-deriv () - (time (deriv-run))) - -(proclaim '(start-block destructive)) -;;; DESTRU -- Destructive operation benchmark - -(defun destructive (n m) - (declare (fixnum n m)) - (let ((l (do ((i 10. (the fixnum (1- i))) - (a () (push () a))) - ((= (the fixnum i) 0) a) - (declare (fixnum i))))) - (do ((i n (the fixnum (1- i)))) - ((= (the fixnum i) 0)) - (declare (fixnum i)) - (cond ((null (car l)) - (do ((l l (cdr l))) - ((null l)) - (or (car l) - (rplaca l (cons () ()))) - (nconc (car l) - (do ((j m (the fixnum (1- j))) - (a () (push () a))) - ((= (the fixnum j) 0) a) - (declare (fixnum j)))))) - (t - (do ((l1 l (cdr l1)) - (l2 (cdr l) (cdr l2))) - ((null l2)) - (rplacd (do ((j (floor (length (car l2)) 2) - (the fixnum (1- j))) - (a (car l2) (cdr a))) - ((zerop (the fixnum j)) a) - (declare (fixnum j)) - (rplaca a i)) - (let ((n (floor (length (car l1)) 2))) - (cond ((= (the fixnum n) 0) (rplaca l1 ()) - (car l1)) - (t - (do ((j n (the fixnum (1- j))) - (a (car l1) (cdr a))) - ((= j 1) - (prog1 (cdr a) - (rplacd a ()))) - (declare (fixnum j)) - (rplaca a i)))))))))))) - -(defun time-destructive () - (time (destructive 600 50))) - -(proclaim '(start-block div2-test-1 div2-test-2)) - -;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s. -;;; This file contains a recursive as well as an iterative test. - -(defun create-n (n) - (declare (fixnum n)) - (do ((n n (1- n)) - (a () (push () a))) - ((= (the fixnum n) 0) a) - (declare (fixnum n)))) - -(defvar div2-l (create-n 200.)) - -(defun iterative-div2 (l) - (do ((l l (cddr l)) - (a () (push (car l) a))) - ((null l) a))) - -(defun recursive-div2 (l) - (cond ((null l) ()) - (t (cons (car l) (recursive-div2 (cddr l)))))) - -(defun div2-test-1 (l) - (do ((i 300. (1- i))) - ((= (the fixnum i) 0)) - (declare (fixnum i)) - (iterative-div2 l) - (iterative-div2 l) - (iterative-div2 l) - (iterative-div2 l))) - -(defun div2-test-2 (l) - (do ((i 300. (1- i))) - ((= (the fixnum i) 0)) - (recursive-div2 l) - (recursive-div2 l) - (recursive-div2 l) - (recursive-div2 l))) - -(defun time-iterative-div2 () - (time (div2-test-1 div2-l))) - -(defun time-recursive-div2 () - (time (div2-test-2 div2-l))) - -(proclaim '(start-block fft)) - -;;; FFT -- This is an FFT benchmark written by Harry Barrow. It tests a -;;; variety of floating point operations, including array references. - -(defvar re (make-array 1025. :element-type 'single-float :initial-element 0.0)) -(defvar im (make-array 1025. :element-type 'single-float :initial-element 0.0)) - - -;areal = real part -;aimag = imaginary part -(defun fft (areal aimag) - (declare (type (simple-array single-float (1025)) areal aimag)) - (prog ((ar areal) - (ai aimag) - (i 0) - (j 0) - (k 0) - (m 0) - (n 0) - (le 0) - (le1 0) - (ip 0) - (nv2 0) - (ur 0.0) - (ui 0.0) - (wr 0.0) - (wi 0.0) - (tr 0.0) - (ti 0.0)) - (declare (fixnum i j k m n le le1 ip nv2) - (single-float ur ui wr wi tr ti)) - (setq n (array-dimension ar 0) - n (1- n) - nv2 (floor n 2) - m 0 ;compute m = log(n) - i 1) - l1 (cond ((< i n) - (setq m (1+ m) - i (+ i i)) - (go l1))) - (cond ((not (equal n (expt 2 m))) - (princ "error ... array size not a power of two.") - (read) - (return (terpri)))) - (setq j 1 ;interchange elements - i 1) ;in bit-reversed order - l3 (cond ((< i j) - (setq tr (aref ar j) - ti (aref ai j)) - (setf (aref ar j) (aref ar i)) - (setf (aref ai j) (aref ai i)) - (setf (aref ar i) tr) - (setf (aref ai i) ti))) - (setq k nv2) - l6 (cond ((< k j) - (setq j (- j k) - k (/ k 2)) - (go l6))) - (setq j (+ j k) - i (1+ i)) - (cond ((< i n) - (go l3))) - (do ((l 1 (1+ l))) - ((> l m)) ;loop thru stages - (declare (fixnum l)) - (setq le (expt 2 l) - le1 (floor le 2) - ur 1.0 - ui 0.0 - wr (cos (/ 3.14159265 (float le1))) - wi (sin (/ 3.14159265 (float le1)))) - (do ((j 1 (1+ j))) - ((> j le1)) ;loop thru butterflies - (declare (fixnum j)) - (do ((i j (+ i le))) - ((> i n)) ;do a butterfly - (declare (fixnum i)) - (setq ip (+ i le1) - tr (- (* (aref ar ip) ur) - (* (aref ai ip) ui)) - ti (+ (* (aref ar ip) ui) - (* (aref ai ip) ur))) - (setf (aref ar ip) (- (aref ar i) tr)) - (setf (aref ai ip) (- (aref ai i) ti)) - (setf (aref ar i) (+ (aref ar i) tr)) - (setf (aref ai i) (+ (aref ai i) ti)))) - (setq tr (- (* ur wr) (* ui wi)) - ti (+ (* ur wi) (* ui wr)) - ur tr - ui ti)) - (return t))) - -(defmacro fft-bench () - '(do ((ntimes 0 (1+ ntimes))) - ((= ntimes 10.)) - (declare (fixnum ntimes)) - (fft re im))) - -(defun time-fft () - (time (fft-bench))) - - -(proclaim '(end-block)) -;;; FPRINT -- Benchmark to print to a file. - -(defvar test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67 - mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12 - wxyzab23 xyzabc34 123456ab 234567bc 345678cd - 456789de 567890ef 678901fg 789012gh 890123hi)) - -(defun fprint-init-aux (m n atoms) - (declare (fixnum m n)) - (cond ((= (the fixnum m) 0) (pop atoms)) - (t (do ((i n (- i 2)) - (a ())) - ((< i 1) a) - (declare (fixnum i)) - (push (pop atoms) a) - (push (fprint-init-aux (1- m) n atoms) a))))) - -(defun fprint-init (m n atoms) - (let ((atoms (subst () () atoms))) - (do ((a atoms (cdr a))) - ((null (cdr a)) (rplacd a atoms))) - (fprint-init-aux m n atoms))) - -(defvar test-pattern (fprint-init 6. 6. test-atoms)) - -(defun fprint () - (let ((stream (open "fprint.tst" :direction :output - :if-exists :supersede))) - (print test-pattern stream) - (close stream))) - -(defun time-fprint () - (time (fprint))) - -;;; FREAD -- Benchmark to read from a file. -;;; Pronounced "FRED". Requires the existance of FPRINT.TST which is created -;;; by FPRINT. - -(defun fread () - (let ((stream (open "fprint.tst" :direction :input))) - (read stream) - (close stream))) - -(defun time-fread () - (time (fread))) - -(proclaim '(start-block pexptsq)) - -;;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic. -;;; Originally writen in Franz Lisp by Richard Fateman. -;;; PDIFFER1 appears in the code, but is not defined; is not called for in this -;;; test, however. - -(defvar *frpoly-v*) -(defvar *x*) -(defvar *alpha*) -(defvar *a*) -(defvar *b*) -(defvar *chk) -(defvar *l) -(defvar *p) -(defvar q*) -(defvar u*) -(defvar *var) -(defvar *y*) -(defvar frpoly-r) -(defvar frpoly-r2) -(defvar frpoly-r3) - -(defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order))) -(defmacro pcoefp (e) `(atom ,e)) - -(defmacro pzerop (x) - `(if (numberp ,x) ; no signp in CL - (zerop ,x))) -(defmacro pzero () 0) -(defmacro cplus (x y) `(+ ,x ,y)) -(defmacro ctimes (x y) `(* ,x ,y)) - -(defun pcoefadd (e c x) - (if (pzerop c) - x - (cons e (cons c x)))) - -(defun pcplus (c p) - (if (pcoefp p) - (cplus p c) - (psimp (car p) (pcplus1 c (cdr p))))) - -(defun pcplus1 (c x) - (cond ((null x) - (if (pzerop c) - nil - (cons 0 (cons c nil)))) - ((pzerop (car x)) - (pcoefadd 0 (pplus c (cadr x)) nil)) - (t - (cons (car x) (cons (cadr x) (pcplus1 c (cddr x))))))) - -(defun pctimes (c p) - (if (pcoefp p) - (ctimes c p) - (psimp (car p) (pctimes1 c (cdr p))))) - -(defun pctimes1 (c x) - (if (null x) - nil - (pcoefadd (car x) - (ptimes c (cadr x)) - (pctimes1 c (cddr x))))) - -(defun pplus (x y) - (cond ((pcoefp x) - (pcplus x y)) - ((pcoefp y) - (pcplus y x)) - ((eq (car x) (car y)) - (psimp (car x) (pplus1 (cdr y) (cdr x)))) - ((pointergp (car x) (car y)) - (psimp (car x) (pcplus1 y (cdr x)))) - (t - (psimp (car y) (pcplus1 x (cdr y)))))) - -(defun pplus1 (x y) - (cond ((null x) y) - ((null y) x) - ((= (car x) (car y)) - (pcoefadd (car x) - (pplus (cadr x) (cadr y)) - (pplus1 (cddr x) (cddr y)))) - ((> (car x) (car y)) - (cons (car x) (cons (cadr x) (pplus1 (cddr x) y)))) - (t (cons (car y) (cons (cadr y) (pplus1 x (cddr y))))))) - -(defun psimp (var x) - (cond ((null x) 0) - ((atom x) x) - ((zerop (car x)) - (cadr x)) - (t - (cons var x)))) - -(defun ptimes (x y) - (cond ((or (pzerop x) (pzerop y)) - (pzero)) - ((pcoefp x) - (pctimes x y)) - ((pcoefp y) - (pctimes y x)) - ((eq (car x) (car y)) - (psimp (car x) (ptimes1 (cdr x) (cdr y)))) - ((pointergp (car x) (car y)) - (psimp (car x) (pctimes1 y (cdr x)))) - (t - (psimp (car y) (pctimes1 x (cdr y)))))) - -(defun ptimes1 (*x* y) - (prog (u* *frpoly-v*) - (setq *frpoly-v* (setq u* (ptimes2 y))) - a - (setq *x* (cddr *x*)) - (if (null *x*) - (return u*)) - (ptimes3 y) - (go a))) - -(defun ptimes2 (y) - (if (null y) - nil - (pcoefadd (+ (car *x*) (car y)) - (ptimes (cadr *x*) (cadr y)) - (ptimes2 (cddr y))))) - -(defun ptimes3 (y) - (prog (e u c) - a1 (if (null y) - (return nil)) - (setq e (+ (car *x*) (car y)) - c (ptimes (cadr y) (cadr *x*) )) - (cond ((pzerop c) - (setq y (cddr y)) - (go a1)) - ((or (null *frpoly-v*) (> e (car *frpoly-v*))) - (setq u* (setq *frpoly-v* (pplus1 u* (list e c)))) - (setq y (cddr y)) - (go a1)) - ((= e (car *frpoly-v*)) - (setq c (pplus c (cadr *frpoly-v*))) - (if (pzerop c) ; never true, evidently - (setq u* (setq *frpoly-v* (pdiffer1 u* (list (car *frpoly-v*) (cadr *frpoly-v*))))) - (rplaca (cdr *frpoly-v*) c)) - (setq y (cddr y)) - (go a1))) - a (cond ((and (cddr *frpoly-v*) (> (caddr *frpoly-v*) e)) - (setq *frpoly-v* (cddr *frpoly-v*)) - (go a))) - (setq u (cdr *frpoly-v*)) - b (if (or (null (cdr u)) (< (cadr u) e)) - (rplacd u (cons e (cons c (cdr u)))) (go e)) - (cond ((pzerop (setq c (pplus (caddr u) c))) - (rplacd u (cdddr u)) - (go d)) - (t - (rplaca (cddr u) c))) - e (setq u (cddr u)) - d (setq y (cddr y)) - (if (null y) - (return nil)) - (setq e (+ (car *x*) (car y)) - c (ptimes (cadr y) (cadr *x*))) - c (cond ((and (cdr u) (> (cadr u) e)) - (setq u (cddr u)) - (go c))) - (go b))) - -(defun pexptsq (p n) - (do ((n (floor n 2) (floor n 2)) - (s (if (oddp n) p 1))) - ((zerop n) s) - (setq p (ptimes p p)) - (and (oddp n) (setq s (ptimes s p))))) - -(eval-when (load eval) - (setf (get 'x 'order) 1) - (setf (get 'y 'order) 2) - (setf (get 'z 'order) 3) - (defparameter frpoly-r - (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1)))) ; r= x+y+z+1) - (defparameter frpoly-r2 (ptimes frpoly-r 100000)) ; r2 = 100000*r - (defparameter frpoly-r3 (ptimes frpoly-r 1.0))) ; r3 = r with floating point coefficients - -(defun time-frpoly-fixnum () - (time (dolist (exp '(2 5 10 15)) - (pexptsq frpoly-r exp)))) - -(defun time-frpoly-bignum () - (time (dolist (exp '(2 5 10 15)) - (pexptsq frpoly-r2 exp)))) - -(defun time-frpoly-float () - (time (dolist (exp '(2 5 10 15)) - (pexptsq frpoly-r3 exp)))) - - -(proclaim '(start-block puzzle)) - -;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal. - -(eval-when (compile load eval) -(defconstant size 511) -(defconstant classmax 3) -(defconstant typemax 12) -); - -(defvar iii 0) -(defvar kount 0) -(defconstant dee 8) - -(proclaim '(type fixnum size classmax typemax iii kount dee)) - -(deftype class-vector () `(simple-vector ,(1+ classmax))) -(deftype type-vector () `(simple-vector ,(1+ typemax))) -(deftype size-vector () `(simple-vector ,(1+ size))) -(deftype p-array () `(simple-array t (,(1+ typemax) ,(1+ size)))) - -(defvar piececount (make-array (1+ classmax) :initial-element 0)) -(defvar class (make-array (1+ typemax) :initial-element 0)) -(defvar piecemax (make-array (1+ typemax) :initial-element 0)) -(defvar puzzle (make-array (1+ size))) -(defvar puzzle-p (make-array (list (1+ typemax) (1+ size)))) - -(proclaim '(type type-vector class piecemax)) -(proclaim '(type class-vector piececount)) -(proclaim '(type size-vector puzzle)) -(proclaim '(type p-array puzzle-p)) - -(defun fit (i j) - (declare (fixnum i j)) - (let ((end (svref piecemax i))) - (declare (fixnum end)) - (do ((k 0 (1+ k))) - ((> k end) t) - (declare (fixnum k)) - (cond ((aref puzzle-p i k) - (cond ((svref puzzle (+ j k)) - (return nil)))))))) - -(defun place (i j) - (declare (fixnum i j)) - (let ((end (svref piecemax i))) - (declare (fixnum end)) - (do ((k 0 (1+ k))) - ((> k end)) - (declare (fixnum k)) - (cond ((aref puzzle-p i k) - (setf (svref puzzle (+ j k)) t)))) - (setf (svref piececount (svref class i)) - (the fixnum (- (the fixnum (svref piececount (svref class i))) 1))) - (do ((k j (1+ k))) - ((> k size) -; (terpri) -; (princ "Puzzle filled") - 0) - (declare (fixnum k)) - (cond ((not (svref puzzle k)) - (return k)))))) - -(defun puzzle-remove (i j) - (declare (fixnum i j)) - (let ((end (svref piecemax i))) - (declare (fixnum end)) - (do ((k 0 (1+ k))) - ((> k end)) - (declare (fixnum k)) - (cond ((aref puzzle-p i k) - (setf (svref puzzle (+ j k)) nil)))) - (setf (svref piececount (svref class i)) - (the fixnum (+ (the fixnum (svref piececount (svref class i))) - 1))))) - -(defun trial (j) - (declare (fixnum j)) - (let ((k 0)) - (declare (fixnum k)) - (do ((i 0 (1+ i))) - ((> i typemax) - (setq kount (the fixnum (1+ (the fixnum kount)))) - nil) - (declare (fixnum i)) - (cond ((not (eql (svref piececount (svref class i)) 0)) - (cond ((fit i j) - (setq k (place i j)) - (cond ((or (trial k) - (= k 0)) -; (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1)) - (setq kount (the fixnum (1+ (the fixnum kount)))) - (return t)) - (t (puzzle-remove i j)))))))))) - -(defun definepiece (iclass ii jj kk) - (declare (fixnum ii jj kk)) - (let ((index 0)) - (declare (fixnum index)) - (do ((i 0 (1+ i))) - ((> i ii)) - (declare (fixnum i)) - (do ((j 0 (1+ j))) - ((> j jj)) - (declare (fixnum j)) - (do ((k 0 (1+ k))) - ((> k kk)) - (declare (fixnum k)) - (setq index (+ i (the fixnum - (* dee (the fixnum - (+ j (the fixnum (* dee k)))))))) - (setf (aref puzzle-p iii index) t)))) - (setf (svref class iii) iclass) - (setf (svref piecemax iii) index) - (cond ((not (= iii typemax)) - (setq iii (+ iii 1)))))) - -(defun puzzle () - (do ((m 0 (1+ m))) - ((> m size)) - (declare (fixnum m)) - (setf (svref puzzle m) t)) - (do ((i 1 (1+ i))) - ((> i 5)) - (declare (fixnum i)) - (do ((j 1 (1+ j))) - ((> j 5)) - (declare (fixnum j)) - (do ((k 1 (1+ k))) - ((> k 5)) - (declare (fixnum k)) - (setf (svref puzzle - (+ i - (the fixnum - (* dee (the fixnum - (+ j (the fixnum (* dee k)))))))) - nil)))) - (do ((i 0 (1+ i))) - ((> i typemax)) - (declare (fixnum i)) - (do ((m 0 (1+ m))) - ((> m size)) - (declare (fixnum m)) - (setf (aref puzzle-p i m) nil))) - (setq iii 0) - (definePiece 0 3 1 0) - (definePiece 0 1 0 3) - (definePiece 0 0 3 1) - (definePiece 0 1 3 0) - (definePiece 0 3 0 1) - (definePiece 0 0 1 3) - - (definePiece 1 2 0 0) - (definePiece 1 0 2 0) - (definePiece 1 0 0 2) - - (definePiece 2 1 1 0) - (definePiece 2 1 0 1) - (definePiece 2 0 1 1) - - (definePiece 3 1 1 1) - - (setf (svref pieceCount 0) 13.) - (setf (svref pieceCount 1) 3) - (setf (svref pieceCount 2) 1) - (setf (svref pieceCount 3) 1) - (let ((m (+ 1 (the fixnum (* dee (the fixnum (+ 1 dee)))))) - (n 0) - (kount 0)) - (declare (fixnum m n kount)) - (cond ((fit 0 m) (setq n (place 0 m))) - (t (format t "~%Error."))) - (cond ((trial n) - (format t "~%Success in ~4D trials." kount)) - (t (format t "~%Failure."))))) - -(defun time-puzzle () - (time (puzzle))) - -(proclaim '(start-block tak trtak)) - -;;; TAK -- A vanilla version of the TAKeuchi function and one with tail recursion -;;; removed. - -(defun tak (x y z) - (declare (fixnum x y z)) - (if (not (< y x)) - z - (tak (tak (the fixnum (1- x)) y z) - (tak (the fixnum (1- y)) z x) - (tak (the fixnum (1- z)) x y)))) - -(defun trtak (x y z) - (declare (fixnum x y z)) - (prog () - tak - (if (not (< y x)) - (return z) - (let ((a (tak (1- x) y z)) - (b (tak (1- y) z x))) - (setq z (tak (1- z) x y) - x a - y b) - (go tak))))) - -(defun time-tak () - (format t "Note: 10 iterations.~%") - (time (dotimes (i 10) (tak 18 12 6)))) - -(defun time-rtak () - (format t "Note: 10 iterations.~%") - (time (dotimes (i 10) (trtak 18 12 6)))) - -(proclaim '(start-block mas)) - -;;; TAKL -- The TAKeuchi function using lists as counters. - -(defun listn (n) - (if (not (= 0 (the fixnum n))) - (cons n (listn (1- n))))) - -(defvar l18 (listn 18.)) -(defvar l12 (listn 12.)) -(defvar l6 (listn 6.)) - -(defun mas (x y z) - (declare (list x y z)) - (if (not (shorterp y x)) - z - (mas (mas (cdr x) - y z) - (mas (cdr y) - z x) - (mas (cdr z) - x y)))) - -(defun shorterp (x y) - (declare (list x y)) - (and y (or (null x) - (shorterp (cdr x) - (cdr y))))) - -(defun time-takl () - (format t "Note: 10 iterations.~%") - (time (dotimes (i 10) (mas l18 l12 l6)))) - -#| -;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache -;;; memory effects. Results should be the same as for TAK on stack machines. -;;; Distribution of calls is not completely flat. - -(defun tak0 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak1 (tak37 (the fixnum (1- x)) y z) - (tak11 (the fixnum (1- y)) z x) - (tak17 (the fixnum (1- z)) x y))))) -(defun tak1 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak2 (tak74 (the fixnum (1- x)) y z) - (tak22 (the fixnum (1- y)) z x) - (tak34 (the fixnum (1- z)) x y))))) -(defun tak2 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak3 (tak11 (the fixnum (1- x)) y z) - (tak33 (the fixnum (1- y)) z x) - (tak51 (the fixnum (1- z)) x y))))) -(defun tak3 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak4 (tak48 (the fixnum (1- x)) y z) - (tak44 (the fixnum (1- y)) z x) - (tak68 (the fixnum (1- z)) x y))))) -(defun tak4 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak5 (tak85 (the fixnum (1- x)) y z) - (tak55 (the fixnum (1- y)) z x) - (tak85 (the fixnum (1- z)) x y))))) -(defun tak5 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak6 (tak22 (the fixnum (1- x)) y z) - (tak66 (the fixnum (1- y)) z x) - (tak2 (the fixnum (1- z)) x y))))) -(defun tak6 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak7 (tak59 (the fixnum (1- x)) y z) - (tak77 (the fixnum (1- y)) z x) - (tak19 (the fixnum (1- z)) x y))))) -(defun tak7 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak8 (tak96 (the fixnum (1- x)) y z) - (tak88 (the fixnum (1- y)) z x) - (tak36 (the fixnum (1- z)) x y))))) -(defun tak8 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak9 (tak33 (the fixnum (1- x)) y z) - (tak99 (the fixnum (1- y)) z x) - (tak53 (the fixnum (1- z)) x y))))) -(defun tak9 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak10 (tak70 (the fixnum (1- x)) y z) - (tak10 (the fixnum (1- y)) z x) - (tak70 (the fixnum (1- z)) x y))))) -(defun tak10 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak11 (tak7 (the fixnum (1- x)) y z) - (tak21 (the fixnum (1- y)) z x) - (tak87 (the fixnum (1- z)) x y))))) -(defun tak11 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak12 (tak44 (the fixnum (1- x)) y z) - (tak32 (the fixnum (1- y)) z x) - (tak4 (the fixnum (1- z)) x y))))) -(defun tak12 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak13 (tak81 (the fixnum (1- x)) y z) - (tak43 (the fixnum (1- y)) z x) - (tak21 (the fixnum (1- z)) x y))))) -(defun tak13 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak14 (tak18 (the fixnum (1- x)) y z) - (tak54 (the fixnum (1- y)) z x) - (tak38 (the fixnum (1- z)) x y))))) -(defun tak14 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak15 (tak55 (the fixnum (1- x)) y z) - (tak65 (the fixnum (1- y)) z x) - (tak55 (the fixnum (1- z)) x y))))) -(defun tak15 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak16 (tak92 (the fixnum (1- x)) y z) - (tak76 (the fixnum (1- y)) z x) - (tak72 (the fixnum (1- z)) x y))))) -(defun tak16 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak17 (tak29 (the fixnum (1- x)) y z) - (tak87 (the fixnum (1- y)) z x) - (tak89 (the fixnum (1- z)) x y))))) -(defun tak17 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak18 (tak66 (the fixnum (1- x)) y z) - (tak98 (the fixnum (1- y)) z x) - (tak6 (the fixnum (1- z)) x y))))) -(defun tak18 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak19 (tak3 (the fixnum (1- x)) y z) - (tak9 (the fixnum (1- y)) z x) - (tak23 (the fixnum (1- z)) x y))))) -(defun tak19 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak20 (tak40 (the fixnum (1- x)) y z) - (tak20 (the fixnum (1- y)) z x) - (tak40 (the fixnum (1- z)) x y))))) -(defun tak20 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak21 (tak77 (the fixnum (1- x)) y z) - (tak31 (the fixnum (1- y)) z x) - (tak57 (the fixnum (1- z)) x y))))) -(defun tak21 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak22 (tak14 (the fixnum (1- x)) y z) - (tak42 (the fixnum (1- y)) z x) - (tak74 (the fixnum (1- z)) x y))))) -(defun tak22 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak23 (tak51 (the fixnum (1- x)) y z) - (tak53 (the fixnum (1- y)) z x) - (tak91 (the fixnum (1- z)) x y))))) -(defun tak23 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak24 (tak88 (the fixnum (1- x)) y z) - (tak64 (the fixnum (1- y)) z x) - (tak8 (the fixnum (1- z)) x y))))) -(defun tak24 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak25 (tak25 (the fixnum (1- x)) y z) - (tak75 (the fixnum (1- y)) z x) - (tak25 (the fixnum (1- z)) x y))))) -(defun tak25 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak26 (tak62 (the fixnum (1- x)) y z) - (tak86 (the fixnum (1- y)) z x) - (tak42 (the fixnum (1- z)) x y))))) -(defun tak26 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak27 (tak99 (the fixnum (1- x)) y z) - (tak97 (the fixnum (1- y)) z x) - (tak59 (the fixnum (1- z)) x y))))) -(defun tak27 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak28 (tak36 (the fixnum (1- x)) y z) - (tak8 (the fixnum (1- y)) z x) - (tak76 (the fixnum (1- z)) x y))))) -(defun tak28 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak29 (tak73 (the fixnum (1- x)) y z) - (tak19 (the fixnum (1- y)) z x) - (tak93 (the fixnum (1- z)) x y))))) -(defun tak29 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak30 (tak10 (the fixnum (1- x)) y z) - (tak30 (the fixnum (1- y)) z x) - (tak10 (the fixnum (1- z)) x y))))) -(defun tak30 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak31 (tak47 (the fixnum (1- x)) y z) - (tak41 (the fixnum (1- y)) z x) - (tak27 (the fixnum (1- z)) x y))))) -(defun tak31 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak32 (tak84 (the fixnum (1- x)) y z) - (tak52 (the fixnum (1- y)) z x) - (tak44 (the fixnum (1- z)) x y))))) -(defun tak32 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak33 (tak21 (the fixnum (1- x)) y z) - (tak63 (the fixnum (1- y)) z x) - (tak61 (the fixnum (1- z)) x y))))) -(defun tak33 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak34 (tak58 (the fixnum (1- x)) y z) - (tak74 (the fixnum (1- y)) z x) - (tak78 (the fixnum (1- z)) x y))))) -(defun tak34 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak35 (tak95 (the fixnum (1- x)) y z) - (tak85 (the fixnum (1- y)) z x) - (tak95 (the fixnum (1- z)) x y))))) -(defun tak35 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak36 (tak32 (the fixnum (1- x)) y z) - (tak96 (the fixnum (1- y)) z x) - (tak12 (the fixnum (1- z)) x y))))) -(defun tak36 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak37 (tak69 (the fixnum (1- x)) y z) - (tak7 (the fixnum (1- y)) z x) - (tak29 (the fixnum (1- z)) x y))))) -(defun tak37 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak38 (tak6 (the fixnum (1- x)) y z) - (tak18 (the fixnum (1- y)) z x) - (tak46 (the fixnum (1- z)) x y))))) -(defun tak38 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak39 (tak43 (the fixnum (1- x)) y z) - (tak29 (the fixnum (1- y)) z x) - (tak63 (the fixnum (1- z)) x y))))) -(defun tak39 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak40 (tak80 (the fixnum (1- x)) y z) - (tak40 (the fixnum (1- y)) z x) - (tak80 (the fixnum (1- z)) x y))))) -(defun tak40 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak41 (tak17 (the fixnum (1- x)) y z) - (tak51 (the fixnum (1- y)) z x) - (tak97 (the fixnum (1- z)) x y))))) -(defun tak41 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak42 (tak54 (the fixnum (1- x)) y z) - (tak62 (the fixnum (1- y)) z x) - (tak14 (the fixnum (1- z)) x y))))) -(defun tak42 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak43 (tak91 (the fixnum (1- x)) y z) - (tak73 (the fixnum (1- y)) z x) - (tak31 (the fixnum (1- z)) x y))))) -(defun tak43 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak44 (tak28 (the fixnum (1- x)) y z) - (tak84 (the fixnum (1- y)) z x) - (tak48 (the fixnum (1- z)) x y))))) -(defun tak44 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak45 (tak65 (the fixnum (1- x)) y z) - (tak95 (the fixnum (1- y)) z x) - (tak65 (the fixnum (1- z)) x y))))) -(defun tak45 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak46 (tak2 (the fixnum (1- x)) y z) - (tak6 (the fixnum (1- y)) z x) - (tak82 (the fixnum (1- z)) x y))))) -(defun tak46 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak47 (tak39 (the fixnum (1- x)) y z) - (tak17 (the fixnum (1- y)) z x) - (tak99 (the fixnum (1- z)) x y))))) -(defun tak47 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak48 (tak76 (the fixnum (1- x)) y z) - (tak28 (the fixnum (1- y)) z x) - (tak16 (the fixnum (1- z)) x y))))) -(defun tak48 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak49 (tak13 (the fixnum (1- x)) y z) - (tak39 (the fixnum (1- y)) z x) - (tak33 (the fixnum (1- z)) x y))))) -(defun tak49 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak50 (tak50 (the fixnum (1- x)) y z) - (tak50 (the fixnum (1- y)) z x) - (tak50 (the fixnum (1- z)) x y))))) -(defun tak50 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak51 (tak87 (the fixnum (1- x)) y z) - (tak61 (the fixnum (1- y)) z x) - (tak67 (the fixnum (1- z)) x y))))) -(defun tak51 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak52 (tak24 (the fixnum (1- x)) y z) - (tak72 (the fixnum (1- y)) z x) - (tak84 (the fixnum (1- z)) x y))))) -(defun tak52 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak53 (tak61 (the fixnum (1- x)) y z) - (tak83 (the fixnum (1- y)) z x) - (tak1 (the fixnum (1- z)) x y))))) -(defun tak53 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak54 (tak98 (the fixnum (1- x)) y z) - (tak94 (the fixnum (1- y)) z x) - (tak18 (the fixnum (1- z)) x y))))) -(defun tak54 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak55 (tak35 (the fixnum (1- x)) y z) - (tak5 (the fixnum (1- y)) z x) - (tak35 (the fixnum (1- z)) x y))))) -(defun tak55 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak56 (tak72 (the fixnum (1- x)) y z) - (tak16 (the fixnum (1- y)) z x) - (tak52 (the fixnum (1- z)) x y))))) -(defun tak56 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak57 (tak9 (the fixnum (1- x)) y z) - (tak27 (the fixnum (1- y)) z x) - (tak69 (the fixnum (1- z)) x y))))) -(defun tak57 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak58 (tak46 (the fixnum (1- x)) y z) - (tak38 (the fixnum (1- y)) z x) - (tak86 (the fixnum (1- z)) x y))))) -(defun tak58 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak59 (tak83 (the fixnum (1- x)) y z) - (tak49 (the fixnum (1- y)) z x) - (tak3 (the fixnum (1- z)) x y))))) -(defun tak59 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak60 (tak20 (the fixnum (1- x)) y z) - (tak60 (the fixnum (1- y)) z x) - (tak20 (the fixnum (1- z)) x y))))) -(defun tak60 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak61 (tak57 (the fixnum (1- x)) y z) - (tak71 (the fixnum (1- y)) z x) - (tak37 (the fixnum (1- z)) x y))))) -(defun tak61 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak62 (tak94 (the fixnum (1- x)) y z) - (tak82 (the fixnum (1- y)) z x) - (tak54 (the fixnum (1- z)) x y))))) -(defun tak62 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak63 (tak31 (the fixnum (1- x)) y z) - (tak93 (the fixnum (1- y)) z x) - (tak71 (the fixnum (1- z)) x y))))) -(defun tak63 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak64 (tak68 (the fixnum (1- x)) y z) - (tak4 (the fixnum (1- y)) z x) - (tak88 (the fixnum (1- z)) x y))))) -(defun tak64 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak65 (tak5 (the fixnum (1- x)) y z) - (tak15 (the fixnum (1- y)) z x) - (tak5 (the fixnum (1- z)) x y))))) -(defun tak65 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak66 (tak42 (the fixnum (1- x)) y z) - (tak26 (the fixnum (1- y)) z x) - (tak22 (the fixnum (1- z)) x y))))) -(defun tak66 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak67 (tak79 (the fixnum (1- x)) y z) - (tak37 (the fixnum (1- y)) z x) - (tak39 (the fixnum (1- z)) x y))))) -(defun tak67 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak68 (tak16 (the fixnum (1- x)) y z) - (tak48 (the fixnum (1- y)) z x) - (tak56 (the fixnum (1- z)) x y))))) -(defun tak68 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak69 (tak53 (the fixnum (1- x)) y z) - (tak59 (the fixnum (1- y)) z x) - (tak73 (the fixnum (1- z)) x y))))) -(defun tak69 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak70 (tak90 (the fixnum (1- x)) y z) - (tak70 (the fixnum (1- y)) z x) - (tak90 (the fixnum (1- z)) x y))))) -(defun tak70 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak71 (tak27 (the fixnum (1- x)) y z) - (tak81 (the fixnum (1- y)) z x) - (tak7 (the fixnum (1- z)) x y))))) -(defun tak71 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak72 (tak64 (the fixnum (1- x)) y z) - (tak92 (the fixnum (1- y)) z x) - (tak24 (the fixnum (1- z)) x y))))) -(defun tak72 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak73 (tak1 (the fixnum (1- x)) y z) - (tak3 (the fixnum (1- y)) z x) - (tak41 (the fixnum (1- z)) x y))))) -(defun tak73 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak74 (tak38 (the fixnum (1- x)) y z) - (tak14 (the fixnum (1- y)) z x) - (tak58 (the fixnum (1- z)) x y))))) -(defun tak74 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak75 (tak75 (the fixnum (1- x)) y z) - (tak25 (the fixnum (1- y)) z x) - (tak75 (the fixnum (1- z)) x y))))) -(defun tak75 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak76 (tak12 (the fixnum (1- x)) y z) - (tak36 (the fixnum (1- y)) z x) - (tak92 (the fixnum (1- z)) x y))))) -(defun tak76 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak77 (tak49 (the fixnum (1- x)) y z) - (tak47 (the fixnum (1- y)) z x) - (tak9 (the fixnum (1- z)) x y))))) -(defun tak77 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak78 (tak86 (the fixnum (1- x)) y z) - (tak58 (the fixnum (1- y)) z x) - (tak26 (the fixnum (1- z)) x y))))) -(defun tak78 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak79 (tak23 (the fixnum (1- x)) y z) - (tak69 (the fixnum (1- y)) z x) - (tak43 (the fixnum (1- z)) x y))))) -(defun tak79 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak80 (tak60 (the fixnum (1- x)) y z) - (tak80 (the fixnum (1- y)) z x) - (tak60 (the fixnum (1- z)) x y))))) -(defun tak80 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak81 (tak97 (the fixnum (1- x)) y z) - (tak91 (the fixnum (1- y)) z x) - (tak77 (the fixnum (1- z)) x y))))) -(defun tak81 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak82 (tak34 (the fixnum (1- x)) y z) - (tak2 (the fixnum (1- y)) z x) - (tak94 (the fixnum (1- z)) x y))))) -(defun tak82 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak83 (tak71 (the fixnum (1- x)) y z) - (tak13 (the fixnum (1- y)) z x) - (tak11 (the fixnum (1- z)) x y))))) -(defun tak83 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak84 (tak8 (the fixnum (1- x)) y z) - (tak24 (the fixnum (1- y)) z x) - (tak28 (the fixnum (1- z)) x y))))) -(defun tak84 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak85 (tak45 (the fixnum (1- x)) y z) - (tak35 (the fixnum (1- y)) z x) - (tak45 (the fixnum (1- z)) x y))))) -(defun tak85 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak86 (tak82 (the fixnum (1- x)) y z) - (tak46 (the fixnum (1- y)) z x) - (tak62 (the fixnum (1- z)) x y))))) -(defun tak86 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak87 (tak19 (the fixnum (1- x)) y z) - (tak57 (the fixnum (1- y)) z x) - (tak79 (the fixnum (1- z)) x y))))) -(defun tak87 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak88 (tak56 (the fixnum (1- x)) y z) - (tak68 (the fixnum (1- y)) z x) - (tak96 (the fixnum (1- z)) x y))))) -(defun tak88 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak89 (tak93 (the fixnum (1- x)) y z) - (tak79 (the fixnum (1- y)) z x) - (tak13 (the fixnum (1- z)) x y))))) -(defun tak89 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak90 (tak30 (the fixnum (1- x)) y z) - (tak90 (the fixnum (1- y)) z x) - (tak30 (the fixnum (1- z)) x y))))) -(defun tak90 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak91 (tak67 (the fixnum (1- x)) y z) - (tak1 (the fixnum (1- y)) z x) - (tak47 (the fixnum (1- z)) x y))))) -(defun tak91 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak92 (tak4 (the fixnum (1- x)) y z) - (tak12 (the fixnum (1- y)) z x) - (tak64 (the fixnum (1- z)) x y))))) -(defun tak92 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak93 (tak41 (the fixnum (1- x)) y z) - (tak23 (the fixnum (1- y)) z x) - (tak81 (the fixnum (1- z)) x y))))) -(defun tak93 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak94 (tak78 (the fixnum (1- x)) y z) - (tak34 (the fixnum (1- y)) z x) - (tak98 (the fixnum (1- z)) x y))))) -(defun tak94 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak95 (tak15 (the fixnum (1- x)) y z) - (tak45 (the fixnum (1- y)) z x) - (tak15 (the fixnum (1- z)) x y))))) -(defun tak95 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak96 (tak52 (the fixnum (1- x)) y z) - (tak56 (the fixnum (1- y)) z x) - (tak32 (the fixnum (1- z)) x y))))) -(defun tak96 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak97 (tak89 (the fixnum (1- x)) y z) - (tak67 (the fixnum (1- y)) z x) - (tak49 (the fixnum (1- z)) x y))))) -(defun tak97 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak98 (tak26 (the fixnum (1- x)) y z) - (tak78 (the fixnum (1- y)) z x) - (tak66 (the fixnum (1- z)) x y))))) -(defun tak98 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak99 (tak63 (the fixnum (1- x)) y z) - (tak89 (the fixnum (1- y)) z x) - (tak83 (the fixnum (1- z)) x y))))) -(defun tak99 (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) z) - (t (tak0 (tak0 (the fixnum (1- x)) y z) - (tak0 (the fixnum (1- y)) z x) - (tak0 (the fixnum (1- z)) x y))))) - -(defun time-takr () - (time (tak0 18 12 6))) -|# - -(proclaim '(start-block stak)) -;;; STAK -- The TAKeuchi function with special variables instead of parameter -;;; passing. - -(defvar stak-x) -(defvar stak-y) -(defvar stak-z) - -(defun stak (stak-x stak-y stak-z) - (stak-aux)) - -(defun stak-aux () - (if (not (< (the fixnum stak-y) (the fixnum stak-x))) - stak-z - (let ((stak-x (let ((stak-x (the fixnum (1- (the fixnum stak-x)))) - (stak-y stak-y) - (stak-z stak-z)) - (stak-aux))) - (stak-y (let ((stak-x (the fixnum (1- (the fixnum stak-y)))) - (stak-y stak-z) - (stak-z stak-x)) - (stak-aux))) - (stak-z (let ((stak-x (the fixnum (1- (the fixnum stak-z)))) - (stak-y stak-x) - (stak-z stak-y)) - (stak-aux)))) - (stak-aux)))) - -(defun time-stak () - (format t "Note: 10 iterations.~%") - (time (dotimes (i 10) (stak 18 12 6)))) - -(proclaim '(end-block)) -;;; TPRINT -- Benchmark to print and read to the terminal. - -(defvar test-atoms '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9 - stu0 uvw1 wxy2 xyz3 123a 234b 345c 456d - 567d 678e 789f 890g)) - -(defun tprint-init (m n atoms) - (let ((atoms (subst () () atoms))) - (do ((a atoms (cdr a))) - ((null (cdr a)) (rplacd a atoms))) - (tprint-init-aux m n atoms))) - -(defun tprint-init-aux (m n atoms) - (declare (fixnum m n)) - (cond ((= (the fixnum m) 0) (pop atoms)) - (t (do ((i n (- i 2)) - (a ())) - ((< i 1) a) - (declare (fixnum i)) - (push (pop atoms) a) - (push (tprint-init-aux (1- m) n atoms) a))))) - -(defvar test-pattern (tprint-init 6. 6. test-atoms)) - -(defun time-tprint () - (time (print test-pattern))) - -(proclaim '(start-block init-traverse run-traverse)) - -;;; TRAVERSE -- Benchmark which creates and traverses a tree structure. - -(defstruct node - (parents ()) - (sons ()) - (sn (snb)) - (entry1 ()) - (entry2 ()) - (entry3 ()) - (entry4 ()) - (entry5 ()) - (entry6 ()) - (mark ())) - -(defvar sn 0) -(defvar rand 21.) -(defvar count 0) -(defvar marker nil) -(defvar root) - -(proclaim '(fixnum sn rand count)) - -(defun snb () - (setq sn (the fixnum (1+ (the fixnum sn))))) - -(defun seed () - (setq rand 21.)) - -(defun traverse-random () - (setq rand (rem (the fixnum (* (the fixnum rand) 17.)) 251.))) - -(defun traverse-remove (n q) - (cond ((eq (cdr (car q)) (car q)) - (prog2 () (caar q) (rplaca q ()))) - ((= (the fixnum n) 0) - (prog2 () (caar q) - (do ((p (car q) (cdr p))) - ((eq (cdr p) (car q)) - (rplaca q - (rplacd p (cdr (car q)))))))) - (t (do ((n n (the fixnum (1- n))) - (q (car q) (cdr q)) - (p (cdr (car q)) (cdr p))) - ((= (the fixnum n) 0) (prog2 () (car q) (rplacd q p))) - (declare (fixnum n)))))) - -(defun traverse-select (n q) - (do ((n n (the fixnum (1- n))) - (q (car q) (cdr q))) - ((= (the fixnum n) 0) (car q)) - (declare (fixnum n)))) - -(defun add (a q) - (cond ((null q) - `(,(let ((x `(,a))) - (rplacd x x) x))) - ((null (car q)) - (let ((x `(,a))) - (rplacd x x) - (rplaca q x))) - (t (rplaca q - (rplacd (car q) `(,a .,(cdr (car q)))))))) - -(defun create-structure (n) - (declare (fixnum n)) - (let ((a `(,(make-node)))) - (do ((m (the fixnum (1- n)) (the fixnum (1- m))) - (p a)) - ((= (the fixnum m) 0) (setq a `(,(rplacd p a))) - (do ((unused a) - (used (add (traverse-remove 0 a) ())) - (x) (y)) - ((null (car unused)) - (find-root (traverse-select 0 used) n)) - (setq x (traverse-remove (rem (traverse-random) n) unused)) - (setq y (traverse-select (rem (traverse-random) n) used)) - (add x used) - (setf (node-sons y) `(,x .,(node-sons y))) - (setf (node-parents x) `(,y .,(node-parents x))) )) - (declare (fixnum m)) - (push (make-node) a)))) - -(defun find-root (node n) - (declare (fixnum n)) - (do ((n n (the fixnum (1- n)))) - ((= (the fixnum n) 0) node) - (declare (fixnum n)) - (cond ((null (node-parents node)) - (return node)) - (t (setq node (car (node-parents node))))))) - -(defun travers (node mark) - (cond ((eq (node-mark node) mark) ()) - (t (setf (node-mark node) mark) - (setq count (the fixnum (1+ count))) - (setf (node-entry1 node) (not (node-entry1 node))) - (setf (node-entry2 node) (not (node-entry2 node))) - (setf (node-entry3 node) (not (node-entry3 node))) - (setf (node-entry4 node) (not (node-entry4 node))) - (setf (node-entry5 node) (not (node-entry5 node))) - (setf (node-entry6 node) (not (node-entry6 node))) - (do ((sons (node-sons node) (cdr sons))) - ((null sons) ()) - (travers (car sons) mark))))) - -(defun traverse (root) - (let ((count 0)) - (travers root (setq marker (not marker))) - count)) - -(defun init-traverse() - (prog1 nil (setq root (create-structure 100.)))) - -(defun run-traverse () - (do ((i 50. (the fixnum (1- i)))) - ((= (the fixnum i) 0)) - (declare (fixnum i)) - (traverse root) - (traverse root) - (traverse root) - (traverse root) - (traverse root))) - -(defun time-init-traverse () - (time (init-traverse))) - -(defun time-run-traverse () - (time (run-traverse))) - -(proclaim '(start-block triangle)) - -;;; TRIANG -- Board game benchmark. - -(defvar board (make-array 16. :initial-element 1)) -(setf (aref board 5) 0) - -(defvar triang-sequence (make-array 14. :initial-element 0)) -(defvar triang-a (make-array 37. :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4 7 11 8 12 - 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 6))) -(defvar triang-b (make-array 37. :initial-contents '(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 - 2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 5))) -(defvar triang-c (make-array 37. :initial-contents '(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 - 1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4))) -(defvar answer) -(defvar final) - -(proclaim '(type simple-vector board triang-sequence triang-a triang-b triang-c)) - -(defun last-position () - (do ((i 1 (1+ i))) - ((= i 16.) 0) - (declare (fixnum i)) - (if (= 1 (the fixnum (aref board i))) - (return i)))) - -(defun try (i depth) - (declare (fixnum i depth)) - (cond ((= depth 14) - (let ((lp (last-position))) - (unless (member lp final) - (push lp final))) - (push (cdr (coerce (the simple-vector triang-sequence) 'list)) - answer) t) ; this is a hack to replace LISTARRAY - ((and (= 1 (the fixnum (aref board (aref triang-a i)))) - (= 1 (the fixnum (aref board (aref triang-b i)))) - (= 0 (the fixnum (aref board (aref triang-c i))))) - (setf (aref board (aref triang-a i)) 0) - (setf (aref board (aref triang-b i)) 0) - (setf (aref board (aref triang-c i)) 1) - (setf (aref triang-sequence depth) i) - (do ((j 0 (1+ j)) - (depth (1+ depth))) - ((or (= j 36.) - (try j depth)) ()) - (declare (fixnum j depth))) - (setf (aref board (aref triang-a i)) 1) - (setf (aref board (aref triang-b i)) 1) - (setf (aref board (aref triang-c i)) 0) ()))) - -(defun triangle (i) - (let ((answer ()) - (final ())) - (try i 1))) - -(defun time-triangle () - (time (triangle 22))) diff --git a/benchmarks/gabriel/ctak.lisp b/benchmarks/gabriel/ctak.lisp deleted file mode 100644 index de3e6dd8dcae6e43c4044752f4993b40a67b2e31..0000000000000000000000000000000000000000 --- a/benchmarks/gabriel/ctak.lisp +++ /dev/null @@ -1,28 +0,0 @@ -(in-package "USER") - -;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility. - -(defun ctak (x y z) - (declare (fixnum x y z)) - (catch 'ctak (ctak-aux x y z))) - -(defun ctak-aux (x y z) - (declare (fixnum x y z)) - (cond ((not (< y x)) - (throw 'ctak z)) - (t (ctak-aux - (catch 'ctak - (ctak-aux (the fixnum (1- x)) - y - z)) - (catch 'ctak - (ctak-aux (the fixnum (1- y)) - z - x)) - (catch 'ctak - (ctak-aux (the fixnum (1- z)) - x - y)))))) - -(defun time-ctak () - (time (ctak 18 12 6))) diff --git a/benchmarks/gabriel/fft.lisp b/benchmarks/gabriel/fft.lisp deleted file mode 100644 index 0d81d5493bd5b95efaea0216906df2c719c26783..0000000000000000000000000000000000000000 --- a/benchmarks/gabriel/fft.lisp +++ /dev/null @@ -1,102 +0,0 @@ -(in-package "USER") -(proclaim '(optimize (safety 0) (speed 3) (space 0))) - -;;; FFT -- This is an FFT benchmark written by Harry Barrow. It tests a -;;; variety of floating point operations, including array references. - -(defvar re (make-array 1025. :element-type 'single-float :initial-element 0.0)) -(defvar im (make-array 1025. :element-type 'single-float :initial-element 0.0)) - - -;areal = real part -;aimag = imaginary part -(defun fft (areal aimag) - (declare (type (simple-array single-float (1025)) areal aimag)) - (prog ((ar areal) - (ai aimag) - (i 0) - (j 0) - (k 0) - (m 0) - (n 0) - (le 0) - (le1 0) - (ip 0) - (nv2 0) - (ur 0.0) - (ui 0.0) - (wr 0.0) - (wi 0.0) - (tr 0.0) - (ti 0.0)) - (declare (fixnum i j k m n le le1 ip nv2) - (single-float ur ui wr wi tr ti)) - (setq n (array-dimension ar 0) - n (1- n) - nv2 (floor n 2) - m 0 ;compute m = log(n) - i 1) - l1 (cond ((< i n) - (setq m (1+ m) - i (+ i i)) - (go l1))) - (cond ((not (equal n (expt 2 m))) - (princ "error ... array size not a power of two.") - (read) - (return (terpri)))) - (setq j 1 ;interchange elements - i 1) ;in bit-reversed order - l3 (cond ((< i j) - (setq tr (aref ar j) - ti (aref ai j)) - (setf (aref ar j) (aref ar i)) - (setf (aref ai j) (aref ai i)) - (setf (aref ar i) tr) - (setf (aref ai i) ti))) - (setq k nv2) - l6 (cond ((< k j) - (setq j (- j k) - k (/ k 2)) - (go l6))) - (setq j (+ j k) - i (1+ i)) - (cond ((< i n) - (go l3))) - (do ((l 1 (1+ l))) - ((> l m)) ;loop thru stages - (declare (fixnum l)) - (setq le (expt 2 l) - le1 (floor le 2) - ur 1.0 - ui 0.0 - wr (cos (/ 3.14159265 (float le1))) - wi (sin (/ 3.14159265 (float le1)))) - (do ((j 1 (1+ j))) - ((> j le1)) ;loop thru butterflies - (declare (fixnum j)) - (do ((i j (+ i le))) - ((> i n)) ;do a butterfly - (declare (fixnum i)) - (setq ip (+ i le1) - tr (- (* (aref ar ip) ur) - (* (aref ai ip) ui)) - ti (+ (* (aref ar ip) ui) - (* (aref ai ip) ur))) - (setf (aref ar ip) (- (aref ar i) tr)) - (setf (aref ai ip) (- (aref ai i) ti)) - (setf (aref ar i) (+ (aref ar i) tr)) - (setf (aref ai i) (+ (aref ai i) ti)))) - (setq tr (- (* ur wr) (* ui wi)) - ti (+ (* ur wi) (* ui wr)) - ur tr - ui ti)) - (return t))) - -(defmacro fft-bench () - '(do ((ntimes 0 (1+ ntimes))) - ((= ntimes 10.)) - (declare (fixnum ntimes)) - (fft re im))) - -(defun time-fft () - (time (fft-bench))) diff --git a/benchmarks/gabriel/puzzle.c b/benchmarks/gabriel/puzzle.c deleted file mode 100644 index 2e2a598f0f03e1240cd82b53ea59ced8c2fd8704..0000000000000000000000000000000000000000 --- a/benchmarks/gabriel/puzzle.c +++ /dev/null @@ -1,230 +0,0 @@ -# define size 511 -# define classMax 3 -# define typeMax 12 -# define d 8 -# define true 1 -# define false 0 - -static int class[typeMax+1]; -static int pieceCount[classMax+1]; -static int pieceMax[typeMax+1]; -static int puzzle[size+1]; -static int p[typeMax+1][size+1]; -static int kount,clock; - - -fit(i,j) -int i,j; - { - register k,plim; - plim = pieceMax[i]; - for (k=0; k <= plim; k++) - { - if (p[i][k]) - { - if (puzzle[j+k]) return (false); - } - } - return(true); - } - -int place (i,j) -int i,j; - { - register k,plim; - plim = pieceMax[i]; - for (k = 0; k <= plim; k++) - if (p[i][k]) puzzle[j+k] = true; - pieceCount[class[i]] = pieceCount[class[i]] - 1; - for (k=j; k <= size; k++) - if (!puzzle[k]) - { - return(k); - } - printf("Puzzle filled.\n"); - return(0); - } - -remove(i,j) -int i,j; - { - register k,plim; - plim = pieceMax[i]; - for (k=0; k<=plim; k++) - if (p[i][k]) puzzle[j+k] = false; - pieceCount[class[i]] = pieceCount[class[i]] + 1; - } - -trial(j) -int j; - { - register i,k; - for (i = 0; i <= typeMax; i++) - if (pieceCount[class[i]] != 0) - if (fit (i, j)) - { - k = place (i, j); - if (trial(k)||(k == 0)) - { -/* printf("piece %d at %d\n",i+1,k+1); */ - kount = kount + 1; - return(true); - } - else remove (i, j); - } - kount = kount + 1; - return(false); - } - -main() - { - register i,j,k,m,n; - -/* printf("starting\n"); */ - - for (m = 0; m<=size; m++) - puzzle[m] = true; - - for (i=1; i <= 5; i++) - for (j=1; j<=5; j++) - for (k=1; k<=5 ; k++) - puzzle[i+d*(j+d*k)] = false; - - for (i=0;i<=typeMax;i++) - for (j=0;j<=size;j++) - p[i][j] = false; - - for (i=0;i<=3;i++) - for (j=0;j<=1;j++) - for (k = 0;k<=0;k++) - p[0][i+d*(j+d*k)] = true; - - class[0] = 0; - pieceMax[0] = 3+d*1+d*d*0; - - for (i=0;i<=1;i++) - for (j=0;j<=0;j++) - for (k=0;k<=3;k++) - p[1][i+d*(j+d*k)] = true; - - class[1] = 0; - pieceMax[1] = 1+d*0+d*d*3; - - for (i=0;i<=0;i++) - for (j=0;j<=3;j++) - for (k=0;k<=1;k++) - p[2][i+d*(j+d*k)] = true; - - class[2] = 0; - pieceMax[2] = 0+d*3+d*d*1; - - for (i=0;i<=1;i++) - for (j=0;j<=3;j++) - for (k=0;k<=0;k++) - p[3][i+d*(j+d*k)] = true; - - class[3] = 0; - pieceMax[3] = 1+d*3+d*d*0; - - for (i=0;i<=3;i++) - for (j=0;j<=0;j++) - for (k=0;k<=1;k++) - p[4][i+d*(j+d*k)] = true; - - class[4] = 0; - pieceMax[4] = 3+d*0+d*d*1; - - for (i=0;i<=0;i++) - for (j=0;j<=1;j++) - for (k=0;k<=3;k++) - p[5][i+d*(j+d*k)] = true; - - class[5] = 0; - pieceMax[5] = 0+d*1+d*d*3; - - for (i=0;i<=2;i++) - for (j=0;j<=0;j++) - for (k=0;k<=0;k++) - p[6][i+d*(j+d*k)] = true; - - class[6] = 1; - pieceMax[6] = 2+d*0+d*d*0; - - for (i=0;i<=0;i++) - for (j=0;j<=2;j++) - for (k=0;k<=0;k++) - p[7][i+d*(j+d*k)] = true; - - class[7] = 1; - pieceMax[7] = 0+d*2+d*d*0; - - for (i=0;i<=0;i++) - for (j=0;j<=0;j++) - for (k=0;k<=2;k++) - p[8][i+d*(j+d*k)] = true; - - class[8] = 1; - pieceMax[8] = 0+d*0+d*d*2; - - for (i=0;i<=1;i++) - for (j=0;j<=1;j++) - for (k=0;k<=0;k++) - p[9][i+d*(j+d*k)] = true; - - class[9] = 2; - pieceMax[9] = 1+d*1+d*d*0; - - for (i=0;i<=1;i++) - for (j=0;j<=0;j++) - for (k=0;k<=1;k++) - p[10][i+d*(j+d*k)] = true; - - class[10] = 2; - pieceMax[10] = 1+d*0+d*d*1; - - for (i=0;i<=0;i++) - for (j=0;j<=1;j++) - for (k=0;k<=1;k++) - p[11][i+d*(j+d*k)] = true; - - class[11] = 2; - pieceMax[11] = 0+d*1+d*d*1; - - for (i=0;i<=1;i++) - for (j=0;j<=1;j++) - for (k=0;k<=1;k++) - p[12][i+d*(j+d*k)] = true; - - class[12] = 3; - pieceMax[12] = 1+d*1+d*d*1; - pieceCount[0] = 13; - pieceCount[1] = 3; - pieceCount[2] = 1; - pieceCount[3] = 1; - m = 1+d*(1+d*1); - kount = 0; - - if (fit(0, m)) - { - n = place(0, m) ; - } - else - { - printf("error 1\n"); - } - -/* printf("n = %d n\n",n); */ - - if (trial(n)) - { - printf("success in %d trials\n", kount); - } - else - { - printf("failure\n"); - } - -/* printf("elapsed user time:\n"); */ - } - - diff --git a/benchmarks/gabriel/puzzle.lisp b/benchmarks/gabriel/puzzle.lisp deleted file mode 100644 index 4920c9025f12f5fcf67b784253f87801448e69c6..0000000000000000000000000000000000000000 --- a/benchmarks/gabriel/puzzle.lisp +++ /dev/null @@ -1,167 +0,0 @@ -;;;; -*- Mode: Lisp; Package: User -*- -;;;; - -(in-package "USER") -(proclaim '(optimize (safety 0) (speed 3))) - -;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal. - -(defconstant size 511) -(defconstant classmax 3) -(defconstant typemax 12) - -(defvar iii 0) -(defvar kount 0) -(defconstant dee 8) - -(proclaim '(type fixnum size classmax typemax iii kount dee)) - -(defvar piececount (make-array (1+ classmax) :initial-element 0)) -(defvar class (make-array (1+ typemax) :initial-element 0)) -(defvar piecemax (make-array (1+ typemax) :initial-element 0)) -(defvar puzzle (make-array (1+ size))) -(defvar p (make-array (list (1+ typemax) (1+ size)))) - -(proclaim '(type simple-vector piececount class piecemax puzzle)) - -(defun fit (i j) - (declare (fixnum i j)) - (let ((end (svref piecemax i))) - (do ((k 0 (1+ k))) - ((> k end) t) - (declare (fixnum k)) - (cond ((aref p i k) - (cond ((svref puzzle (+ j k)) - (return nil)))))))) - -(defun place (i j) - (declare (fixnum i j)) - (let ((end (svref piecemax i))) - (do ((k 0 (1+ k))) - ((> k end)) - (declare (fixnum k)) - (cond ((aref p i k) - (setf (svref puzzle (+ j k)) t)))) - (setf (svref piececount (svref class i)) - (- (svref piececount (svref class i)) 1)) - (do ((k j (1+ k))) - ((> k size) -; (terpri) -; (princ "Puzzle filled") - 0) - (declare (fixnum k)) - (cond ((not (svref puzzle k)) - (return k)))))) - -(defun puzzle-remove (i j) - (declare (fixnum i j)) - (let ((end (svref piecemax i))) - (do ((k 0 (1+ k))) - ((> k end)) - (declare (fixnum k)) - (cond ((aref p i k) - (setf (svref puzzle (+ j k)) nil)))) - (setf (svref piececount (svref class i)) - (+ (svref piececount (svref class i)) 1)))) - -(defun trial (j) - (declare (fixnum j)) - (let ((k 0)) - (declare (fixnum k)) - (do ((i 0 (1+ i))) - ((> i typemax) (setq kount (1+ kount)) nil) - (declare (fixnum i)) - (cond ((not (= (svref piececount (svref class i)) 0)) - (cond ((fit i j) - (setq k (place i j)) - (cond ((or (trial k) - (= k 0)) -; (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1)) - (setq kount (+ kount 1)) - (return t)) - (t (puzzle-remove i j)))))))))) - -(defun definepiece (iclass ii jj kk) - (declare (fixnum ii jj kk)) - (let ((index 0)) - (do ((i 0 (1+ i))) - ((> i ii)) - (declare (fixnum i)) - (do ((j 0 (1+ j))) - ((> j jj)) - (declare (fixnum j)) - (do ((k 0 (1+ k))) - ((> k kk)) - (declare (fixnum k)) - (setq index (+ i (* dee (+ j (* dee k))))) - (setf (aref p iii index) t)))) - (setf (svref class iii) iclass) - (setf (svref piecemax iii) index) - (cond ((not (= iii typemax)) - (setq iii (+ iii 1)))))) - -(defun puzzle () - (do ((m 0 (1+ m))) - ((> m size)) - (declare (fixnum m)) - (setf (svref puzzle m) t)) - (do ((i 1 (1+ i))) - ((> i 5)) - (declare (fixnum i)) - (do ((j 1 (1+ j))) - ((> j 5)) - (declare (fixnum j)) - (do ((k 1 (1+ k))) - ((> k 5)) - (declare (fixnum k)) - (setf (svref puzzle (+ i (* dee (+ j (* dee k))))) nil)))) - (do ((i 0 (1+ i))) - ((> i typemax)) - (declare (fixnum i)) - (do ((m 0 (1+ m))) - ((> m size)) - (declare (fixnum m)) - (setf (aref p i m) nil))) - (setq iii 0) - (definePiece 0 3 1 0) - (definePiece 0 1 0 3) - (definePiece 0 0 3 1) - (definePiece 0 1 3 0) - (definePiece 0 3 0 1) - (definePiece 0 0 1 3) - - (definePiece 1 2 0 0) - (definePiece 1 0 2 0) - (definePiece 1 0 0 2) - - (definePiece 2 1 1 0) - (definePiece 2 1 0 1) - (definePiece 2 0 1 1) - - (definePiece 3 1 1 1) - - (setf (svref pieceCount 0) 13.) - (setf (svref pieceCount 1) 3) - (setf (svref pieceCount 2) 1) - (setf (svref pieceCount 3) 1) - (let ((m (+ 1 (* dee (+ 1 dee)))) - (n 0) - (kount 0)) - (declare (fixnum m n kount)) - (cond ((fit 0 m) (setq n (place 0 m))) - (t - (write-string " -Error."))) - (cond ((trial n) - (write-string " -Success in ") - (print kount) - (write-string " trials.")) - (t - (write-string " -Failure.") - )))) - - -(defun time-puzzle () - (time (puzzle))) diff --git a/benchmarks/gabriel/tak.lisp b/benchmarks/gabriel/tak.lisp deleted file mode 100644 index da24990a080fd5b141a8bb9172427eb523ea74ba..0000000000000000000000000000000000000000 --- a/benchmarks/gabriel/tak.lisp +++ /dev/null @@ -1,28 +0,0 @@ -;;; TAK -- A vanilla version of the TAKeuchi function. - -(in-package "USER") -(proclaim '(optimize (speed 1) (safety 1) (brevity 0))) - -(defun tak (x y z) - (declare (fixnum x y z)) - (if (not (< y x)) - z - (tak (tak (the fixnum (1- x)) y z) - (tak (the fixnum (1- y)) z x) - (tak (the fixnum (1- z)) x y)))) - -(defun time-tak () - (time (tak 18 12 6))) - -(proclaim '(optimize (speed 3) (safety 0))) - -(defun fast-tak (x y z) - (declare (fixnum x y z)) - (if (not (< y x)) - z - (fast-tak (fast-tak (the fixnum (1- x)) y z) - (fast-tak (the fixnum (1- y)) z x) - (fast-tak (the fixnum (1- z)) x y)))) - -(defun time-fast-tak () - (time (fast-tak 18 12 6))) diff --git a/benchmarks/gabriel/triang.lisp b/benchmarks/gabriel/triang.lisp deleted file mode 100644 index 5cb59a1b6a4a4f99b881bd0be6df72182b2e131c..0000000000000000000000000000000000000000 --- a/benchmarks/gabriel/triang.lisp +++ /dev/null @@ -1,57 +0,0 @@ - -;;; TRIANG -- Board game benchmark. - -(defvar board (make-array 16. :initial-element 1)) -(setf (aref board 5) 0) - -(defvar sequence (make-array 14. :initial-element 0)) -(defvar a (make-array 37. :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4 7 11 8 12 - 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 6))) -(defvar b (make-array 37. :initial-contents '(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 - 2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 5))) -(defvar c (make-array 37. :initial-contents '(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 - 1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4))) -(defvar answer) -(defvar final) - -(proclaim '(type simple-vector board sequence a b c)) - -(defun last-position () - (do ((i 1 (1+ i))) - ((= i 16.) 0) - (declare (fixnum i)) - (if (= 1 (the fixnum (aref board i))) - (return i)))) - -(defun try (i depth) - (declare (fixnum i depth)) - (cond ((= depth 14) - (let ((lp (last-position))) - (unless (member lp final) - (push lp final))) - (push (cdr (coerce (the simple-vector sequence) 'list)) - answer) t) ; this is a hack to replace LISTARRAY - ((and (= 1 (the fixnum (aref board (aref a i)))) - (= 1 (the fixnum (aref board (aref b i)))) - (= 0 (the fixnum (aref board (aref c i))))) - (setf (aref board (aref a i)) 0) - (setf (aref board (aref b i)) 0) - (setf (aref board (aref c i)) 1) - (setf (aref sequence depth) i) - (do ((j 0 (1+ j)) - (depth (1+ depth))) - ((or (= j 36.) - (try j depth)) ()) - (declare (fixnum j depth))) - (setf (aref board (aref a i)) 1) - (setf (aref board (aref b i)) 1) - (setf (aref board (aref c i)) 0) ()))) - -(defun triangle (i) - (let ((answer ()) - (final ())) - (try i 1))) -#| -(defun time-triangle () - (time (triangle 22))) -|# diff --git a/benchmarks/oprofile.lisp b/benchmarks/oprofile.lisp deleted file mode 100644 index 104cc4c5ec4deafd130dc1b86056a769fbbeb4fb..0000000000000000000000000000000000000000 --- a/benchmarks/oprofile.lisp +++ /dev/null @@ -1,317 +0,0 @@ -;;; -*- Mode: Lisp; Package: Profile; Log: profile.log -*- -;;; -;;; This code has been placed in the public domain by the author. -;;; It is distributed without warranty of any kind. -;;; -;;; Description: Simple profiling facility. -;;; -;;; Author: Skef Wholey, Rob MacLachlan -;;; -;;; Current maintainer: Rob MacLachlan -;;; -;;; Address: Carnegie-Mellon University -;;; Computer Science Department -;;; Pittsburgh, PA 15213 -;;; -;;; Net address: ram@cs.cmu.edu -;;; -;;; Copyright status: Public domain. -;;; -;;; Compatibility: Runs in any valid Common Lisp. Three small implementation- -;;; dependent changes can be made to improve performance and prettiness. -;;; -;;; Dependencies: The macro Quickly-Get-Time and the function -;;; Required-Arguments should probably be tailored to the implementation for -;;; the best results. They will default to working, albeit inefficent, forms -;;; in non-CMU implementations. The Total-Consing macro is used to profile -;;; consing: in unknown implementations 0 will be used. -;;; See the "Implementation Parameters" section. -;;; -;;; Note: a timing overhead factor is computed at load time. This will be -;;; incorrect if profiling code is run in a different environment than this -;;; file was loaded in. For example, saving a core image on a high -;;; performance machine and running it on a low performance one will result -;;; in use of an erroneously small timing overhead factor. -;;; -(in-package "OPROFILE") - -(export '(*timed-functions* profile unprofile report-time reset-time)) - - - -(progn - #-:cmu - (eval-when (compile eval) - (warn - "You may want to supply an implementation-specific ~ - Quickly-Get-Time function.")) - - (defconstant quick-time-units-per-second internal-time-units-per-second) - - (defmacro quickly-get-time () - `(get-internal-run-time))) - - -;;; To avoid unnecessary consing in the "encapsulation" code, we find out the -;;; number of required arguments, and use &rest to capture only non-required -;;; arguments. The function Required-Arguments returns two values: the first -;;; is the number of required arguments, and the second is T iff there are any -;;; non-required arguments (e.g. &optional, &rest, &key). - -#+nil -(defun required-arguments (name) - (let ((function (symbol-function name))) - (if (eql (system:%primitive get-type function) system:%function-type) - (let ((min (ldb system:%function-min-args-byte - (system:%primitive header-ref function - system:%function-min-args-slot))) - (max (ldb system:%function-max-args-byte - (system:%primitive header-ref function - system:%function-max-args-slot))) - (rest (ldb system:%function-rest-arg-byte - (system:%primitive header-ref function - system:%function-rest-arg-slot))) - (key (ldb system:%function-keyword-arg-byte - (system:%primitive header-ref function - system:%function-keyword-arg-slot)))) - (values min (or (/= min max) (/= rest 0) (/= key 0)))) - (values 0 t)))) - - -#-:cmu -(progn - (eval-when (compile eval) - (warn - "You may want to add an implementation-specific Required-Arguments function.")) - (eval-when (load eval) - (defun required-arguments (name) - (declare (ignore name)) - (values 0 t)))) - - - -;;; The Total-Consing macro is called to find the total number of bytes consed -;;; since the beginning of time. - -#+cmu -(defmacro total-consing () '(ext:get-bytes-consed)) - -#-:cmu -(progn - (eval-when (compile eval) - (warn "No consing will be reported unless a Total-Consing function is ~ - defined.")) - - (defmacro total-consing () '0)) - - -(defvar *timed-functions* () - "List of functions that are currently being timed.") - - -(defmacro profile (&rest names) - "Wraps profiling code around the named functions. The Names are not evaluated, - as in Trace." - (do ((names names (cdr names)) - (stuff ())) - ((null names) - ;; Keep the compiler quiet by sending standard output to bit bucket. - `(compiler-let (#|(*standard-output* (make-broadcast-stream))|#) - ,@stuff - (values))) - (push (profile-1-function (car names)) stuff))) - - -;;; A function is profiled by replacing its definition with a closure created by -;;; the following function. The closure records the starting time, calls the -;;; original function, and records finishing time. Other closures are used to -;;; perform various operations on the encapsulated function. - -(defun profile-1-function (name) - (multiple-value-bind (min-args optionals-p) - (required-arguments name) - (let ((required-args ())) - (dotimes (i min-args) - (push (gensym) required-args)) - `(funcall - (compile - nil - ;; Use ' instead of #' below so guaranteed null lexical environment. - '(lambda () - (let* ((time 0) - (count 0) - (consed 0) - (old-definition (symbol-function ',name)) - (new-definition - #'(lambda (,@required-args - ,@(if optionals-p - `(&rest optional-args))) - (incf count) - (let ((old-time time) - (start-time (quickly-get-time)) - (old-consed consed) - (start-consed (total-consing))) - (multiple-value-prog1 - ,(if optionals-p - `(apply old-definition - ,@required-args optional-args) - `(funcall old-definition ,@required-args)) - (setq time - (+ old-time (- (quickly-get-time) - start-time))) - (setq consed - (+ old-consed (- (total-consing) - start-consed)))))))) - (pushnew ',name *timed-functions*) - (setf (get ',name 'read-time) - #'(lambda () - (values count time consed)) - (get ',name 'reset-time) - #'(lambda () - (setq count 0) - (setq time 0) - (setq consed 0) - t) - (symbol-function ',name) - new-definition - (get ',name 'reset-definition) - #'(lambda () - (remprop ',name 'read-time) - (remprop ',name 'reset-time) - (if (eq (symbol-function ',name) new-definition) - (setf (symbol-function ',name) old-definition) - (warn "The function ~S was redefined without ~ - unprofiling and reprofiling.~%~ - Timing figures have not been updated ~ - since that redefinition." - ',name)) - (remprop ',name 'reset-definition) - (setq *timed-functions* - (delete ',name *timed-functions*)) - nil))))))))) - - -(defmacro unprofile (&rest names) - "Unwraps the profiling code around the named functions. Names defaults to the - list of all currently profiled functions." - `(dolist (name ,(if names `',names '*timed-functions*) (values)) - (unprofile-1-function name))) - -(defun unprofile-1-function (name) - (if (get name 'reset-definition) - (funcall (get name 'reset-definition)) - (error "~S is not a function being profiled." name))) - - -(defmacro report-time (&rest names) - "Reports the time spent in the named functions. Names defaults to the list of - all currently profiled functions." - `(%report-times ,(if names `',names '*timed-functions*))) - - -;;; We average the timing overhead over this many iterations. -;;; -(defconstant timer-overhead-iterations 5000) - -;;; Compute-Time-Overhead -- Internal -;;; -;;; Return as a float the total number of seconds it takes to call both -;;; Quickly-Get-Time and Total-Consing together, plus a funcall thrown in -;;; to represent some of the other overhead. We also return a something -;;; computed from the results in order to frustrate clever compilers. -;;; -(defun compute-time-overhead-aux (x) - x) -(proclaim '(notinline compute-time-overhead-aux)) -;;; -(defun compute-time-overhead () - (let ((foo 0) - (fun (symbol-function 'compute-time-overhead-aux)) - (start (quickly-get-time))) - (funcall fun nil) - (dotimes (i timer-overhead-iterations) - (setq foo (logxor (funcall fun (quickly-get-time)) - (total-consing) - foo))) - (let ((now (quickly-get-time))) - (values - (/ (float (- now start)) - (float timer-overhead-iterations) - (float quick-time-units-per-second)) - foo)))) - - -(defvar *time-overhead* (compute-time-overhead)) - -(defstruct (time-info - (:constructor make-time-info (name calls time consing))) - name - calls - time - consing) - - -(defun %report-times (names) - (let ((info ()) - (no-call ())) - (dolist (name names) - (multiple-value-bind - (calls time consing) - (funcall (or (get name 'read-time) - (error "~S is not profiled."))) - (if (zerop calls) - (push name no-call) - (let ((compensated - (- (/ (float time) (float quick-time-units-per-second)) - (* *time-overhead* (float calls))))) - (push (make-time-info name calls - (if (minusp compensated) 0.0 compensated) - consing) - info))))) - - (setq info (sort info #'>= :key #'time-info-time)) - - (format *trace-output* - "~& Seconds | Consed | Calls | Sec/Call | Name:~@ - ------------------------------------------------------~%") - - (let ((total-time 0.0) - (total-consed 0) - (total-calls 0)) - (dolist (time info) - (incf total-time (time-info-time time)) - (incf total-calls (time-info-calls time)) - (incf total-consed (time-info-consing time)) - (format *trace-output* - "~10,3F | ~9:D | ~7:D | ~10,5F | ~S~%" - (time-info-time time) - (time-info-consing time) - (time-info-calls time) - (/ (time-info-time time) (float (time-info-calls time))) - (time-info-name time))) - (format *trace-output* - "------------------------------------------------------~@ - ~10,3F | ~9:D | ~7:D | | Total~%" - total-time total-consed total-calls) - - (format *trace-output* - "~%Estimated total profiling overhead: ~4,2F seconds~%" - (* *time-overhead* (float total-calls) 2.0))) - - (when no-call - (format *trace-output* - "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" - (sort no-call #'string< :key #'symbol-name))) - (values))) - - -(defmacro reset-time (&rest names) - "Resets the time counter for the named functions. Names defaults to the list - of all currently profiled functions." - `(dolist (name ,(if names `',names '*timed-functions*) (values)) - (reset-1-time name))) - -(defun reset-1-time (name) - (if (get name 'reset-time) - (funcall (get name 'reset-time)) - (error "~S is not a function being profiled."))) diff --git a/benchmarks/richards/RICHARDS_MAIL b/benchmarks/richards/RICHARDS_MAIL deleted file mode 100644 index 34e3e6a68d154a12006efeb1415603b33e42e76d..0000000000000000000000000000000000000000 --- a/benchmarks/richards/RICHARDS_MAIL +++ /dev/null @@ -1,63 +0,0 @@ -Newsgroups: comp.lang.smalltalk -Distribution: comp -Subject: Smalltalk vs. C(++) performance - -Executive summary: a non-trivial benchmark written in C++ and -Smalltalk is available from otis.stanford.edu; please send me your -results. -------------------------------------------------------------------- - -As some have pointed out, it is difficult to compare the runtime -performance of Smalltalk programs with the performance of equivalent C -programs. One reason for this is that for most non-trivial programs -there is no equivalent program written in the other language (because -it would be a non-trivial effort to write it). - -The "best" benchmark I know of is the Richards benchmark, an operating -system simulation. It is written in an object-oriented style, uses -polymorphism, and is reasonably non-trivial (700 lines). It's -probably not the world's greatest benchmark, but better than -micro-benchamrks, and it is available in Smalltalk, Self, T (an -object-oriented version of Scheme) and C++. - -[Historical note: the Richards benchmark was originally written in -BCPL by Mark Richards. Many thanks to L. Peter Deutsch for the -Smalltalk version.] - -The sources for Richards are available from otis.stanford.edu -(36.22.0.201) in /pub/benchmarks. I would be interested in -comparisons of the performance of the C++ and Smalltalk versions on -various systems. We measured it a while ago for the Sun-3/4 versions -of PP 2.4, and the difference was about a factor of 10. - -Disclaimer: Richards is *not* a typical application: it is relatively -small and contains no graphics or other user interaction. Thus it may -not reflect the relative performance of Your Own Real-World (TM) -Application, but I think it tests the efficiency of the basic language -mechanisms fairly well. If you think you have a better benchmark -which is available both in ST-80 and C (or Fortran or...), please let -me know. - -******* ADVERTISEMENT ******** - -The goal of the Self project at Stanford is to improve the performance -of dynamically-typed object-oriented languages such as Smalltalk and -Self. Though similar to Smalltalk, Self is simpler and more flexible. -Our current system runs significantly faster than any Smalltalk -implementation we know of. For example, here are the numbers for -Richards on a Sun-4/260: - - C++ (-O2) 730ms - Self 2160ms (Nov'90; 1940ms for an experimental system) - PP ST-80 2.4 7740ms - T 9800ms (8100ms with some not-so-kosher "tuning") - -[On some other benchmarks, the Stanford Integer Benchmarks, Self -actually looks even better, running at around 60-70% of the speed of -optimized C.] - -More information (papers, documentation, how to get the current system) -is available via anonymous ftp from otis.stanford.edu. - -******* END OF ADVERTISEMENT ******** - diff --git a/benchmarks/richards/cbase.h b/benchmarks/richards/cbase.h deleted file mode 100644 index d88baddea20adcb80c31521525e966b400859aa8..0000000000000000000000000000000000000000 --- a/benchmarks/richards/cbase.h +++ /dev/null @@ -1,15 +0,0 @@ -/* cbase.h */ - -#ifndef CBASE - -#define CBASE - -#define BOOLEAN int -#define TRUE 1 -#define FALSE 0 - -#include <stdio.h> -#include <ctype.h> -#include <assert.h> - -#endif diff --git a/benchmarks/richards/rbase.h b/benchmarks/richards/rbase.h deleted file mode 100644 index 6f4abbbaeaf754379d44bd3137048d9db9b8afc0..0000000000000000000000000000000000000000 --- a/benchmarks/richards/rbase.h +++ /dev/null @@ -1,16 +0,0 @@ -/* rbase.h */ -#ifndef RBASE - -#define RBASE - -typedef enum {DevicePacket, WorkPacket} - PacketKind; -typedef enum {Idler, Worker, HandlerA, HandlerB, DeviceA, DeviceB} - Identity; - -#define NTASKS 6 /* # elements of Identity */ - /* = # of tasks */ -#define NoWork NULL -#define NoTask NULL - -#endif diff --git a/benchmarks/richards/richards.c b/benchmarks/richards/richards.c deleted file mode 100644 index 7c223cb3f47f4ef9a33248ff4bcd6482f8d9f954..0000000000000000000000000000000000000000 --- a/benchmarks/richards/richards.c +++ /dev/null @@ -1,235 +0,0 @@ -/* richards.c - Richards Benchmark in C++ */ -/* uh 2/2/89 */ - -#include <time.h> -#define clock_t long /* because Sun library isn't ANSI */ -#define CLK_TCK 1000000 -#include "richards.h" - - -/* -// creation -*/ - -void RBench::CreateDevice (Identity id, int prio, Packet *work, - TaskState *state) -{ DeviceTaskRec *data; - TaskControlBlock *t; - - data = new DeviceTaskRec; - t = new DeviceTCB(taskList, id, prio, work, state, data); - EnterTask(id, t); -} - - -void RBench::CreateHandler(Identity id, int prio, Packet *work, - TaskState *state) -{ HandlerTaskRec *data; - TaskControlBlock *t; - - data = new HandlerTaskRec; - t = new HandlerTCB(taskList, id, prio, work, state, data); - EnterTask(id, t); -} - - -void RBench::CreateIdler (Identity id, int prio, Packet *work, - TaskState *state) -{ IdleTaskRec *data; - TaskControlBlock *t; - - data = new IdleTaskRec; - t = new IdlerTCB(taskList, id, prio, work, state, data); - EnterTask(id, t); -} - - -void RBench::CreateWorker (Identity id, int prio, Packet *work, - TaskState *state) -{ WorkerTaskRec *data; - TaskControlBlock *t; - - data = new WorkerTaskRec; - t = new WorkerTCB(taskList, id, prio, work, state, data); - EnterTask(id, t); -} - - -void RBench::EnterTask(Identity id, TaskControlBlock *t) -{ - taskList = t; - taskTable[id] = t; -} - - -/* -//private -*/ - -TaskControlBlock *RBench::FindTask(Identity id) -{ TaskControlBlock *t; - - t = taskTable[id]; - if (t == NULL) printf("***error: FindTask failed! "); - return t; -} - - -TaskControlBlock *RBench::HoldSelf() -{ - holdCount++; - currentTask->SetTaskHolding(TRUE); - return currentTask->Link(); -} - - -TaskControlBlock *RBench::QueuePacket(Packet *p) -{ TaskControlBlock *t; - - t = FindTask(p->Ident()); - queuePacketCount++; - p->SetLink(NoWork); - p->SetIdent(currentTaskIdent); - return t->AddPacket(p, currentTask); -} - - -TaskControlBlock *RBench::Release(Identity id) -{ TaskControlBlock *t; - - t = FindTask(id); - t->SetTaskHolding(FALSE); - return (t->Priority() > currentTask->Priority()) ? t : currentTask; -} - - -void RBench::Trace(Identity id) -{ - if(! --layout) {printf("\n"); layout = 50;} - printf("%d", id + 1); -} - - -TaskControlBlock *RBench::Wait() -{ - currentTask->SetTaskWaiting(TRUE); - return currentTask; -} - - -/* -//scheduling -*/ - -void RBench::Schedule() -{ - currentTask = taskList; - while (currentTask != NoTask) { - if (currentTask->IsTaskHoldingOrWaiting()) - currentTask = currentTask->Link(); - else { - currentTaskIdent = currentTask->Ident(); - if (tracing) Trace(currentTaskIdent); - currentTask = currentTask->RunTask(); - } - } -} - -/* -//initializing -*/ - -void RBench::InitScheduler() -{ - queuePacketCount = 0; - holdCount = 0; - for (int i = 0; i < NTASKS; i++) {taskTable[i] = NoTask;} - taskList = NoTask; -} - - -void RBench::InitTrace() -{ char c; - - printf("Trace (y/n)? "); - c = getchar(); - tracing = (_toupper(c) == 'Y'); -} - - -void RBench::Start(BOOLEAN trace) { -// clock_t t1, t2, t3, t4; - TaskState *t; - Packet *workQ; - - if (trace) InitTrace(); else tracing = FALSE; - InitScheduler(); -// t1 = clock(); -// printf("\nRichards benchmark: initializing...\n"); - t = new TaskState; t->Running(); // Idler - CreateIdler(Idler, 0, NoWork, t); - - workQ = new Packet(NoWork, Worker, WorkPacket); // Worker - workQ = new Packet(workQ , Worker, WorkPacket); - t = new TaskState; t->WaitingWithPacket(); - CreateWorker(Worker, 1000, workQ, t); - - workQ = new Packet(NoWork, DeviceA, DevicePacket); // HandlerA - workQ = new Packet(workQ , DeviceA, DevicePacket); - workQ = new Packet(workQ , DeviceA, DevicePacket); - t = new TaskState; t->WaitingWithPacket(); - CreateHandler(HandlerA, 2000, workQ, t); - - workQ = new Packet(NoWork, DeviceB, DevicePacket); // HandlerB - workQ = new Packet(workQ , DeviceB, DevicePacket); - workQ = new Packet(workQ , DeviceB, DevicePacket); - t = new TaskState; t->WaitingWithPacket(); - CreateHandler(HandlerB, 3000, workQ, t); - - t = new TaskState; t->Waiting(); // DeviceA - CreateDevice(DeviceA, 4000, NoWork, t); - t = new TaskState; t->Waiting(); // DeviceB - CreateDevice(DeviceB, 5000, NoWork, t); - -// printf("starting...\n"); -// t2 = clock(); - Schedule(); -// t3 = clock(); -// printf("done.\n"); - -// printf("QueuePacketCount = %d, HoldCount = %d.\nThese results are %s", -// queuePacketCount, holdCount, -// (queuePacketCount == 23246 && holdCount == 9297) ? -// "correct." : "wrong!" -// ); - if (! (queuePacketCount == 23246 && holdCount == 9297)) { - printf("error: richards results are incorrect\n"); - } - -// t4 = clock(); -// printf("\nScheduler time = %g seconds, total time = %g\n", -// (double)(t3 - t2) / CLK_TCK, -// (double)(t4 - t1) / CLK_TCK); -} - - -#define ITER 10 /* # of iterations in main loop */ - -int main() -{ clock_t t_start, t_stop; - - t_start = clock(); - for (int i = 0; i < ITER; i++) - bm.Start(ITER == 1); - t_stop = clock(); - - clock_t diff = (t_stop - t_start)/ITER; - - printf("richards: %d ms\n", diff/(CLK_TCK/1000)); - -// if (ITER > 1) -// printf("\n*** %d iterations, average of %g secs / iteration.\n", -// ITER, -// (double)(t_stop - t_start) / (ITER * CLK_TCK)); -} - diff --git a/benchmarks/richards/richards.h b/benchmarks/richards/richards.h deleted file mode 100644 index 87f8191e6d2a2198c30c97947f2cce888a206bc5..0000000000000000000000000000000000000000 --- a/benchmarks/richards/richards.h +++ /dev/null @@ -1,52 +0,0 @@ -/* richards.h */ -/* Richards benchmark in C++, translated from Smalltalk */ -/* uh 2/2/89 */ - -#include "rbase.h" -#include "tasks.h" - -/* -// RBench class definition -*/ - -class RBench { - private: - TaskControlBlock *taskList, *currentTask; - Identity currentTaskIdent; - TaskControlBlock *taskTable[NTASKS]; - int layout; - int holdCount, queuePacketCount; - - /* creation */ - void CreateDevice (Identity id, int prio, Packet *work, - TaskState *state); - void CreateHandler(Identity id, int prio, Packet *work, - TaskState *state); - void CreateIdler (Identity id, int prio, Packet *work, - TaskState *state); - void CreateWorker (Identity id, int prio, Packet *work, - TaskState *state); - void EnterTask(Identity id, TaskControlBlock *t); - - /* scheduling */ - void Schedule(); - - /* initializing */ - void InitScheduler(); - void InitTrace(); - public: - /* task management */ - TaskControlBlock *FindTask(Identity id); - TaskControlBlock *HoldSelf(); - TaskControlBlock *QueuePacket(Packet *p); - TaskControlBlock *Release(Identity id); - TaskControlBlock *Wait(); - /* tracing */ - BOOLEAN tracing; - void Trace(Identity id); - - void Start(BOOLEAN askTrace); -}; - -RBench bm; // benchmark currently executing - diff --git a/benchmarks/richards/richards.lisp b/benchmarks/richards/richards.lisp deleted file mode 100644 index cd29c02495c6489a0412825deda93bbbaad00e10..0000000000000000000000000000000000000000 --- a/benchmarks/richards/richards.lisp +++ /dev/null @@ -1,407 +0,0 @@ -(in-package "USER") -#+declare-unsafe -(proclaim '(optimize speed (space 0) (safety 0) (compilation-speed 0))) - -(defconstant deviceA 5) -(defconstant deviceB 6) -(defconstant devicePacketKind 1) -(defconstant handlerA 3) -(defconstant handlerB 4) -(defconstant idler 1) -(defconstant noWork nil) -(defconstant noTask nil) -(defconstant worker 2) -(defconstant workPacketKind 2) - -(defvar taskList noTask) -(defvar currentTask nil) -(defvar currentTaskIdentity nil) -(defvar taskTable (make-array 6 :initial-element noTask)) -(proclaim '(simple-vector taskTable)) -(defvar tracing nil) -(defvar layout 0) -(defvar queuePacketCount 0) -(defvar holdCount 0) -(proclaim '(fixnum layout queuePacketCount holdCount)) - -(declaim (inline make-taskControlBlock make-packet make-deviceTaskDataRecord - make-handlerTaskDataRecord make-idleTaskDataRecord - make-workerTaskDataRecord wait)) - -(defstruct (taskControlBlock (:constructor make-taskControlBLock ())) - packetPending taskWaiting taskHolding link identity - (priority 0 :type fixnum) - input state handle) - -(defstruct (packet (:constructor make-packet ())) - link identity - (kind 0 :type fixnum) - (datum 0 :type fixnum) - (data '#() :type simple-vector)) - -(defstruct (deviceTaskDataRecord (:constructor make-deviceTaskDataRecord ())) - pending) - -(defstruct (handlerTaskDataRecord (:constructor make-handlerTaskDataRecord ())) - workIn deviceIn) - -(defstruct (idleTaskDataRecord (:constructor make-idleTaskDataRecord ())) - (control 0 :type fixnum) - (count 0 :type fixnum)) - -(defstruct (workerTaskDataRecord (:constructor make-workerTaskDataRecord ())) - (destination 0 :type fixnum) - (count 0 :type fixnum)) - -(defun wait () - (setf (taskControlBlock-taskWaiting currentTask) t) - currentTask) - -#+cmu -(declaim (ext:freeze-type taskControlBlock packet deviceTaskDataRecord - handlerTaskDataRecord idleTaskDataRecord - workerTaskDataRecord)) -#+cmu -(declaim (ext:start-block richards)) - -(defun deviceTaskDataRecord-run (self work) - (let ((functionWork work)) - (if (eq noWork functionWork) - (progn - (setq functionWork (deviceTaskDataRecord-pending self)) - (if (eq noWork functionWork) - (wait) - (progn - (setf (deviceTaskDataRecord-pending self) noWork) - (queuePacket functionWork)))) - (progn - (setf (deviceTaskDataRecord-pending self) functionWork) - (if tracing (trace-it (packet-datum functionWork))) - (holdSelf))))) - -(defun handlerTaskDataRecord-run (self work) - (if (eq noWork work) - nil - (if (= workPacketKind (packet-kind work)) - (workInAdd self work) - (deviceInAdd self work))) - (let ((workPacket (handlerTaskDataRecord-workIn self))) - (if (eq noWork workPacket) - (wait) - (let ((count (packet-datum workPacket))) - (if (> count 4) - (progn - (setf (handlerTaskDataRecord-workIn self) - (packet-link workPacket)) - (queuePacket workPacket)) - (let ((devicePacket (handlerTaskDataRecord-deviceIn self))) - (if (eq noWork devicePacket) - (wait) - (progn - (setf (handlerTaskDataRecord-deviceIn self) - (packet-link devicePacket)) - (setf (packet-datum devicePacket) - (svref (packet-data workPacket) (- count 1))) - (setf (packet-datum workPacket) (+ count 1)) - (queuePacket devicePacket))))))))) - -(defun idleTaskDataRecord-run (self work) - (declare (ignore work)) - (setf (idleTaskDataRecord-count self) - (- (idleTaskDataRecord-count self) 1)) - (if (= 0 (idleTaskDataRecord-count self)) - (holdSelf) - (if (= 0 (logand (idleTaskDataRecord-control self) 1)) - (progn - (setf (idleTaskDataRecord-control self) - (floor (idleTaskDataRecord-control self) 2)) - (release deviceA)) - (progn - (setf (idleTaskDataRecord-control self) - (logxor (floor (idleTaskDataRecord-control self) 2) - 53256)) - (release deviceB))))) - -(defun workerTaskDataRecord-run (self work) - (if (eq noWork work) - (wait) - (progn - (setf (workerTaskDataRecord-destination self) - (if (= handlerA (workerTaskDataRecord-destination self)) - handlerB - handlerA)) - (setf (packet-identity work) (workerTaskDataRecord-destination self)) - (setf (packet-datum work) 1) - (do ((i 0 (+ i 1))) - ((> i 3) nil) - (declare (fixnum i)) - (setf (workerTaskDataRecord-count self) - (+ (workerTaskDataRecord-count self) 1)) - (if (> (workerTaskDataRecord-count self) 256) - (setf (workerTaskDataRecord-count self) 1)) - (setf (svref (packet-data work) i) - (the fixnum - (+ (char-code #\A) - (- (workerTaskDataRecord-count self) 1))))) - (queuePacket work)))) - -(defun appendHead (packet queueHead) - (setf (packet-link packet) noWork) - (if (eq noWork queueHead) - packet - (let ((mouse queueHead)) - (let ((link (packet-link mouse))) - (do () - ((eq noWork link) nil) - (setq mouse link) - (setq link (packet-link mouse))) - (setf (packet-link mouse) packet) - queueHead)))) - -(defun initialize-globals () - (setq taskList noTask) - (setq currentTask nil) - (setq currentTaskIdentity nil) - (setq taskTable (make-array 6 :initial-element noTask)) - (setq tracing nil) - (setq layout 0) - (setq queuePacketCount 0) - (setq holdCount 0)) - -(defun richards () - (initialize-globals) - - (createIdler idler 0 noWork (running (make-taskControlBlock))) - - (let ((workQ)) - - (setq workQ (createPacket noWork worker workPacketKind)) - (setq workQ (createPacket workQ worker workPacketKind)) - (createWorker worker 1000 workQ (waitingWithPacket)) - - (setq workQ (createPacket noWork deviceA devicePacketKind)) - (setq workQ (createPacket workQ deviceA devicePacketKind)) - (setq workQ (createPacket workQ deviceA devicePacketKind)) - (createHandler handlerA 2000 workQ (waitingWithPacket)) - - (setq workQ (createPacket noWork deviceB devicePacketKind)) - (setq workQ (createPacket workQ deviceB devicePacketKind)) - (setq workQ (createPacket workQ deviceB devicePacketKind)) - (createHandler handlerB 3000 workQ (waitingWithPacket)) - - (createDevice deviceA 4000 noWork (waiting)) - (createDevice deviceB 5000 noWork (waiting)) - - ) - - (schedule) - - (if (not (and (= queuePacketCount 23246) (= holdCount 9297))) - (error "richards results incorrect")) - - nil) - -(defun schedule () - (setq currentTask taskList) - (do () - ((eq noTask currentTask) nil) - (if (isTaskHoldingOrWaiting currentTask) - (setq currentTask (taskControlBlock-link currentTask)) - (progn - (setq currentTaskIdentity (taskControlBlock-identity currentTask)) - (if tracing (trace-it currentTaskIdentity)) - (setq currentTask (runTask currentTask)))))) - -(defun findTask (identity) - (declare (fixnum identity)) - (let ((tk (svref taskTable (- identity 1)))) - (if (eq noTask tk) (error "findTask failed")) - tk)) - -(defun holdSelf () - (setq holdCount (+ holdCount 1)) - (setf (taskControlBlock-taskHolding currentTask) t) - (taskControlBlock-link currentTask)) - -(defun queuePacket (packet) - (let ((tk (findTask (packet-identity packet)))) - (if (eq noTask tk) - noTask - (progn - (setq queuePacketCount (+ queuePacketCount 1)) - (setf (packet-link packet) noWork) - (setf (packet-identity packet) currentTaskIdentity) - (addInput tk packet currentTask))))) - -(defun release (identity) - (let ((tk (findTask identity))) - (if (eq noTask tk) - noTask - (progn - (setf (taskControlBlock-taskHolding tk) nil) - (if (> (taskControlBlock-priority tk) - (taskControlBlock-priority currentTask)) - tk - currentTask))))) - -(defun trace-it (id) - (setq layout (- layout 1)) - (if (>= 0 layout) - (progn - (format t "~%") - (setq layout 30))) - (format t "~a " id)) - -(defun createDevice (identity priority work state) - (let ((data (create-deviceTaskDataRecord))) - (createTask identity priority work state data))) - -(defun createHandler (identity priority work state) - (let ((data (create-handlerTaskDataRecord))) - (createTask identity priority work state data))) - -(defun createIdler (identity priority work state) - (let ((data (create-idleTaskDataRecord))) - (createTask identity priority work state data))) - -(defun createWorker (identity priority work state) - (let ((data (create-workerTaskDataRecord))) - (createTask identity priority work state data))) - -(defun createTask (identity priority work state data) - (let ((tk (create-taskControlBlock - taskList identity priority work state data))) - (setq taskList tk) - (setf (svref taskTable (- identity 1)) tk))) - -(defun createPacket (link identity kind) - (create-packet link identity kind)) - -(defun running (tcb) - (setf (taskControlBlock-packetPending tcb) nil) - (setf (taskControlBlock-taskWaiting tcb) nil) - (setf (taskControlBlock-taskHolding tcb) nil) - tcb) - -(defun waiting () - (let ((tcb (make-taskControlBlock))) - (setf (taskControlBlock-packetPending tcb) nil) - (setf (taskControlBlock-taskWaiting tcb) t) - (setf (taskControlBlock-taskHolding tcb) nil) - tcb)) - -(defun waitingWithPacket () - (let ((tcb (make-taskControlBlock))) - (setf (taskControlBlock-packetPending tcb) t) - (setf (taskControlBlock-taskWaiting tcb) t) - (setf (taskControlBlock-taskHolding tcb) nil) - tcb)) - -(defun isTaskHoldingOrWaiting (tcb) - (or (taskControlBlock-taskHolding tcb) - (and (not (taskControlBlock-packetPending tcb)) - (taskControlBlock-taskWaiting tcb)))) - -(defun isWaitingWithPacket (tcb) - (and (taskControlBlock-packetPending tcb) - (and (taskControlBlock-taskWaiting tcb) - (not (taskControlBlock-taskHolding tcb))))) - -(defun packetNowPending (tcb) - (setf (taskControlBlock-packetPending tcb) t) - (setf (taskControlBlock-taskWaiting tcb) nil) - (setf (taskControlBlock-taskHolding tcb) nil) - tcb) - -(defun create-taskControlBlock - (link identity priority initialWorkQueue initialState privateData) - (let ((r (make-taskControlBlock))) - (setf (taskControlBlock-link r) link) - (setf (taskControlBlock-identity r) identity) - (setf (taskControlBlock-priority r) priority) - (setf (taskControlBlock-input r) initialWorkQueue) - (setf (taskControlBlock-packetPending r) - (taskControlBlock-packetPending initialState)) - (setf (taskControlBlock-taskWaiting r) - (taskControlBlock-taskWaiting initialState)) - (setf (taskControlBlock-taskHolding r) - (taskControlBlock-taskHolding initialState)) - (setf (taskControlBlock-handle r) privateData) - (setf (taskControlBlock-state r) nil) - r)) - -(defun addInput (tcb packet oldTask) - (if (eq noWork (taskControlBlock-input tcb)) - (progn - (setf (taskControlBlock-input tcb) packet) - (setf (taskControlBlock-packetPending tcb) t) - (if (> (taskControlBlock-priority tcb) - (taskControlBlock-priority oldTask)) - tcb - oldTask)) - (progn - (setf (taskControlBlock-input tcb) - (appendHead packet (taskControlBlock-input tcb))) - oldTask))) - -(defun runTask (tcb) - (let ((message nil)) - (if (isWaitingWithPacket tcb) - (progn - (setq message (taskControlBlock-input tcb)) - (setf (taskControlBlock-input tcb) (packet-link message)) - (if (eq noWork (taskControlBlock-input tcb)) - (running tcb) - (packetNowPending tcb))) - (setq message noWork)) - (run (taskControlBlock-handle tcb) message))) - -(defun run (self work) - (typecase self - (deviceTaskDataRecord (deviceTaskDataRecord-run self work)) - (handlerTaskDataRecord (handlerTaskDataRecord-run self work)) - (idleTaskDataRecord (idleTaskDataRecord-run self work)) - (workerTaskDataRecord (workerTaskDataRecord-run self work)))) - -(defun create-packet (link identity kind) - (let ((p (make-packet))) - (setf (packet-link p) link) - (setf (packet-identity p) identity) - (setf (packet-kind p) kind) - (setf (packet-datum p) 1) - (let ((v (make-array 4 :initial-element 0))) - (setf (packet-data p) v)) - p)) - -(defun create-deviceTaskDataRecord () - (let ((tk (make-deviceTaskDataRecord))) - (setf (deviceTaskDataRecord-pending tk) noWork) - tk)) - -(defun create-handlerTaskDataRecord () - (let ((tk (make-handlerTaskDataRecord))) - (setf (handlerTaskDataRecord-workIn tk) noWork) - (setf (handlerTaskDataRecord-deviceIn tk) noWork) - tk)) - -(defun deviceInAdd (tk packet) - (setf (handlerTaskDataRecord-deviceIn tk) - (appendHead packet (handlerTaskDataRecord-deviceIn tk))) - tk) - -(defun workInAdd (tk packet) - (setf (handlerTaskDataRecord-workIn tk) - (appendHead packet (handlerTaskDataRecord-workIn tk))) - tk) - -(defun create-idleTaskDataRecord () - (let ((tk (make-idleTaskDataRecord))) - (setf (idleTaskDataRecord-control tk) 1) - (setf (idleTaskDataRecord-count tk) 10000) - tk)) - -(defun create-workerTaskDataRecord () - (let ((tk (make-workerTaskDataRecord))) - (setf (workerTaskDataRecord-destination tk) handlerA) - (setf (workerTaskDataRecord-count tk) 0) - tk)) diff --git a/benchmarks/richards/richards.t b/benchmarks/richards/richards.t deleted file mode 100644 index 4368dbfe4d685591906ce99acdd1f28f2be7b1ed..0000000000000000000000000000000000000000 --- a/benchmarks/richards/richards.t +++ /dev/null @@ -1,378 +0,0 @@ -(herald richards) - -(define deviceA 5) -(define deviceB 6) -(define devicePacketKind 1) -(define handlerA 3) -(define handlerB 4) -(define idler 1) -(define noWork nil) -(define noTask nil) -(define worker 2) -(define workPacketKind 2) - -(lset taskList noTask) -(lset currentTask nil) -(lset currentTaskIdentity nil) -(lset taskTable (make-vector 6)) -(lset tracing nil) -(lset layout 0) -(lset queuePacketCount 0) -(lset holdCount 0) - -(define-operation (run self work)) - -(vector-fill taskTable noTask) - -(define (hash-obj l) - (if l (object-hash l) nil)) - -(define-structure-type taskControlBlock - packetPending taskWaiting taskHolding link identity priority input state - handle) - -(define-structure-type packet - link identity kind datum data) - -(define-structure-type deviceTaskDataRecord - pending - (((run self work) - (lset functionWork work) - (if (equal? noWork functionWork) - (block - (set functionWork (deviceTaskDataRecord-pending self)) - (if (equal? noWork functionWork) - (wait) - (block - (set (deviceTaskDataRecord-pending self) noWork) - (queuePacket functionWork)))) - (block - (set (deviceTaskDataRecord-pending self) functionWork) - (if tracing (trace (packet-datum functionWork))) - (holdSelf)))))) - -(define-structure-type handlerTaskDataRecord - workIn deviceIn - (((run self work) - (if (equal? noWork work) - nil - (if (equal? workPacketKind (packet-kind work)) - (workInAdd self work) - (deviceInAdd self work))) - (let ((workPacket (handlerTaskDataRecord-workIn self))) - (if (equal? noWork workPacket) - (wait) - (let ((count (packet-datum workPacket))) - (if (> count 4) - (block - (set (handlerTaskDataRecord-workIn self) - (packet-link workPacket)) - (queuePacket workPacket)) - (let ((devicePacket (handlerTaskDataRecord-deviceIn self))) - (if (equal? noWork devicePacket) - (wait) - (block - (set (handlerTaskDataRecord-deviceIn self) - (packet-link devicePacket)) - (set (packet-datum devicePacket) - (vref (packet-data workPacket) (- count 1))) - (set (packet-datum workPacket) (+ count 1)) - (queuePacket devicePacket))))))))))) - -(define-structure-type idleTaskDataRecord - control count - (((run self work) - (ignorable work) - (set (idleTaskDataRecord-count self) - (- (idleTaskDataRecord-count self) 1)) - (if (equal? 0 (idleTaskDataRecord-count self)) - (holdSelf) - (if (equal? 0 (logand (idleTaskDataRecord-control self) 1)) - (block - (set (idleTaskDataRecord-control self) - (quotient (idleTaskDataRecord-control self) 2)) - (release deviceA)) - (block - (set (idleTaskDataRecord-control self) - (logxor (quotient (idleTaskDataRecord-control self) 2) - 53256)) - (release deviceB))))))) - -(define-structure-type workerTaskDataRecord - destination count - (((run self work) - (if (equal? noWork work) - (wait) - (block - (set (workerTaskDataRecord-destination self) - (if (equal? handlerA (workerTaskDataRecord-destination self)) - handlerB - handlerA)) - (set (packet-identity work) (workerTaskDataRecord-destination self)) - (set (packet-datum work) 1) - (do ((i 0 (+ i 1))) - ((> i 3) nil) - (set (workerTaskDataRecord-count self) - (+ (workerTaskDataRecord-count self) 1)) - (if (> (workerTaskDataRecord-count self) 256) - (set (workerTaskDataRecord-count self) 1)) - (vset (packet-data work) i - (+ (char->ascii #\A) - (- (workerTaskDataRecord-count self) 1)))) - (queuePacket work)))))) - -(define (appendHead packet queueHead) - (set (packet-link packet) noWork) - (if (equal? noWork queueHead) - packet - (block - (lset mouse queueHead) - (lset link (packet-link mouse)) - (do () - ((equal? noWork link) nil) - (set mouse link) - (set link (packet-link mouse))) - (set (packet-link mouse) packet) - queueHead))) - -(define (initialize-globals) - (set taskList noTask) - (set currentTask nil) - (set currentTaskIdentity nil) - (set taskTable (make-vector 6)) - (set tracing nil) - (set layout 0) - (set queuePacketCount 0) - (set holdCount 0) - (vector-fill taskTable noTask)) - -(define (richards) - (initialize-globals) - - (createIdler idler 0 noWork (running (make-taskControlBlock))) - - (lset workQ (createPacket noWork worker workPacketKind)) - (set workQ (createPacket workQ worker workPacketKind)) - (createWorker worker 1000 workQ (waitingWithPacket)) - - (set workQ (createPacket noWork deviceA devicePacketKind)) - (set workQ (createPacket workQ deviceA devicePacketKind)) - (set workQ (createPacket workQ deviceA devicePacketKind)) - (createHandler handlerA 2000 workQ (waitingWithPacket)) - - (set workQ (createPacket noWork deviceB devicePacketKind)) - (set workQ (createPacket workQ deviceB devicePacketKind)) - (set workQ (createPacket workQ deviceB devicePacketKind)) - (createHandler handlerB 3000 workQ (waitingWithPacket)) - - (createDevice deviceA 4000 noWork (waiting)) - (createDevice deviceB 5000 noWork (waiting)) - - (schedule) - - (if (not (and (equal? queuePacketCount 23246) (equal? holdCount 9297))) - (error "richards results incorrect")) - - nil) - -(define (schedule) - (set currentTask taskList) - (do () - ((equal? noTask currentTask) nil) - (if (isTaskHoldingOrWaiting currentTask) - (set currentTask (taskControlBlock-link currentTask)) - (block - (set currentTaskIdentity (taskControlBlock-identity currentTask)) - (if tracing (trace currentTaskIdentity)) - (set currentTask (runTask currentTask)))))) - -(define (findTask identity) - (let ((tk (vref taskTable (- identity 1)))) - (if (equal? noTask tk) (error "findTask failed")) - tk)) - -(define (holdSelf) - (set holdCount (+ holdCount 1)) - (set (taskControlBlock-taskHolding currentTask) t) - (taskControlBlock-link currentTask)) - -(define (queuePacket packet) - (let ((tk (findTask (packet-identity packet)))) - (if (equal? noTask tk) - noTask - (block - (set queuePacketCount (+ queuePacketCount 1)) - (set (packet-link packet) noWork) - (set (packet-identity packet) currentTaskIdentity) - (addInput tk packet currentTask))))) - -(define (release identity) - (let ((tk (findTask identity))) - (if (equal? noTask tk) - noTask - (block - (set (taskControlBlock-taskHolding tk) nil) - (if (> (taskControlBlock-priority tk) - (taskControlBlock-priority currentTask)) - tk - currentTask))))) - -(define (trace id) - (set layout (- layout 1)) - (if (>= 0 layout) - (block - (format (debug-output) "~%") - (set layout 30))) - (format (debug-output) "~a " id)) - -(define (wait) - (set (taskControlBlock-taskWaiting currentTask) t) - currentTask) - -(define (createDevice identity priority work state) - (let ((data (create-deviceTaskDataRecord))) - (createTask identity priority work state data))) - -(define (createHandler identity priority work state) - (let ((data (create-handlerTaskDataRecord))) - (createTask identity priority work state data))) - -(define (createIdler identity priority work state) - (let ((data (create-idleTaskDataRecord))) - (createTask identity priority work state data))) - -(define (createWorker identity priority work state) - (let ((data (create-workerTaskDataRecord))) - (createTask identity priority work state data))) - -(define (createTask identity priority work state data) - (let ((tk (create-taskControlBlock - taskList identity priority work state data))) - (set taskList tk) - (vset taskTable (- identity 1) tk))) - -(define (createPacket link identity kind) - (create-packet link identity kind)) - -(define (running tcb) - (set (taskControlBlock-packetPending tcb) nil) - (set (taskControlBlock-taskWaiting tcb) nil) - (set (taskControlBlock-taskHolding tcb) nil) - tcb) - -(define (waiting) - (let ((tcb (make-taskControlBlock))) - (set (taskControlBlock-packetPending tcb) nil) - (set (taskControlBlock-taskWaiting tcb) t) - (set (taskControlBlock-taskHolding tcb) nil) - tcb)) - -(define (waitingWithPacket) - (let ((tcb (make-taskControlBlock))) - (set (taskControlBlock-packetPending tcb) t) - (set (taskControlBlock-taskWaiting tcb) t) - (set (taskControlBlock-taskHolding tcb) nil) - tcb)) - -(define (isTaskHoldingOrWaiting tcb) - (or (taskControlBlock-taskHolding tcb) - (and (not (taskControlBlock-packetPending tcb)) - (taskControlBlock-taskWaiting tcb)))) - -(define (isWaitingWithPacket tcb) - (and (taskControlBlock-packetPending tcb) - (and (taskControlBlock-taskWaiting tcb) - (not (taskControlBlock-taskHolding tcb))))) - -(define (packetNowPending tcb) - (set (taskControlBlock-packetPending tcb) t) - (set (taskControlBlock-taskWaiting tcb) nil) - (set (taskControlBlock-taskHolding tcb) nil) - tcb) - -(define (create-taskControlBlock - link identity priority initialWorkQueue initialState privateData) - (let ((r (make-taskControlBlock))) - (set (taskControlBlock-link r) link) - (set (taskControlBlock-identity r) identity) - (set (taskControlBlock-priority r) priority) - (set (taskControlBlock-input r) initialWorkQueue) - (set (taskControlBlock-packetPending r) - (taskControlBlock-packetPending initialState)) - (set (taskControlBlock-taskWaiting r) - (taskControlBlock-taskWaiting initialState)) - (set (taskControlBlock-taskHolding r) - (taskControlBlock-taskHolding initialState)) - (set (taskControlBlock-handle r) privateData) - (set (taskControlBlock-state r) nil) - r)) - -(define (addInput tcb packet oldTask) - (if (equal? noWork (taskControlBlock-input tcb)) - (block - (set (taskControlBlock-input tcb) packet) - (set (taskControlBlock-packetPending tcb) t) - (if (> (taskControlBlock-priority tcb) - (taskControlBlock-priority oldTask)) - tcb - oldTask)) - (block - (set (taskControlBlock-input tcb) - (appendHead packet (taskControlBlock-input tcb))) - oldTask))) - -(define (runTask tcb) - (lset message nil) - (if (isWaitingWithPacket tcb) - (block - (set message (taskControlBlock-input tcb)) - (set (taskControlBlock-input tcb) (packet-link message)) - (if (equal? noWork (taskControlBlock-input tcb)) - (running tcb) - (packetNowPending tcb))) - (set message noWork)) - (run (taskControlBlock-handle tcb) message)) - -(define (create-packet link identity kind) - (let ((p (make-packet))) - (set (packet-link p) link) - (set (packet-identity p) identity) - (set (packet-kind p) kind) - (set (packet-datum p) 1) - (let ((v (make-vector 4))) - (vector-fill v 0) - (set (packet-data p) v)) - p)) - -(define (create-deviceTaskDataRecord) - (let ((tk (make-deviceTaskDataRecord))) - (set (deviceTaskDataRecord-pending tk) noWork) - tk)) - -(define (create-handlerTaskDataRecord) - (let ((tk (make-handlerTaskDataRecord))) - (set (handlerTaskDataRecord-workIn tk) noWork) - (set (handlerTaskDataRecord-deviceIn tk) noWork) - tk)) - -(define (deviceInAdd tk packet) - (set (handlerTaskDataRecord-deviceIn tk) - (appendHead packet (handlerTaskDataRecord-deviceIn tk))) - tk) - -(define (workInAdd tk packet) - (set (handlerTaskDataRecord-workIn tk) - (appendHead packet (handlerTaskDataRecord-workIn tk))) - tk) - -(define (create-idleTaskDataRecord) - (let ((tk (make-idleTaskDataRecord))) - (set (idleTaskDataRecord-control tk) 1) - (set (idleTaskDataRecord-count tk) 10000) - tk)) - -(define (create-workerTaskDataRecord) - (let ((tk (make-workerTaskDataRecord))) - (set (workerTaskDataRecord-destination tk) handlerA) - (set (workerTaskDataRecord-count tk) 0) - tk)) diff --git a/benchmarks/richards/tasks.c b/benchmarks/richards/tasks.c deleted file mode 100644 index 6d4b6ef637a67f93fe3ffdccd3e5ac8d50b4aab0..0000000000000000000000000000000000000000 --- a/benchmarks/richards/tasks.c +++ /dev/null @@ -1,153 +0,0 @@ -/* tasks.c */ - -#include "tasks.h" -#include "richards.h" - -/* -// TaskControlBlock -*/ - -TaskControlBlock::TaskControlBlock(TaskControlBlock *l, Identity id, int prio, - Packet *initialWork, TaskState *initialState, - void *privateData) -{ - link = l; ident = id; priority = prio; input = initialWork; - packetPending = initialState->IsPacketPending(); - taskWaiting = initialState->IsTaskWaiting(); - taskHolding = initialState->IsTaskHolding(); - handle = privateData; -} - - -TaskControlBlock *TaskControlBlock::AddPacket(Packet *p, - TaskControlBlock *oldTask) -{ - if (input == NoWork) { - input = p; - packetPending = TRUE; - if (priority > oldTask->priority) return this; - } - else AddToList(input, p); - return oldTask; -} - - -TaskControlBlock *TaskControlBlock::RunTask() -{ Packet *msg; - - if (IsWaitingWithPacket()) { - msg = input; - input = input->Link(); - if (input == NoWork) - Running(); - else PacketPending(); - } - else msg = NoWork; - return this->ActionFunc(msg, handle); -} - - -/* -// action functions -*/ - -TaskControlBlock *TaskControlBlock::ActionFunc(Packet *p, void *handle) -{ - p, handle, 0; - printf("***error: virtual TaskControlBlock.ActionFunc called!\n"); - return NoTask; -} - - -TaskControlBlock *DeviceTCB::ActionFunc(Packet *p, void *handle) -{ DeviceTaskRec *data = (DeviceTaskRec *)handle; - - if (p == NoWork) { - if ((p = data->Pending()) == NoWork) - return bm.Wait(); - else { - data->SetPending(NoWork); - return bm.QueuePacket(p); - } - } - else { - data->SetPending(p); - if (bm.tracing) bm.Trace(p->Datum()); - return bm.HoldSelf(); - } -} - - -TaskControlBlock *HandlerTCB::ActionFunc(Packet *p, void *handle) -{ HandlerTaskRec *data = (HandlerTaskRec *)handle; - Packet *work, *devicePacket; - int count; - - if (p != NoWork) { - if (p->Kind() == WorkPacket) - data->WorkInAdd(p); - else data->DeviceInAdd(p); - } - if ((work = data->WorkIn()) == NoWork) - return bm.Wait(); - else { - count = work->Datum(); - if (count > 4) { - data->SetWorkIn(work->Link()); - return bm.QueuePacket(work); - } - else { - if ((devicePacket = data->DeviceIn()) == NoWork) - return bm.Wait(); - else { - data->SetDeviceIn(devicePacket->Link()); - devicePacket->SetDatum(work->Data()[count-1]); - work->SetDatum(count + 1); - return bm.QueuePacket(devicePacket); - } - } - } -} - - -TaskControlBlock *IdlerTCB::ActionFunc(Packet *p, void *handle) -/* p is not used here */ -{ IdleTaskRec *data = (IdleTaskRec *)handle; - - p, 0; - - data->SetCount(data->Count() - 1); - if (data->Count() == 0) - return bm.HoldSelf(); - else if ((data->Control() & 1) == 0) { - data->SetControl(data->Control() / 2); - return bm.Release(DeviceA); - } - else { - data->SetControl((data->Control() / 2) ^ 53256); - return bm.Release(DeviceB); - } -} - - -TaskControlBlock *WorkerTCB::ActionFunc(Packet *p, void *handle) -{ WorkerTaskRec *data = (WorkerTaskRec *)handle; - Identity dest; - - if (p == NoWork) - return bm.Wait(); - else { - dest = (data->Destination() == HandlerA) ? HandlerB : HandlerA; - data->SetDestination(dest); - p->SetIdent(dest); - p->SetDatum(1); - for(int i = 0; i < 4; i++) { - data->SetCount(data->Count() + 1); - if (data->Count() > 26) data->SetCount(1); - p->Data()[i] = 'A' + data->Count(); - } - return bm.QueuePacket(p); - } -} - - diff --git a/benchmarks/richards/tasks.h b/benchmarks/richards/tasks.h deleted file mode 100644 index 295bde66d51a37b0ff86450173c59c57615dd96e..0000000000000000000000000000000000000000 --- a/benchmarks/richards/tasks.h +++ /dev/null @@ -1,122 +0,0 @@ -/* tasks.h - definitions of TaskState, TaskControlBlock and xxxTCB - * The subclasses of TaskControlBlock differ only in their - * implementation of the action function */ - -#ifndef TASKS - -#define TASKS - -#include "types.h" - -/* -// TaskState -*/ - -class TaskState { - protected: - BOOLEAN packetPending, taskWaiting, taskHolding; - - public: - /* initializing */ - TaskState() {packetPending = TRUE; taskWaiting = taskHolding = FALSE;} - void PacketPending() {packetPending = TRUE; taskHolding = taskWaiting = FALSE;} - void Waiting() {packetPending = taskHolding = FALSE; taskWaiting = TRUE;} - void Running() {packetPending = taskWaiting = taskHolding = FALSE;} - void WaitingWithPacket() {packetPending = taskWaiting = TRUE; taskHolding = FALSE;} - /* accessing */ - BOOLEAN IsPacketPending() {return packetPending;} - BOOLEAN IsTaskWaiting() {return taskWaiting;} - BOOLEAN IsTaskHolding() {return taskHolding;} - void SetTaskHolding(BOOLEAN state) {taskHolding = state;} - void SetTaskWaiting(BOOLEAN state) {taskWaiting = state;} - /* testing */ - BOOLEAN IsRunning() {return !packetPending && !taskWaiting && !taskHolding;} - BOOLEAN IsTaskHoldingOrWaiting() {return taskHolding || !packetPending && taskWaiting;} - BOOLEAN IsWaiting() {return !packetPending && taskWaiting && !taskHolding;} - BOOLEAN IsWaitingWithPacket() {return packetPending && taskWaiting && !taskHolding;} -}; - -/* -// TaskControlBlock -*/ - -class TaskControlBlock : public TaskState { - - protected: - TaskControlBlock *link; - Identity ident; - int priority; - Packet *input; - void *handle; - - public: - /* initializing */ - TaskControlBlock(TaskControlBlock *l, Identity id, int prio, - Packet *initialWork, TaskState *initialState, - void *privateData); - /* accessing */ - Identity Ident() {return ident;} - int Priority() {return priority;} - TaskControlBlock *Link() {return link;} - /* scheduling */ - TaskControlBlock *AddPacket(Packet *p, TaskControlBlock *old); - virtual TaskControlBlock *ActionFunc(Packet *p, void *handle); - TaskControlBlock *RunTask(); -}; - -/* -// DeviceTCB -*/ - -class DeviceTCB : public TaskControlBlock { - public: - DeviceTCB(TaskControlBlock *l, Identity id, int prio, - Packet *initialWork, TaskState *initialState, - void *privateData) : - (l, id, prio, initialWork, initialState, privateData){} - TaskControlBlock *ActionFunc(Packet *p, void *handle); -}; - - -/* -// HandlerTCB -*/ - -class HandlerTCB : public TaskControlBlock { - public: - HandlerTCB(TaskControlBlock *l, Identity id, int prio, - Packet *initialWork, TaskState *initialState, - void *privateData) : - (l, id, prio, initialWork, initialState, privateData){} - TaskControlBlock *ActionFunc(Packet *p, void *handle); -}; - - -/* -// IdlerTCB -*/ - -class IdlerTCB : public TaskControlBlock { - public: - IdlerTCB(TaskControlBlock *l, Identity id, int prio, - Packet *initialWork, TaskState *initialState, - void *privateData) : - (l, id, prio, initialWork, initialState, privateData){} - TaskControlBlock *ActionFunc(Packet *p, void *handle); -}; - - -/* -// WorkerTCB -*/ - -class WorkerTCB : public TaskControlBlock { - public: - WorkerTCB(TaskControlBlock *l, Identity id, int prio, - Packet *initialWork, TaskState *initialState, - void *privateData) : - (l, id, prio, initialWork, initialState, privateData){} - TaskControlBlock *ActionFunc(Packet *p, void *handle); -}; - -#endif diff --git a/benchmarks/richards/types.c b/benchmarks/richards/types.c deleted file mode 100644 index 81bc9ef272bd9d1ed19abb520f5671bd601146e8..0000000000000000000000000000000000000000 --- a/benchmarks/richards/types.c +++ /dev/null @@ -1,28 +0,0 @@ -/* types.c */ - -#include "types.h" - -/* -// AddToList - list utility (append elem at end of list, return head) -*/ -Packet *AddToList(Packet *list, Packet *elem) -{ Packet *p, *next; - - elem->SetLink(NoWork); - if (list != NoWork) { - p = list; - while((next = p->Link()) != NoWork) p = next; - p->SetLink(elem); - } - else list = elem; - return list; -} - -Packet::Packet(Packet *l, Identity id, PacketKind k) -{ - link = l; - ident = id; - kind = k; - datum = 1; - for(int i = 0; i < 4; i++) data[i] = 0; -} diff --git a/benchmarks/richards/types.h b/benchmarks/richards/types.h deleted file mode 100644 index ab9578b329fd44e637fcccc1efd4e6f528ac9c3f..0000000000000000000000000000000000000000 --- a/benchmarks/richards/types.h +++ /dev/null @@ -1,100 +0,0 @@ -/* types.h -- basic classes (Packet, {Device,Idle,...}TaskRec) */ - -#include "cbase.h" -#include "rbase.h" - -/* -// Packet -*/ - -class Packet { - private: - Packet *link; // next packet in queue - Identity ident; // Idle, Worker, DeviceA, ... - PacketKind kind; // DevicePacket or WorkPacket - int datum; - char data[4]; - public: - Packet(Packet *l, Identity id, PacketKind k); - char *Data() {return data;} - void SetData(char d[4]) {for(int i=0; i < 4; i++) data[i] = d[i];} - int Datum() {return datum;} - void SetDatum(int n) {datum = n;} - Identity Ident() {return ident;} - void SetIdent(Identity i) {ident = i;} - PacketKind Kind() {return kind;} - void SetKind(PacketKind k) {kind = k;} - Packet *Link() {return link;} - void SetLink(Packet *l) {link = l;} -}; - -/* -// AddToList - list utility (append elem at end of list, return head) -*/ -Packet *AddToList(Packet *list, Packet *elem); - -/* -// DeviceTaskRec -*/ - -class DeviceTaskRec { - private: - Packet *pending; - public: - DeviceTaskRec() {pending = NoWork;} - Packet *Pending() {return pending;} - void SetPending(Packet *p) {pending = p;} -}; - - - -/* -// IdleTaskRec -*/ - -class IdleTaskRec { - private: - int control, count; - public: - IdleTaskRec() {control = 1; count = 10000;} - int Control() {return control;} - void SetControl(int n) {control = n;} - int Count() {return count;} - void SetCount(int n) {count = n;} -}; - - -/* -// HandlerTaskRec -*/ - -class HandlerTaskRec { - private: - Packet *workIn, *deviceIn; - public: - HandlerTaskRec() {workIn = deviceIn = NoWork;} - Packet *WorkIn() {return workIn;} - void SetWorkIn(Packet *p) {workIn = p;} - Packet *WorkInAdd(Packet *p) {return workIn = AddToList(workIn, p);} - Packet *DeviceIn() {return deviceIn;} - void SetDeviceIn(Packet *p) {deviceIn = p;} - Packet *DeviceInAdd(Packet *p) {return deviceIn = AddToList(deviceIn, p);} -}; - - -/* -// WorkerTaskRec -*/ - -class WorkerTaskRec { - private: - Identity destination; - int count; - public: - WorkerTaskRec() {destination = HandlerA; count = 0;} - int Count() {return count;} - void SetCount(int n) {count = n;} - Identity Destination() {return destination;} - void SetDestination(Identity d) {destination = d;} -}; - diff --git a/benchmarks/soar/default.soar b/benchmarks/soar/default.soar deleted file mode 100644 index 5ecbc6ff79684f37aeefde295a75e61899844696..0000000000000000000000000000000000000000 --- a/benchmarks/soar/default.soar +++ /dev/null @@ -1,705 +0,0 @@ -(comment default soar version 4.0) -(comment inter-lisp version go to lower case for other versions) - -(comment this production gathers all relevant preferences and makes them - available to the decision procedure through the decide action. - users should never create decide productions) - -(sp decision*gather-preferences decide - (gc <g> ^problem-space <p> ^state <s> ^operator <q>) - (preference <id> ^role <role> ^value <value> ^reference <c> - ^goal <g> ^problem-space <p> ^state <s> ^operator <q>) - --> - (decide ^goal <g> ^identifier <id> ^role <role> ^value <value> ^reference <c>)) - - - -(comment ****** common search-control productions ******) - -(comment all operator augmentations of the problem space have - acceptable-preferences created for them) - -(sp default*make-all-operators-acceptable - (gc <g> ^problem-space <p>) - (problem-space <p> ^operator <x>) - -(preference <x> ^role operator ^value acceptable ^problem-space <p>) - --> - (preference <x> ^role operator ^value acceptable - ^problem-space <p>)) - - -(comment if an operator has just been applied to a state - - detected by using the preference created for that state - - reject the operator for that state so it will not be reapplied - in the future) - -(sp default*no-operator-retry - (gc <g> ^problem-space <p> ^state <s2>) - (preference ^object <s2> ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state <s> - ^operator { <> undecided <> nil <q> }) - --> - (preference <q> ^role operator ^value reject - ^goal <g> ^problem-space <p> ^state <s>)) - - -(comment if there is a reject-preference for the current state - - make an acceptable-preference for the prior state so problem - solving can backup) - -(sp default*backup-if-failed-state - (gc <g> ^problem-space <p> ^state <s>) - (preference <s> ^role state ^value reject - ^goal <g> ^problem-space <p>) - (preference <s> ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state { <> undecided <> nil <n> } - ^operator <> undecided) - --> - (preference <n> ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state <s>)) - -(comment ****** default knowledge for impasses ****** - ****** tie impasses ******) - -(comment if the problem space for handling the subgoal fails - - signified by the choices none impasse below it - - make a worst-preference for each tied object) - - (sp default*problem-space-tie - (gc <g3> ^role goal ^choices none ^supergoal <g2>) - (gc <g2> ^role problem-space ^impasse tie ^supergoal <g1> - ^item <p>) - --> - (preference <p> ^role problem-space ^value worst - ^goal <g1>)) - -(sp default*state-tie - (gc <g3> ^role goal ^choices none ^supergoal <g2>) - (gc <g2> ^role state ^impasse tie ^supergoal <g1> ^item <s>) - (gc <g1> ^problem-space <p>) - --> - (preference <s> ^role state ^value worst - ^goal <g1> ^problem-space <p>)) - -(sp default*operator-tie - (gc <g3> ^role goal ^choices none ^supergoal <g2>) - (gc <g2> ^role operator ^impasse tie ^supergoal <g1> - ^item <q>) - (gc <g1> ^problem-space <p> ^state <s>) - --> - (preference <q> ^role operator ^value worst - ^goal <g1> ^problem-space <p> ^state <s>)) - - -(comment ****** conflict impasses ******) - -(comment if the problem space for handling the subgoal fails - - signified by the choices none impasse below it - - make a reject-preference for each conflicted object) - - (sp default*problem-space-conflict - (gc <g3> ^role goal ^choices none ^supergoal <g2>) - (gc <g2> ^role problem-space ^impasse conflict ^supergoal <g1> - ^item <p>) - --> - (preference <p> ^role problem-space ^value reject - ^goal <g1>)) - -(sp default*state-conflict - (gc <g3> ^role goal ^choices none ^supergoal <g2>) - (gc <g2> ^role state ^impasse conflict - ^supergoal <g1> ^item <s>) - (gc <g1> ^problem-space <p>) - --> - (preference <s> ^role state ^value reject - ^goal <g1> ^problem-space <p>)) - -(sp default*operator-conflict - (gc <g3> ^role goal ^choices none ^supergoal <g2>) - (gc <g2> ^role operator ^impasse conflict ^supergoal <g1> - ^item <q>) - (gc <g1> ^problem-space <p> ^state <s>) - --> - (preference <q> ^role operator ^value reject - ^goal <g1> ^problem-space <p> ^state <s>)) - - -(comment ****** no-choice impasses ******) - -(comment if no problem spaces are available for the top goal - - terminate the problem solving session with halt) - -(sp default*goal-no-choices - (gc <g3> ^role goal ^choices none ^supergoal <g2>) - -(gc <g2> ^supergoal) - --> - (write1 (crlf) "No problem space can be selected for top goal.") - (write1 (crlf) "Soar must terminate.") - (halt)) - - -(comment if no states are available for a problem space - - and there is no problem space to find more - - reject that problem space) - -(sp default*problem-space-no-choices - (gc <g3> ^role goal ^choices none ^supergoal <g2>) - (gc <g2> ^role problem-space ^choices none ^supergoal <g1>) - (gc <g1> ^problem-space <p>) - --> - (preference <p> ^role problem-space ^value reject ^goal <g1>)) - - -(comment if no operators are available for a state - - and there is no problem space to find more - - reject that state) - -(sp default*state-no-choices - (gc <g3> ^role goal ^choices none ^supergoal <g2>) - (gc <g2> ^role state ^choices none ^supergoal <g1>) - (gc <g1> ^problem-space <p> ^state <s>) - --> - (preference <s> ^role state ^value reject - ^goal <g1> ^problem-space <p>)) - -(comment if no changes for an operator - - and there is no problem space to find more - - reject that operator) - -(sp default*operator-no-choices - (gc <g3> ^role goal ^choices none ^supergoal <g2>) - (gc <g2> ^role operator ^impasse no-change ^supergoal <g1>) - (gc <g1> ^problem-space <p> ^state <s> ^operator <q>) - --> - (preference <q> ^role operator ^value reject - ^goal <g1> ^problem-space <p> ^state <s>)) - - -(comment ************** selection problem space ****************) - - -(comment use the selection problem space for all choice multiple - impasses - make it worst so that any other will dominate) - -(sp select*selection-space elaborate - (gc <g> ^choices multiple) - --> - (preference <p> ^role problem-space ^value acceptable ^goal <g>) - (preference <p> ^role problem-space ^value worst ^goal <g>) - (problem-space <p> ^name selection)) - - -(comment the state of the selection problem space is empty) - -(sp select*create-state - (gc <g> ^problem-space <p> ^state undecided) - (space <p> ^name selection) - --> - (preference <s> ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state undecided)) - - - -(comment ************** evaluate-object operator ****************) - - -(comment create evaluate operator in selection problem space) - -(sp eval*select-evaluate - (gc <g> ^problem-space <p> ^state <s> ^supergoal <g2> ^item <x>) - (problem-space <p> ^name selection) - --> - (operator <o> ^state <s> ^name evaluate-object ^object <x>) - (preference <o> ^role operator ^value indifferent - ^goal <g> ^problem-space <p> ^state <s> ) - (preference <o> ^role operator ^value acceptable - ^goal <g> ^problem-space <p> ^state <s> )) - - -(comment for parallel evaluation - remove this comment if you want parallel evaluation of - the alternatives. - -(sp eval*parallel-evaluate - (gc <g> ^problem-space <p> ^state <s> ^role operator ^supergoal <g2>) - (problem-space <p> ^name selection ) - (operator <q1> ^state <s> ^object <y>) - (operator <q2> ^state <s> ^object { <> <y> <x> }) - --> - (preference <q1> ^role operator ^value parallel - ^goal <g> ^problem-space <p> ^state <s> ^reference <q2>))) - - -(comment create evaluation once the eval operator is selected) - -(sp eval*apply-evaluate - (gc <g> ^problem-space <p> ^state <s> ^operator <q> - ^role <role> ^supergoal <g2>) - (problem-space <p> ^name selection) - (gc <g2> ^problem-space <p2> ^state <s2> ^desired <d>) - (operator <q> ^name evaluate-object ^object <x>) - --> - (state <s> ^evaluation <e>) - (evaluation <e> ^object <x> ^state <s> ^operator <q> ^desired <d>) - (operator <q> ^role <role> ^evaluation <e> ^desired <d> - ^supergoal <g2> ^superproblem-space <p2> ^superstate <s2>)) - - -(comment reject evaluate-object after it finished in selection space) - -(sp eval*reject-evaluate-finished elaborate - (gc <g> ^problem-space <p> ^state <s> ^operator <q>) - (problem-space <p> ^name selection) - (operator <q> ^name evaluate-object ^evaluation <e>) - (evaluation <e> ^ << numeric-value symbolic-value >>) - --> - (preference <q> ^role operator ^value reject ^goal <g> - ^problem-space <p> ^state <s>)) - - -(comment if two objects have equal evaluations they are indifferent) - -(sp eval*equal-eval-indifferent-preference - (gc <g> ^problem-space <p> ^state <s> ^role <role> ^supergoal <g2>) - (problem-space <p> ^name selection) - (state <s> ^evaluation <e1> ^evaluation { <> <e1> <e2> }) - (gc <g2> ^problem-space <p2> ^state <s2> ^desired <d>) - (evaluation <e1> ^object <x> ^numeric-value <v> ^desired <d>) - (evaluation <e2> ^object <y> ^numeric-value <v> ^desired <d>) - --> - (preference <x> ^role <role> ^value indifferent ^reference <y> - ^goal <g2> ^problem-space <p2> ^state <s2>)) - - -(comment generate operator preferences based on their evaluations and info - as to whether higher or lower evaluations are better) - -(sp eval*prefer-higher-evaluation - (gc <g> ^problem-space <p> ^state <s> ^role <role> ^supergoal <g2>) - (problem-space <p> ^name selection) - (gc <g2> ^problem-space <p2> ^state <s2> ^desired <d>) - (state <s> ^evaluation <e1> ^evaluation { <> <e1> <e2> }) - (evaluation <d> ^better higher) - (evaluation <e1> ^object <q1> ^numeric-value <v> ^desired <d>) - (evaluation <e2> ^object <q2> ^numeric-value < <v> ^desired <d>) - --> - (preference <q2> ^role <role> ^value worse ^reference <q1> - ^goal <g2> ^problem-space <p2> ^state <s2>)) - -(sp eval*prefer-lower-evaluation - (gc <g> ^problem-space <p> ^state <s> ^role <role> ^supergoal <g2>) - (problem-space <p> ^name selection) - (gc <g2> ^problem-space <p2> ^state <s2> ^desired <d>) - (state <s> ^evaluation <e1> ^evaluation { <> <e1> <e2> }) - (evaluation <d> ^better lower) - (evaluation <e1> ^object <q1> ^numeric-value <v> ^desired <d>) - (evaluation <e2> ^object <q2> ^numeric-value > <v> ^desired <d>) - --> - (preference <q2> ^role operator ^value worse ^reference <q1> - ^goal <g2> ^problem-space <p2> ^state <s2>)) - -(comment productions that fire in the evaluation subgoal) - - -(comment copy down the desired and create the appropriate context - - given the role of the object being evaluated) - -(sp eval*select-role-problem-space - (gc <g> ^problem-space undecided ^supergoal <g2> ^superoperator <q2>) - (gc <g2> ^operator <q2>) - (operator <q2> ^name evaluate-object ^role problem-space ^object <p> ^desired <d>) - --> - (gc <g> ^desired <d>) - (preference <p> ^role problem-space ^value acceptable ^goal <g>)) - - -(sp eval*select-role-state - (gc <g> ^problem-space undecided ^supergoal <g2> ^superoperator <q2>) - (gc <g2> ^operator <q2>) - (operator <q2> ^name evaluate-object ^role state ^object <s> - ^superproblem-space <p> ^desired <d>) - --> - (gc <g> ^desired <d>) - (preference <p> ^role problem-space ^value acceptable ^goal <g>) - (preference <s> ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state undecided) - (preference <s> ^role state ^value best - ^goal <g> ^problem-space <p> ^state undecided)) - - -(sp eval*select-role-operator - (gc <g> ^problem-space undecided ^supergoal <g2> ^superoperator <q2>) - (gc <g2> ^operator <q2>) - (operator <q2> ^name evaluate-object ^role operator ^object <q> - ^superproblem-space <p> ^superstate <s> ^desired <d>) - --> - (gc <g> ^desired <d>) - (preference <p> ^role problem-space ^value acceptable ^goal <g>) - (preference <s> ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state undecided) - (preference <q> ^role operator ^value acceptable - ^goal <g> ^problem-space <p> ^state <s>)) - - -(sp eval*reject-non-slot-operator - (gc <g> ^problem-space <p> ^state <s> ^supergoal <g2> ^superoperator <q2>) - (operator <q2> ^name evaluate-object ^role operator ^object <q> - ^superstate <s>) - (preference { <> <q> <q3> } ^role operator ^value acceptable - ^goal <g> ^problem-space <p> ^state <s>) - --> - (preference <q3> ^role operator ^value reject - ^goal <g> ^problem-space <p> ^state <s>)) - -(comment give symbol-value failure to an operator that has been rejected - during evaluation and did not create a new state and reject the eval-operator) - -(sp eval*failure-if-reject-evaling-operator - (gc <g> ^problem-space <p> ^state <s> ^operator <q> - ^supergoal <g2> ^superoperator <q2>) - (gc <g2> ^problem-space <p2> ^state <s2>) - (operator <q2> ^name evaluate-object ^role operator - ^object <q> ^superstate <s> ^evaluation <e2>) - (preference <q> ^role operator ^value reject - ^goal <g> ^problem-space <p> ^state <s> ^operator <q>) - -(preference ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state <s> ^operator <q>) - --> - (evaluation <e2> ^symbolic-value failure)) - -(comment give symbol-value failure to an operator - that produces a state that gets rejected in the subgoal) - -(sp eval*failure-if-reject-state - (gc <g> ^problem-space <p> ^state <s> - ^supergoal <g2> ^superoperator <q2>) - (gc <g2> ^problem-space <p2> ^state <s2>) - (operator <q2> ^name evaluate-object ^evaluation <e2>) - (preference <s> ^role state ^value reject - ^goal <g> ^problem-space <p>) - --> - (evaluation <e2> ^symbolic-value failure)) - - - -(comment if an operator leads to success and it is being - tried out in a subgoal to evaluate another operator - - give that second operator a success evaluation also) - -(sp eval*pass-back-success elaborate - (gc <g> ^problem-space <p> ^state <s> ^operator <q> ^supergoal <g2>) - (problem-space <p> ^name selection) - (operator <q> ^name evaluate-object ^evaluation <e1> ^desired <eb>) - (evaluation <e1> ^symbolic-value success) - (gc <g2> ^superoperator <q3>) - (operator <q3> ^name evaluate-object ^evaluation <e2> ^desired <eb>) - --> - (evaluation <e2> ^symbolic-value success)) - - -(comment if an operator is evaluated to be lose or failure - - create a worst-preference for it) - -(sp eval*failure-becomes-worst - (gc <g> ^problem-space <p> ^state <s> ^operator <q> ^supergoal <g2>) - (problem-space <p> ^name selection) - (gc <g2> ^problem-space <p2> ^state <s2> ^desired <e>) - (operator <q> ^name evaluate-object ^evaluation <e1> ^desired <e> - ^role <role> ^object <q1>) - (evaluation <e1> ^symbolic-value << lose failure >>) - --> - (preference <q1> ^role operator ^value worst - ^goal <g2> ^problem-space <p2> ^state <s2>)) - - -(comment if an operator is evaluated to be success - - create a best-preference for it) - -(sp eval*success-becomes-best - (gc <g> ^problem-space <p> ^state <s> ^operator <q> ^supergoal <g2>) - (problem-space <p> ^name selection) - (gc <g2> ^problem-space <p2> ^state <s2> ^desired <eb>) - (operator <q> ^name evaluate-object ^evaluation <e1> - ^desired <eb> ^object <q1> ^role <role>) - (evaluation <e1> ^symbolic-value success) - --> - (preference <q1> ^role <role> ^value best - ^goal <g2> ^problem-space <p2> ^state <s2>)) - - -(comment convert state augmentations into evaluations) - -(sp eval*state-to-evaluation-success - (gc <g> ^problem-space <p> ^state <s> ^superoperator <sq>) - (operator <sq> ^name evaluate-object - ^evaluation <e> ^desired <eb>) - (state <s> ^success <eb> ) - --> - (evaluation <e> ^symbolic-value success)) - -(sp eval*state-to-evaluation-failure - (gc <g> ^problem-space <p> ^state <s> ^superoperator <sq>) - (operator <sq> ^name evaluate-object - ^evaluation <e> ^desired <eb>) - (state <s> ^failure <eb> ) - --> - (evaluation <e> ^symbolic-value failure)) - -(sp eval*state-to-evaluation-win - (gc <g> ^problem-space <p> ^state <s> ^superoperator <sq>) - (operator <sq> ^name evaluate-object - ^evaluation <e> ^desired <eb>) - (state <s> ^win <eb> ) - --> - (evaluation <e> ^symbolic-value win)) - -(sp eval*state-to-evaluation-draw - (gc <g> ^problem-space <p> ^state <s> ^superoperator <sq>) - (operator <sq> ^name evaluate-object - ^evaluation <e> ^desired <eb>) - (state <s> ^draw <eb> ) - --> - (evaluation <e> ^symbolic-value draw)) - -(sp eval*state-to-evaluation-lose - (gc <g> ^problem-space <p> ^state <s> ^superoperator <sq>) - (operator <sq> ^name evaluate-object - ^evaluation <e> ^desired <eb>) - (state <s> ^lose <eb> ) - --> - (evaluation <e> ^symbolic-value lose)) - - - -(comment handle state augmentations dealing with goal - termination for the top-level goal) - -(sp eval*detect-success - (gc <g> ^state <s> ^name <name> ^desired <eb> -^supergoal) - (state <s> ^success <eb>) - --> - (write1 (crlf) "GOAL" <name> "ACHIEVED") - (halt)) - -(sp eval*detect-win - (gc <g> ^state <s> ^name <name> -^supergoal ^desired <eb>) - (state <s> ^win <eb>) - --> - (write1 (crlf) "GAME" <name> "WON") - (halt)) - -(sp eval*detect-failure - (gc <g> ^state <s> ^name <name> -^supergoal ^desired <eb>) - (state <s> ^failure <eb>) - --> - (preference <s> ^role state ^value reject - ^goal <g> ^problem-space <p>)) - -(sp eval*detect-lose - (gc <g> ^state <s> ^name <name> -^supergoal ^desired <eb>) - (state <s> ^lose <eb>) - --> - (write1 (crlf) "GAME" <name> "LOST") - (halt)) - - -(comment two player games - win side oside lose) - -(sp eval*move-side-to-eval - (gc <g> ^state <s> ^superoperator <sq>) - (state <s> ^oside <side> ^ << lose win >>) - (operator <sq> ^name evaluate-object ^evaluation <e>) - --> - (evaluation <e> ^side <side>)) - -(sp eval*winning-values - (gc <g> ^problem-space <p> ^state <s> ^supergoal <g1> ^operator <q>) - (problem-space <p> ^name selection) - (gc <g1> ^problem-space <p1> ^state <s1>) - (state <s1> ^side <side>) - (operator <q> ^name evaluate-object ^evaluation <e> ^object <q1> ^role <role>) - (evaluation <e> ^symbolic-value win ^side <side>) - --> - (preference <q1> ^role <role> ^value best - ^goal <g1> ^problem-space <p1> ^state <s1>)) - -(sp eval*winning-values2 - (gc <g> ^problem-space <p> ^state <s> ^supergoal <g1> ^operator <q>) - (problem-space <p> ^name selection) - (gc <g1> ^problem-space <p1> ^state <s1>) - (state <s1> ^oside <side>) - (operator <q> ^name evaluate-object ^evaluation <e> ^object <q1> ^role <role>) - (evaluation <e> ^symbolic-value lose ^side <side>) - --> - (preference <q1> ^role <role> ^value best - ^goal <g1> ^problem-space <p1> ^state <s1>)) - -(sp eval*draw-values - (gc <g> ^problem-space <p> ^state <s> ^supergoal <g1> ^operator <q>) - (problem-space <p> ^name selection) - (gc <g1> ^problem-space <p1> ^state <s1>) - (operator <q> ^name evaluate-object ^evaluation <e> ^object <q1> ^role <role>) - (evaluation <e> ^symbolic-value draw) - --> - (preference <q1> ^role <role> ^value indifferent - ^goal <g1> ^problem-space <p1> ^state <s1>)) - -(sp eval*losing-values - (gc <g> ^problem-space <p> ^state <s> ^supergoal <g1> ^operator <q>) - (problem-space <p> ^name selection) - (gc <g1> ^problem-space <p1> ^state <s1>) - (state <s1> ^oside <side>) - (operator <q> ^name evaluate-object ^evaluation <e> ^object <q1> ^role <role>) - (evaluation <e> ^symbolic-value win ^side <side>) - --> - (preference <q1> ^role <role> ^value worst - ^goal <g1> ^problem-space <p1> ^state <s1>)) - -(sp eval*losing-values2 - (gc <g> ^problem-space <p> ^state <s> ^supergoal <g1> ^operator <q>) - (problem-space <p> ^name selection) - (gc <g1> ^problem-space <p1> ^state <s1>) - (state <s1> ^side <side>) - (operator <q> ^name evaluate-object ^evaluation <e> ^object <q1> ^role <role>) - (evaluation <e> ^symbolic-value lose ^side <side>) - --> - (preference <q1> ^role <role> ^value worst - ^goal <g1> ^problem-space <p1> ^state <s1>)) - -(sp eval*pass-back-win - (gc <g> ^problem-space <p> ^state <s> ^supergoal <g2> ^operator <q>) - (problem-space <p> ^name selection) - (operator <q> ^name evaluate-object ^evaluation <e1> ^desired <eb>) - (evaluation <e1> ^symbolic-value win ^side <side>) - (gc <g2> ^superoperator <q3>) - (operator <q3> ^name evaluate-object ^evaluation <e2> ^desired <eb> - ^superstate <s4>) - (state <s4> ^oside <side>) - --> - (evaluation <e2> ^symbolic-value win ^side <side>)) - -(sp eval*pass-back-win2 - (gc <g> ^problem-space <p> ^state <s> ^supergoal <g2> ^operator <q>) - (problem-space <p> ^name selection) - (operator <q> ^name evaluate-object ^evaluation <e1> ^desired <eb>) - (evaluation <e1> ^symbolic-value lose ^side <side>) - (gc <g2> ^superoperator <q3>) - (operator <q3> ^name evaluate-object ^evaluation <e2> ^desired <eb> - ^superstate <s4>) - (state <s4> ^side <side>) - --> - (evaluation <e2> ^symbolic-value win ^side <side>)) - -(comment **************** operator subgoaling **************** - there are two ways to do operator subgoal - just pass down most recent operator - or pass down all of them - this implementation passes down just the super operator as the - desired - uncomment opsub*go-for-it2 if you want all supergoals - to be included) - -(comment make the super-problem space the default - when there is a no-change for the operator) - -(sp opsub*try-operator-subgoaling elaborate - (gc <g> ^impasse no-change ^role operator - ^problem-space undecided ^supergoal <g2>) - (gc <g2> ^problem-space <p2>) - --> - (preference <p2> ^goal <g> ^role problem-space ^value acceptable) - (preference <p2> ^goal <g> ^role problem-space ^value worst)) - - -(comment if the superproblem-space is selected as the - current problem space then operator subgoaling - is being used so select the superstate - - the superoperator becomes the desired) - -(sp opsub*go-for-it elaborate - (gc <g> ^problem-space <p> ^state undecided - ^impasse no-change ^role operator ^supergoal <g2>) - (gc <g2> ^problem-space <p> ^state <s> ^operator <q>) - --> - (gc <g> ^name operator-subgoal ^desired <q>) - (preference <s> ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state undecided)) - - -(comment pass down all super operator subgoals as well -(sp opsub*go-for-it2 elaborate - (gc <g> ^problem-space <p> ^state undecided - ^impasse no-change ^role operator ^supergoal <g2>) - (gc <g2> ^problem-space <p> ^state <s> ^desired <q>) - --> - (gc <g> ^desired <q>)) ) - - -(comment don't select the operator for the initial state that we are - subgoaling on) - -(sp opsub*reject-opsub*operator - (gc <g> ^problem-space <p> ^state <s> ^desired <q>) - (op-info ^identifier <q>) - (preference <s> ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state undecided) - --> - (preference <q> ^role operator ^value reject - ^goal <g> ^problem-space <p> ^state <s>)) - - -(comment select superoperator for all new states) - -(sp opsub*select-opsub*operator elaborate - (gc <g1> ^problem-space <p> ^state <s> ^desired <q>) - (op-info ^identifier <q>) - --> - (preference <q> ^role operator ^value acceptable - ^goal <g1> ^problem-space <p> ^state <s>) - (preference <q> ^role operator ^value best - ^goal <g1> ^problem-space <p> ^state <s>)) - - -(comment if superoperator applied to a state then success - we make a preference for the state it created) - -(sp opsub*detect-direct-opsub-success elaborate - (gc <g0> ^problem-space <p> ^state <s> ^operator <q> - ^supergoal <g1> ^name operator-subgoal) - (gc <g1> ^problem-space <p> ^state <s2> ^operator <q>) - (preference <ns> ^role state ^value acceptable - ^goal <g0> ^problem-space <p> ^state <s> ^operator <q>) - --> - (preference <ns> ^role state ^value acceptable - ^goal <g1> ^problem-space <p> ^state <s2> ^operator <q>)) - - -(comment if there is an evaluation subgoal within - an operator subgoal and the operator being - subgoaled on is applied - success) - -(sp opsub*detect-indirect-opsub-success elaborate - (gc <g1> ^name operator-subgoal ^supergoal <g2>) - (gc <g2> ^problem-space <p> ^state <s2> ^operator <q>) - (gc <g0> ^problem-space <p> ^state <s> ^operator <q> - ^desired <q> ^superoperator <sq>) - (operator <sq> ^name evaluate-object) - (preference <ns> ^role state ^value acceptable - ^goal <g0> ^problem-space <p> ^state <s> ^operator <q>) - --> - (state <s> ^success <q>)) - - -(comment if the operator being subgoaled on is the current - operator and a no-change subgoal is created for it - then reject it in the subgoal) - -(sp opsub*reject-double-op-sub - (gc <g1> ^name operator-subgoal ^desired <q>) - (gc { <> <g1> <g3> } ^name operator-subgoal) - (gc <g3> ^supergoal <g4>) - (gc <g4> ^problem-space <p> ^state <s> ^operator <q>) - -(gc ^supergoal <g3>) - --> - (preference <q> ^role operator ^value reject - ^goal <g4> ^problem-space <p> ^state <s>)) - -nil diff --git a/benchmarks/soar/eight.soar b/benchmarks/soar/eight.soar deleted file mode 100644 index 56b31da4cef35badaa4cd4854116a4f3e6c4c2df..0000000000000000000000000000000000000000 --- a/benchmarks/soar/eight.soar +++ /dev/null @@ -1,269 +0,0 @@ -(comment eight puzzle for soar 35) - - -(comment this is the eight puzzle problem) -(comment state structure - each state contains nine bindings - the bindings connect together a cell - - one of the nine positions on the board - - and a tile - one of the movable pieces - the cells have pointers ^cell to each of their - adjacent cells - the state also has a pointer to the blank-cell and the cell - that the last moved tile is in this improve efficiency and - simplify computations that depend on the previous operator) - -(comment each operator contains a pointer to the cell with the blank - and the cell with the tile to be moved) - - - -(multi-attributes '((state binding 5) (desired binding 5) - (operator blank 3) (operator cell 2) (cell cell 4))) - -(trace-attributes '((operator tile-cell))) - -(comment name the first subgoal eight-puzzle and create the - problem space and operators) - -(sp eight*start - (gc <g> ^problem-space undecided - ^supergoal) - --> - (gc <g> ^name solve-eight-puzzle ^impasse <d> ^desired <d>) - (problem-space <p> ^name eight-puzzle) - (preference <p> ^role problem-space ^value acceptable - ^goal <g>)) - -(comment define the initial state and the impasse state - each state is a set of bindings - each binding points to a cell and a tile - each cell points to its neighboring cells) - -(sp eight*initial-desired-states - (gc <g> ^problem-space <p> ^state undecided - ^name solve-eight-puzzle ^desired <d>) - (space <p> ^name eight-puzzle) - --> - (preference <s> ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state undecided) - (tile <t0> ^name 0) (tile <t1> ^name 1) (tile <t2> ^name 2) - (tile <t3> ^name 3) (tile <t4> ^name 4) (tile <t5> ^name 5) - (tile <t6> ^name 6) (tile <t7> ^name 7) (tile <t8> ^name 8) - - (binding <bb0> ^cell c11 ^tile <t2>) - (binding <bb1> ^cell c12 ^tile <t1>) - (binding <bb2> ^cell c13 ^tile <t7>) - (binding <bb3> ^cell c21 ^tile <t8>) - (binding <bb4> ^cell c22 ^tile <t6>) - (binding <bb5> ^cell c23 ^tile <t0>) - (binding <bb6> ^cell c31 ^tile <t3>) - (binding <bb7> ^cell c32 ^tile <t4>) - (binding <bb8> ^cell c33 ^tile <t5>) - (state <s> ^binding <bb0> <bb1> <bb2> <bb3> - <bb4> <bb5> <bb6> <bb7> <bb8> ^blank-cell c23) - (cell c11 ^cell c12 ^cell c21) - (cell c12 ^cell c11 ^cell c13 ^cell c22) - (cell c13 ^cell c12 ^cell c23) - (cell c21 ^cell c11 ^cell c31 ^cell c22) - (cell c22 ^cell c21 ^cell c12 ^cell c23 ^cell c32) - (cell c23 ^cell c22 ^cell c33 ^cell c13) - (cell c31 ^cell c32 ^cell c21) - (cell c32 ^cell c31 ^cell c22 ^cell c33) - (cell c33 ^cell c32 ^cell c23) - - (binding <d1> ^cell c11 ^tile <t1>) - (binding <d2> ^cell c12 ^tile <t8>) - (binding <d3> ^cell c13 ^tile <t7>) - (binding <d8> ^cell c21 ^tile <t2>) - (binding <d0> ^cell c22 ^tile <t0>) - (binding <d4> ^cell c23 ^tile <t6>) - (binding <d7> ^cell c31 ^tile <t3>) - (binding <d6> ^cell c32 ^tile <t4>) - (binding <d5> ^cell c33 ^tile <t5>) - (desired <d> ^binding <d0> <d1> <d2> <d3> <d4> - <d5> <d6> <d7> <d8>) - (evaluation <d> ^better higher) -) - -(comment create an operator if it will apply) - -(sp eight*acceptable - (gc <g> ^problem-space <p> ^state <s>) - (problem-space <p> ^name eight-puzzle) - (state <s> ^blank-cell <c1>) - (cell <c1> ^cell <c2>) - -(op-info ^attribute state ^value <s>) - --> - (operator <q> ^name move-tile ^state <s> ^tile-cell <c2> ^blank-cell <c1>) - (preference <q> ^role operator ^value acceptable - ^goal <g> ^problem-space <p> ^state <s>)) - - - -(comment reject the operator that was applied to create this state) - -(sp eight*reject-undo - (gc <g> ^problem-space <p> ^state <s>) - (problem-space <p> ^name eight-puzzle) - (state <s> ^tile-cell <tc>) - (preference <q> ^role operator ^value acceptable - ^problem-space <p> ^state <s>) - (operator <q> ^tile-cell <tc>) - --> - (preference <q> ^role operator ^value reject - ^goal <g> ^problem-space <p> ^state <s>)) - - - -(comment apply operator to state and copy unchanged bindings new state) - -(comment swap blank binding and one specified by operator) - -(sp eight*apply-move-tile - (gc <g> ^problem-space <p> ^state <s> ^operator <q>) - (problem-space <p> ^name eight-puzzle) - (state <s> ^binding <b1> <b2> ^blank-cell <c1>) - (binding <b1> ^tile <t1> ^cell <c1>) - (binding <b2> ^tile <t2> ^cell <c2>) - (operator <q> ^tile-cell <c2> ^blank-cell <c1> ^name move-tile) - --> - (preference <s2> ^role state ^value acceptable - ^goal <g> ^problem-space <p> ^state <s> ^operator <q>) - (state <s2> ^blank-cell <c2> ^tile-cell <c1> - ^binding <b3> ^binding <b4>) - (binding <b3> ^tile <t2> ^cell <c1>) - (binding <b4> ^tile <t1> ^cell <c2>) -) - -(comment copy pointers to all untouched bindings) - -(sp eight*copy-unchanged - (gc <g> ^problem-space <p> ^state <s> ^operator <q>) - (problem-space <p> ^name eight-puzzle) - (preference <n> ^role state ^value acceptable - ^problem-space <p> ^state { <> nil <s> } ^operator { <> nil <q> }) - (state <s> ^binding <b>) - (binding <b> ^cell <c>) - (state <n> -^tile-cell <c> -^blank-cell <c>) - --> - (state <n> ^binding <b>)) - -(comment detect success) - -(sp eight*detect-goal - (gc <g> ^problem-space <p> ^state <s> ^desired <d>) - (space <p> ^name eight-puzzle) - (state <s> ^binding <x11> <x12> <x13> <x21> <x22> <x23> - <x31> <x32> <x33>) - (binding <x11> ^cell c11 ^tile <o11>) - (binding <x12> ^cell c12 ^tile <o12>) - (binding <x13> ^cell c13 ^tile <o13>) - (binding <x21> ^cell c21 ^tile <o21>) - (binding <x22> ^cell c22 ^tile <o22>) - (binding <x23> ^cell c23 ^tile <o23>) - (binding <x31> ^cell c31 ^tile <o31>) - (binding <x32> ^cell c32 ^tile <o32>) - (binding <x33> ^cell c33 ^tile <o33>) - (desired <d> - ^binding <d11> <d12> <d13> <d21> <d22> <d23> - <d31> <d32> <d33>) - (binding <d11> ^cell c11 ^tile <o11>) - (binding <d12> ^cell c12 ^tile <o12>) - (binding <d13> ^cell c13 ^tile <o13>) - (binding <d21> ^cell c21 ^tile <o21>) - (binding <d22> ^cell c22 ^tile <o22>) - (binding <d23> ^cell c23 ^tile <o23>) - (binding <d31> ^cell c31 ^tile <o31>) - (binding <d32> ^cell c32 ^tile <o32>) - (binding <d33> ^cell c33 ^tile <o33>) - --> - (state <s> ^success <d>)) - -(comment monitor new states) - -(sp eight*monitor - (gc <g> ^problem-space <p> ^state <s> ^operator <q>) - (problem-space <p> ^name eight-puzzle) - (preference <n> ^role state ^value acceptable - ^problem-space <p> ^state <s> ^operator <q>) - (operator <q> ^tile-cell <qname>) - (state <n> ^binding <x11> <x12> <x13> <x21> <x22> <x23> - <x31> <x32> <x33>) - (binding <x11> ^cell c11 ^tile <o11>) - (binding <x12> ^cell c12 ^tile <o12>) - (binding <x13> ^cell c13 ^tile <o13>) - (binding <x21> ^cell c21 ^tile <o21>) - (binding <x22> ^cell c22 ^tile <o22>) - (binding <x23> ^cell c23 ^tile <o23>) - (binding <x31> ^cell c31 ^tile <o31>) - (binding <x32> ^cell c32 ^tile <o32>) - (binding <x33> ^cell c33 ^tile <o33>) - (tile <o11> ^name <v11>) - (tile <o12> ^name <v12>) - (tile <o13> ^name <v13>) - (tile <o21> ^name <v21>) - (tile <o22> ^name <v22>) - (tile <o23> ^name <v23>) - (tile <o31> ^name <v31>) - (tile <o32> ^name <v32>) - (tile <o33> ^name <v33>) - --> - (write2 (crlf) (crlf) <qname> "(" <s> ") --> " <n> (crlf)) - (write1 " -------------" (crlf)) - (write1 " |" <v11> "|" <v21> "|" <v31> "|" (crlf)) - (write1 " |---|---|---|" (crlf)) - (write1 " |" <v12> "|" <v22> "|" <v32> "|" (crlf)) - (write1 " |---|---|---|" (crlf)) - (write1 " |" <v13> "|" <v23> "|" <v33> "|" (crlf)) - (write1 " -------------" (crlf))) - - -(comment compute evaluation function based on changes by operators) -(comment 1 point for moving binding into its impasse location) - -(sp eight*eval-state-plus-one - (gc <g> ^problem-space <p> ^state { <> <ss> <s> } ^superoperator <sq>) - (problem-space <p> ^name eight-puzzle) - (operator <sq> ^name evaluate-object ^evaluation <e> - ^superstate <ss> ^desired <d>) - (state <s> ^tile-cell <c1> ^binding <b1>) - (binding <b1> ^cell <c1> ^tile <v1>) - (desired <d> ^binding <b2>) - (binding <b2> ^cell <c1> ^tile <v1>) - --> - (evaluation <e> ^numeric-value 1)) - -(comment 0 points for not moving tile in or out of its impasse cell) - -(sp eight*eval-state-zero - (gc <g> ^problem-space <p> ^state { <> <ss> <s> } ^superoperator <sq>) - (space <p> ^name eight-puzzle) - (operator <sq> ^name evaluate-object ^evaluation <e> - ^desired <d> ^superstate <ss>) - (state <s> ^tile-cell <c1> ^blank-cell <c0> - ^binding <b1> <b2> <b3>) - (binding <b1> ^cell <c1> ^tile <v1>) - (binding <b2> ^tile <v2>) - (binding <b3> ^tile <v3>) - (desired <d> ^binding <b4> <b5>) - (binding <b4> ^cell <c1> ^tile { <> <v1> <v2> }) - (binding <b5> ^cell <c0> ^tile { <> <v1> <v3> }) - --> - (evaluation <e> ^numeric-value 0)) - - -(comment -1 points for moving tile out of its impasse cell) - -(sp eight*eval-state-minus-one - (gc <g> ^problem-space <p> ^state { <> <ss> <s> } ^superoperator <sq>) - (space <p> ^name eight-puzzle) - (operator <sq> ^name evaluate-object ^evaluation <e> - ^desired <d> ^superstate <ss>) - (state <s> ^tile-cell <c1> ^binding <b1> ^blank-cell <c0>) - (binding <b1> ^cell <c1> ^tile <v1>) - (desired <d> ^binding <b2>) - (binding <b2> ^cell <c0> ^tile <v1>) - --> - (evaluation <e> ^numeric-value -1)) - -nil diff --git a/benchmarks/soar/readme.txt b/benchmarks/soar/readme.txt deleted file mode 100644 index 6a92d123540ab58b53624057d5f62114cda3375a..0000000000000000000000000000000000000000 --- a/benchmarks/soar/readme.txt +++ /dev/null @@ -1,8 +0,0 @@ -To run soar: - (load "soar.fasl") - (load "default.soar") - (load "eight.soar") - (d) - -Optionally before calling D, you can call WATCH with -1 to turn off tracing -information. This is desirable for timing situation. diff --git a/benchmarks/soar/soar.lisp b/benchmarks/soar/soar.lisp deleted file mode 100644 index 65f9e9e162d1a6100a0543c3d4ce48a4bb382bb4..0000000000000000000000000000000000000000 --- a/benchmarks/soar/soar.lisp +++ /dev/null @@ -1,7273 +0,0 @@ -;;; -*- Mode: LISP; Package: User -*- - -#+declare-unsafe (proclaim '(optimize (speed 3) (safety 0))) -(proclaim - '(special *matrix* *feature-count* *pcount* *vars* *cur-vars* - *curcond* *subnum* *last-node* *last-branch* *first-node* - *sendtocall* *flag-part* *alpha-flag-part* *data-part* - *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt* - *current-token* *record-array* *result-array* - *max-cs* *total-cs* *limit-cs* *cr-temp* *side* - *conflict-set* *halt-flag* *phase* *critical* - *cycle-count* *total-token* *max-token* *refracts* - *limit-token* *total-wm* *current-wm* *max-wm* - *action-count* *wmpart-list* *wm* *data-matched* *p-name* - *variable-memory* *ce-variable-memory* *max-index* - *next-index* *size-result-array* *rest* *build-trace* *last* - *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file* - *write-file* *record-index* *max-record-index* *old-wm* - *record* *filters* *break-flag* *strategy* *remaining-cycles* - *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline* - *ce-count* *brkpts* *class-list* *buckets* *action-type*)) - -(proclaim '(special *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* - *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* - *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* - *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* - *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* - *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* - *c60* *c61* *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* - *c70* *c71* *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* - *c80* *c81* *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* - *c90* *c91* *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* - *c100* *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108* - *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116* *c117* - *c118* *c119* *c120* *c121* *c122* *c123* *c124* *c125* *c126* - *c127* )) - -(defmacro soarputprop (n v a) - `(setf (get ,n ,a) ,v)) - -(defmacro soarassq (item alist) - `(assoc ,item ,alist :test #'eq)) - -; getvector and putvector are fast routines for using ONE-DIMENSIONAL -; arrays. these routines do no checking; they assume -; 1. the array is a vector with 0 being the index of the first -; element -; 2. the vector holds arbitrary list values - -(defmacro putvector (array index value) - `(setf (svref ,array ,index) ,value)) - -(defmacro getvector (array index) - `(svref ,array ,index)) - -(shadow 'remove (find-package 'user)) - -(defmacro remove (&body z) - `(ops-remove ',z)) - -(shadow 'write (find-package 'user)) - -(defmacro write (&body z) - `(ops-write ',z)) - -(defmacro princq (ob &optional st) - (cond ((eq st nil) - `(princ ,ob)) - (t - `(princ ,ob ,st)))) - -(defmacro literal (&body z) - `(ops-literal ',z)) - -(defmacro literalize (&body z) - `(ops-literalize ',z)) - -(defmacro vector-attribute (&body l) - `(ops-vector-attribute ',l)) - -(defmacro p (&body z) - `(ops-p ',z)) - -(defmacro wm (&body a) - `(ops-wm ',a)) - -(defmacro make (&body z) - `(ops-make ',z)) - -(defmacro modify (&body z) - `(ops-modify ',z)) - -(defmacro bind (&body z) - `(ops-bind ',z)) - -(defmacro cbind (&body z) - `(ops-cbind ',z)) - -(defmacro call1 (&body z) - `(ops-call1 ',z)) - -(defmacro build (&body z) - `(ops-build ',z)) - -(defmacro openfile (&body z) - `(ops-openfile ',z)) - -(defmacro closefile (&body z) - `(ops-closefile ',z)) - -(defmacro default (&body z) - `(ops-default ',z)) - -(defmacro accept (&body z) - `(ops-accept ',z)) - -(defmacro acceptline (&body z) - `(ops-acceptline ',z)) - -(defmacro substr (&body l) - `(ops-substr ',l)) - -(defmacro compute (&body z) - `(ops-compute ',z)) - -(defmacro arith (&body z) - `(ops-arith ',z)) - -(defmacro litval (&body z) - `(ops-litval ',z)) - -(defmacro rjust (&body z) - `(ops-rjust ',z)) - -(defmacro crlf (&body z) - `(ops-crlf ',z)) - -(defmacro tabto (&body z) - `(ops-tabto ',z)) - -(defmacro ppwm (&body avlist) - `(ops-ppwm ',avlist)) - -(defmacro pm (&body z) - `(ops-pm ',z)) - -(defmacro matches (&body rule-list) - `(ops-matches ',rule-list)) - -(defmacro excise (&body z) - `(ops-excise ',z)) - -(defmacro run (&body z) - `(ops-run ',z)) - -(defmacro strategy (&body z) - `(ops-strategy ',z)) - -(defmacro cs (&body z) - `(ops-cs ',z)) - -(defmacro watch (&body z) - `(ops-watch ',z)) - -(defmacro external (&body z) - `(ops-external ',z)) - -(defmacro pbreak (&body z) - `(ops-pbreak ',z)) - -(defmacro == (x y) - `(equal ,x ,y)) - -(defmacro =alg (a b) - `(equalp ,a ,b)) - -(defun ce-gelm (x k) - (declare (optimize speed)) - (prog nil - loop (and (== k 1.) (return (car x))) - (setq k (1- k)) - (setq x (cdr x)) - (go loop))) - -(defun gelm (x k) - (declare (optimize speed)) - (prog (ce sub) - (setq ce (truncate k 10000.)) ;use multiple-value-setq??? - (setq sub (- k (* ce 10000.))) ;@@@ ^ - celoop (and (eq ce 0.) (go ph2)) - (setq x (cdr x)) - (and (eq ce 1.) (go ph2)) - (setq x (cdr x)) - (and (eq ce 2.) (go ph2)) - (setq x (cdr x)) - (and (eq ce 3.) (go ph2)) - (setq x (cdr x)) - (and (eq ce 4.) (go ph2)) - (setq ce (- ce 4.)) - (go celoop) - ph2 (setq x (car x)) - subloop (and (eq sub 0.) (go finis)) - (setq x (cdr x)) - (and (eq sub 1.) (go finis)) - (setq x (cdr x)) - (and (eq sub 2.) (go finis)) - (setq x (cdr x)) - (and (eq sub 3.) (go finis)) - (setq x (cdr x)) - (and (eq sub 4.) (go finis)) - (setq x (cdr x)) - (and (eq sub 5.) (go finis)) - (setq x (cdr x)) - (and (eq sub 6.) (go finis)) - (setq x (cdr x)) - (and (eq sub 7.) (go finis)) - (setq x (cdr x)) - (and (eq sub 8.) (go finis)) - (setq sub (- sub 8.)) - (go subloop) - finis (return (car x))) ) - -;;; Utility functions - -;;; intersect two lists using eq for the equality test -(defun interq (x y) - (cond ((atom x) nil) - ((member (car x) y) (cons (car x) (interq (cdr x) y))) - (t (interq (cdr x) y)))) - - -(eval-when (compile load eval) - (set-macro-character #\{ #'(lambda (s c) - (declare (ignore s c)) - '\{)) ;5/5/83 - (set-macro-character #\} #'(lambda (s c) - (declare (ignore s c)) - '\})) ;5/5/83 - (set-macro-character #\^ #'(lambda (s c) - (declare (ignore s c)) - '\^)) ;5/5/83 - ) - -(defun %warn (what where) - (prog nil - (terpri) - (princ '?) - (and *p-name* (princ *p-name*)) - (princ '"..") - (princ where) - (princ '"..") - (princ what) - (return where))) - -(defun %error (what where) - (%warn what where) - (throw '!error! '!error!)) - -(defun top-levels-eq (la lb) - (prog nil - lx (cond ((eq la lb) (return t)) - ((null la) (return nil)) - ((null lb) (return nil)) - ((not (eq (car la) (car lb))) (return nil))) - (setq la (cdr la)) - (setq lb (cdr lb)) - (go lx))) - -;;; LITERAL and LITERALIZE - -(defun ops-literal (z) - (prog (atm val old) - top (and (atom z) (return 'bound)) - (or (eq (cadr z) '=) (return (%warn '|wrong format| z))) - (setq atm (car z)) - (setq val (caddr z)) - (setq z (cdddr z)) - (cond ((not (numberp val)) - (%warn '|can bind only to numbers| val)) - ((or (not (symbolp atm)) (variablep atm)) - (%warn '|can bind only constant atoms| atm)) - ((and (setq old (literal-binding-of atm)) (not (equal old val))) - (%warn '|attempt to rebind attribute| atm)) - (t (soarputprop atm val 'ops-bind)) - (go top)))) - -(defun ops-literalize (l) - (prog (class-name atts) - (setq class-name (car l)) - (cond ((have-compiled-production) - (%warn '|literalize called after p| class-name) - (return nil)) - ((get class-name 'att-list) - (%warn '|attempt to redefine class| class-name) - (return nil))) - (setq *class-list* (cons class-name *class-list*)) - (setq atts (remove-duplicates (cdr l))) - (test-attribute-names atts) - (mark-conflicts atts atts) - (soarputprop class-name atts 'att-list))) - -(defun ops-vector-attribute (l) - (cond ((have-compiled-production) - (%warn '|vector-attribute called after p| l)) - (t - (test-attribute-names l) - (mapc (function vector-attribute2) l)))) - -(defun vector-attribute2 (att) (soarputprop att t 'vector-attribute)) - -(defun is-vector-attribute (att) (get att 'vector-attribute)) - -(defun test-attribute-names (l) - (mapc (function test-attribute-names2) l)) - -(defun test-attribute-names2 (atm) - (cond ((or (not (symbolp atm)) (variablep atm)) - (%warn '|can bind only constant atoms| atm)))) - -(defun have-compiled-production nil (not (zerop *pcount*))) - -(defun put-ppdat (class) - (prog (al att ppdat) - (setq ppdat nil) - (setq al (get class 'att-list)) - top (cond ((not (atom al)) - (setq att (car al)) - (setq al (cdr al)) - (setq ppdat - (cons (cons (literal-binding-of att) att) - ppdat)) - (go top))) - (soarputprop class ppdat 'ppdat))) - -; note-user-assigns and note-user-vector-assigns are needed only when -; literal and literalize are both used in a program. They make sure that -; the assignments that are made explicitly with literal do not cause problems -; for the literalized classes. - -(defun note-user-assigns (class) - (mapc (function note-user-assigns2) (get class 'att-list))) - -(defun note-user-assigns2 (att) - (prog (num conf buck clash) - (setq num (literal-binding-of att)) - (and (null num) (return nil)) - (setq conf (get att 'conflicts)) - (setq buck (store-binding att num)) - (setq clash (find-common-atom buck conf)) - (and clash - (%warn '|attributes in a class assigned the same number| - (cons att clash))) - (return nil))) - -(defun note-user-vector-assigns (att given needed) - (and (> needed given) - (%warn '|vector attribute assigned too small a value in literal| att))) - -(defun assign-scalars (class) - (mapc (function assign-scalars2) (get class 'att-list))) - -(defun assign-scalars2 (att) - (prog (tlist num bucket conf) - (and (literal-binding-of att) (return nil)) - (and (is-vector-attribute att) (return nil)) - (setq tlist (buckets)) - (setq conf (get att 'conflicts)) - top (cond ((atom tlist) - (%warn '|could not generate a binding| att) - (store-binding att -1.) - (return nil))) - (setq num (caar tlist)) - (setq bucket (cdar tlist)) - (setq tlist (cdr tlist)) - (cond ((disjoint bucket conf) (store-binding att num)) - (t (go top))))) - -(defun assign-vectors (class) - (mapc (function assign-vectors2) (get class 'att-list))) - -(defun assign-vectors2 (att) - (prog (big conf new old need) - (and (not (is-vector-attribute att)) (return nil)) - (setq big 1.) - (setq conf (get att 'conflicts)) - top (cond ((not (atom conf)) - (setq new (car conf)) - (setq conf (cdr conf)) - (cond ((is-vector-attribute new) - (%warn '|class has two vector attributes| - (list att new))) - (t (setq big (max (literal-binding-of new) big)))) - (go top))) - (setq need (1+ big)) ;"plus" changed to "+" by gdw - (setq old (literal-binding-of att)) - (cond (old (note-user-vector-assigns att old need)) - (t (store-binding att need))) - (return nil))) - -(defun disjoint (la lb) (not (find-common-atom la lb))) - -(defun find-common-atom (la lb) - (prog nil - top (cond ((null la) (return nil)) - ((member (car la) lb) (return (car la))) - (t (setq la (cdr la)) (go top))))) - -(defun mark-conflicts (rem all) - (cond ((not (null rem)) - (mark-conflicts2 (car rem) all) - (mark-conflicts (cdr rem) all)))) - -(defun mark-conflicts2 (atm lst) - (prog (l) - (setq l lst) - top (and (atom l) (return nil)) - (conflict atm (car l)) - (setq l (cdr l)) - (go top))) - -(defun conflict (a b) - (prog (old) - (setq old (get a 'conflicts)) - (and (not (eq a b)) - (not (member b old)) - (soarputprop a (cons b old) 'conflicts)))) - -(defun literal-binding-of (name) (get name 'ops-bind)) - -(defun store-binding (name lit) - (soarputprop name lit 'ops-bind) - (add-bucket name lit)) - -(defun add-bucket (name num) - (prog (buc) - (setq buc (assoc num (buckets))) - (and (not (member name buc)) - (rplacd buc (cons name (cdr buc)))) - (return buc))) - -(defun buckets nil - (and (atom *buckets*) (setq *buckets* (make-nums *buckets*))) - *buckets*) - -(defmacro ncons (x) `(cons ,x nil)) - -(defun make-nums (k) - (prog (nums) - (setq nums nil) - l (and (< k 2.) (return nums)) - (setq nums (cons (ncons k) nums)) - (setq k (1- k)) - (go l))) - -(defun erase-literal-info (class) - (mapc (function erase-literal-info2) (get class 'att-list)) - (remprop class 'att-list)) - -(defun erase-literal-info2 (att) (remprop att 'conflicts)) - - -;;; LHS Compiler - -(defun peek-lex nil (car *matrix*)) - -(defun lex nil - (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*)))) - -(defun end-of-p nil (atom *matrix*)) - -(defun rest-of-p nil *matrix*) - -(defun prepare-lex (prod) (setq *matrix* prod)) - -(defun peek-sublex nil (car *curcond*)) - -(defun sublex nil - (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*)))) - -(defun end-of-ce nil (atom *curcond*)) - -(defun rest-of-ce nil *curcond*) - -(defun prepare-sublex (ce) (setq *curcond* ce)) - -(defun make-bottom-node nil (setq *first-node* (list '&bus nil))) - -(defun rating-part (pnode) (cadr pnode)) - -(defun var-part (pnode) (car (cdddr pnode))) - -(defun ce-var-part (pnode) (cadr (cdddr pnode))) - -(defun rhs-part (pnode) (caddr (cdddr pnode))) - -(defun kill-node (node) - (prog nil - top (and (atom node) (return nil)) - (rplaca node '&old) - (setq node (cdr node)) - (go top))) - -(defun cmp-negce nil (lex) (cmp-ce)) - -(defun cmp-posce nil - (setq *ce-count* (1+ *ce-count*)) - (cond ((eq (peek-lex) '\{) (cmp-ce+cevar)) - (t (cmp-ce)))) - -(defun cmp-ce+cevar nil - (prog (z) - (lex) - (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce)) - (t (cmp-ce) (cmp-cevar))) - (setq z (lex)) - (or (eq z '\}) (%error '|missing '}'| z)))) - -(defun new-subnum (k) - (or (numberp k) (%error '|tab must be a number| k)) - (setq *subnum* (fix k))) - -(defun incr-subnum nil (setq *subnum* (1+ *subnum*))) - -(defun cmp-element nil - (and (eq (peek-sublex) '^) (cmp-tab)) - (cond ((eq (peek-sublex) '\{) (cmp-product)) - (t (cmp-atomic-or-any)))) - -(defun cmp-atomic-or-any nil - (cond ((eq (peek-sublex) '<<) (cmp-any)) - (t (cmp-atomic)))) - -(defun cmp-any nil - (prog (a z) - (sublex) - (setq z nil) - la (cond ((end-of-ce) (%error '|missing '>>'| a))) - (setq a (sublex)) - (cond ((not (eq '>> a)) (setq z (cons a z)) (go la))) - (link-new-node (list '&any nil (current-field) z)))) - -(defun $litbind (x) - (prog (r) - (cond ((and (symbolp x) (setq r (literal-binding-of x))) - (return r)) - (t (return x))))) - -(defun get-bind (x) - (prog (r) - (cond ((and (symbolp x) (setq r (literal-binding-of x))) - (return r)) - (t (return nil))))) - -(defun cmp-atomic nil - (prog (test x) - (setq x (peek-sublex)) - (cond ((eq x '= ) (setq test 'eq) (sublex)) - ((eq x '<>) (setq test 'ne) (sublex)) - ((eq x '<) (setq test 'lt) (sublex)) - ((eq x '<=) (setq test 'le) (sublex)) - ((eq x '>) (setq test 'gt) (sublex)) - ((eq x '>=) (setq test 'ge) (sublex)) - ((eq x '<=>) (setq test 'xx) (sublex)) - (t (setq test 'eq))) - (cmp-symbol test))) - -(defun cmp-product nil - (prog (save) - (setq save (rest-of-ce)) - (sublex) - la (cond ((end-of-ce) - (cond ((member '\} save :test #'equal) - (%error '|wrong contex for '}'| save)) - (t (%error '|missing '}'| save)))) - ((eq (peek-sublex) '\}) (sublex) (return nil))) - (cmp-atomic-or-any) - (go la))) - -(defun symbol-print-name (x) - (symbol-name x)) - -(defun cmp-symbol (test) - (prog (flag) - (setq flag t) - (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil))) - (cond ((and flag (variablep (peek-sublex))) - (cmp-var test)) - ((numberp (peek-sublex)) (cmp-number test)) - ((symbolp (peek-sublex)) (cmp-constant test)) - (t (%error '|unrecognized symbol| (sublex)))))) - -(defun cmp-constant (test) - (or (member test '(eq ne xx)) - (%error '|non-numeric constant after numeric predicate| (sublex))) - (link-new-node (list (intern (concatenate 'string - (symbol-print-name 't) - (symbol-print-name test) - (symbol-print-name 'a))) - nil - (current-field) - (sublex)))) - -(defun cmp-number (test) - (link-new-node - (list - (intern - (concatenate 'string - (symbol-print-name 't) - (symbol-print-name test) - (symbol-print-name 'n))) - nil ;outs -- nodelist to traverse - (current-field) ;register - (sublex)))) ;constant - -; %%% things to change to convert set of *cN* to *c* array: -; %%% current-field field-name *subnum* eval-nodelist ?? wm-hash -; %%% send-to, &bus - -(defun current-field nil (field-name *subnum*)) - -(defun field-name (num) - (cond ((= num 1.) '*c1*) - ((= num 2.) '*c2*) - ((= num 3.) '*c3*) - ((= num 4.) '*c4*) - ((= num 5.) '*c5*) - ((= num 6.) '*c6*) - ((= num 7.) '*c7*) - ((= num 8.) '*c8*) - ((= num 9.) '*c9*) - ((= num 10.) '*c10*) - ((= num 11.) '*c11*) - ((= num 12.) '*c12*) - ((= num 13.) '*c13*) - ((= num 14.) '*c14*) - ((= num 15.) '*c15*) - ((= num 16.) '*c16*) - (t (%error '|condition is too long| (rest-of-ce))))) - - -;;; Compiling variables -; -; -; -; *cur-vars* are the variables in the condition element currently -; being compiled. *vars* are the variables in the earlier condition -; elements. *ce-vars* are the condition element variables. note -; that the interpreter will not confuse condition element and regular -; variables even if they have the same name. -; -; *cur-vars* is a list of triples: (name predicate subelement-number) -; eg: ( (<x> eq 3) - ; (<y> ne 1) - ; . . . ) -; -; *vars* is a list of triples: (name ce-number subelement-number) -; eg: ( (<x> 3 3) - ; (<y> 1 1) - ; . . . ) -; -; *ce-vars* is a list of pairs: (name ce-number) -; eg: ( (ce1 1) - ; (<c3> 3) - ; . . . ) - - -(defun var-dope (var) (soarassq var *vars*)) - -(defun ce-var-dope (var) (soarassq var *ce-vars*)) - -(defun cmp-new-var (name test) - (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*))) - -(defun cmp-old-eq-var (test old) ; jgk inserted concatenate form - (link-new-node (list (intern (concatenate 'string - (symbol-print-name 't) - (symbol-print-name test) - (symbol-print-name 's))) - nil - (current-field) - (field-name (caddr old))))) - -;@@@ added defunb of delq -;(defun delq (i l) -; (delete i l :test #'eq)) - -; -; Spdelete "special delete" is a function which deletes every occurence -; of element from list. This function was defined because common lisp's -; delete function only deletes top level elements from a list, not lists -; from lists. -; -(defun spdelete (element list) - - (cond ((null list) nil) - ((equal element (car list)) (spdelete element (cdr list))) - (t (cons (car list) (spdelete element (cdr list)))))) - - - -(defun cmp-new-eq-var (name old) ;jgk inserted concatenate form - (prog (pred next) - (setq *cur-vars* (delq old *cur-vars*)) - (setq next (soarassq name *cur-vars*)) - (cond (next (cmp-new-eq-var name next)) - (t (cmp-new-var name 'eq))) - (setq pred (cadr old)) - (link-new-node (list (intern (concatenate 'string - (symbol-print-name 't) - (symbol-print-name pred) - (symbol-print-name 's))) - nil - (field-name (caddr old)) - (current-field))))) - -(defun cmp-cevar nil - (prog (name old) - (setq name (lex)) - (setq old (soarassq name *ce-vars*)) - (and old - (%error '|condition element variable used twice| name)) - (setq *ce-vars* (cons (list name 0.) *ce-vars*)))) - -(defun cmp-not nil (cmp-beta '¬)) - -(defun cmp-nobeta nil (cmp-beta nil)) - -(defun cmp-and nil (cmp-beta '&and)) - -(defun cmp-beta (kind) - (prog (tlist vdope vname #|vpred vpos|# old) - (setq tlist nil) - la (and (atom *cur-vars*) (go lb)) - (setq vdope (car *cur-vars*)) - (setq *cur-vars* (cdr *cur-vars*)) - (setq vname (car vdope)) - ;; (setq vpred (cadr vdope)) Dario - commented out (unused) - ;; (setq vpos (caddr vdope)) - (setq old (soarassq vname *vars*)) - (cond (old (setq tlist (add-test tlist vdope old))) - ((not (eq kind '¬)) (promote-var vdope))) - (go la) - lb (and kind (build-beta kind tlist)) - (or (eq kind '¬) (fudge)) - (setq *last-branch* *last-node*))) - -(defun add-test (list new old) ; jgk inserted concatenate form - (prog (ttype lloc rloc) - (setq *feature-count* (1+ *feature-count*)) - (setq ttype (intern (concatenate 'string (symbol-print-name 't) - (symbol-print-name (cadr new)) - (symbol-print-name 'b)))) - (setq rloc (encode-singleton (caddr new))) - (setq lloc (encode-pair (cadr old) (caddr old))) - (return (cons ttype (cons lloc (cons rloc list)))))) - -; the following two functions encode indices so that gelm can -; decode them as fast as possible - -;; %%% change to use clisp hash fns ?? -(defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b))) -;"plus" changed to "+" by gdw - -(defun encode-singleton (a) (1- a)) - -(defun fudge nil - (mapc (function fudge*) *vars*) - (mapc (function fudge*) *ce-vars*)) - -(defun fudge* (z) - (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a))))) - -(defun build-beta (type tests) - (prog (rpred lpred lnode lef) - (link-new-node (list '&mem nil nil (protomem))) - (setq rpred *last-node*) - (cond ((eq type '&and) - (setq lnode (list '&mem nil nil (protomem)))) - (t (setq lnode (list '&two nil nil)))) - (setq lpred (link-to-branch lnode)) - (cond ((eq type '&and) (setq lef lpred)) - (t (setq lef (protomem)))) - (link-new-beta-node (list type nil lef rpred tests)))) - -(defun protomem nil (list nil)) - -(defun memory-part (mem-node) (car (cadddr mem-node))) - -(defun encode-dope nil - (prog (r all z k) - (setq r nil) - (setq all *vars*) - la (and (atom all) (return r)) - (setq z (car all)) - (setq all (cdr all)) - (setq k (encode-pair (cadr z) (caddr z))) - (setq r (cons (car z) (cons k r))) - (go la))) - -(defun encode-ce-dope nil - (prog (r all z k) - (setq r nil) - (setq all *ce-vars*) - la (and (atom all) (return r)) - (setq z (car all)) - (setq all (cdr all)) - (setq k (cadr z)) - (setq r (cons (car z) (cons k r))) - (go la))) - - - -;;; Linking the nodes - -(defun link-new-node (r) - (cond ((not (member (car r) '(&p &mem &two &and ¬) :test #'equal)) - (setq *feature-count* (1+ *feature-count*)))) - (setq *virtual-cnt* (1+ *virtual-cnt*)) - (setq *last-node* (link-left *last-node* r))) - -(defun link-to-branch (r) - (setq *virtual-cnt* (1+ *virtual-cnt*)) - (setq *last-branch* (link-left *last-branch* r))) - -(defun link-new-beta-node (r) - (setq *virtual-cnt* (1+ *virtual-cnt*)) - (setq *last-node* (link-both *last-branch* *last-node* r)) - (setq *last-branch* *last-node*)) - -(defun link-left (pred succ) - (prog (a r) - (setq a (left-outs pred)) - (setq r (find-equiv-node succ a)) - (and r (return r)) - (setq *real-cnt* (1+ *real-cnt*)) - (attach-left pred succ) - (return succ))) - -(defun link-both (left right succ) - (prog (a r) - (setq a (interq (left-outs left) (right-outs right))) - (setq r (find-equiv-beta-node succ a)) - (and r (return r)) - (setq *real-cnt* (1+ *real-cnt*)) - (attach-left left succ) - (attach-right right succ) - (return succ))) - -(defun attach-right (old new) - (rplaca (cddr old) (cons new (caddr old)))) - -(defun attach-left (old new) - (rplaca (cdr old) (cons new (cadr old)))) - -(defun right-outs (node) (caddr node)) - -(defun left-outs (node) (cadr node)) - -(defun find-equiv-node (node list) - (prog (a) - (setq a list) - l1 (cond ((atom a) (return nil)) - ((equiv node (car a)) (return (car a)))) - (setq a (cdr a)) - (go l1))) - -(defun find-equiv-beta-node (node list) - (prog (a) - (setq a list) - l1 (cond ((atom a) (return nil)) - ((beta-equiv node (car a)) (return (car a)))) - (setq a (cdr a)) - (go l1))) - -; do not look at the predecessor fields of beta nodes; they have to be -; identical because of the way the candidate nodes were found - -(defun equiv (a b) - (and (eq (car a) (car b)) - (or (eq (car a) '&mem) - (eq (car a) '&two) - (equal (caddr a) (caddr b))) - (equal (cdddr a) (cdddr b)))) - -(defun beta-equiv (a b) - (and (eq (car a) (car b)) - (equal (cddddr a) (cddddr b)) - (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) - -; the equivalence tests are set up to consider the contents of -; node memories, so they are ready for the build action - -;;; Network interpreter - -(defun match (flag wme) - (sendto flag (list wme) 'left (list *first-node*))) - -; note that eval-nodelist is not set up to handle building -; productions. would have to add something like ops4's build-flag - -(defun eval-nodelist (nl) - (prog nil - top (and (not nl) (return nil)) - (setq *sendtocall* nil) - (setq *last-node* (car nl)) - (apply (caar nl) (cdar nl)) ;; %%% here's the apply cdar nl must - ;; be the *cN* item, caar nl is test - (setq nl (cdr nl)) - (go top))) - -(defun sendto (flag data side nl) - (prog nil - top (and (not nl) (return nil)) - (setq *side* side) - (setq *flag-part* flag) - (setq *data-part* data) - (setq *sendtocall* t) - (setq *last-node* (car nl)) - (apply (caar nl) (cdar nl)) ;; %%% ditto - (setq nl (cdr nl)) - (go top))) - -(defun &any (outs register const-list) - (prog (z c) - (setq z (symbol-value register)) - (cond ((numberp z) (go number))) - symbol (cond ((null const-list) (return nil)) - ((eq (car const-list) z) (go ok)) - (t (setq const-list (cdr const-list)) (go symbol))) - number (cond ((null const-list) (return nil)) - ((and (numberp (setq c (car const-list))) - (=alg c z)) - (go ok)) - (t (setq const-list (cdr const-list)) (go number))) - ok (eval-nodelist outs))) - -(defun teqa (outs register constant) - (and (eq (symbol-value register) constant) (eval-nodelist outs))) - -(defun tnea (outs register constant) - (and (not (eq (symbol-value register) constant)) (eval-nodelist outs))) - -(defun txxa (outs register constant) - (declare (ignore constant)) - (and (symbolp (symbol-value register)) (eval-nodelist outs))) - -(defun teqn (outs register constant) - (prog (z) - (setq z (symbol-value register)) - (and (numberp z) - (=alg z constant) - (eval-nodelist outs)))) - -(defun tnen (outs register constant) - (prog (z) - (setq z (symbol-value register)) - (and (or (not (numberp z)) - (not (=alg z constant))) - (eval-nodelist outs)))) - -(defun txxn (outs register constant) - (declare (ignore constant)) - (prog (z) - (setq z (symbol-value register)) - (and (numberp z) (eval-nodelist outs)))) - -(defun tltn (outs register constant) - (prog (z) - (setq z (symbol-value register)) - (and (numberp z) - (> constant z) - (eval-nodelist outs)))) - -(defun tgtn (outs register constant) - (prog (z) - (setq z (symbol-value register)) - (and (numberp z) - (> z constant) - (eval-nodelist outs)))) - -(defun tgen (outs register constant) - (prog (z) - (setq z (symbol-value register)) - (and (numberp z) - (not (> constant z)) - (eval-nodelist outs)))) - -(defun tlen (outs register constant) - (prog (z) - (setq z (symbol-value register)) - (and (numberp z) - (not (> z constant)) - (eval-nodelist outs)))) - -(defun teqs (outs vara varb) - (prog (a b) - (setq a (symbol-value vara)) - (setq b (symbol-value varb)) - (cond ((eq a b) (eval-nodelist outs)) - ((and (numberp a) - (numberp b) - (=alg a b)) - (eval-nodelist outs))))) - -(defun tnes (outs vara varb) - (prog (a b) - (setq a (symbol-value vara)) - (setq b (symbol-value varb)) - (cond ((eq a b) (return nil)) - ((and (numberp a) - (numberp b) - (=alg a b)) - (return nil)) - (t (eval-nodelist outs))))) - -(defun txxs (outs vara varb) - (prog (a b) - (setq a (symbol-value vara)) - (setq b (symbol-value varb)) - (cond ((and (numberp a) (numberp b)) (eval-nodelist outs)) - ((and (not (numberp a)) (not (numberp b))) - (eval-nodelist outs))))) - -(defun tlts (outs vara varb) - (prog (a b) - (setq a (symbol-value vara)) - (setq b (symbol-value varb)) - (and (numberp a) - (numberp b) - (> b a) - (eval-nodelist outs)))) - -(defun tgts (outs vara varb) - (prog (a b) - (setq a (symbol-value vara)) - (setq b (symbol-value varb)) - (and (numberp a) - (numberp b) - (> a b) - (eval-nodelist outs)))) - -(defun tges (outs vara varb) - (prog (a b) - (setq a (symbol-value vara)) - (setq b (symbol-value varb)) - (and (numberp a) - (numberp b) - (not (> b a)) - (eval-nodelist outs)))) - -(defun tles (outs vara varb) - (prog (a b) - (setq a (symbol-value vara)) - (setq b (symbol-value varb)) - (and (numberp a) - (numberp b) - (not (> a b)) - (eval-nodelist outs)))) - -(defun &two (left-outs right-outs) - (prog (fp dp) - (cond (*sendtocall* - (setq fp *flag-part*) - (setq dp *data-part*)) - (t - (setq fp *alpha-flag-part*) - (setq dp *alpha-data-part*))) - (sendto fp dp 'left left-outs) - (sendto fp dp 'right right-outs))) - -(defun &mem (left-outs right-outs memory-list) - (prog (fp dp) - (cond (*sendtocall* - (setq fp *flag-part*) - (setq dp *data-part*)) - (t - (setq fp *alpha-flag-part*) - (setq dp *alpha-data-part*))) - (sendto fp dp 'left left-outs) - (add-token memory-list fp dp nil) - (sendto fp dp 'right right-outs))) - -(defun &and (outs lpred rpred tests) - (prog (mem) - (cond ((eq *side* 'right) (setq mem (memory-part lpred))) - (t (setq mem (memory-part rpred)))) - (cond ((not mem) (return nil)) - ((eq *side* 'right) (and-right outs mem tests)) - (t (and-left outs mem tests))))) - -(defun and-left (outs mem tests) - (prog (fp dp memdp tlist tst lind rind res) - (setq fp *flag-part*) - (setq dp *data-part*) - fail (and (null mem) (return nil)) - (setq memdp (car mem)) - (setq mem (cdr mem)) - (setq tlist tests) - tloop (and (null tlist) (go succ)) - (setq tst (car tlist)) - (setq tlist (cdr tlist)) - (setq lind (car tlist)) - (setq tlist (cdr tlist)) - (setq rind (car tlist)) - (setq tlist (cdr tlist)) - ;### (comment the next line differs in and-left & -right) - (setq res (funcall tst (gelm memdp rind) (gelm dp lind))) - (cond (res (go tloop)) - (t (go fail))) - succ - ;### (comment the next line differs in and-left & -right) - (sendto fp (cons (car memdp) dp) 'left outs) - (go fail))) - -(defun and-right (outs mem tests) - (prog (fp dp memdp tlist tst lind rind res) - (setq fp *flag-part*) - (setq dp *data-part*) - fail (and (null mem) (return nil)) - (setq memdp (car mem)) - (setq mem (cdr mem)) - (setq tlist tests) - tloop (and (null tlist) (go succ)) - (setq tst (car tlist)) - (setq tlist (cdr tlist)) - (setq lind (car tlist)) - (setq tlist (cdr tlist)) - (setq rind (car tlist)) - (setq tlist (cdr tlist)) - ;### (comment the next line differs in and-left & -right) - (setq res (funcall tst (gelm dp rind) (gelm memdp lind))) - (cond (res (go tloop)) - (t (go fail))) - succ - ;### (comment the next line differs in and-left & -right) - (sendto fp (cons (car dp) memdp) 'right outs) - (go fail))) - - -(defun teqb (new eqvar) - (cond ((eq new eqvar) t) - ((not (numberp new)) nil) - ((not (numberp eqvar)) nil) - ((=alg new eqvar) t) - (t nil))) - -(defun tneb (new eqvar) - (cond ((eq new eqvar) nil) - ((not (numberp new)) t) - ((not (numberp eqvar)) t) - ((=alg new eqvar) nil) - (t t))) - -(defun tltb (new eqvar) - (cond ((not (numberp new)) nil) - ((not (numberp eqvar)) nil) - ((> eqvar new) t) - (t nil))) - -(defun tgtb (new eqvar) - (cond ((not (numberp new)) nil) - ((not (numberp eqvar)) nil) - ((> new eqvar) t) - (t nil))) - -(defun tgeb (new eqvar) - (cond ((not (numberp new)) nil) - ((not (numberp eqvar)) nil) - ((not (> eqvar new)) t) - (t nil))) - -(defun tleb (new eqvar) - (cond ((not (numberp new)) nil) - ((not (numberp eqvar)) nil) - ((not (> new eqvar)) t) - (t nil))) - -(defun txxb (new eqvar) - (cond ((numberp new) - (cond ((numberp eqvar) t) - (t nil))) - (t - (cond ((numberp eqvar) nil) - (t t))))) - - -(defun &p (rating name var-dope ce-var-dope rhs) - (declare (ignore var-dope ce-var-dope rhs)) - (prog (fp dp) - (cond (*sendtocall* - (setq fp *flag-part*) - (setq dp *data-part*)) - (t - (setq fp *alpha-flag-part*) - (setq dp *alpha-data-part*))) - (and (member fp '(nil old)) (removecs name dp)) - (and fp (insertcs name dp rating)))) - -(defun &old (a b c d e) - (declare (ignore a b c d e)) - nil) - -(defun ¬ (outs lmem rpred tests) - (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil) - ((eq *side* 'right) (not-right outs (car lmem) tests)) - (t (not-left outs (memory-part rpred) tests lmem)))) - -(defun not-left (outs mem tests own-mem) - (prog (fp dp memdp tlist tst lind rind res c) - (setq fp *flag-part*) - (setq dp *data-part*) - (setq c 0.) - fail (and (null mem) (go fin)) - (setq memdp (car mem)) - (setq mem (cdr mem)) - (setq tlist tests) - tloop (and (null tlist) (setq c (1+ c)) (go fail)) - (setq tst (car tlist)) - (setq tlist (cdr tlist)) - (setq lind (car tlist)) - (setq tlist (cdr tlist)) - (setq rind (car tlist)) - (setq tlist (cdr tlist)) - ;### (comment the next line differs in not-left & -right) - (setq res (funcall tst (gelm memdp rind) (gelm dp lind))) - (cond (res (go tloop)) - (t (go fail))) - fin (add-token own-mem fp dp c) - (and (== c 0.) (sendto fp dp 'left outs)))) - -(defun not-right (outs mem tests) - (prog (fp dp memdp tlist tst lind rind res newfp inc newc) - (setq fp *flag-part*) - (setq dp *data-part*) - (cond ((not fp) (setq inc -1.) (setq newfp 'new)) - ((eq fp 'new) (setq inc 1.) (setq newfp nil)) - (t (return nil))) - fail (and (null mem) (return nil)) - (setq memdp (car mem)) - (setq newc (cadr mem)) - (setq tlist tests) - tloop (and (null tlist) (go succ)) - (setq tst (car tlist)) - (setq tlist (cdr tlist)) - (setq lind (car tlist)) - (setq tlist (cdr tlist)) - (setq rind (car tlist)) - (setq tlist (cdr tlist)) - ;### (comment the next line differs in not-left & -right) - (setq res (funcall tst (gelm dp rind) (gelm memdp lind))) - (cond (res (go tloop)) - (t (setq mem (cddr mem)) (go fail))) - succ (setq newc (+ inc newc)) ;"plus" changed to "+" by gdw - (rplaca (cdr mem) newc) - (cond ((or (and (== inc -1.) (== newc 0.)) - (and (== inc 1.) (== newc 1.))) - (sendto newfp memdp 'right outs))) - (setq mem (cddr mem)) - (go fail))) - - - -;;; Node memories - - -(defun add-token (memlis flag data-part num) - (prog (was-present) - (cond ((eq flag 'new) - (setq was-present nil) - (real-add-token memlis data-part num)) - ((not flag) - (setq was-present (remove-old memlis data-part num))) - ((eq flag 'old) (setq was-present t))) - (return was-present))) - -(defun real-add-token (lis data-part num) - (setq *current-token* (1+ *current-token*)) - (cond (num (rplaca lis (cons num (car lis))))) - (rplaca lis (cons data-part (car lis)))) - -(defun remove-old (lis data num) - (cond (num (remove-old-num lis data)) - (t (remove-old-no-num lis data)))) - -(defun remove-old-num (lis data) - (prog (m next last) - (setq m (car lis)) - (cond ((atom m) (return nil)) - ((top-levels-eq data (car m)) - (setq *current-token* (1- *current-token*)) - (rplaca lis (cddr m)) - (return (car m)))) - (setq next m) - loop (setq last next) - (setq next (cddr next)) - (cond ((atom next) (return nil)) - ((top-levels-eq data (car next)) - (rplacd (cdr last) (cddr next)) - (setq *current-token* (1- *current-token*)) - (return (car next))) - (t (go loop))))) - -(defun remove-old-no-num (lis data) - (prog (m next last) - (setq m (car lis)) - (cond ((atom m) (return nil)) - ((top-levels-eq data (car m)) - (setq *current-token* (1- *current-token*)) - (rplaca lis (cdr m)) - (return (car m)))) - (setq next m) - loop (setq last next) - (setq next (cdr next)) - (cond ((atom next) (return nil)) - ((top-levels-eq data (car next)) - (rplacd last (cdr next)) - (setq *current-token* (1- *current-token*)) - (return (car next))) - (t (go loop))))) - - - -;;; Conflict Resolution -; -; -; each conflict set element is a list of the following form: -; ((p-name . data-part) (sorted wm-recency) special-case-number) - -(defun order-tags (dat) - (prog (tags) - (setq tags nil) - l1p (and (atom dat) (go l2p)) - (setq tags (cons (creation-time (car dat)) tags)) - (setq dat (cdr dat)) - (go l1p) - l2p (cond ((eq *strategy* 'mea) - (return (cons (car tags) (dsort (cdr tags))))) - (t (return (dsort tags)))))) - -; destructively sort x into descending order - -(defun dsort (x) - (prog (sorted cur next cval nval) - (and (atom (cdr x)) (return x)) - loop (setq sorted t) - (setq cur x) - (setq next (cdr x)) - chek (setq cval (car cur)) - (setq nval (car next)) - (cond ((> nval cval) - (setq sorted nil) - (rplaca cur nval) - (rplaca next cval))) - (setq cur next) - (setq next (cdr cur)) - (cond ((not (null next)) (go chek)) - (sorted (return x)) - (t (go loop))))) - -(defun order-part (conflict-elem) (cdr conflict-elem)) - -(defun conflict-set-compare (x y) - (prog (x-order y-order xl yl xv yv) - (setq x-order (order-part x)) - (setq y-order (order-part y)) - (setq xl (car x-order)) - (setq yl (car y-order)) - data (cond ((and (null xl) (null yl)) (go ps)) - ((null yl) (return t)) - ((null xl) (return nil))) - (setq xv (car xl)) - (setq yv (car yl)) - (cond ((> xv yv) (return t)) - ((> yv xv) (return nil))) - (setq xl (cdr xl)) - (setq yl (cdr yl)) - (go data) - ps (setq xl (cdr x-order)) - (setq yl (cdr y-order)) - psl (cond ((null xl) (return t))) - (setq xv (car xl)) - (setq yv (car yl)) - (cond ((> xv yv) (return t)) - ((> yv xv) (return nil))) - (setq xl (cdr xl)) - (setq yl (cdr yl)) - (go psl))) - - - -;;; WM maintaining functions -; -; The order of operations in the following two functions is critical. -; add-to-wm order: (1) change wm (2) record change (3) match -; remove-from-wm order: (1) record change (2) match (3) change wm -; (back will not restore state properly unless wm changes are recorded -; before the cs changes that they cause) (match will give errors if -; the thing matched is not in wm at the time) - -; remove-from-wm uses eq, not equal to determine if wme is present - -; mapwm maps down the elements of wm, applying fn to each element -; each element is of form (datum . creation-time) - -(defun mapwm (fn) - (prog (wmpl part) - (setq wmpl *wmpart-list*) - lab1 (cond ((atom wmpl) (return nil))) - (setq part (get (car wmpl) 'wmpart*)) - (setq wmpl (cdr wmpl)) - (mapc fn part) - (go lab1))) - -(defun ops-wm (a) - (mapc (function (lambda (z) (terpri) (ppelm z *standard-output*))) - (get-wm a)) - nil) - -(defun get-wm (z) - (setq *wm-filter* z) - (setq *wm* nil) - (mapwm (function get-wm2)) - (prog2 nil *wm* (setq *wm* nil))) - -(defun get-wm2 (elem) - (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*)) - (setq *wm* (cons (car elem) *wm*))))) - -(defun creation-time (wme) - (cdr (soarassq wme (get (wm-hash wme) 'wmpart*)))) - -(defun refresh nil - (prog nil - (setq *old-wm* nil) - (mapwm (function refresh-collect)) - (mapc (function refresh-del) *old-wm*) - (mapc (function refresh-add) *old-wm*) - (setq *old-wm* nil))) - -(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*))) - -(defun refresh-del (x) (remove-from-wm (car x))) - -;;;soar redefined add-to-wm -;;;;(defun refresh-add (x) (add-to-wm (car x) (cdr x))) - -(defun trace-file () - (prog (port) - (setq port *standard-output*) - (cond (*trace-file* - (setq port ($ofile *trace-file*)) - (cond ((null port) - (%warn '|trace: file has been closed| *trace-file*) - (setq port *standard-output*))))) - (return port))) - -;;; Basic functions for RHS evaluation - -(defun time-tag-print (data port) - (cond ((not (null data)) - (time-tag-print (cdr data) port) - (princq '| | port) - (princq (creation-time (car data)) port)))) - -(defun init-var-mem (vlist) - (prog (v ind r) - (setq *variable-memory* nil) - top (and (atom vlist) (return nil)) - (setq v (car vlist)) - (setq ind (cadr vlist)) - (setq vlist (cddr vlist)) - (setq r (gelm *data-matched* ind)) - (setq *variable-memory* (cons (cons v r) *variable-memory*)) - (go top))) - -(defun init-ce-var-mem (vlist) - (prog (v ind r) - (setq *ce-variable-memory* nil) - top (and (atom vlist) (return nil)) - (setq v (car vlist)) - (setq ind (cadr vlist)) - (setq vlist (cddr vlist)) - (setq r (ce-gelm *data-matched* ind)) - (setq *ce-variable-memory* - (cons (cons v r) *ce-variable-memory*)) - (go top))) - -(defun make-ce-var-bind (var elem) - (setq *ce-variable-memory* - (cons (cons var elem) *ce-variable-memory*))) - -(defun make-var-bind (var elem) - (setq *variable-memory* (cons (cons var elem) *variable-memory*))) - -(defun get-ce-var-bind (x) - (prog (r) - (cond ((numberp x) (return (get-num-ce x)))) - (setq r (soarassq x *ce-variable-memory*)) - (cond (r (return (cdr r))) - (t (return nil))))) - -(defun get-num-ce (x) - (prog (r l d) - (setq r *data-matched*) - (setq l (length r)) - (setq d (- l x)) - (and (> 0. d) (return nil)) - la (cond ((null r) (return nil)) - ((> 1. d) (return (car r)))) - (setq d (1- d)) - (setq r (cdr r)) - (go la))) - - -(defun build-collect (z) - (prog (r) - la (and (atom z) (return nil)) - (setq r (car z)) - (setq z (cdr z)) - (cond ((consp r) ;dtpr\consp gdw - ($value '\() - (build-collect r) - ($value '\))) - ((eq r '\\) ($change (car z)) (setq z (cdr z))) - (t ($value r))) - (go la))) - -(defun unflat (x) (setq *rest* x) (unflat*)) - -(defun unflat* nil - (prog (c) - (cond ((atom *rest*) (return nil))) - (setq c (car *rest*)) - (setq *rest* (cdr *rest*)) - (cond ((eq c '\() (return (cons (unflat*) (unflat*)))) - ((eq c '\)) (return nil)) - (t (return (cons c (unflat*))))))) - - -(defun $change (x) - (prog nil - (cond ((consp x) (eval-function x)) ;dtpr\consp gdw - (t ($value ($varbind x)))))) - -(defun eval-args (z) - (prog (r) - (rhs-tab 1.) - la (and (atom z) (return nil)) - (setq r (car z)) - (setq z (cdr z)) - (cond ((EQ R '^) - (RHS-tab (car z)) - (setq r (cadr z)) - (setq z (cddr z)))) - (cond ((eq r '//) ($value (car z)) (setq z (cdr z))) - (t ($change r))) - (go la))) - - -(defun eval-function (form) - (cond ((not *in-rhs*) - (%warn '|functions cannot be used at top level| (car form))) - (t (eval form)))) - -;;; Functions to manipulate the result array - -(defun $reset nil - (setq *max-index* 0.) - (setq *next-index* 1.)) - -(defun rhs-tab (z) ($tab ($varbind z))) - -(defun $tab (z) - (prog (edge next) - (setq next ($litbind z)) - (and (floatp next) (setq next (fix next))) - (cond ((or (not (numberp next)) - (> next *size-result-array*) - (> 1. next)) ; ( '| |) - (%warn '|illegal index after ^| next) - (return *next-index*))) - (setq edge (- next 1.)) - (cond ((> *max-index* edge) (go ok))) - clear (cond ((== *max-index* edge) (go ok))) - (putvector *result-array* edge nil) - (setq edge (1- edge)) - (go clear) - ok (setq *next-index* next) - (return next))) - -(defun $value (v) - (cond ((> *next-index* *size-result-array*) - (%warn '|index too large| *next-index*)) - (t - (and (> *next-index* *max-index*) - (setq *max-index* *next-index*)) - (putvector *result-array* *next-index* v) - (setq *next-index* (1+ *next-index*))))) - - -(defun use-result-array nil - (prog (k r) - (setq k *max-index*) - (setq r nil) - top (and (== k 0.) (return r)) - (setq r (cons (getvector *result-array* k) r)) - (setq k (1- k)) - (go top))) - -(defun $assert nil - (setq *last* (use-result-array)) - (add-to-wm *last*)) - -(defun $parametercount nil *max-index*) - -(defun $parameter (k) - (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.)) - (%warn '|illegal parameter number | k) - nil) - ((> k *max-index*) nil) - (t (getvector *result-array* k)))) - - -;;; RHS actions - -(defun ops-make (z) - (prog nil - ($reset) - (eval-args z) - ($assert))) - -(defun ops-modify (z) - (prog (old) - (cond ((not *in-rhs*) - (%warn '|cannot be called at top level| 'modify) - (return nil))) - (setq old (get-ce-var-bind (car z))) - (cond ((null old) - (%warn '|modify: first argument must be an element variable| - (car z)) - (return nil))) - (remove-from-wm old) - (setq z (cdr z)) - ($reset) - copy (and (atom old) (go fin)) - ($change (car old)) - (setq old (cdr old)) - (go copy) - fin (eval-args z) - ($assert))) - -(defun ops-cbind (z) - (cond ((not *in-rhs*) - (%warn '|cannot be called at top level| 'cbind)) - ((not (= (length z) 1.)) - (%warn '|cbind: wrong number of arguments| z)) - ((not (symbolp (car z))) - (%warn '|cbind: illegal argument| (car z))) - ((null *last*) - (%warn '|cbind: nothing added yet| (car z))) - (t (make-ce-var-bind (car z) *last*)))) - -(defun ops-remove (z) - (prog (old) - (and (not *in-rhs*)(return (top-level-remove z))) - top (and (atom z) (return nil)) - (setq old (get-ce-var-bind (car z))) - (cond ((null old) - (%warn '|remove: argument not an element variable| (car z)) - (return nil))) - (remove-from-wm old) - (setq z (cdr z)) - (go top))) - -(defun ops-call1 (z) - (prog (f) - (setq f (car z)) - ($reset) - (eval-args (cdr z)) - (funcall f))) - -(defmacro append-string (x) - `(setq wrstring (concatenate 'simple-string wrstring ,x))) - -(defun default-write-file () - (prog (port) - (setq port *standard-output*) - (cond (*write-file* - (setq port ($ofile *write-file*)) - (cond ((null port) - (%warn '|write: file has been closed| *write-file*) - (setq port *standard-output*))))) - (return port))) - -(defun do-rjust (width value port) - (prog (size) - (cond ((eq value '|=== T A B T O ===|) - (%warn '|rjust cannot precede this function| 'tabto) - (return nil)) - ((eq value '|=== C R L F ===|) - (%warn '|rjust cannot precede this function| 'crlf) - (return nil)) - ((eq value '|=== R J U S T ===|) - (%warn '|rjust cannot precede this function| 'rjust) - (return nil))) - ;original-> (setq size (flatc value (1+ width))) - (setq size (min value (1+ width))) ;### KLUGE - (cond ((> size width) - (princq '| | port) - (princq value port) - (return nil))) - (princq value port))) - -(defun do-tabto (col &optional port) - (prog (pos) - (finish-output port);kluge - (setq pos 0);kluge - (do ((k (- col pos) (1- k))) ((not (> k 0))) (princq '| | port)) - (return nil))) - -(defun halt nil - (cond ((not *in-rhs*) - (%warn '|cannot be called at top level| 'halt)) - (t (setq *halt-flag* t)))) - -(defun ops-build (z) - (prog (r) - (cond ((not *in-rhs*) - (%warn '|cannot be called at top level| 'build) - (return nil))) - ($reset) - (build-collect z) - (setq r (unflat (use-result-array))) - (and *build-trace* (funcall *build-trace* r)) - (compile-production (car r) (cdr r)))) - -(defun ops-openfile (z) - (prog (file mode id) - ($reset) - (eval-args z) - (cond ((not (equal ($parametercount) 3.)) - (%warn '|openfile: wrong number of arguments| z) - (return nil))) - (setq id ($parameter 1)) - (setq file ($parameter 2)) - (setq mode ($parameter 3)) - (cond ((not (symbolp id)) - (%warn '|openfile: file id must be a symbolic atom| id) - (return nil)) - ((null id) - (%warn '|openfile: 'nil' is reserved for the terminal| nil) - (return nil)) - ((or ($ifile id)($ofile id)) - (%warn '|openfile: name already in use| id) - (return nil))) - (cond ((eq mode 'in) (soarputprop id (setq id (infile file)) 'inputfile)) - ((eq mode 'out) (soarputprop id (setq id (outfile file)) 'outputfile)) - (t (%warn '|openfile: illegal mode| mode) - (return nil))) - (return nil))) - -(defun $ifile (x) - (cond ((symbolp x) (get x 'inputfile)) - (t nil))) - -(defun $ofile (x) - (cond ((symbolp x) (get x 'outputfile)) - (t nil))) - -(defun ops-closefile (z) - ($reset) - (eval-args z) - (mapc (function closefile2) (use-result-array))) - -(defun closefile2 (file) - (prog (port) - (cond ((not (symbolp file)) - (%warn '|closefile: illegal file identifier| file)) - ((setq port ($ifile file)) - (close port) - (remprop file 'inputfile)) - ((setq port ($ofile file)) - (close port) - (remprop file 'outputfile))) - (return nil))) - -(defun ops-default (z) - (prog (file use) - ($reset) - (eval-args z) - (cond ((not (equal ($parametercount) 2.)) - (%warn '|default: wrong number of arguments| z) - (return nil))) - (setq file ($parameter 1)) - (setq use ($parameter 2)) - (cond ((not (symbolp file)) - (%warn '|default: illegal file identifier| file) - (return nil)) - ((not (member use '(write accept trace) :test #'equal)) - (%warn '|default: illegal use for a file| use) - (return nil)) - ((and (member use '(write trace) :test #'equal) - (not (null file)) - (not ($ofile file))) - (%warn '|default: file has not been opened for output| file) - (return nil)) - ((and (equal use 'accept) - (not (null file)) - (not ($ifile file))) - (%warn '|default: file has not been opened for input| file) - (return nil)) - ((equal use 'write) (setq *write-file* file)) - ((equal use 'accept) (setq *accept-file* file)) - ((equal use 'trace) (setq *trace-file* file))) - (return nil))) - -(defun flat-value (x) - (cond ((atom x) ($value x)) - (t (mapc (function flat-value) x)))) - -(defun ops-accept (z) - (prog (port arg) - (cond ((> (length z) 1.) - (%warn '|accept: wrong number of arguments| z) - (return nil))) - (setq port *standard-input*) - (cond (*accept-file* - (setq port ($ifile *accept-file*)) - (cond ((null port) - (%warn '|accept: file has been closed| *accept-file*) - (return nil))))) - (cond ((= (length z) 1) - (setq arg ($varbind (car z))) - (cond ((not (symbolp arg)) - (%warn '|accept: illegal file name| arg) - (return nil))) - (setq port ($ifile arg)) - (cond ((null port) - (%warn '|accept: file not open for input| arg) - (return nil))))) - (cond ((equal (peek-char t port nil "eof" ) "eof" ) - ($value 'end-of-file) - (return nil))) - (flat-value (read port)))) - -(defun ops-acceptline (z) - (let ((port *standard-input*) - (def z)) - (cond (*accept-file* - (setq port ($ifile *accept-file*)) - (cond ((null port) - (%warn '|acceptline: file has been closed| - *accept-file*) - (return-from ops-acceptline nil))))) - (cond ((> (length def) 0) - (let ((arg ($varbind (car def)))) - (cond ((and (symbolp arg) ($ifile arg)) - (setq port ($ifile arg)) - (setq def (cdr def))))))) - (let ((line (read-line port nil 'eof))) - (declare (simple-string line)) - ;; Strip meaningless characters from start and end of string. - (setq line (string-trim '(#\( #\) #\, #\tab #\space) line)) - (when (equal line "") - (mapc (function $change) def) - (return-from ops-acceptline nil)) - (setq line (concatenate 'simple-string "(" line ")")) - ;; Read all items from the line - (flat-value (read-from-string line))))) - -(defun ops-substr (l) - (prog (k elm start end) - (cond ((not (= (length l) 3.)) - (%warn '|substr: wrong number of arguments| l) - (return nil))) - (setq elm (get-ce-var-bind (car l))) - (cond ((null elm) - (%warn '|first argument to substr must be a ce var| - l) - (return nil))) - (setq start ($varbind (cadr l))) - (setq start ($litbind start)) - (cond ((not (numberp start)) - (%warn '|second argument to substr must be a number| - l) - (return nil))) - ;### (comment |if a variable is bound to INF, the following| - ; |will get the binding and treat it as INF is| - ; |always treated. that may not be good|) - (setq end ($varbind (caddr l))) - (cond ((eq end 'inf) (setq end (length elm)))) - (setq end ($litbind end)) - (cond ((not (numberp end)) - (%warn '|third argument to substr must be a number| - l) - (return nil))) - (setq k 1.) - la (cond ((> k end) (return nil)) - ((not (< k start)) ($value (car elm)))) - (setq elm (cdr elm)) - (setq k (1+ k)) - (go la))) - -(defun ops-compute (z) ($value (ari z))) - -(defun ops-arith (z) ($value (ari z))) - -(defun ari (x) - (cond ((atom x) - (%warn '|bad syntax in arithmetic expression | x) - 0.) - ((atom (cdr x)) (ari-unit (car x))) - ((eq (cadr x) '+) - (+ (ari-unit (car x)) (ari (cddr x)))) - ;"plus" changed to "+" by gdw - ((eq (cadr x) '-) - (- (ari-unit (car x)) (ari (cddr x)))) - ((eq (cadr x) '*) - (* (ari-unit (car x)) (ari (cddr x)))) - ((eq (cadr x) '//) - (floor (ari-unit (car x)) (ari (cddr x)))) ;@@@ quotient? / - ;@@@ kluge only works for integers - ;@@@ changed to floor by jcp (from round) - ((eq (cadr x) '\\) - (mod (fix (ari-unit (car x))) (fix (ari (cddr x))))) - (t (%warn '|bad syntax in arithmetic expression | x) 0.))) - -(defun ari-unit (a) - (prog (r) - (cond ((consp a) (setq r (ari a))) ;dtpr\consp gdw - (t (setq r ($varbind a)))) - (cond ((not (numberp r)) - (%warn '|bad value in arithmetic expression| a) - (return 0.)) - (t (return r))))) - -(defun genatom nil ($value (gensym))) - -(defun ops-litval (z) - (prog (r) - (cond ((not (= (length z) 1.)) - (%warn '|litval: wrong number of arguments| z) - ($value 0) - (return nil)) - ((numberp (car z)) ($value (car z)) (return nil))) - (setq r ($litbind ($varbind (car z)))) - (cond ((numberp r) ($value r) (return nil))) - (%warn '|litval: argument has no literal binding| (car z)) - ($value 0))) - -;;; Printing WM - -(defun ppwm2 (elm-tag) - (cond ((filter (car elm-tag)) - (terpri) (ppelm (car elm-tag) (default-write-file))))) - -(defun filter (elm) - (prog (fl indx val) - (setq fl *filters*) - top (and (atom fl) (return t)) - (setq indx (car fl)) - (setq val (cadr fl)) - (setq fl (cddr fl)) - (and (ident (nth (1- indx) elm) val) (go top)) - (return nil))) - -(defun ident (x y) - (cond ((eq x y) t) - ((not (numberp x)) nil) - ((not (numberp y)) nil) - ((=alg x y) t) - (t nil))) - -; the new ppelm is designed especially to handle literalize format -; however, it will do as well as the old ppelm on other formats - -(defun ppelm (elm port) - (prog (ppdat sep val att mode lastpos) - (princq (creation-time elm) port) - (princq '|: | port) - (setq mode 'vector) - (setq ppdat (get (car elm) 'ppdat)) - (and ppdat (setq mode 'a-v)) - (setq sep "(") ; ")" - (setq lastpos 0) - (do ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist))) - ((atom vlist) nil) ; terminate - (setq val (car vlist)) ; tagbody begin - (setq att (assoc curpos ppdat)) ;should ret (curpos attr-name) - (cond (att (setq att (cdr att))) ; att = (attr-name) ?? - (t (setq att curpos))) - (and (symbolp att) (is-vector-attribute att) (setq mode 'vector)) - (cond ((or (not (null val)) (eq mode 'vector)) - (princq sep port) - (ppval val att lastpos port) - (setq sep '| |) - (setq lastpos curpos)))) - (princq '|)| port))) - -(defun ppval (val att lastpos port) - ; (break "in ppval") - (cond ((not (equal att (1+ lastpos))) ; ok, if we got an att - (princq '^ port) - (princq att port) - (princq '| | port))) - (princq val port)) - -;;; printing production memory - -(defun ppline2 () - (prog (needspace) - (setq needspace nil) - top (and (atom *ppline*) (return nil)) - (and needspace (princ '| |)) - (cond ((eq (car *ppline*) '^) (ppattval)) - (t (pponlyval))) - (setq needspace t) - (go top))) - -(defun getval () - (prog (res v1) - (setq v1 (car *ppline*)) - (setq *ppline* (cdr *ppline*)) - (cond ((member v1 '(= <> < <= => > <=>)) - (setq res (cons v1 (getval)))) - ((eq v1 '{) - (setq res (cons v1 (getupto '})))) - ((eq v1 '<<) - (setq res (cons v1 (getupto '>>)))) - ((eq v1 '//) - (setq res (list v1 (car *ppline*))) - (setq *ppline* (cdr *ppline*))) - (t (setq res (list v1)))) - (return res))) - -(defun getupto (end) - (prog (v) - (and (atom *ppline*) (return nil)) - (setq v (car *ppline*)) - (setq *ppline* (cdr *ppline*)) - (cond ((eq v end) (return (list v))) - (t (return (cons v (getupto end))))))) - -;;; backing up - -(defun record-index-plus (k) - (setq *record-index* (+ k *record-index*)) ;"plus" changed to "+" by gdw - (cond ((< *record-index* 0.) - (setq *record-index* *max-record-index*)) - ((> *record-index* *max-record-index*) - (setq *record-index* 0.)))) - -(defun initialize-record nil - (setq *record-index* 0.) - (setq *recording* nil) - (setq *max-record-index* 31.) - (putvector *record-array* 0. nil)) - -(defun begin-record (p data) - (setq *recording* t) - (setq *record* (list '=>refract p data))) - -(defun end-record nil - (cond (*recording* - (setq *record* - (cons *cycle-count* (cons *p-name* *record*))) - (record-index-plus 1.) - (putvector *record-array* *record-index* *record*) - (setq *record* nil) - (setq *recording* nil)))) - -(defun record-change (direct time elm) - (cond (*recording* - (setq *record* - (cons direct (cons time (cons elm *record*))))))) - -(defun record-refract (rule data) - (and *recording* - (setq *record* (cons '<=refract (cons rule (cons data *record*)))))) - -(defun refracted (rule data) - (prog (z) - (and (null *refracts*) (return nil)) - (setq z (cons rule data)) - (return (member z *refracts* :test #'equal)))) - -(defun back (k) - (prog (r) - loop (and (< k 1.) (return nil)) - (setq r (getvector *record-array* *record-index*)) ; ((')) - (and (null r) (return '|nothing more stored|)) - (putvector *record-array* *record-index* nil) - (record-index-plus -1.) - (undo-record r) - (setq k (1- k)) - (go loop))) - -(defun undo-record (r) - (prog (save act a b rate) - (setq save *recording*) - (setq *refracts* nil) - (setq *recording* nil) - (and *ptrace* (back-print (list '|undo:| (car r) (cadr r)))) - (setq r (cddr r)) - top (and (atom r) (go fin)) - (setq act (car r)) - (setq a (cadr r)) - (setq b (caddr r)) - (setq r (cdddr r)) - (and *wtrace* (back-print (list '|undo:| act a))) - (cond ((eq act '<=wm) (add-to-wm b a)) - ((eq act '=>wm) (remove-from-wm b)) - ((eq act '<=refract) - (setq *refracts* (cons (cons a b) *refracts*))) - ((and (eq act '=>refract) (still-present b)) - (setq *refracts* (spdelete (cons a b) *refracts*)) - (setq rate (rating-part (get a 'topnode))) - (removecs a b) - (insertcs a b rate)) - (t (%warn '|back: cannot undo action| (list act a)))) - (go top) - fin (setq *recording* save) - (setq *refracts* nil) - (return nil))) - -(defun still-present (data) - (prog nil - loop - (cond ((atom data) (return t)) - ((creation-time (car data)) - (setq data (cdr data)) - (go loop)) - (t (return nil))))) - -(defun back-print (x) - (prog (port) - (setq port (trace-file)) - (terpri port) - (print x port))) - -(defun ops-matches (rule-list) - (mapc (function matches2) rule-list) - (terpri)) - -(defun matches2 (p) - (cond ((atom p) - (terpri) - (terpri) - (princ p) - (matches3 (get p 'backpointers) 2. (ncons 1.))))) - -(defun matches3 (nodes ce part) - (cond ((not (null nodes)) - (terpri) - (princ '| ** matches for |) - (princ part) - (princ '| ** |) - (mapc (function write-elms) (find-left-mem (car nodes))) - (terpri) - (princ '| ** matches for |) - (princ (ncons ce)) - (princ '| ** |) - (mapc (function write-elms) (find-right-mem (car nodes))) - (matches3 (cdr nodes) (1+ ce) (cons ce part))))) - -(defun write-elms (wme-or-count) - (cond ((consp wme-or-count) ;dtpr\consp gdw - (terpri) - (mapc (function write-elms2) wme-or-count)))) - -(defun write-elms2 (x) - (princ '| |) - (princ (creation-time x))) - -(defun find-left-mem (node) - (cond ((eq (car node) '&and) (memory-part (caddr node))) - (t (car (caddr node))))) - -(defun find-right-mem (node) (memory-part (cadddr node))) - - -;;; Check the RHSs of productions - -(defun check-rhs (rhs) (mapc (function check-action) rhs)) - -(defun check-build (z) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-build-collect (cdr z))) - -(defun check-build-collect (args) - (prog (r) - top (and (null args) (return nil)) - (setq r (car args)) - (setq args (cdr args)) - (cond ((consp r) (check-build-collect r)) ;dtpr\consp gdw - ((eq r '\\) - (and (null args) (%warn '|nothing to evaluate| r)) - (check-rhs-value (car args)) - (setq args (cdr args)))) - (go top))) - -(defun check-remove (z) ;@@@ kluge by gdw - (and (null (cdr z)) (%warn '|needs arguments| z)) - (mapc (function check-rhs-ce-var) (cdr z))) - -(defun check-openfile (z) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-change& (cdr z))) - -(defun check-closefile (z) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-change& (cdr z))) - -(defun check-default (z) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-change& (cdr z))) - -(defun check-write (z) ;note this works w/write - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-change& (cdr z))) - -(defun check-call1 (z) - (prog (f) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (setq f (cadr z)) - (and (variablep f) - (%warn '|function name must be a constant| z)) - (or (symbolp f) - (%warn '|function name must be a symbolic atom| f)) - (or (externalp f) - (%warn '|function name not declared external| f)) - (check-change& (cddr z)))) - -(defun check-halt (z) - (or (null (cdr z)) (%warn '|does not take arguments| z))) - -(defun check-cbind (z) - (prog (v) - (or (= (length z) 2.) (%warn '|takes only one argument| z)) - (setq v (cadr z)) - (or (variablep v) (%warn '|takes variable as argument| z)) - (note-ce-variable v))) - -(defun check-bind (z) - (prog (v) - (or (> (length z) 1.) (%warn '|needs arguments| z)) - (setq v (cadr z)) - (or (variablep v) (%warn '|takes variable as argument| z)) - (note-variable v) - (check-change& (cddr z)))) - - -(defun check-change& (z) - (prog (r tab-flag) - (setq tab-flag nil) - la (and (atom z) (return nil)) - (setq r (car z)) - (setq z (cdr z)) - (cond ((eq r '^) - (and tab-flag - (%warn '|no value before this tab| (car z))) - (setq tab-flag t) - (check-tab-index (car z)) - (setq z (cdr z))) - ((eq r '//) (setq tab-flag nil) (setq z (cdr z))) - (t (setq tab-flag nil) (check-rhs-value r))) - (go la))) - -(defun check-rhs-ce-var (v) - (cond ((and (not (numberp v)) (not (ce-bound? v))) - (%warn '|unbound element variable| v)) - ((and (numberp v) (or (< v 1.) (> v *ce-count*))) - (%warn '|numeric element designator out of bounds| v)))) - -(defun check-rhs-atomic (x) - (and (variablep x) - (not (bound? x)) - (%warn '|unbound variable| x))) - -(defun check-rhs-function (x) - (prog (a) - (setq a (car x)) - (cond ((eq a 'compute) (check-compute x)) - ((eq a 'arith) (check-compute x)) - ((eq a 'substr) (check-substr x)) - ((eq a 'accept) (check-accept x)) - ((eq a 'acceptline) (check-acceptline x)) - ((eq a 'crlf) (check-crlf x)) - ((eq a 'genatom) (check-genatom x)) - ((eq a 'litval) (check-litval x)) - ((eq a 'tabto) (check-tabto x)) - ((eq a 'rjust) (check-rjust x)) - ((not (externalp a)) - (%warn '"rhs function not declared external" a))))) - -(defun check-litval (x) - (or (= (length x) 2) (%warn '|wrong number of arguments| x)) - (check-rhs-atomic (cadr x))) - -(defun check-accept (x) - (cond ((= (length x) 1) nil) - ((= (length x) 2) (check-rhs-atomic (cadr x))) - (t (%warn '|too many arguments| x)))) - -(defun check-acceptline (x) - (mapc (function check-rhs-atomic) (cdr x))) - -(defun check-crlf (x) - (check-0-args x)) - -(defun check-genatom (x) (check-0-args x)) - -(defun check-tabto (x) - (or (= (length x) 2) (%warn '|wrong number of arguments| x)) - (check-print-control (cadr x))) - -(defun check-rjust (x) - (or (= (length x) 2) (%warn '|wrong number of arguments| x)) - (check-print-control (cadr x))) - -(defun check-0-args (x) - (or (= (length x) 1.) (%warn '|should not have arguments| x))) - -(defun check-substr (x) - (or (= (length x) 4.) (%warn '|wrong number of arguments| x)) - (check-rhs-ce-var (cadr x)) - (check-substr-index (caddr x)) - (check-last-substr-index (cadddr x))) - -(defun check-compute (x) (check-arithmetic (cdr x))) - -(defun check-arithmetic (l) - (cond ((atom l) - (%warn '|syntax error in arithmetic expression| l)) - ((atom (cdr l)) (check-term (car l))) - ((not (member (cadr l) '(+ - * // \\))) ;"plus" changed to "+" by gdw - (%warn '|unknown operator| l)) - (t (check-term (car l)) (check-arithmetic (cddr l))))) - -(defun check-term (x) - (cond ((consp x) (check-arithmetic x)) ;dtpr\consp gdw - (t (check-rhs-atomic x)))) - -(defun check-last-substr-index (x) - (or (eq x 'inf) (check-substr-index x))) - -(defun check-substr-index (x) - (prog (v) - (cond ((bound? x) (return x))) - (setq v ($litbind x)) - (cond ((not (numberp v)) - (%warn '|unbound symbol used as index in substr| x)) - ((or (< v 1.) (> v 127.)) - (%warn '|index out of bounds in tab| x))))) - -(defun check-print-control (x) - (prog () - (cond ((bound? x) (return x))) - (cond ((or (not (numberp x)) (< x 1.) (> x 127.)) - (%warn '|illegal value for printer control| x))))) - -(defun check-tab-index (x) - (prog (v) - (cond ((bound? x) (return x))) - (setq v ($litbind x)) - (cond ((not (numberp v)) - (%warn '|unbound symbol occurs after ^| x)) - ((or (< v 1.) (> v 127.)) - (%warn '|index out of bounds after ^| x))))) - -(defun note-variable (var) - (setq *rhs-bound-vars* (cons var *rhs-bound-vars*))) - -(defun bound? (var) - (or (member var *rhs-bound-vars*) - (var-dope var))) - -(defun note-ce-variable (ce-var) - (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*))) - -(defun ce-bound? (ce-var) - (or (member ce-var *rhs-bound-ce-vars*) - (ce-var-dope ce-var))) - -;;; Top level routines - -(defun process-changes (adds dels) - (prog (x) - process-deletes (and (atom dels) (go process-adds)) - (setq x (car dels)) - (setq dels (cdr dels)) - (remove-from-wm x) - (go process-deletes) - process-adds (and (atom adds) (return nil)) - (setq x (car adds)) - (setq adds (cdr adds)) - (add-to-wm x nil) - (go process-adds))) - -(defun check-limits nil - (cond ((> (length *conflict-set*) *limit-cs*) - (format t "~%~%conflict set size exceeded the limit of ~D after ~D~%" - *limit-cs* *p-name*) - (setq *halt-flag* t))) - (cond ((> *current-token* *limit-token*) - (format t "~%~%token memory size exceeded the limit of ~D after ~D~%" - *limit-token* *p-name*) - (setq *halt-flag* t)))) - -(defun top-level-remove (z) - (cond ((equal z '(*)) (process-changes nil (get-wm nil))) - (t (process-changes nil (get-wm z))))) - -(defun ops-excise (z) (mapc (function excise-p) z)) - -(defun ops-strategy (z) - (cond ((atom z) *strategy*) - ((equal z '(lex)) (setq *strategy* 'lex)) - ((equal z '(mea)) (setq *strategy* 'mea)) - (t 'what?))) - -(defun ops-cs (z) - (cond ((atom z) (conflict-set)) - (t 'what?))) - -(defun ops-external (z) (catch '!error! (external2 z))) - -(defun external2 (z) (mapc (function external3) z)) - -(defun external3 (x) - (cond ((symbolp x) (soarputprop x t 'external-routine)) - (t (%error '|not a legal function name| x)))) - -(defun externalp (x) - (cond ((symbolp x) t) - (t (%warn '|not a legal function name| x) nil))) - -(defun rematm (atm list) - (cond ((atom list) list) - ((eq atm (car list)) (rematm atm (cdr list))) - (t (cons (car list) (rematm atm (cdr list)))))) - -(defun broken (rule) (member rule *brkpts*)) - -(defun fix (x) (floor x)) - -(defun infile (f_name) - (open f_name :direction :input)) - -(defun sequencep (x) (typep x 'sequence)) - -(defun outfile (f_name) - (open f_name :direction :output :if-exists :new-version)) - -;********** -; Soar 4.0 -;********** - -(proclaim '(special *3600-display* *action-closure* *action-list* - *already-fired* *always-learn* *attribute-index* - *begin-time* *big-index* *big-info-index* - *brknames* *brkrun* *cav* *cavi* *chunk-all-paths* - *chunk-classes* *chunk-free-problem-spaces* *chunks* - *closure* *condition-list* *condition-vars* *context* - *context-field-found* *context-stack* *copy-action-list* - *created-list* *creating-subgoal* - *current-goal* *current-list* *current-preferences* - *current-production-trace* *data-matched* *decide-count* - *decide-trace* *default-multi* *default-user-select* - *dtrace* *elaborations-count* *elapsed-time* - *first-action* *first-remove* *free-gensym-list* - *free-pname-list* *global-pair* *goal-index* *gtrace* - *id-index* *impasse-subset-not-equal* *indent* *init-wm* - *instance-attributes* *interlisp* *last-value-var* - *learn-ids* *learning* *ltrace* *max-chunk-conditions* - *max-elaborations* *max-recurse* *multi-attribute* - *never-learn* *new-chunks* *new-contexts* *new-root* - *operator-index* *ops5-actions* *order-trace* *otrace* - *p-type* *pick-first-condition* *pnames* - *preference-found* *print-attribute-list* *print-learn* - *print-pname* *print-spo-list* *prior-operator* - *problem-space-index* *prod-count* *rcontext* - *rcontext-stack* *remaining-decide* *result* - *save-action* *save-class-list* *save-condition* - *select-equal* *slot-index* *smaller-chunks* - *sp-classes* *split-actions* *spo-default-depth* - *state-index* *strace* *sub-context* *subgoal-results* - *subgoal-tabs* *suspected-duplicates* *trace-number* - *tracep* *tracep-list* *ttrace* *unbound* - *unbound-action-ids* *used-char-list* *used-gensym-list* - *used-var-list* *user-ids* *value-index* *variable-pairs* - *version-number* *warning* *watch-free-problem-spaces* - *wme-list-stack*)) - -; ****************************** - -;;; Macros and functions to help in the conversion of the Soar system -;;; from Interlisp to Commonlisp. - -(defmacro soarterpri (&body z) - (cons 'terpri z)) - -(defmacro smake (&body z) - (cond ((assoc (car z) *sp-classes*) - (spm-to-make z)) - (t - (cons 'make z)))) - -(defmacro soarwarn (&body z) - (cons '%warn z)) ; Using Ops5 %warn function -(defmacro %%warn (&body z) - (cons '%warn z)) ; Using Ops5 %warn function -(defmacro %%error (&body z) - (cons '%error z)) ; Using Ops5 %error function - -(defmacro soarsort (list) - `(sort ,list #'string-lessp)) - -(defmacro soardelq (item list) - `(delete ,item ,list :test #'eq)) -(defmacro dremove (item list) - `(delete ,item ,list :test #'eq)) - -(defmacro soarassoc (item alist) - `(assoc ,item ,alist :test #'equalp)) - -(defmacro soarmemq (item list) - `(member ,item ,list :test #'eq)) -(defmacro soarmember (item list) - `(member ,item ,list :test #'equalp)) - -(defun addprop (n a v) - (soarputprop n (cons v (get n a)) a)) - -(defmacro soarmapc (func list) - `(mapc ,func ,list)) - -(defmacro soarmapcar (func list) - `(mapcar ,func ,list)) - -(defmacro soarmapconc (func list) - `(mapcan ,func ,list)) - -(defmacro soarpush (item list) - `(push ,item ,list)) - -(defmacro quotient (x y) - `(float (/ ,x ,y))) - -(defmacro neq (&body z) - (list 'not (cons 'eq z))) - -(defmacro copy (thing) - `(copy-tree ,thing)) - -(defmacro soarnth (ind list) - `(nth ,ind ,list)) - -(defmacro soarnthcdr (ind list) - `(nthcdr ,ind ,list)) - -(defmacro alwaystime () - `(get-internal-run-time)) - -(defmacro time-conversion (tempus) - `(float (/ ,tempus internal-time-units-per-second))) - -(defmacro init-gensym (&body z) - (declare (ignore z)) - `(gensym 0) ) - -(defun soargensymbol (x) - (gentemp (string x))) - -(defun soarnthchar (sym num) - (char (string sym) (- num 1))) - -(defun soarpack (a b c d) - (intern (format nil "~A~A~D~A" a b c d))) - -(defun soarpack2 (a b) - (intern (format nil "~A~A" a b))) - -(defmacro soarload (f) - `(load ,f)) - -(defmacro soar-do (&body z) - (cons 'do z)) - -(defmacro soarwhile (test &body z) - (append (list 'do '() (list (list 'not test))) z)) - -(defun rplnode (x c d) - (rplaca x c) - (rplacd x d)) - -(defmacro soarcarsort (x) - `(sort ,x #'string-lessp :key #'car)) - -(defmacro array (n) - `(make-array ,n :initial-element () )) -(defmacro makevector (n) - `(make-array ,n :initial-element () )) - -(defmacro soarcatch (&body z) - (cons 'catch z)) - -(defmacro *throw (&body z) - (cons 'throw z)) - -(defmacro readp (z) - `(listen ,z)) - -(defmacro concat (&body z) - (cons 'concatenate (cons '(quote string) z))) - -(defmacro dreverse (x) - `(nreverse ,x)) - - -(eval-when (compile load eval) - (set-macro-character #\{ #'(lambda (s c) - (declare (ignore s c)) - '\{)) ;5/5/83 - (set-macro-character #\} #'(lambda (s c) - (declare (ignore s c)) - '\})) ;5/5/83 - (set-macro-character #\^ #'(lambda (s c) - (declare (ignore s c)) - '\^)) ;5/5/83 - ) - -(defmacro SETSYNTAX (&body z) - `() ) ; I'm betting that these can be ignored - -(defun soarsyntax () -) - -(defun soarresetsyntax () -) - -(defmacro selectq (&body z) - (setq z (nreverse z)) - (cond - ((eq 'err (car z)) - (cons 'ecase (nreverse (cdr z)))) - (t - (cons 'case (nreverse z)))) -) - -(defun soarclearprops (sym) - (setf (symbol-plist sym) () ) -) - -(defun soarmachinetype () - (setq *3600-display* nil) - (setq *interlisp* nil) -) - - -(defun interlisp-menu (x) - (declare (ignore x)) - t -) - -(defun pm-size () - (terpri) - (printlinec (list *pcount* 'productions - (list *real-cnt* '// *virtual-cnt* 'nodes)))) - -(defun printlinec (x) - (mapc (function printlinec*) x)) - -(defun printlinec* (x) - (princ " ") - (princ x)) - -(defun flatc (x) - (cond ((numberp x) - 3) - ((atom x) - (length (string x))) - (t - (+ (flatc (car x)) (flatc (cdr x)) 1)))) - -(defun flast (list) - (last list)) -(defun soarlast (list) - (car (last list))) - -(defun soarlistp (thing) - (cond ((null thing) - NIL) - (t - (listp thing)))) - -(defmacro comment (&body z) - (declare (ignore z)) - t) - - -(defmacro pop-match-elt (x) - `(prog (temp) - (setq temp (classify-match-elt ,x)) - (setq ,x (car temp)) - (return (cdr temp)))) - -(defmacro pop-term (x) - `(prog (temp) - (setq temp (classify-term ,x)) - (setq ,x (car temp)) - (return (cdr temp)))) - -(defun variablep (x) - (and (symbolp x) (equalp (soarnthchar x 1) #\<) - (not (predicatep x)) (not (eq x '<<)))) - -; ****************************** - -;;; Do not print a decimal point after integers -(setq *nopoint* t) - -(defun start-soar nil - (i-g-v)) - -(defun nwritn (x) - (send standard-output ':read-cursorpos ':character)) - -; For version 4.0 -(defmacro class (x) `(car ,x)) -(defmacro identifier (x) `(cadr ,x)) -(defmacro sattribute (x) `(caddr ,x)) -(defmacro svalue (x) `(cadddr ,x)) - -(defmacro call2 (&body z) - (list 'ops-call2 (list 'quote z))) - -(defmacro d (&body z) - (list 'ops-d (list 'quote z))) - -(defmacro sremove (&body z) - (list 'ops-sremove (list 'quote z))) - -(defmacro po (&body z) - (list 'ops-po (list 'quote z))) - -(defmacro pi (&body z) - (list 'ops-pi (list 'quote z))) - -(defmacro pop-goal (&body z) - (list 'ops-pop-goal (list 'quote z))) - -(defmacro ptrace (&body z) - (list 'ops-ptrace (list 'quote z))) - -(defmacro smatches (&body z) - (list 'ops-smatches (list 'quote z))) - -(defmacro spop (&body z) - (list 'ops-spop (list 'quote z))) - -(defmacro swatch (&body z) - (list 'ops-swatch (list 'quote z))) - -(defmacro tabstop (&body z) - (list 'ops-tabstop (list 'quote z))) - -(defmacro unpbreak (&body z) - (list 'ops-unpbreak (list 'quote z))) - -(defmacro write1 (&body z) - (list 'ops-write1 (list 'quote z))) - -(defmacro write2 (&body z) - (list 'ops-write2 (list 'quote z))) - -(defmacro sp (&body z) - (list 'ops-sp (list 'quote z))) - -(defmacro spm (&body z) - (list 'ops-spm (list 'quote z))) - -(defmacro spo (&body z) - (list 'ops-spo (list 'quote z))) - -(defmacro sppwm (&body z) - (list 'ops-sppwm (list 'quote z))) - -(defmacro spr (&body z) - (list 'ops-spr (list 'quote z))) - -(defmacro swm (&body z) - (list 'ops-swm (list 'quote z))) - -; common lisp ops should fix this with package -;; (defmacro write (&body z) -;; (list 'ops-write (list 'quote z))) - -(defmacro back-trace (&body z) - (list 'ops-back-trace (list 'quote z))) - -(defmacro learn (&body z) - (list 'ops-learn (list 'quote z))) - -(defun back-trace-conditions (current-goal action-list trace-flag) - (prog (production-traces production-trace previously-traced action actions return-list - depth) - (cond (trace-flag - (soarprint " ") - (soarprinc "Backtracing to determine conditions") - (soarprinc " for goal: ") - (soarprint current-goal) - (soarprint "Working-memory elements being traced:") - (soarmapc #'ppline - (p-conds-to-sp (soarmapcar #'clean-up-element action-list))) - (soarprint " ") - (soarprinc "Productions and conditions traced through:"))) - (setq depth 0) - (setq return-list nil) - (setq actions action-list) - (setq previously-traced nil) - (setq production-traces (get current-goal 'production-trace)) - l0 (cond ((null action-list) (return return-list))) - (setq action (pop action-list)) - (cond ((eq action 'mark) (setq depth (1- depth)) (go l0)) - ((eq action '-) - (setq action (pop action-list)) - (cond ((and (neq current-goal (get (svalue action) 'in-id-field)) - (not (soarmember action return-list))) - (trace-new-condition action trace-flag depth '-) - (soarpush action return-list) - (soarpush '- return-list))) - (go l0)) - ((and (eq (class action) 'goal-context-info) - (or (not (soarmember action *created-list*)) - (and *smaller-chunks* - (not (soarmemq action actions)) - (soarmember action *subgoal-results*)))) - (cond ((not (soarmember action return-list)) - (trace-new-condition action trace-flag depth nil) - (soarpush action return-list))) - (go l0)) - ((and (neq (class action) 'goal-context-info) - (or (not (soarmemq action *created-list*)) - (and *smaller-chunks* - (not (soarmemq action actions)) - (soarmemq action *subgoal-results*)))) - (cond ((not (soarmemq action return-list)) - (trace-new-condition action trace-flag depth nil) - (soarpush action return-list))) - (go l0)) - ((null action) (go l0))) - (setq production-trace (find-back-production action production-traces)) - (cond ((null production-trace) (go l0))) - (cond ((soarmemq (car production-trace) previously-traced) (go l0)) - (t (soarpush (car production-trace) previously-traced))) - (setq action-list (append (cadr production-trace) (cons 'mark action-list))) - (cond (trace-flag - (do-tabto (* 3 depth) (trace-file)) - (soarprint (caddr production-trace)))) - (setq depth (1+ depth)) - (go l0))) - -(defun broken2 (value) - (cond ((or (soarlistp value) - (null value)) - nil) - ((or (soarmemq (get value 'name) *brknames*) - (soarmemq value *brknames*) - (and *brkrun* - (eq (get value 'name) *brkrun*)) - (eq value *brkrun*))))) - -(defun build-sp-cond (avlist extralist) - (prog (result) - (soarmapc - #'(lambda (x) (setq result (append (car x) (append (nreverse (cdr x)) result)))) - avlist) - (setq result (append (nreverse extralist) result)) - (return result))) - -(defun ops-call2 (z) - (prog (sym val) - (cond ((not *in-rhs*) - (soarwarn "Cannot be called at top level " 'call2) - (return nil)) - ((not (symbolp (car z))) - (soarwarn "Call2: illegal argument " (car z)) - (return nil))) - ($reset) - (eval-args z) - (eval (use-result-array)))) - -(defun cdrmember (element list) - (prog nil - l0 (cond ((null list) (return nil)) - ((equal (cdr element) (cdr (pop list))) (return t))) - (go l0))) - -(defun check-decide nil - (or (eq *p-type* 'decide) - (soarwarn "Illegal decide in production type " *p-type*))) - -(defun check-default-make (z) - (or (soarmemq *p-type* '(elaborate-once elaborate)) - (soarwarn "Illegal make in production type " *p-type*)) - (and (null z) - (soarwarn "Arguments missing from make action " z)) - (check-change& z)) - -(defun check-remove-ops (z) - (soarwarn "Illegal remove in Soar production" *p-type*) - (and (null (cdr z)) - (soarwarn "Missing arguments for remove " z)) - (soarmapc #'check-rhs-ce-var (cdr z))) - -(defun clean-up-element (element) - (clean-up-clause element 'nil)) - -(defun compare-conditions (elm1 elm2) - (cond ((and (null elm1) - (null elm2)) - t) - ((or (null elm1) - (null elm2)) - nil) - ((eq (car elm1) (car elm2)) (compare-conditions (cdr elm1) (cdr elm2))) - ((and (eq (get (car elm1) 'tested) 1) - (eq (get (car elm2) 'tested) 1)) - (soarpush (car elm1) *suspected-duplicates*) - (compare-conditions (cdr elm1) (cdr elm2))) - (t nil))) - -(defun compute-choice (choice) - (cond ((and (get choice 'name) - (get choice 'instance)) - (concat (get choice 'name) (soarmapcar #'compute-choice (get choice 'instance)))) - ((get choice 'name) (get choice 'name)) - ((get choice 'instance) (soarmapcar #'compute-choice (get choice 'instance))) - (t choice))) - -(defun compute-negation-index (matrix) - (prog (save-matrix negation-vars negation-list count1 neg-var save-negation-vars - negated-conditions condition) - (setq negated-conditions nil) - (setq negation-vars nil) - (setq negation-list nil) - (setq save-matrix matrix) - l1 (cond (matrix - (cond ((equal (car matrix) '-) - (pop matrix) - (soarpush (remove-condition-trash (car matrix)) negated-conditions) - (setq negation-vars - (merge-not-time (find-neg-variables (car negated-conditions)) - negation-vars)))) - (pop matrix) - (go l1))) - (and (null negated-conditions) - (return nil)) - (setq count1 0) - l3 (cond ((or (null save-matrix) - (eq condition '-->)) - (return (list negated-conditions negation-list)))) - (setq condition (pop save-matrix)) - (cond ((eq condition '-) (setq save-matrix (cdr save-matrix)) (go l3))) - (setq save-negation-vars negation-vars) - (setq negation-vars nil) - l4 (cond ((null save-negation-vars) (setq count1 (1+ count1)) (go l3))) - (setq neg-var (pop save-negation-vars)) - (cond ((eq condition '-->) (soarpush neg-var negation-vars)) - ((soarmemq neg-var condition) - (soarpush (list neg-var count1 (find-position neg-var condition)) - negation-list)) - (t (soarpush neg-var negation-vars))) - (go l4))) - -(defun condition-trace (x) - (trace-condition-action x 'condition)) - -(defun conv-input-wme (input) - (cond ((numberp input) (get-wm (list input))) - ((and (soarlistp input) - (neq (car input) 'preference)) - (soarmapconc #'sswm (sp-info-expand nil input nil))) - ((soarlistp input) (sswm input)) - (t (sswm (append '(^ identifier) (list input)))))) - -(defun create-goal-info (data-matched goal-id) - (setq *data-matched* data-matched) - (setq *first-action* t)) - -(defun created (g) - (soarmapc #'print (get g 'created)) - t) - -(defun ops-d (dc) - (cond ((atom dc) (run)) (t (eval (list 'run (car dc) 'd))))) - -(defun delprop (name attribute value) - (soarputprop name (dremove value (get name attribute)) attribute)) - -(defun eliminate-trailing-nil (wme) - (prog nil - (cond ((atom wme) (return wme)) ((soarlast wme) (return wme))) - (setq wme (dreverse wme)) - l1 (cond ((car wme) (return (dreverse wme)))) - (setq wme (cdr wme)) - (go l1))) - -(defun excise-chunks nil - (prog (chunks) - (setq chunks (append *chunks* nil)) - (soarmapc #'(lambda (x) (setq *tracep-list* (dremove x *tracep-list*))) chunks) - (eval (cons 'excise chunks)))) - -(defun fill-up (wme) - (fill-up-c wme 'new) - (sendto 'new (list wme) 'left (list *new-root*))) - -(defun fill-up-c (wme flag) - (prog (dp) - (setq *alpha-flag-part* flag) - (setq *alpha-data-part* (list wme)) - (setq dp wme) - (setq *c1* (car dp)) - (setq dp (cdr dp)) - (setq *c2* (car dp)) - (setq dp (cdr dp)) - (setq *c3* (car dp)) - (setq dp (cdr dp)) - (setq *c4* (car dp)) - (setq dp (cdr dp)) - (setq *c5* (car dp)) - (setq dp (cdr dp)) - (setq *c6* (car dp)) - (setq dp (cdr dp)) - (setq *c7* (car dp)) - (setq dp (cdr dp)) - (setq *c8* (car dp)) - (setq dp (cdr dp)) - (setq *c9* (car dp)) - (setq dp (cdr dp)) - (setq *c10* (car dp)) - (setq dp (cdr dp)) - (setq *c11* (car dp)) - (setq dp (cdr dp)) - (setq *c12* (car dp)) - (setq dp (cdr dp)) - (setq *c13* (car dp)) - (setq dp (cdr dp)) - (setq *c14* (car dp)) - (setq dp (cdr dp)) - (setq *c15* (car dp)) - (setq dp (cdr dp)) - (setq *c16* (car dp)))) - -(defun fill-up-wm (wm) - (soarmapc #'fill-up wm)) - -(defun fill-up2 (wme) - (fill-up-c (car wme) 'new) - (sendto 'new (list (car wme)) 'left (list *new-root*))) - -(defun find-acceptable-preference (preferences id) - (prog (preference) - l0 (cond ((null preferences) (return nil))) - (setq preference (pop preferences)) - (cond ((and (eq 'preference (class preference)) - (eq id (identifier preference)) - (eq 'acceptable (svalue preference))) - (return preference))) - (go l0))) - -(defun find-action-sets (actions subgoal) - (prog (return-list new-action-list current-closure moved-action action possible-actions) - (setq return-list nil) - l0 (and (null actions) - (return (nreverse return-list))) - (setq action (pop actions)) - (setq new-action-list (list action)) - (setq current-closure (find-unbound-symbols action)) - (cond ((null current-closure) - (soarpush (nreverse new-action-list) return-list) - (go l0))) - l2 (setq moved-action nil) - (setq possible-actions actions) - (setq actions nil) - l1 (cond ((and (null possible-actions) - moved-action) - (go l2)) - ((null possible-actions) - (soarpush (nreverse new-action-list) return-list) - (go l0))) - (setq action (pop possible-actions)) - (cond ((intrq (cons (cadr action) (cdddr action)) current-closure) - (setq current-closure - (append (find-unbound-symbols action) current-closure)) - (soarpush action new-action-list) - (setq moved-action t)) - ((and *smaller-chunks* - (neq (car action) 'preference) - (intrq (list (cadr action)) current-closure)) - (setq current-closure - (append (find-unbound-symbols action) current-closure)) - (soarpush action new-action-list) - (setq moved-action t)) - ((and *smaller-chunks* - (eq (car action) 'preference) - (intrq (list (cddddr action)) current-closure)) - (setq current-closure - (append (find-unbound-symbols action) current-closure)) - (soarpush action new-action-list) - (setq moved-action t)) - (t (soarpush action actions))) - (go l1))) - -(defun find-back-production (action traces) - (cdr (cond ((eq (class action) 'goal-context-info) (soarassoc action traces)) - (t (soarassq action traces))))) - -(defun find-max-goal-depth (goal-list) - (prog (max-depth max-depth-goal goal-depth) - (setq max-depth -1) - (setq max-depth-goal nil) - l0 (cond ((null goal-list) (return max-depth-goal))) - (setq goal-depth (get (cadar goal-list) 'goal-depth)) - (cond ((and goal-depth - (< max-depth goal-depth)) - (setq max-depth goal-depth) - (setq max-depth-goal (cadar goal-list)))) - (pop goal-list) - (go l0))) - -(defun find-neg-variables (condition) - (prog (return-list) - (setq return-list nil) - l1 (cond ((null condition) (return return-list)) - ((variablep (car condition)) (soarpush (car condition) return-list))) - (pop condition) - (go l1))) - -(defun find-position (var condition) - (prog (attribute) - l1 (cond ((or (null condition) - (eq var (car condition))) - (return (1- (literal-binding-of attribute)))) - ((and (car condition) - (predicatep (car condition))) - (setq condition (cddr condition))) - ((and (car condition) - (eq (car condition) '^)) - (setq attribute (cadr condition)) - (setq condition (cddr condition))) - ((and (car condition) - (soarmemq (car condition) '({ }))) - (pop condition)) - (t (pop condition))) - (go l1))) - -(defun find-selected-result (choice results) - (prog (result) - (cond ((numberp choice) - (cond ((or (< choice 1) - (> choice (length results))) - (return nil))) - (return (soarnth (1- choice) results)))) - l1 (setq result (pop results)) - (cond ((test-selected-result choice result) - (and (null *select-equal*) - (setq *select-equal* *default-user-select*)) - (return result)) - ((null results) (return nil))) - (go l1))) - -(defun find-small-action-sets (actions subgoal) - (prog (action action-pi pi-action-list return-list rest-pi-list) - (setq pi-action-list nil) - l1 (cond ((null actions) (return (soarmapcar #'cdr pi-action-list)))) - (setq action (pop actions)) - (setq action-pi - (car (find-back-production action (get subgoal 'production-trace)))) - (cond ((setq rest-pi-list (soarassq action-pi pi-action-list)) - (rplacd rest-pi-list (cons action (cdr rest-pi-list)))) - (t (soarpush (list action-pi action) pi-action-list))) - (go l1))) - -;** Chris Fedor 11/26/85 -;** added (not (numberp value)) test to avoid doing get on a number -(defun find-subgoal-nonresults (subgoal supergoal created-list) - (prog (change-flag action id nonresult-list goal value) - (setq *subgoal-results* nil) - l1 (setq change-flag nil) - (setq nonresult-list nil) - l2 (cond ((and (null created-list) - (null change-flag)) - (setq *subgoal-results* (nreverse *subgoal-results*)) - (return nonresult-list)) - ((null created-list) - (setq created-list (nreverse nonresult-list)) (go l1))) - (setq action (pop created-list)) - (setq id (identifier action)) - (setq goal (get id 'in-id-field)) - (cond ((or (and (eq (car action) 'preference) - (closure-preference action subgoal)) - (and (neq (car action) 'preference) - (neq goal subgoal))) - (setq change-flag t) - (soarpush action *subgoal-results*) - (setq value (svalue action)) - (cond ((and (eq (car action) 'preference) - (eq goal subgoal)) - (soarpush id *unbound-action-ids*) - (and supergoal - (soarputprop id supergoal 'in-id-field))) - ((and (neq (car action) 'preference) - (not (numberp value)) - (eq (get value 'in-id-field) subgoal)) - (and supergoal - (soarputprop value supergoal 'in-id-field)) - (soarpush value *unbound-action-ids*))) - (and supergoal (addprop supergoal 'created action))) - (t (soarpush action nonresult-list))) - (go l2))) - -(defun find-variables (list) - (cond ((null list) nil) - ((variablep (car list)) (cons (car list) (find-variables (cdr list)))) - (t (find-variables (cdr list))))) - -(defun find-reject-preferences (preferences) - (prog (preference return-list) - (setq return-list nil) - l0 (cond ((null preferences) (return return-list))) - (setq preference (pop preferences)) - (cond ((and (eq 'preference (class preference)) - (eq 'reject (svalue preference))) - (soarpush preference return-list))) - (go l0))) - -(defun find-unbound-symbols (action) - (prog (return-list) - (setq return-list nil) - l1 (cond ((null action) (return return-list)) - ((and (get (car action) 'in-id-field) - (soarmemq (car action) *unbound-action-ids*)) - (soarpush (car action) return-list))) - (pop action) - (go l1))) - -(defun flatten (l) - (soarmapconc #'(lambda (item) (cond ((atom item) (list item)) (t (flatten item)))) l)) - -(defun gensyminit nil - (soarmapc #'soarclearprops *used-gensym-list*) - (soarmapc #'move-to-free-gensym-list *used-gensym-list*) - (setq *used-gensym-list* nil)) - -(defun handle-back-trace-actions (action-list old-context prior-context new-context - subgoaled) - (prog (duplicate-list copy-list return-value closure condition-list negation-list - wme-list) - (clear-var-list) - (setq wme-list - (back-trace-conditions (get-current old-context 'goal) action-list - *ltrace*)) - (setq *p-name* (get-current old-context 'goal)) - (setq *first-action* t) - (soarmapc - #'(lambda (x) (save-production-trace x wme-list (get-current new-context 'goal))) - action-list) - (cond ((and (not *always-learn*) - (or subgoaled - (get-context-subgoaled old-context))) - (return t)) - ((or (not *learning*) - (soarmemq (get (get-current old-context 'problem-space) 'name) - *chunk-free-problem-spaces*) - (not (test-context prior-context))) - (return nil))) - (setq closure (find-closure wme-list)) - (soarmapc #'build-variable-list closure) - (setq *action-closure* (find-action-closure action-list)) - (setq condition-list - (soarmapcar #'(lambda (x) (clean-up-clause x 'condition)) wme-list)) - (setq action-list (soarmapcar #'clean-up-action action-list)) - (setq condition-list (process-negations condition-list)) - (setq negation-list (cdr condition-list)) - (setq condition-list (build-terse (soarcarsort (car condition-list)))) - (cond ((test-chunk-for-content condition-list) - (and *ltrace* - (soarmapc #'ppline (p-conds-to-sp condition-list))) - (return nil))) - (setq duplicate-list - (compactify-conditions (append condition-list negation-list) action-list)) - (setq copy-list (bind-it *action-list*)) - (setq *action-list* (rebind-action-ids *action-list* copy-list)) - (setq *copy-action-list* *action-list*) - (setq return-value (build-a-production *condition-list* *action-list* wme-list)) - (and duplicate-list - (soarmapc #'build-copies duplicate-list)) - (return return-value))) - -(defun init-literalizes nil - (literalize preference object role value reference goal problem-space state operator) - (literalize goal-context-info identifier attribute value) - (literalize space-info identifier attribute value) - (literalize state-info identifier attribute value) - (literalize op-info identifier attribute value) - (literalize eval-info identifier attribute value) - (literalize desired-info identifier attribute value) - (literalize info identifier attribute value)) - -(defun init-soar nil - (setq *in-rhs* nil) - (sremove) - (setq *init-wm* nil) - (setq *conflict-set* nil) - (setq *wmpart-list* nil) - (setq *p-name* nil) - (setq *phase* 'elaborate) - (setq *prod-count* (setq *decide-count* (setq *cycle-count* (setq *action-count* 0)))) - (setq *total-token* (setq *max-token* (setq *current-token* 0))) - (setq *first-action* nil) - (gensyminit) - (setq *current-production-trace* 'cpt) - (soarmapc #'soarclearprops *user-ids*) - (setq *user-ids* nil) - (and *3600-display* - (clear-soar2-window)) - (setq *total-cs* (setq *max-cs* 0)) - (setq *total-wm* (setq *max-wm* (setq *current-wm* 0))) - (setq *elapsed-time* 0) - (setq *trace-number* 0) - (setq *context* - (list (soargensym 'goal) - 'undecided - 'undecided - 'undecided - 1 - 'nil - 'nil - 'nil - 'nil - 'nil - 0)) - (setq *context-stack* (list *context*)) - (setq *data-matched* nil)) - -(defun init-wm nil - (prog (cg cp cs co) - (cond ((not *init-wm*) - (setq *phase* 'decide) - (setq cg (get-current *context* 'goal)) - (setq cp (get-current *context* 'problem-space)) - (setq cs (get-current *context* 'state)) - (setq co (get-current *context* 'operator)) - (soarputprop cg 1 'goal-depth) - (and *learning* - (learn)) - (make-info 'goal-context-info cg 'problem-space cp) - (trace-object 'goal cg 0) - (trace-object 'problem-space cp 0) - (make-info 'goal-context-info cg 'state cs) - (trace-object 'state cs 0) - (make-info 'goal-context-info cg 'operator co) - (trace-object 'operator co 0) - (setq *init-wm* t) - (setq *phase* 'elaborate))))) - -(defun intrq (x y) - (cond ((atom x) nil) - ((soarmemq (car x) y) (cons (car x) (intrq (cdr x) y))) - (t (intrq (cdr x) y)))) - -(defun last-chunk nil - (eval (cons 'spm (list (car *chunks*))))) - -(defun list-chunks nil - (eval (cons 'spm (reverse *chunks*)))) - -(defun make-new-root (pname) - (link-new-node (list '&priv nil pname))) - -(defun make-nil-list (list-length) - (prog (nil-list) - (setq nil-list '(nil)) - l1 (cond ((eq list-length (length nil-list)) (return nil-list))) - (soarpush 'nil nil-list) - (go l1))) - -(defun mark-in-id (wme) - (prog (id att value port) - (setq port (trace-file)) - (setq id (identifier wme)) - (setq att (sattribute wme)) - (and (not id) - (return nil)) - (cond ((and (neq *phase* 'decide) - (eq 'goal-context-info (class wme)) - (soarmemq att '(problem-space state operator))) - (soarwarn "Illegal attempt to modify context" wme) - (return t)) - ((eq *phase* 'decide) (setq *current-goal* (get-current *context* 'goal))) - ((and (not *current-goal*) - (setq *current-goal* 'undecided))) - ((and *first-action* - (eq (get *p-name* 'type) 'elaborate-once)) - (and (eq (cdr (soarassq *p-name* *already-fired*)) *current-goal*) - (return t)) - (soarpush (cons *p-name* *current-goal*) *already-fired*))) - (cond ((and (not (get id 'gensymed)) - (not (soarmemq id *user-ids*))) - (soarpush id *user-ids*))) - (cond ((not (get id 'in-id-field)) (soarputprop id *current-goal* 'in-id-field))) - (setq value (svalue wme)) - (cond ((eq att 'name) (soarputprop id value 'name)) - ((soarmember (list (class wme) att) *instance-attributes*) - (addprop id 'instance value))) - (cond ((not *never-learn*) - (save-production-trace wme (reverse *data-matched*) *current-goal*))) - (cond (*first-action* - (cond ((and *ptrace* - *ttrace* - (not *wtrace*) - (trace-problem-space?)) - (soarprinc "-->"))) - (setq *first-remove* t) - (setq *first-action* nil))) - (addprop *current-goal* 'created wme) - (return nil))) - -(defun match-update (wme) - (fill-up-c (car wme) 'new) - (sendto 'new (list (car wme)) 'left (list *new-root*))) - -(defun mem-length (mem) - (prog (n) - (setq n 0) - (soarmapc #'(lambda (ci) (cond ((soarlistp ci) (setq n (+ n 1))))) mem) - (return n))) - -(defun merge-not-time (lista listb) - (prog (elm) - (and (null lista) - (return listb)) - (setq elm (car lista)) - (cond ((null listb) (return lista)) - ((numberp elm) (return (merge-not-time (cdr lista) listb))) - ((soarmemq elm listb) (return (merge-not-time (cdr lista) listb))) - (t (return (cons elm (merge-not-time (cdr lista) listb))))))) - -(defun most-recent-subgoal (context-stack) - (cond ((null (cdr context-stack)) (caar context-stack)) - (t (most-recent-subgoal (cadr context-stack))))) - -(defun move-to-free-gensym-list (symbol) - (prog (char sym-list) - (setq char (soarnthchar symbol 1)) - (setq sym-list (soarassq char *free-gensym-list*)) - (cond ((null sym-list) - (setq *free-gensym-list* - (append *free-gensym-list* (list (list char symbol))))) - (t (rplacd sym-list (append (list symbol) (cdr sym-list))))))) - -(defun multi-attribute (x) - (prog (class) - (cond ((soarassq (car x) *sp-classes*) - (setq class (cdr (soarassq (car x) *sp-classes*)))) - (t (setq class (soarpack2 (car x) '-info)) - (soarpush (cons (car x) class) *sp-classes*))) - (cond ((not (soarmemq class *save-class-list*)) - (soarpush class *save-class-list*) - (soarputprop class (get 'state-info 'ppdat) 'ppdat))) - (setq x (cdr x)) - (cond ((and (cdr x) - (numberp (cadr x)) - (or (> (cadr x) 99) - (< (cadr x) 1))) - (soarwarn "Illegal multi-attribute value" (cadr x)) - (setq x (list (car x))))) - (soarpush (cons class x) *multi-attribute*))) - -(defun multi-attributes (x) - (soarmapc #'multi-attribute x)) - -(defun new-variables (condition stack) - (prog (first elm) - (setq first (car stack)) - l1 (setq elm (pop condition)) - (cond ((null condition) (return stack)) - ((and (variablep elm) - (neq first elm)) - (soarpush elm stack))) - (go l1))) - -(defun new-variable-list (condition list) - (prog (elm) - l1 (setq condition (cdr condition)) - (setq elm (car condition)) - (cond ((null condition) (return list)) - ((and (variablep elm) - (not (soarmemq elm list))) - (soarpush elm list))) - (go l1))) - -(defun ops-sremove (z) - (cond ((equal z '*) (process-changes nil (get-wm nil))) - (t (process-changes nil (get-wm z))))) - - -(defun sswm (avlist) - (cond ((and (cdddr avlist) - (variablep (cadddr avlist))) - (rplacd avlist (cddddr avlist)))) - (cond ((not (conv-to-attr-nums avlist nil)) nil) - (t (mapwm #'sswm2) (prog2 nil *wm* (setq *wm* nil))))) - -(defun sswm2 (elm-tag) - (cond ((filter (car elm-tag)) (soarpush (car elm-tag) *wm*)))) - -(defun pgs nil - (pgs-frame *context-stack* 1 nil nil nil) - (soarprintc "Decision cycle ") - (soarprinc *decide-count*) - (terpri (trace-file))) - -(defun pgs-frame (context-stack depth difficulty results second-time) - (prog (slots slot id context difficulty2 super-op result port) - (setq port (trace-file)) - (setq context (pop context-stack)) - (cond ((null context) (return nil)) (second-time (terpri (trace-file)))) - (setq super-op (get-context-super-operator context)) - (setq difficulty2 - (list (get-context-difficulty context) (get-context-slot context))) - (setq result (get-context-results context)) - (setq slots '(g p s o)) - l2 (cond (slots - (setq id (pop context)) - (setq slot (pop slots)) - (cond ((neq id 'undecided) - (terpri port) - (cond (*subgoal-tabs* (do-tabto (+ 2 (* depth 3)) port)) - (t (do-tabto 5 port) - (soarprinc3 "(" (1- depth) ")") - (do-tabto 11 port))) - (soarprinc2 slot ": ") - (print-id id) - (setq difficulty nil))) - (go l2))) - (setq second-time nil) - (soarmapc - #'(lambda (x) - (pgs-frame x (1+ depth) difficulty2 result second-time) - (setq second-time t)) - context-stack))) - -(defun ops-po (object) - (print-object (car object) (cadr object))) - - -(defun ops-pi (z) - (print-partial-instantiation (car z) (cond ((cdr z) (cadr z)) (t 1)))) - - -(defun ppi3 (p i nodes ce part) - (prog (saved-mems n smatch-flg) - (cond ((null nodes) - (setq n 0) - (soarmapc - #'(lambda (ci) - (cond ((eq (car ci) p) - (setq n (+ n 1)) - (cond ((equal n i) - (soarmapc - #'(lambda (wme) (eval (list 'wm (creation-time wme)))) - (reverse (cdr ci))) - (terpri (trace-file))))))) - *conflict-set*) - (terpri (trace-file)) - (return ce)) - ((null (setq saved-mems (find-left-mem (car nodes)))) (return nil)) - ((not (setq smatch-flg (ppi3 p i (cdr nodes) (1+ ce) (cons ce part)))) - (soarmapc #'(lambda (ci) (eval (list 'wm (creation-time ci)))) - (reverse (soarnth (1- i) saved-mems))) - (terpri (trace-file)) - (return ce))) - (return smatch-flg))) - -(defun ops-pop-goal (goals) - (cond ((null goals) - (soarmapc - #'(lambda (x) - (pop-subgoals x (most-recent-subgoal *context-stack*) *context-stack* - (car *context-stack*))) - (cdr *context-stack*))) - (t (soarmapc - #'(lambda (y) - (soarmapc - #'(lambda (x) (pop-subgoals x y *context-stack* (car *context-stack*))) - (cdr *context-stack*))) - goals))) - nil) - - -(defun pop-subgoals (stack g prior-stack prior-context) - (cond (stack - (cond ((eq (caar stack) g) - (remove-subgoal-objects stack) - (rplacd prior-stack nil) - (rplaca (soarnthcdr 4 prior-context) 0) - (rplaca (soarnthcdr 5 prior-context) nil)) - (t (soarmapc #'(lambda (x) (pop-subgoals x g stack (car stack))) - (cdr stack))))))) - -(defun print-choice (choice) - (print-id choice) - (soarprint " ")) - -(defun print-id (id) - (soarprinc2 id " ") - (cond ((and id - (atom id) - (neq id 'undecided)) - (and (get id 'name) - (soarprinc (get id 'name))) - (setq *print-attribute-list* (list id)) - (print-instance id) - (setq *print-attribute-list* nil)))) - -(defun print-instance (id) - (prog (flag) - (cond ((get id 'instance) - (setq flag nil) - (soarprinc "(") - (soarmapc - #'(lambda (object) - (and flag - (soarprinc " ")) - (setq flag t) - (cond ((get object 'name) - (soarprinc (get object 'name)) - (cond ((not (soarmemq object *print-attribute-list*)) - (soarpush object *print-attribute-list*) - (print-instance object)))) - (t (soarprinc object) - (cond ((not (soarmemq object *print-attribute-list*)) - (soarpush object *print-attribute-list*) - (print-instance object)))))) - (get id 'instance)) - (soarprinc ")"))))) - -(defun print-instantiation (p i) - (prog (n) - (setq n 0) - (soarmapc - #'(lambda (inst) - (cond ((eq (car inst) p) - (setq n (1+ n)) - (cond ((equal n i) - (soarmapc - #'(lambda (wme) (eval (list 'wm (creation-time wme)))) - (reverse (cdr inst))) - (terpri (trace-file))))))) - *conflict-set*))) - -(defun print-partial-instantiation (p i) - (ppi3 p i (get p 'backpointers) 2 (ncons 1))) - -(defun printline (x) - (soarmapc #'soarprinc x) - (terpri (trace-file))) - -(defun print-object (object depth) - (cond ((and *3600-display*) (draw-current-contents object)) - (t (eval (append '(ppwm ^ identifier) (list object)))))) - -(defun print-status nil - (soarprintc "Learn status: ") - (cond (*learning* (soarprinc "on ")) - (*never-learn* (soarprinc "never ")) - (t (soarprinc "off "))) - (cond (*always-learn* (soarprinc "always ")) (t (soarprinc "bottom-up "))) - (cond ((eq *print-learn* 0) (soarprinc "print ")) - (*print-learn* (soarprinc "full-print ")) - (t (soarprinc "noprint "))) - (cond ((and *ltrace* *tracep*) (soarprint "full-trace ")) - (*tracep* (soarprint "trace ")) - (t (soarprint "notrace "))) - t) - -(defun process-instance (instance) - (prog nil - (setq *first-action* t) - (accum-stats) - (eval-rhs (car instance) (cdr instance)) - (check-limits) - (and (broken (car instance)) - (setq *break-flag* t)))) - -(defun process-negations (conditions) - (prog (return-conditions element negations) - (setq negations nil) - l2 (cond ((null conditions) - (setq negations (variablize-negations negations)) - (and negations - (return (cons (nreverse return-conditions) - (nreverse (tersify-negations negations))))) - (return (list (nreverse return-conditions)))) - ((eq (car conditions) '-) - (pop conditions) - (soarpush (pop conditions) negations)) - (t (soarpush (pop conditions) return-conditions))) - (go l2))) - -(defun ops-ptrace (arg) - (cond ((atom arg) *tracep-list*) - (t (setq *tracep-list* - (append *tracep-list* - (soarmapcar - #'(lambda (x) - (cond ((or (numberp x) - (soarlistp x)) - (car (conv-input-wme x))) - (t x))) - arg)))))) - - -(defun remove-condition-attributes (condition) - ($reset) - (cond ((neq (cadr condition) '^) - (eval-args (append (cons (car condition) '(^ identifier)) (cdr condition)))) - (t (eval-args condition))) - (use-result-array)) - -(defun remove-condition-trash (condition) - (prog (return-condition pand-flag disjunction-flag) - (setq return-condition nil) - (setq pand-flag nil) - (setq disjunction-flag nil) - l1 (cond ((null condition) (return (nreverse return-condition))) - ((eq (car condition) '<<) (pop condition) (setq disjunction-flag t)) - ((eq (car condition) '>>) (pop condition) (setq disjunction-flag nil)) - (disjunction-flag (pop condition)) - ((eq (car condition) '{) (pop condition) (setq pand-flag t)) - ((eq (car condition) '}) - (pop condition) - (and pand-flag - (soarpush (soargenvar 'z) return-condition)) - (setq pand-flag nil)) - ((predicatep (car condition)) (setq condition (cddr condition))) - (t (soarpush (pop condition) return-condition) (setq pand-flag nil))) - (go l1))) - -(defun remove-current (goal slot old-value new-value) - (prog nil - (cond ((soarlistp old-value) - (soarmapc - #'(lambda (x) (remove-from-wm (list 'goal-context-info goal slot x))) - old-value)) - (t (remove-from-wm (list 'goal-context-info goal slot old-value)))) - (return (cond ((soarlistp new-value) - (soarmapcar #'(lambda (x) (list 'goal-context-info goal slot x)) - new-value)) - (t (list (list 'goal-context-info goal slot new-value))))))) - -(defun remove-subgoal-objects (stack) - (cond (stack - (soarmapc #'remove-subgoal-objects (cdr stack)) - (soarmapc #'remove-from-wm (get (caar stack) 'created)) - (soarclearprops (caar stack))))) - -(defun restart-soar nil - (prog (pnames) - (setq pnames (append *pnames* nil)) - (eval (cons 'excise pnames)) - (soarmapc #'soarclearprops - (append *save-class-list* *class-list* *used-gensym-list*)) - (i-g-v))) - -(defun save-production-trace (wme data-matched current-goal) - (cond (data-matched - (cond ((and *first-action* data-matched) - (setq *current-production-trace* - (list (setq *trace-number* (1+ *trace-number*)) - data-matched - *p-name*)))) - (addprop current-goal 'production-trace (cons wme *current-production-trace*)) - wme))) - -(defun showload (file) - (prog (in nextexpr) - (setq in (openfile file 'input)) - l1 (setq nextexpr (read in)) - (cond ((eq nextexpr 'stop) (return))) - (soarprinc "----> ") - (soarprinc nextexpr) - (terpri (trace-file)) - (soarprinc (eval nextexpr)) - (terpri (trace-file)) - (go l1))) - -(defun ops-smatches (rule-list) - (soarmapc #'smatches2 rule-list) - (terpri (trace-file))) - - -(defun smatches2 (p) - (cond ((atom p) - (terpri (trace-file)) - (spprule p (smatches3 p (get p 'backpointers) 2 (ncons 1)))))) - -(defun smatches3 (p nodes ce part) - (prog (saved-mems n smatch-flg temp-flg port) - (setq port (trace-file)) - (cond ((null nodes) - (terpri (trace-file)) - (cond ((not (soarassq p *conflict-set*)) (return nil))) - (soarprinc3 "** MATCHES FOR " (reverse part) " ** ") - (setq n 0) - (soarmapc - #'(lambda (ci) - (cond ((eq (car ci) p) (swrite-elms (cdr ci)) (setq n (+ n 1))))) - *conflict-set*) - (terpri (trace-file)) - (return (ncons n))) - (t (setq saved-mems (find-left-mem (car nodes))) - (cond ((null saved-mems) (return nil))) - (setq temp-flg (smatches3 p (cdr nodes) (1+ ce) (cons ce part))) - (setq smatch-flg - (cons (mem-length saved-mems) - (cons (mem-length (find-right-mem (car nodes))) temp-flg))) - (cond ((not temp-flg) - (terpri (trace-file)) - (soarprinc3 "** MATCHES FOR " (reverse part) " ** ") - (soarmapc #'swrite-elms saved-mems) - (terpri (trace-file)) - (soarprinc3 "** MATCHES FOR " ce " ** ") - (terpri (trace-file)) - (soarmapc - #'(lambda (x) - (cond ((soarlistp x) (soarmapc #'write-elms2 (reverse x))))) - (find-right-mem (car nodes))) - (terpri (trace-file)) - (return smatch-flg))) - (return smatch-flg))))) - -(defun soarprinc (warning) - (princ warning (trace-file))) - -(defun soarprinc1 (x1 x2) - (princ x1 (trace-file)) - (princ x2 (trace-file))) - -(defun soarprinc2 (x1 x2) - (princ x1 (trace-file)) - (princ x2 (trace-file))) - -(defun soarprinc3 (x1 x2 x3) - (princ x1 (trace-file)) - (princ x2 (trace-file)) - (princ x3 (trace-file))) - -(defun soarprint (warning) - (prog2 nil (princ warning (trace-file)) (terpri (trace-file)))) - -(defun soarprintc (warning) - (terpri (trace-file)) - (princ warning (trace-file))) - -(defun soarwarn (warning warning2) - (prog (port) - (and (null *warning*) - (return warning2)) - (setq port (trace-file)) - (terpri port) - (princ "Warning: " port) - (and *p-name* - (princ *p-name*)) - (princ ".." port) - (princ warning port) - (princ " " port) - (princ warning2 port) - (return warning2))) - -(defun ops-spop (object) - (setq *indent* 0) - (setq *print-spo-list* nil) - (cond ((or (null object) - (numberp (car object)))) - ((not (numberp (soarlast object))) - (terpri (trace-file)) - (spo1 (car object) *spo-default-depth* t) - (eval (cons 'spop (cdr object)))) - (t (terpri (trace-file)) - (spo1 (car object) (soarlast object) t) - (eval (cons 'spop (cdr object))))) - (setq *print-spo-list* nil)) - - -(defun spprule (name cond-nums) - (prog (matrix next lab cond-flg port) - (and (not (symbolp name)) - (return nil)) - (setq matrix (get name 'production)) - (and (null matrix) - (return nil)) - (setq port (trace-file)) - (setq cond-flg nil) - (terpri port) - (soarprinc3 "(" 'p " ") - (soarprinc3 name " " (get name 'type)) - top (and (atom matrix) - (go fin)) - (setq next (car matrix)) - (setq matrix (cdr matrix)) - (setq lab nil) - (terpri port) - (cond ((and cond-nums - (> (car cond-nums) 0)) - (princ (car cond-nums) port) - (do-tabto 5 (trace-file)) - (setq cond-nums (cddr cond-nums))) - ((eq next '-->) (princ " " port) (setq cond-flg t)) - (cond-flg (princ " " port)) - (t (princ ">>>>" port) (setq cond-flg t))) - (cond ((eq next '-) - (princ "- " port) - (setq next (car matrix)) - (setq matrix (cdr matrix))) - ((neq next '-->) (princ " " port))) - (ppline next) - (cond (lab (soarprinc3 " " lab '}))) - (go top) - fin (soarprint ")"))) - -(defun swrite-elms (wme-or-count) - (cond ((soarlistp wme-or-count) - (terpri (trace-file)) - (soarmapc #'write-elms2 (reverse wme-or-count))))) - -(defun soargenpname (x) - (prog (sym-list sym) - (cond (*free-pname-list* (setq sym (pop *free-pname-list*))) - (t (setq sym (soargensymbol (soarnthchar x 1))))) - (soarputprop sym t 'gensymed) - (return sym))) - -(defun soargensym (x) - (prog (sym-list charx sym) - (setq charx (soarnthchar x 1)) - (setq sym-list (soarassq charx *free-gensym-list*)) - (cond ((null (cdr sym-list)) (setq sym (soargensymbol charx))) - (t (setq sym (cadr sym-list)) (rplacd sym-list (cddr sym-list)))) - (soarputprop sym t 'gensymed) - (soarpush sym *used-gensym-list*) - (return sym))) - -(defun soargenvar (id) - (prog (first-char gen-number new-var) - (setq first-char (soarnthchar id 1)) - (cond ((soarmemq first-char *used-char-list*) - (setq gen-number (get first-char 'var-count))) - (t (soarpush first-char *used-char-list*) (setq gen-number 1))) - (setq new-var (soarpack '< first-char gen-number '>)) - (soarpush new-var *used-var-list*) - (soarputprop first-char (1+ gen-number) 'var-count) - (return new-var))) - -(defun ops-swatch (z) - (cond ((equal z '(0)) (setq *gtrace* nil) (setq *strace* nil) (setq *dtrace* nil) 0) - ((equal z '(1)) (setq *gtrace* t) (setq *strace* nil) (setq *dtrace* nil) 1) - ((equal z '(2)) (setq *gtrace* t) (setq *strace* t) (setq *dtrace* nil) 2) - ((equal z '(3)) (setq *gtrace* t) (setq *strace* t) (setq *dtrace* t) 3) - ((and (atom z) - (null *gtrace*)) - 0) - ((and (atom z) - (null *strace*)) - 1) - ((and (atom z) - (null *dtrace*)) - 2) - ((atom z) 3) - (t 'what?))) - - -(defun t-in-list? (x) - (soarmemq 't (flatten x))) - -(defun ops-tabstop (z) - (prog (val) - (cond ((not *in-rhs*) - (soarwarn "TABSTOP can not be called at the top level" " ") - (return nil)) - ((neq (length z) 1) - (soarwarn "Wrong number of arguments for Tabstop:" z) - (return nil)) - ((not (variablep (car z))) - (soarwarn "Illegal argument for Tabstop:" (car z)) - (return nil)) - ((equalp (length z) 1) - (setq val (+ 3 (* (get-context-depth *context*) 3))))) - (make-var-bind (car z) val))) - - -(defun test-connected-actions (actions) - (prog (changed-flag action save-action saved-actions found-variable) - (setq changed-flag t) - (setq saved-actions (cdr actions)) - l1 (setq actions saved-actions) - (setq saved-actions nil) - (cond ((null actions) (return)) - ((null changed-flag) - (soarwarn "Unconnected actions in production" (p-to-sp actions)) - (return))) - (setq changed-flag nil) - l2 (cond ((null actions) (go l1))) - (setq action (pop actions)) - (cond ((neq (car action) 'make) (go l2))) - (setq save-action action) - (setq found-variable nil) - l3 (cond ((and (null action) - found-variable) - (soarpush save-action saved-actions) - (go l2)) - ((null action) (go l2)) - ((soarmemq (car action) *condition-vars*) - (setq *condition-vars* - (append *condition-vars* (find-variables save-action))) - (setq changed-flag t) - (setq found-variable t) - (go l2)) - ((variablep (car action)) (setq found-variable t))) - (pop action) - (go l3))) - -(defun test-preference-field (field subgoal) - (or (null field) - (eq field 'undecided) - (neq (get field 'in-id-field) subgoal))) - -(defun test-selected-result (choice result) - (or (eq choice result) - (eq choice (get result 'name)) - (and (soarmemq choice (get result 'instance)) - t) - (and (get result 'instance) - (soarmemq t - (flatten - (soarmapcar #'(lambda (x) (test-selected-result choice x)) - (get result 'instance)))) - t))) - -(defun test-subset (lista listb) - (cond ((null lista) t) - ((soarmemq (car lista) listb) (test-subset (cdr lista) listb)) - (t nil))) - -(defun teqnilb (x y) - (or (eq x y) - (null x))) - -(defun trace-attribute (x) - (prog (class) - (cond ((soarassq (car x) *sp-classes*) - (soarpush (cons (cdr (soarassq (car x) *sp-classes*)) (cdr x)) - *instance-attributes*)) - (t (setq class (soarpack2 (car x) '-info)) - (soarpush (cons (car x) class) *sp-classes*) - (soarpush class *save-class-list*) - (soarputprop class (get 'state-info 'ppdat) 'ppdat) - (soarpush (cons class (cdr x)) *instance-attributes*))))) - -(defun trace-attributes (x) - (soarmapc #'trace-attribute x)) - -(defun trace-condition-action (wme flag) - (cond ((null *tracep-list*)) - ((or (soarmember wme *tracep-list*) - (soarmemq (identifier wme) *tracep-list*) - (soarmemq (get (identifier wme) 'name) *tracep-list*)) - (soarprintc *p-name*) - (cond ((eq flag 'action) (soarprinc ": -->")) (t (soarprinc ": matches "))) - (ppline (car (p-conds-to-sp (list (clean-up-clause wme 'action)))))))) - -(defun trace-ids (item) - (print-id item)) - -(defun trace-new-condition (action trace-flag depth negation) - (cond ((and trace-flag negation) - (do-tabto (* 3 depth) (trace-file)) - (ppline (cons negation (car (p-conds-to-sp (list (clean-up-element action)))))) - (soarprint " ")) - (trace-flag - (do-tabto (* 3 depth) (trace-file)) - (ppline (car (p-conds-to-sp (list (clean-up-element action))))) - (soarprint " ")))) - -(defun trace-object (type id depth) - (cond ((or (and (not *gtrace*) - (not *otrace*)) - (not (trace-problem-space?)) - (eq id 'undecided))) - ((and *otrace* id) - (cond ((and *3600-display* *gtrace*) (draw-current-object type id depth))) - (soarprintc *decide-count*) - (cond ((and *subgoal-tabs* - (neq depth 0) - (eq type 'goal)) - (do-tabto (+ 2 (* depth 3)) (trace-file)) - (princ '==> (trace-file))) - (*subgoal-tabs* (do-tabto (+ 5 (* depth 3)) (trace-file))) - (t (do-tabto 5 (trace-file)) - (soarprinc3 "(" depth ")") - (do-tabto 11 (trace-file)))) - (soarprinc2 - (cond ((eq type 'goal) 'g) - ((eq type 'problem-space) 'p) - ((eq type 'state) 's) - ((eq type 'operator) 'o)) - ": ") - (print-id id)))) - -(defun trace-problem-space? nil - (not (soarmemq (get (get-current *context* 'problem-space) 'name) - *watch-free-problem-spaces*))) - -(defun ops-unpbreak (z) - (cond ((atom z) (setq *brkpts* nil) (setq *brknames* nil) nil) - (t (soarmapc #'unpbreak2 z) nil))) - - -(defun unpbreak2 (rule) - (prog (type blist) - (cond ((or (not (symbolp rule)) - (soarlistp rule)) - (soarwarn "Illegal argument:" rule)) - ((soarmemq rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)) rule) - ((soarmemq rule *brknames*) (setq *brknames* (rematm rule *brknames*)) rule) - (t nil)))) - -(defun unptrace nil - (setq *tracep-list* nil)) - -(defun untest (element) - (cond ((and element - (variablep (caddr element))) - (soarputprop (caddr element) (1- (get (caddr element) 'tested)) 'tested) - (untest (cdddr element))) - (element (untest (cdddr element))))) - -(defun variablize-negations (negations) - (prog (condition return-list new-condition id value) - (setq return-list nil) - l1 (cond ((null negations) (return return-list))) - (setq condition (pop negations)) - (setq new-condition (list (pop condition))) - l2 (cond ((null condition) - (setq new-condition (nreverse new-condition)) - (and (soarmember new-condition return-list) - (go l1)) - (soarpush new-condition return-list) - (go l1))) - (soarpush (pop condition) new-condition) - (soarpush (pop condition) new-condition) - (setq id (pop condition)) - (setq value (cdr (soarassq id *learn-ids*))) - (cond (value - (soarputprop value - (1+ (or (get value 'tested) - 0)) - 'tested)) - (t (setq value id))) - (soarpush value new-condition) - (go l2))) - -(defun write-trace (arg1 arg2 arg3) - (cond ((and *ptrace* - (trace-problem-space?)) - (soarprintc *decide-count*) - (soarprinc3 '":" *cycle-count* arg1) - (soarprinc3 arg2 '" " arg3) - (soarprinc '" ")))) - -(defun ops-write1 (z) - (prog (port max k x needspace) - (cond ((not *in-rhs*) - (soarwarn "Write1 cannot be called at the top level." " ") - (return nil))) - ($reset) - (eval-args z) - (setq k 1) - (setq max ($parametercount)) - (cond ((< max 1) (soarwarn "Write1: nothing to print:" z) (return nil))) - (setq port (default-write-file)) - (setq x ($parameter 1)) - (cond ((and (symbolp x) - ($ofile x)) - (setq port ($ofile x)) - (setq k 2))) - (setq needspace t) - la (and (> k max) - (return nil)) - (setq x ($parameter k)) - (cond ((equal x 'crlf) (setq needspace nil) (terpri port)) - ((equal x 'rjust) - (setq k (+ 2 k)) - (do-rjust ($parameter (1- k)) ($parameter k) port)) - ((equal x 'tabto) - (setq needspace nil) - (setq k (1+ k)) - (do-tabto ($parameter k) port)) - (t (and needspace - (princ " " port)) - (setq needspace t) - (princ x port))) - (setq k (1+ k)) - (go la))) - - -(defun ops-write2 (z) - (prog (port max k x) - (cond ((not *in-rhs*) - (soarwarn "Write2 cannot be called at the top level" " ") - (return nil))) - ($reset) - (eval-args z) - (setq k 1) - (setq max ($parametercount)) - (cond ((< max 1) (soarwarn "Write2: nothing to print" " ") (return nil))) - (setq port (default-write-file)) - (setq x ($parameter 1)) - (cond ((and (symbolp x) - ($ofile x)) - (setq port ($ofile x)) - (setq k 2))) - la (and (> k max) - (return nil)) - (setq x ($parameter k)) - (cond ((equal x 'crlf) (terpri port)) - ((equal x 'rjust) - (setq k (+ 2 k)) - (do-rjust ($parameter (1- k)) ($parameter k) port)) - ((equal x 'tabto) (setq k (1+ k)) (do-tabto ($parameter k) port)) - (t (princ x port))) - (setq k (1+ k)) - (go la))) - - -(defun compose-p-conds (cl) - (soar-do - ((avlist) (c) (cl1 cl (skip-whole-cond cl1)) (type (car (get-pos-cond cl))) - (id-var (get-term (cdddr (get-pos-cond cl))))) - ((null cl1) (cons (conv-type-to-sp type) (append id-var (build-sp-cond avlist nil)))) - (setq c (get-pos-cond cl1)) (cond ((eq (car c) 'make) (setq c (cdr c)))) - (soar-do ((c1 (cddr c) (cdr c1)) (attr '*undefined**) (val '*undefined**) (x)) - ((null c1) - (cond ((not (eq attr '*undefined**)) - (setq x (soarassoc attr avlist)) - (cond ((not (eq val '*undefined**)) - (cond (x (rplacd x (append val (cdr x)))) - (t (soarpush (cons attr val) avlist)))) - (t (soarpush (list attr) avlist)))) - ((not (eq val '*undefined**)) (soarpush val extravals)))) - (setq label (pop c1)) - (cond ((eq label 'attribute) - (setq attr (cons '^ (get-term c1))) - (and (eq (car cl1) '-) - (soarpush '- attr))) - ((eq label 'value) (setq val (nreverse (get-term c1))))) - (pop-term c1)))) - -(defun conv-to-attr-nums (avlist warnflag) - (prog (next a) - (setq *filters* nil) - (setq next 1) - l (and (atom avlist) - (return t)) - (setq a (car avlist)) - (setq avlist (cdr avlist)) - (cond ((eq a '^) - (setq next (car avlist)) - (setq avlist (cdr avlist)) - (setq next ($litbind next)) - (cond ((or (not (numberp next)) - (> next *size-result-array*) - (> 1 next)) - (and warnflag - (soarwarn "Illegal index after ^" next)) - (return nil)))) - ((variablep a) (soarwarn "(S)PPWM does not take variables:" a) (return nil)) - (t (setq *filters* (cons next (cons a *filters*))) (setq next (1+ next)))) - (go l))) - -(defun conv-type-to-sp (type) - (soar-do ((cl *sp-classes* (cdr cl))) ((null cl) type) - (cond ((eq (cdar cl) type) (return (caar cl)))))) - -(defun get-ids (infolist oldids) - (prog (newids pair) - (soarmapc - #'(lambda (x) - (setq pair (cons (cadddr x) (car x))) - (cond ((and (or (not oldids) - (soarmember pair oldids)) - (not (soarmember pair newids))) - (soarpush pair newids)))) - infolist) - (return newids))) - -(defun get-pos-cond (cl) - (cond ((eq (car cl) '-) (cadr cl)) (t (car cl)))) - -(defun get-similar-conds (cond cl) - (prog (rest result) - (setq rest (cons nil cl)) - (soar-do - ((type (car cond)) (id-var (get-term (cdddr cond))) (negflag) (cl1 rest) (c)) - ((or (null cl) - (eq (car cl) '-->))) - (setq c (pop cl)) - (cond ((eq c '-) (setq c (pop cl)) (setq negflag t)) (t (setq negflag nil))) - (cond ((eq (car c) 'make) (setq c (cdr c)))) - (cond ((and (equal id-var (get-term (cdddr c))) - (eq type (car c))) - (cond (negflag (soarpush '- result) (rplacd cl1 (cddr cl1)))) - (soarpush c result) - (rplacd cl1 (cddr cl1))) - (t (cond (negflag (setq cl1 (cdr cl1)))) (setq cl1 (cdr cl1))))) - (return (cons (nreverse result) (cdr rest))))) - -(defun get-term (c) - (list-head c (skip-term c))) - -(defun indent nil - (soar-do ((i *indent* (- i 1))) ((= i 0)) (princ " " (trace-file)))) - -(defun list-head (whole tail) - (soar-do ((result)) ((null whole) (nreverse result)) - (cond ((eq whole tail) (return (nreverse result))) - (t (setq result (cons (car whole) result)) (setq whole (cdr whole)))))) - -(defun p-conds-to-sp (cl) - (prog (c pref cl1 result temp negs type) - (setq cl1 (copy cl)) - l1 (setq c (get-pos-cond cl1)) - (cond ((or (null c) - (eq c '-->)) - (return (nreverse result))) - ((eq (car c) 'make) (setq c (cdr c)))) - (setq type (car c)) - (cond ((soarmemq type *ops5-actions*) (soarpush c result) (setq cl1 (cdr cl1))) - ((or (eq type (conv-type-to-sp type)) - (not (eq 'identifier (caddr c)))) - (cond ((equal (car cl1) '-) (soarpush '- result))) - (cond ((and (eq (caddr c) 'object) - (eq type 'preference)) - (soarpush (cons 'preference (cdddr c)) result)) - (t (soarpush c result))) - (setq cl1 (skip-whole-cond cl1))) - (t (setq temp (get-similar-conds c cl1)) - (setq cl1 (cdr temp)) - (soarpush (compose-p-conds (car temp)) result))) - (go l1))) - -(defun p-to-sp (rule) - (prog (result) - (setq result (p-conds-to-sp rule)) - (cond ((soarmemq '--> rule) - (setq result - (append result - (cons '--> (p-conds-to-sp (cdr (soarmemq '--> rule)))))))) - (return result))) - -(defun pp-class-ids (ids) - (soarmapc - #'(lambda (x) - (soarmapc #'(lambda (y) (ppline y) (terpri (trace-file))) - (p-conds-to-sp (sppwm1 (list (cdr x) '^ 'identifier (car x)))))) - ids)) - -(defun ppelm1 (elm) - (prog (ppdat result val att vlist) - (setq ppdat (get (car elm) 'ppdat)) - (setq result (list (car elm))) - (setq vlist (cdr elm)) - (soar-do ((curpos 2 (+ 1 curpos))) ((atom vlist)) (setq val (car vlist)) - (setq vlist (cdr vlist)) (setq att (cdr (soarassq curpos ppdat))) - (cond ((or (not (eq (car elm) 'preference)) - (not (null val))) - (soarpush '^ result) - (soarpush att result) - (soarpush val result)))) - (return (nreverse result)))) - -(defun skip-term (c) - (car (classify-term c))) - -(defun skip-whole-cond (cl) - (cond ((eq (car cl) '-) (cddr cl)) (t (cdr cl)))) - -(defun ops-sp (xs) - (setq *xs* xs) - (soarcatch '!error! (eval (reorder-p-conds (sp-to-p *xs*)))) - nil) - - -(defun sp-form-expand (pname x in-actions follows-negation) - (prog (nf new-class) - (cond ((and (not (atom x)) - (eq (car x) 'make)) - (setq x (cdr x)))) - (setq nf - (cond ((atom x) (list x)) - ((soarassq (class x) *sp-classes*) - (setq new-class (cdr (soarassq (class x) *sp-classes*))) - (cond ((not (soarmemq new-class *save-class-list*)) - (soarpush new-class *save-class-list*) - (soarputprop new-class (get 'state-info 'ppdat) 'ppdat))) - (sp-info-expand pname x in-actions)) - ((and (cdr x) - (not (eq (class x) 'preference)) - (not (eq (cadr x) '^)) - (or (not in-actions) - (not (soarmemq (class x) *ops5-actions*)))) - (setq new-class (soarpack2 (class x) '-info)) - (soarpush (cons (class x) new-class) *sp-classes*) - (soarpush new-class *save-class-list*) - (soarputprop new-class (get 'state-info 'ppdat) 'ppdat) - (sp-info-expand pname x in-actions)) - ((and in-actions - (not (soarmemq (car x) *ops5-actions*))) - (cond ((and (cdr x) - (not (eq (cadr x) '^)) - (not (eq (cadr x) '-))) - (list (cons 'make - (cons (car x) - (cons '^ - (cons - (cond - ((eq (car x) 'preference) 'object) - (t 'identifier)) - (cdr x))))))) - (t (list (cons 'make x))))) - ((and in-actions - (soarmemq (car x) *ops5-actions*)) - (list x)) - ((and (cdr x) - (not (eq (cadr x) '^)) - (not (eq (cadr x) '-))) - (list (cons (car x) - (cons '^ - (cons (cond ((eq (car x) 'preference) 'object) - (t 'identifier)) - (cdr x)))))) - (t (list x)))) - (cond ((and follows-negation - (> (length nf) 1)) - (%error "Attempt to negate a compound object" pname)) - (t (return nf))))) - -(defun sp-info-expand (pname form in-actions) - (prog (avlist newform end-atom type id clist pand-id temp-form negated no-value) - (setq pand-id nil) - (setq clist nil) - (setq type (cdr (soarassq (car form) *sp-classes*))) - (cond ((variablep (cadr form)) (setq id (cadr form)) (setq avlist (cddr form))) - ((equal (cadr form) '^) - (setq id (soarpack '< 'x (soargensym (car form)) '>)) - (setq avlist (cdr form))) - ((equal (cadr form) '{) - (setq pand-id t) - (setq avlist (cddr form)) - (setq id (ncons '{)) - (soarwhile - (and avlist - (not (equal (car avlist) '}))) - (soarpush (car avlist) id) (pop avlist)) - (cond ((null avlist) (%error "Didn't find terminating }" form))) - (setq id (dreverse (cons '} id))) - (setq avlist (cdr avlist))) - (t (setq id (cadr form)) (setq avlist (cddr form)))) - loop (cond ((not avlist) (return (reverse clist)))) - (setq negated nil) - (cond ((equal (car avlist) '-) (pop avlist) (setq negated t))) - (cond ((not (equal (car avlist) '^)) - (%error "Didn't find a ^ when expected" avlist))) - (pop avlist) - (setq end-atom - (cond ((eq (car avlist) '<<) '>>) ((eq (car avlist) '{) '}) (t nil))) - (cond (pand-id - (setq newform - (append (list type '^ 'identifier) - (append id (list '^ 'attribute (pop avlist)))))) - (t (setq newform (list type '^ 'identifier id '^ 'attribute (pop avlist))))) - (cond (end-atom - (soarwhile - (and avlist - (not (eq (car avlist) end-atom))) - (setq newform (append newform (list (pop avlist))))) - (cond ((null avlist) (%error "Didn't find terminator" end-atom))) - (setq newform (append newform (list (pop avlist)))))) - (setq no-value t) - (cond ((and avlist - (not (eq (car avlist) '^)) - (not (eq (car avlist) '-)) - (or (not (soarlistp (car avlist))) - (not (eq (caar avlist) '^)))) - (setq newform (append newform (list '^ 'value))) - (setq no-value nil))) - (setq temp-form newform) - (soarwhile - (and avlist - (not (eq (car avlist) '^)) - (not (eq (car avlist) '-)) - (or (not (soarlistp (car avlist))) - (not (eq (caar avlist) '^)))) - (setq newform temp-form) - (cond ((predicatep (car avlist)) - (setq newform (append newform (list (pop avlist)))))) - (setq end-atom - (cond ((eq (car avlist) '<<) '>>) ((eq (car avlist) '{) '}) (t nil))) - (setq newform (append newform (list (pop avlist)))) - (cond (end-atom - (soarwhile - (and avlist - (not (eq (car avlist) end-atom))) - (setq newform (append newform (list (pop avlist))))) - (cond ((null avlist) (%error "Didn't find terminator" end-atom))) - (setq newform (append newform (list (pop avlist)))))) - (cond ((and avlist - (soarlistp (car avlist))) - (setq newform (append newform (pop avlist))))) - (cond (in-actions (soarpush 'make newform))) (cond (negated (soarpush '- clist))) - (soarpush newform clist)) - (cond (no-value - (cond ((and avlist - (soarlistp (car avlist))) - (setq newform (append newform (pop avlist))))) - (cond (in-actions (soarpush 'make newform))) - (cond (negated (soarpush '- clist))) - (soarpush newform clist))) - (go loop))) - -(defun sp-to-p (xs) - (prog (in-actions follows-negation forms pname) - (setq in-actions nil) - (setq follows-negation nil) - (setq pname (car xs)) - (return (cons 'p - (soarmapconc - #'(lambda (x) - (cond ((equal x '-->) (setq in-actions t))) - (setq forms - (sp-form-expand pname x in-actions follows-negation)) - (setq follows-negation (eq x '-)) - forms) - xs))))) - -(defun ops-spm (z) - (setq *indent* 0) - (soarmapc #'(lambda (x) (pprule x 'sp)) z) - nil) - - -(defun spm-to-make (form) - (soarmapc #'eval (sp-info-expand nil form t)) - nil) - -(defun ops-spo (object) - (setq *indent* 0) - (cond ((or (null object) - (numberp (car object)))) - ((not (numberp (soarlast object))) - (terpri (trace-file)) - (spo1 (car object) *spo-default-depth* nil) - (eval (cons 'spo (cdr object)))) - (t (terpri (trace-file)) - (spo1 (car object) (soarlast object) nil) - (eval (cons 'spo (cdr object))))) - (setq *print-spo-list* nil)) - - -(defun spo1 (object depth prefflag) - (prog (out class out2 out1) - (cond ((soarmemq object *print-spo-list*) (return)) - (t (soarpush object *print-spo-list*))) - (setq out (p-conds-to-sp (sppwm1 (append '(^ identifier) (list object))))) - (setq out1 nil) - (soarmapc - #'(lambda (x) - (cond ((eq prefflag (eq (car x) 'preference)) - (ppline x) - (soarpush x out1) - (terpri (trace-file))))) - out) - (cond ((<= depth 1) (return))) - (setq out out1) - (setq *indent* (+ *indent* 3)) - (soar-do ((out2 out (cdr out2))) ((null out2)) - (soar-do ((out1 (cdar out2) (cdr out1))) ((null out1)) - (cond ((get (cadr out1) 'in-id-field) (spo1 (cadr out1) (- depth 1) prefflag))))) - (setq *indent* (- *indent* 3)))) - -(defun ops-sppwm (avlist) - (prog (noclassflag condlist cond1 ids avinfos) - (soarterpri) - (setq *indent* 0) - (cond ((null avlist) (go l2)) - ((not (soarassoc (car avlist) *sp-classes*)) - (setq avlist (cons 'state avlist)) - (setq noclassflag t))) - (cond ((null (cdr avlist)) - (setq avinfos (list (list (cdr (soarassoc (car avlist) *sp-classes*)))))) - ((null (cddr avlist)) - (setq avinfos - (list (list (cdr (soarassoc (car avlist) *sp-classes*)) - '^ - 'identifier - (cadr avlist))))) - (t (soarcatch '!error! (setq avinfos (sp-form-expand nil avlist nil nil))))) - (cond ((variablep (cadddr (car avinfos))) - (soarmapc #'(lambda (x) (rplacd x (cdr (cdddr x)))) avinfos))) - (cond (noclassflag - (setq avinfos (soarmapcar #'cdr avinfos)) - (setq avlist (cdr avlist)))) - (setq ids (get-ids (sppwm1 (car avinfos)) nil)) - l1 (setq avinfos (cdr avinfos)) - (cond ((null avinfos) (go l2))) - (setq ids (get-ids (sppwm1 (car avinfos)) ids)) - (cond ((null ids) (go l3))) - (go l1) - l2 (cond (avlist (setq ids (append ids (get-ids (sppwm1 avlist) nil))))) - (pp-class-ids ids) - l3 )) - - -(defun sppwm1 (avlist) - (cond ((not (conv-to-attr-nums avlist nil)) nil) - (t (mapwm #'sppwm2) (prog2 nil *wm* (setq *wm* nil))))) - -(defun sppwm2 (elm-tag) - (cond ((filter (car elm-tag)) (setq *wm* (cons (ppelm1 (car elm-tag)) *wm*))))) - -(defun ops-spr (arg) - (cond ((get (car arg) 'in-id-field) (eval (cons 'spo arg))) - ((soarmemq (car arg) *pnames*) (eval (cons 'spm arg))) - ((numberp (car arg)) (eval (cons 'swm arg))) - ((null (car arg)) (pgs)) - (t (eval (cons 'sppwm arg))))) - - -(defun ops-swm (a) - (pp-class-ids (soarmapcar #'(lambda (x) (cons (cadr x) (car x))) (get-wm a)))) - -(defun $varbind (x) - (prog (r) - (and (not *in-rhs*) (return x)) - (setq r (soarassq x *variable-memory*)) - (cond (r (return (cdr r))) - ((variablep x) - (setq r (soargensym (soarnthchar x 2))) - (make-var-bind x r) - (return r)) - (t (return x))))) - -(defun &bus (outs) - (prog (dp) - (setq *alpha-flag-part* *flag-part*) - (setq *alpha-data-part* *data-part*) - (setq dp (car *data-part*)) - (setq *c1* (car dp)) - (setq dp (cdr dp)) - (setq *c2* (car dp)) - (setq dp (cdr dp)) - (setq *c3* (car dp)) - (setq dp (cdr dp)) - (setq *c4* (car dp)) - (setq dp (cdr dp)) - (setq *c5* (car dp)) - (setq dp (cdr dp)) - (setq *c6* (car dp)) - (setq dp (cdr dp)) - (setq *c7* (car dp)) - (setq dp (cdr dp)) - (setq *c8* (car dp)) - (setq dp (cdr dp)) - (setq *c9* (car dp)) - (setq dp (cdr dp)) - (setq *c10* (car dp)) - (setq dp (cdr dp)) - (setq *c11* (car dp)) - (setq dp (cdr dp)) - (setq *c12* (car dp)) - (setq dp (cdr dp)) - (setq *c13* (car dp)) - (setq dp (cdr dp)) - (setq *c14* (car dp)) - (setq dp (cdr dp)) - (setq *c15* (car dp)) - (setq dp (cdr dp)) - (setq *c16* (car dp)) - (eval-nodelist outs))) - -(defun &priv (outs name) - (prog nil - (eval-nodelist outs))) - -(defun accum-stats nil - (setq *prod-count* (+ *prod-count* 1)) - (setq *total-token* (+ *total-token* *current-token*)) - (cond ((> *current-token* *max-token*) (setq *max-token* *current-token*))) - (setq *total-wm* (+ *total-wm* *current-wm*)) - (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*)))) - -(defun add-to-wm (wme) - (prog (class part timetag port match-time) - (setq port (trace-file)) - (setq wme (eliminate-trailing-nil wme)) - (setq class (class wme)) - (setq part (get class 'wmpart*)) - (cond ((soarassoc wme part) - (and *chunk-all-paths* - (mark-in-id wme)) - (return nil)) - ((mark-in-id wme) (return nil)) - ((soarmember wme *brkrun*) (setq *break-flag* t))) - (trace-condition-action wme 'action) - (setq *critical* t) - (setq *action-count* (1+ *action-count*)) - (setq *current-wm* (1+ *current-wm*)) - (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))) - (or (soarmemq class *wmpart-list*) - (soarpush class *wmpart-list*)) - (setq timetag *action-count*) - (soarputprop class (cons (cons wme timetag) part) 'wmpart*) - (match 'new wme) - (setq *critical* nil) - (cond ((or (not *in-rhs*) - (not (trace-problem-space?)))) - ((and (not *wtrace*) - *ptrace* - *ttrace*) - (time-tag-print (list wme) port)) - (*wtrace* (soarprintc "=>WM: ") (ppelm wme port))))) - -(defun best-of (set) - (prog (cs entry best-list) - (setq cs set) - (setq best-list nil) - l1 (setq entry (car cs)) - (setq cs (cdr cs)) - (cond ((null entry) (return best-list)) - ((or (eq *phase* (get (car entry) 'type)) - (and (eq *phase* 'elaborate) - (eq (get (car entry) 'type) 'elaborate-once))) - (soarpush entry best-list) - (and (eq *phase* 'elaborate) - (remove-cs entry)))) - (go l1))) - -(defun ops-bind (z) - (prog (val) - (cond ((not *in-rhs*) - (soarwarn "Cannot be called at top level" 'bind) - (return nil)) - ((< (length z) 1) - (soarwarn "Bind: Wrong number of arguments to" z) - (return nil)) - ((not (symbolp (car z))) - (soarwarn "Bind: illegal argument" (car z)) - (return nil)) - ((equalp (length z) 1) (setq val (soargensym 's))) - (t ($reset) (eval-args (cdr z)) (setq val ($parameter 1)))) - (make-var-bind (car z) val))) - - -(defun check-action (x) - (prog (a) - (cond ((atom x) (soarwarn "Atomic Action" x) (return nil))) - (setq a (setq *action-type* (car x))) - (cond ((eq a 'bind) (check-bind x)) - ((eq a 'cbind) (check-cbind x)) - ((eq a 'call2) (return nil)) - ((eq a 'tabstop) (check-bind x)) - ((eq a 'decide) (check-decide)) - ((eq a 'make) (check-make x)) - ((eq a 'modify) (check-modify x)) - ((eq a 'remove-ops) (check-remove-ops x)) - ((eq a 'write) (check-write x)) - ((eq a 'write1) (check-write x)) - ((eq a 'write2) (check-write x)) - ((eq a 'call1) (check-call1 x)) - ((eq a 'halt) (check-halt x)) - ((eq a 'openfile) (check-openfile x)) - ((eq a 'closefile) (check-closefile x)) - ((eq a 'default) (check-default x)) - ((eq a 'build) (check-build x)) - (t (soarwarn "Illegal Action" x))))) - -(defun check-make (z) - (or (soarmemq *p-type* '(elaborate-once elaborate)) - (soarwarn "Illegal make in production type" *p-type*)) - (and (null (cdr z)) - (soarwarn "Missing arguments in Make" " ")) - (check-change& (cdr z))) - -(defun check-modify (z) - (soarwarn "Illegal modify in Soar production" *p-type*) - (and (null (cdr z)) - (soarwarn "Missing arguments in Modify" " ")) - (check-rhs-ce-var (cadr z)) - (and (null (cddr z)) - (soarwarn "No changes to make in Modify" " ")) - (check-change& (cddr z))) - -(defun check-rhs-value (x) - (cond ((soarlistp x) (check-rhs-function x)))) - -(defun cmp-ce nil - (prog (z) - (new-subnum 0) - (setq *cur-vars* nil) - (setq z (lex)) - (and (atom z) - (%error "Atomic conditions are not allowed" z)) - (setq *preference-found* (eq (car z) 'preference)) - (prepare-sublex z) - la (and (end-of-ce) - (return nil)) - (incr-subnum) - (cmp-element) - (setq *context-field-found* nil) - (go la))) - -(defun cmp-tab nil - (prog (r) - (sublex) - (setq r (sublex)) - (setq *context-field-found* - (and *preference-found* - (soarmemq r '(goal problem-space state operator)))) - (setq r ($litbind r)) - (new-subnum r))) - -(defun cmp-var (test) - (prog (old name) - (setq name (sublex)) - (setq old (soarassq name *cur-vars*)) - (cond ((and old - (eq (cadr old) 'eq)) - (cmp-old-eq-var test old)) - ((and old - (eq test 'eq)) - (cmp-new-eq-var name old)) - ((and (eq test 'eq) - *context-field-found*) - (cmp-new-var name 'eqnil)) - (t (cmp-new-var name test))))) - -(defun cmp-p (name type matrix) - (prog (m bakptrs root) - (cond ((soarlistp name) (%error "Illegal production name" name)) - ((equal (get name 'production) matrix) (return nil))) - (cond ((not (soarmemq type '(elaborate elaborate-once decide))) - (%error "Illegal production type" type))) - (and *print-pname* - (princ name (trace-file))) - (prepare-lex matrix) - (cond ((excise-p name) (princ (list 'excised name) (trace-file)))) - (setq bakptrs nil) - (setq *last-node* *first-node*) - (and (> *current-wm* 0) - (make-new-root name)) - (setq root (setq *new-root* *last-node*)) - (setq *pcount* (1+ *pcount*)) - (setq *feature-count* 0) - (setq *ce-count* 0) - (setq *vars* nil) - (setq *ce-vars* nil) - (setq *rhs-bound-vars* nil) - (setq *rhs-bound-ce-vars* nil) - (setq *last-branch* nil) - (setq m (rest-of-p)) - l1 (and (end-of-p) - (%error "No '-->' in production" m)) - (setq *last-node* root) - (cmp-prin) - (setq bakptrs (cons *last-branch* bakptrs)) - (or (eq '--> (peek-lex)) - (go l1)) - (lex) - (cond ((not (soarmemq name *pnames*)) (setq *pnames* (cons name *pnames*)))) - (check-rhs (rest-of-p)) - (link-new-node - (list '&p - *feature-count* - name - (encode-dope) - (encode-ce-dope) - (cons 'progn (rest-of-p)))) - (soarputprop name type 'type) - (soarputprop name (cdr (nreverse bakptrs)) 'backpointers) - (soarputprop name matrix 'production) - (soarputprop name (compute-negation-index matrix) 'negation-index) - (soarputprop name *last-node* 'topnode) - (cond ((> *current-wm* 0) (mapwm #'match-update))) - (return nil))) - -(defun cmp-prin nil - (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta)) - ((eq (peek-lex) '-) (cmp-negce) (cmp-not)) - (t (cmp-posce) (cmp-and)))) - -(defun compile-production (name type matrix) - (setq *p-type* type) - (setq *matrix* matrix) - (setq *p-name* name) - (soarcatch '!error! (cmp-p *p-name* *p-type* *matrix*)) - (setq *p-name* nil)) - -(defun conflict-resolution nil - (prog (best len) - (setq len (length *conflict-set*)) - (cond ((> len *max-cs*) (setq *max-cs* len))) - (setq *total-cs* (+ *total-cs* len)) - (cond (*conflict-set* - (setq best (best-of *conflict-set*)) - (cond ((neq *phase* 'decide) (soarmapc #'remove-cs best))) - (return best)) - (t (return nil))))) - -(defun conflict-set nil - (prog (cnts cs p z phase-type) - (setq cnts nil) - (setq cs *conflict-set*) - (setq phase-type 'decide) - l1 (and (atom cs) - (go l2)) - (setq p (caar cs)) - (and (neq (get p 'type) 'decide) - (setq phase-type 'elaborate)) - (setq cs (cdr cs)) - (setq z (soarassq p cnts)) - (cond ((null z) (setq cnts (cons (cons p 1) cnts))) (t (rplacd z (1+ (cdr z))))) - (go l1) - l2 (cond ((atom cnts) (terpri (trace-file)) (return (list 'phase phase-type)))) - (cond ((and (eq phase-type 'elaborate) - (eq (get (caar cnts) 'type) 'decide)) - (setq cnts (cdr cnts)) - (go l2))) - (terpri (trace-file)) - (soarprinc3 (caar cnts) " " (get (caar cnts) 'type)) - (cond ((> (cdar cnts) 1) (soarprinc3 " (" (cdar cnts) " OCCURRENCES)"))) - (setq cnts (cdr cnts)) - (go l2))) - -(defun ops-crlf (z) - (cond (z (soarwarn "CRLF: Does not take arguments" z)) (t ($value 'crlf)))) - - -(defun do-continue (wmi) - (cond (*critical* (soarprintc "WARNING: Network may be inconsistent"))) - (process-changes wmi nil) - (main)) - -(defun eval-rhs (pname data) - (prog (node port) - (cond ((and (trace-problem-space?) - (or *ptrace* - (soarmemq pname *tracep-list*))) - (setq port (trace-file)) - (soarprintc (1+ *decide-count*)) - (soarprinc3 ":" *cycle-count* " ") - (soarprinc pname) - (and *ptrace* - *ttrace* - (time-tag-print data port)))) - (setq *data-matched* data) - (setq *p-name* pname) - (setq *last* nil) - (setq node (get pname 'topnode)) - (init-var-mem (var-part node)) - (init-ce-var-mem (ce-var-part node)) - (setq *in-rhs* t) - (setq *current-goal* (find-max-goal-depth *data-matched*)) - (soarmapc #'condition-trace *data-matched*) - (cond ((null *never-learn*) - (setq *data-matched* - (append (add-negations *current-goal* (reverse *data-matched*)) - *data-matched*)))) - (eval (rhs-part node)) - (setq *in-rhs* nil))) - -(defun excise-p (name) - (prog nil - (cond ((and (symbolp name) - (get name 'topnode)) - (princ "#" (trace-file)) - (setq *pcount* (1- *pcount*)) - (remove-from-conflict-set name) - (kill-node (get name 'topnode)) - (remprop name 'production) - (remprop name 'backpointers) - (remprop name 'topnode) - (remprop name 'type) - (remprop name 'negation-index) - (setq *chunks* (dremove name *chunks*)) - (setq *pnames* (dremove name *pnames*)) - (and (get name 'gensymed) - (setq *free-pname-list* (soarsort (cons name *free-pname-list*)))) - (return t)) - (t (return nil))))) - -(defun finish-literalize nil - (cond ((not (null *class-list*)) - (soarmapc #'note-user-assigns *class-list*) - (soarmapc #'assign-scalars *class-list*) - (soarmapc #'assign-vectors *class-list*) - (soarmapc #'put-ppdat *class-list*) - (soarmapc #'erase-literal-info *class-list*) - (setq *value-index* (1- (literal-binding-of 'value))) - (setq *attribute-index* (1- (literal-binding-of 'attribute))) - (setq *id-index* (1- (literal-binding-of 'identifier))) - (setq *goal-index* (1- (literal-binding-of 'goal))) - (setq *problem-space-index* (1- (literal-binding-of 'problem-space))) - (setq *state-index* (1- (literal-binding-of 'state))) - (setq *operator-index* (1- (literal-binding-of 'operator))) - (setq *slot-index* (1- (literal-binding-of 'role))) - (setq *big-info-index* (max *id-index* *attribute-index* *value-index*)) - (setq *big-index* - (max *id-index* - *goal-index* - *problem-space-index* - *state-index* - *operator-index* - *value-index* - *slot-index*)) - (setq *save-class-list* *class-list*) - (setq *class-list* nil) - (setq *buckets* nil)))) - -(defun i-g-v nil - (prog (x) - (setq *save-class-list* nil) - (setq *class-list* nil) - (soarsyntax) - (soarputprop 'identifier 2 'ops-bind) - (soarputprop 'object 2 'ops-bind) - (soarputprop 'attribute 3 'ops-bind) - (soarputprop 'value 4 'ops-bind) - (setq *sp-classes* - '((state . state-info) (object . info) (problem-space . space-info) - (space . space-info) (operator . op-info) (desired . desired-info) - (gc . goal-context-info) (goal . goal-context-info) - (context . goal-context-info) (goal-context . goal-context-info) - (evaluation . eval-info))) - (setq *ops5-actions* - '(openfile closefile default write write1 write2 call1 halt decide bind - call2 cbind obind build tabto tabstop)) - (setq *impasse-subset-not-equal* nil) - (setq *brkpts* nil) - (setq *brkrun* nil) - (setq *brknames* nil) - (setq *default-multi* 5) - (setq *warning* t) - (setq *order-trace* nil) - (setq *print-pname* nil) - (setq *buckets* 16) - (setq *accept-file* nil) - (setq *write-file* nil) - (setq *trace-file* nil) - (setq *strategy* 'lex) - (setq *user-ids* nil) - (setq *in-rhs* nil) - (setq *decide-trace* nil) - (setq *pick-first-condition* t) - (setq *max-recurse* 2) - (setq *multi-attribute* nil) - (multi-attributes '((problem-space operator) (goal item) (state evaluation 2))) - (setq *instance-attributes* nil) - (trace-attributes - '((goal role) (goal impasse) (goal desired) (goal superoperator) - (operator object) (operator instance))) - (setq *watch-free-problem-spaces* nil) - (setq *chunk-free-problem-spaces* nil) - (setq *tracep-list* nil) - (setq *cav* nil) - (setq *cavi* nil) - (setq *tracep* t) - (setq *max-chunk-conditions* 200) - (setq *subgoal-results* nil) - (setq *chunk-all-paths* t) - (setq *smaller-chunks* nil) - (setq *chunks* nil) - (setq *chunk-classes* '(problem-space state operator)) - (setq *always-learn* t) - (setq *new-chunks* nil) - (setq *wme-list-stack* nil) - (setq *learn-ids* nil) - (setq *learning* nil) - (setq *ltrace* nil) - (setq *never-learn* t) - (setq *print-learn* 0) - (setq *split-actions* t) - (setq *select-equal* 'first) - (setq *default-user-select* t) - (setq *pnames* nil) - (setq *free-pname-list* nil) - (setq *used-gensym-list* nil) - (setq *free-gensym-list* (list (list 'free-list))) - (setq *used-var-list* nil) - (setq *used-char-list* nil) - (init-gensym) - (soarmapc #'(lambda (x) (soarputprop x 't 'predicate)) '(< <= <=> <> = > >=)) - (setq *recording* nil) - (setq *refracts* nil) - (setq *real-cnt* (setq *virtual-cnt* 0)) - (setq *limit-token* 1000000) - (setq *limit-cs* 1000000) - (setq *critical* nil) - (setq *wmpart-list* nil) - (setq *global-pair* (list 'nil)) - (setq *subgoal-tabs* t) - (setq *size-result-array* 15) - (setq *result-array* (makevector 16)) - (setq *record-array* (makevector 16)) - (setq x 0) - loop (putvector *result-array* x nil) - (putvector *record-array* x nil) - (setq x (1+ x)) - (and (not (> x *size-result-array*)) - (go loop)) - (make-bottom-node) - (setq *pcount* 0) - (setq *already-fired* nil) - (setq *current-goal* nil) - (soarmachinetype) - (setq *spo-default-depth* 1) - (setq *print-spo-list* nil) - (setq *indent* 0) - (watch 0) - (swatch 0) - (setq *max-elaborations* 100) - (setq *remaining-cycles* 1000000) - (setq *remaining-decide* 1000000) - (setq *version-number* "4") - (setq *minor-version* "0") - (setq *release-number* "1") - (setq *public-version* t) - (setq *date-created* "November 14, 1985") - (soar-greeting) - (init-literalizes) - (init-soar))) - -(defun soar-greeting nil - (soarprintc "Soar ") - (cond (*public-version* - (soarprinc "(Version ") - (soarprinc *version-number*) - (soarprinc ", Release ") - (soarprinc *release-number*) - (soarprinc ")")) - (t (soarprinc *version-number*) - (soarprinc ".") - (soarprinc *minor-version*))) - (soarprintc "Created ") - (soarprint *date-created*) - (cond (*public-version* - (soarprint "Bugs and questions to soar@h.cs.cmu.edu"))) - (soarprint "Copyright (c) 1985 Xerox Corporation. All Rights Reserved.") - (terpri) - (soarprint "Use of this software is permitted for non-commercial") - (soarprint "research purposes, and it may be copied only for that use.") - (soarprint "This software is made available AS IS, and Xerox") - (soarprint "Corporation, Stanford University and Carnegie-Mellon") - (soarprint "University make no warranty about the software or its") - (soarprint "performance.") -) - -(defun insertcs (name data rating) - (prog (instan) - (and (refracted name data) - (return nil)) - (setq instan (cons name data)) - (and (atom *conflict-set*) - (setq *conflict-set* nil)) - (return (setq *conflict-set* (cons instan *conflict-set*))))) - -(defun instantiation (conflict-elem) - (cdr (pname-instantiation conflict-elem))) - -(defun main nil - (prog (phase-set r) - (setq *halt-flag* nil) - (setq *break-flag* nil) - (setq *elaborations-count* 0) - (setq phase-set nil) - dil (cond (*halt-flag* (setq r "End -- Explicit Halt") (go finis)) - ((or (zerop *remaining-decide*) - (zerop *remaining-cycles*)) - (setq *break-flag* t))) - (cond ((or *break-flag* -; (readp t) - ) - (setq r '***break***) - (go finis))) - (setq *first-remove* (setq *first-action* t)) - (setq phase-set (conflict-resolution)) - (cond ((eq *phase* 'decide) - (setq *remaining-cycles* (1- *remaining-cycles*)) - (setq *remaining-decide* (1- *remaining-decide*)) - (setq *cycle-count* (1+ *cycle-count*)) - (setq *decide-count* (1+ *decide-count*)) - (setq *elaborations-count* 0) - (setq *in-rhs* t) - (process-decide phase-set) - (setq *in-rhs* nil) - (setq *phase* 'elaborate)) - ((not phase-set) (setq *phase* 'decide)) - (t (setq *cycle-count* (1+ *cycle-count*)) - (cond ((and *wtrace* - (trace-problem-space?)) - (soarprintc "--Elaboration Phase--"))) - (setq *already-fired* nil) - (soarmapc #'process-instance phase-set) - (setq *remaining-cycles* (1- *remaining-cycles*)) - (setq *elaborations-count* (1+ *elaborations-count*)) - (cond ((eq *max-elaborations* *elaborations-count*) - (soarwarn - "Exceeded *max-elaborations*. Proceeding to decision procedure." - *max-elaborations*) - (setq *phase* 'decide))))) - (go dil) - finis (setq *p-name* nil) - (terpri (trace-file)) - (return r))) - -(defun ops-p (z) - (finish-literalize) - (princ '* (trace-file)) - (cond ((soarlistp (cadr z)) (compile-production (car z) 'elaborate (cdr z))) - (t (compile-production (car z) (cadr z) (cddr z))))) - -(defun ops-pbreak (z) - (cond ((atom z) - (terpri (trace-file)) - (soarprinc2 "Production breaks:" *brkpts*) - (terpri (trace-file)) - (soarprinc2 "Name/identifier breaks:" *brknames*) - (terpri (trace-file)) - nil) - (t (soarmapc #'pbreak2 z) z))) - - -(defun pbreak2 (rule) - (prog (type blist) - (cond ((or (not (symbolp rule)) - (soarlistp rule)) - (soarwarn "Illegal argument:" rule)) - ((or (soarmemq rule *brkpts*) - (soarmemq rule *brknames*)) - nil) - ((get rule 'topnode) (soarpush rule *brkpts*) rule) - (t (soarpush rule *brknames*) rule)))) - -(defun pname-instantiation (conflict-elem) - conflict-elem) - -(defun ops-pm (z) - (soarmapc #'(lambda (x) (pprule x nil)) z) - nil) - - -(defun ppattval nil - (prog (att val) - (setq att (cadr *ppline*)) - (setq *ppline* (cddr *ppline*)) - (cond ((or (null *ppline*) - (eq (car *ppline*) '^)) - (setq val nil)) - (t (setq val (getval)))) - (cond ((> (+ (nwritn t) (flatc att) (flatc val)) 76) - (soarprintc " ") (indent))) - (soarprinc2 '^ att) - (soarmapc #'(lambda (z) (soarprinc2 " " z)) val))) - -(defun ppline (line) - (prog nil - (indent) - (cond ((atom line) (princ line (trace-file))) - (t (princ "(" (trace-file)) - (setq *ppline* line) - (ppline2) - (princ ")" (trace-file)))) - (return nil))) - -(defun pponlyval nil - (prog (val needspace) - (setq val (getval)) - (setq needspace nil) - (cond ((> (+ (nwritn t) (flatc val)) 76) - (setq needspace nil) - (soarprintc " ") - (indent))) - top (and (atom val) - (return nil)) - (and needspace - (princ " " (trace-file))) - (setq needspace t) - (princ (car val) (trace-file)) - (setq val (cdr val)) - (go top))) - -(defun pprule (name flag) - (prog (matrix next lab port) - (and (not (symbolp name)) - (return nil)) - (setq matrix (get name 'production)) - (and (null matrix) - (return nil)) - (setq port (trace-file)) - (soarprintc "(") - (cond ((eq flag 'sp) (setq matrix (p-to-sp matrix)) (princ 'sp port)) - (t (princ 'p port))) - (soarprinc2 " " name) - (and (eq 'decide (get name 'type)) - (soarprinc2 " " 'decide)) - top (and (atom matrix) - (go fin)) - (setq next (car matrix)) - (setq matrix (cdr matrix)) - (setq lab nil) - (terpri port) - (cond ((eq next '-) - (princ " - " port) - (setq next (car matrix)) - (setq matrix (cdr matrix))) - ((eq next '-->) (princ " " port)) - ((and (eq next '{) - (atom (car matrix))) - (princ " {" port) - (setq lab (car matrix)) - (setq next (cadr matrix)) - (setq matrix (cdddr matrix))) - ((eq next '{) - (princ " {" port) - (setq lab (cadr matrix)) - (setq next (car matrix)) - (setq matrix (cdddr matrix))) - (t (princ " " port))) - (ppline next) - (cond (lab (soarprinc3 " " lab "}"))) - (go top) - fin (soarprint ")"))) - -(defun ops-ppwm (avlist) - (conv-to-attr-nums avlist t) - (mapwm #'ppwm2) - nil) - - -(defun print-stats nil - (setq *break-flag* nil) - (print-times "Run Statistics")) - -(defun print-times (mess) - (prog (cc ac pc dc time d-time) - (setq time (time-conversion *elapsed-time*)) - (setq dc (+ (float *decide-count*) 1.0e-20)) - (setq cc (+ (float *cycle-count*) 1.0e-20)) - (setq pc (+ (float *prod-count*) 1.0e-20)) - (setq ac (+ (float *action-count*) 1.0e-20)) - (soarprintc mess) - (pm-size) - (cond ((eq *decide-count* 0) (terpri (trace-file)) (return))) - (printline (list time " Seconds Elapsed")) - (cond ((eq time 0) (setq time 1.0e-8))) - (printline - (list *decide-count* - " Decision Cycles " - (list (quotient (float *decide-count*) time) " Per Sec."))) - (printline - (list *cycle-count* - " Prod Cycles " - (list (quotient (float *cycle-count*) time) " Per Sec.") - " " - (list (- (quotient (float *cycle-count*) dc) 1) - " E cycles/ D cycle"))) - (printline - (list *prod-count* - " Prod. Firings " - (list (quotient (float *prod-count*) time) " Per Sec.") - " " - (and (< 0.01 (- cc *decide-count*)) - (list (quotient (float (- *prod-count* *decide-count*)) - (- cc *decide-count*)) - " Elab. prod. in parallel")))) - (printline - (list *action-count* - " RHS Actions " - (list (quotient (float *action-count*) time) " Per Sec."))) - (printline - (list (round (quotient (float *total-cs*) cc)) - " Mean conflict set size " - (list *max-cs* " Maximum"))) - (printline - (list (round (quotient (float *total-wm*) pc)) - " Mean working memory size " - (list *max-wm* " Maximum " *current-wm* " Current "))) - (printline - (list (round (quotient (float *total-token*) pc)) - " Mean token memory size " - (list *max-token* " Maximum " *current-token* " Current "))))) - -(defun promote-var (dope) - (prog (vname vpred vpos new) - (setq vname (car dope)) - (setq vpred (cadr dope)) - (setq vpos (caddr dope)) - (cond ((eq vpred 'eqnil) (setq vpred 'eq)) - ((not (eq vpred 'eq)) - (%error "Illegal predicate for first occurrence" (list vname vpred)))) - (setq new (list vname 0 vpos)) - (setq *vars* (cons new *vars*)))) - -(defun remove-cs (entry) - (setq *conflict-set* (dremove entry *conflict-set*))) - -(defun remove-from-conflict-set (name) - (prog (cs entry) - l1 (setq cs *conflict-set*) - l2 (cond ((atom cs) (return nil))) - (setq entry (car cs)) - (setq cs (cdr cs)) - (cond ((eq name (car entry)) - (setq *conflict-set* (dremove entry *conflict-set*)) - (go l1)) - (t (go l2))))) - -(defun remove-from-wm (wme) - (prog (class z part timetag port match-time) - (setq port (trace-file)) - (setq wme (eliminate-trailing-nil wme)) - (setq class (wm-hash wme)) - (setq part (get class 'wmpart*)) - (setq z - (cond ((eq class 'goal-context-info) (soarassoc wme part)) - (t (soarassq wme part)))) - (or z - (return nil)) - (setq wme (car z)) - (setq timetag (cdr z)) - (cond ((and *in-rhs* *first-remove*) - (and *ptrace* - *ttrace* - (trace-problem-space?) - (not *wtrace*) - (princ " <--" port)) - (setq *first-action* t) - (setq *first-remove* nil))) - (cond ((or (not *in-rhs*) - (not (trace-problem-space?)))) - ((and (not *wtrace*) - *ptrace* - *ttrace*) - (time-tag-print (list wme) port)) - (*wtrace* (soarprintc "<=WM: ") (ppelm wme port))) - (setq *action-count* (1+ *action-count*)) - (setq *critical* t) - (setq *current-wm* (1- *current-wm*)) - (match nil wme) - (soarputprop class (dremove z part) 'wmpart*) - (setq *critical* nil))) - -(defun removecs (name data) - (prog (cr-data inst cs) - (setq cr-data (cons name data)) - (setq cs *conflict-set*) - l (cond ((null cs) (record-refract name data) (return nil))) - (setq inst (car cs)) - (setq cs (cdr cs)) - (and (not (top-levels-eq inst cr-data)) - (go l)) - (setq *conflict-set* (dremove inst *conflict-set*)))) - -(defun ops-rjust (z) - (prog (val) - (cond ((not (== (length z) 1)) - (soarwarn "RJUST: Wrong number of arguments" z) - (return nil))) - (setq val ($varbind (car z))) - (cond ((or (not (numberp val)) - (< val 1) - (> val 127)) - (soarwarn "RJUST: Illegal value for field width" val) - (return nil))) - ($value 'rjust) - ($value val))) - - -(defun ops-run (z) - (prog (result) - (cond ((eq *pcount* 0) - (terpri (trace-file)) - (soarprint "Please load in some productions first.") - (return nil))) - (init-wm) - (setq *brkrun* nil) - (setq *begin-time* (alwaystime)) - (setq *remaining-decide* 1000000) - (setq *remaining-cycles* 1000000) - (cond ((atom z)) - ((and (atom (cdr z)) - (numberp (car z)) - (> (car z) -1)) - (setq *remaining-cycles* (car z))) - ((and (numberp (car z)) - (eq (cadr z) 'd)) - (setq *remaining-decide* (car z))) - ((soarlistp (car z)) - (setq *brkrun* (conv-input-wme (car z))) - (and (null *brkrun*) - (return "What?"))) - (t (setq *brkrun* (car z)))) - (setq result (do-continue nil)) - (setq *elapsed-time* - (+ *elapsed-time* (- (alwaystime) *begin-time*))) - (return result))) - - -(defun ops-tabto (z) - (prog (val) - (cond ((not (== (length z) 1)) - (soarwarn "TABTO: Wrong number of arguments" z) - (return nil))) - (setq val ($varbind (car z))) - (cond ((or (not (numberp val)) - (< val 1) - (> val 127)) - (soarwarn "TABTO: Illegal column number" val) - (return nil))) - ($value 'tabto) - ($value val))) - -(defun ops-watch (z) - (cond ((equal z '(-1)) (setq *wtrace* nil) - (setq *ptrace* nil) (setq *otrace* nil) -1) - ((equal z '(0)) (setq *wtrace* nil) - (setq *ptrace* nil) (setq *otrace* t) 0) - ((equal z '(0.5)) - (setq *wtrace* nil) - (setq *ptrace* t) - (setq *ttrace* nil) - (setq *otrace* t) - 0.5) - ((equal z '(1)) - (setq *wtrace* nil) - (setq *ptrace* t) - (setq *ttrace* t) - (setq *otrace* t) - 1) - ((equal z '(1.5)) - (setq *wtrace* t) - (setq *ttrace* nil) - (setq *ptrace* t) - (setq *otrace* t) - 1.5) - ((equal z '(2)) - (setq *wtrace* t) - (setq *ttrace* t) - (setq *ptrace* t) - (setq *otrace* t) - 2) - ((equal z '(3)) - (setq *otrace* t) - (setq *wtrace* t) - (setq *ptrace* t) - '(2 -- conflict set trace not supported)) - ((and (atom z) - (null *otrace*)) - -1) - ((and (atom z) - (null *ptrace*)) - 0) - ((and (atom z) - (null *wtrace*)) - 1) - ((atom z) 2) - (t 'what?))) - - -(defun wm-hash (x) - (car x)) - -(defun ops-write (z) - (prog (port max k x needspace) - (cond ((not *in-rhs*) - (soarwarn "Write cannot be called at the top level" " ") - (return nil))) - ($reset) - (eval-args z) - (setq k 1) - (setq max ($parametercount)) - (cond ((< max 1) (soarwarn "Write: nothing to print:" z) (return nil))) - (setq port (default-write-file)) - (setq x ($parameter 1)) - (cond ((and (symbolp x) - ($ofile x)) - (setq port ($ofile x)) - (setq k 2))) - (setq needspace t) - la (and (> k max) - (return nil)) - (setq x ($parameter k)) - (cond ((equal x 'crlf) (setq needspace nil) (terpri port)) - ((equal x 'rjust) - (setq k (+ 2 k)) - (do-rjust ($parameter (1- k)) ($parameter k) port)) - ((equal x 'tabto) - (setq needspace nil) - (setq k (1+ k)) - (do-tabto ($parameter k) port)) - (t (and needspace - (princ " " port)) - (setq needspace t) - (princ x port))) - (setq k (1+ k)) - (go la))) - - -(defun add-negations (current-goal data-matched) - (prog (negation-list return-list negation var-list condition new-condition element) - (and (null *p-name*) - (return nil)) - (and (null (get *p-name* 'negation-index)) - (return nil)) - (setq return-list nil) - (setq negation-list (car (get *p-name* 'negation-index))) - (setq var-list (cadr (get *p-name* 'negation-index))) - l1 (cond ((null negation-list) (return return-list))) - (setq condition (pop negation-list)) - (setq new-condition (list (pop condition))) - l2 (cond ((null condition) - (setq new-condition (nreverse new-condition)) - (soarpush '- return-list) - (soarpush new-condition return-list) - (go l1))) - (soarpush (pop condition) new-condition) - (soarpush (pop condition) new-condition) - (cond ((variablep (car condition)) - (setq element (cdr (soarassq (pop condition) var-list))) - (cond (element - (soarpush - (soarnth (cadr element) (soarnth (car element) data-matched)) - new-condition)) - (t (soarpush '<unbound> new-condition)))) - ((eq (car condition) '<<) - (prog nil - l3 (soarpush (pop condition) new-condition) - (and condition - (neq (car new-condition) '>>) - (go l3)))) - (t (soarpush (pop condition) new-condition))) - (cond ((eq current-goal (get (car new-condition) 'in-id-field)) (go l1))) - (go l2))) - -(defun ops-back-trace (objects) - (prog (wme goal) - (setq *unbound-action-ids* nil) - (cond ((and (not (numberp (car objects))) - (get (car objects) 'goal-depth)) - (setq goal (pop objects))) - ((null objects) (setq goal (most-recent-subgoal *context-stack*)))) - (cond ((null objects) - (setq *created-list* (get goal 'created)) - (find-subgoal-nonresults goal nil *created-list*) - (soarmapcar #'(lambda (x) (back-trace-conditions goal x t)) - (cond (*split-actions* (find-action-sets *subgoal-results* goal)) - (t (list *subgoal-results*))))) - (t (setq wme (conv-input-wme (pop objects))) - (setq goal - (cond ((null objects) (most-recent-subgoal *context-stack*)) - (t (car objects)))) - (setq *created-list* (get goal 'created)) - (setq *subgoal-results* wme) - (back-trace-conditions goal wme t))) - (setq *created-list* nil) - (setq *subgoal-results* nil) - (soarprint " "))) - - -(defun bind-it (action-list) - (prog (variable-list) - (setq variable-list (find-constant-ids action-list)) - (setq *learn-ids* (append variable-list *learn-ids*)) - (return variable-list))) - -(defun build-a-production (condition-list action-list wme-list) - (prog (new-chunk) - (cond ((null action-list) - (soarwarn "No chunk was built because there were no actions" " ") - (return nil)) - ((> (length condition-list) *max-chunk-conditions*) - (soarwarn - "No chunk was built because *max-chunk-conditions* was exceeded:" - (length condition-list)) - (return nil))) - l1 (setq *p-name* (soargenpname 'p)) - (cond ((soarmemq *p-name* *pnames*) (go l1))) - (setq *unbound* nil) - (setq condition-list - (nreverse (knotify-conditions (re-order-conditions condition-list)))) - (and *unbound* - (setq condition-list (re-order-conditions condition-list))) - (setq new-chunk - (list (list 'quote *p-name*) - (list 'quote 'elaborate) - (list 'quote (nconc (nconc condition-list (list '-->)) action-list)))) - (cond ((cdrmember new-chunk *new-chunks*) - (and *print-learn* - (soarprintc "Duplicate chunk")) - (return t))) - (and *tracep* - (soarpush *p-name* *tracep-list*)) - (soarpush *p-name* *chunks*) - (soarpush new-chunk *new-chunks*) - (soarpush wme-list *wme-list-stack*) - (return t))) - -(defun build-copies (duplicate) - (build-a-production - (append *condition-list* (soarmapcar #'cdr *copy-action-list*) (list (car duplicate))) - (rebind-action-ids (cdr duplicate) *learn-ids*) nil)) - -(defun build-duplicates (action-list class-list duplicate-variable duplicates negations) - (prog (cond-list condition dup-list class) - (setq dup-list nil) - (setq *action-list* (prune-actions action-list duplicate-variable)) - (setq *condition-list* nil) - (setq class-list (dremove 'goal-context-info class-list)) - (soarpush 'goal-context-info class-list) - l1 (setq class (pop class-list)) - (cond ((null class) - (cond ((null *action-list*) - (setq *condition-list* *save-condition*) - (setq *action-list* *save-action*) - (return nil))) - (setq *condition-list* (nreverse (append negations *condition-list*))) - (return dup-list))) - (setq cond-list (get class 'condition)) - (soarputprop class nil 'condition) - l2 (setq condition (pop cond-list)) - (cond ((null condition) (go l1)) - ((soarmemq condition duplicates) - (soarpush (cons condition (dup-action condition)) dup-list)) - (t (soarpush condition *condition-list*))) - (go l2))) - -(defun build-terse (conditions) - (prog (return-conditions change-flag element) - (and *ltrace* - (soarprinc "Conditions that are tersed out: ")) - l0 (setq change-flag nil) - (setq return-conditions nil) - l1 (setq element (pop conditions)) - (cond ((and (null element) - change-flag) - (setq conditions (nreverse return-conditions)) - (go l0)) - ((null element) - (and *ltrace* - (terpri (trace-file))) - (return (nreverse return-conditions))) - ((and (neq (class element) 'preference) - (free-condition element)) - (setq change-flag t) - (and *ltrace* - (ppline (car (p-conds-to-sp (list (clean-up-element element)))))) - (untest (cdr element))) - (t (soarpush element return-conditions))) - (go l1))) - -(defun build-variable-list (element) - (and element - (get element 'in-id-field) - (setq *learn-ids* (cons (cons element (soargenvar element)) *learn-ids*)))) - -(defun clean-up-action (action) - (cons 'make (clean-up-clause action 'action))) - -(defun clean-up-clause (condition c-or-a) - (prog (new-condition curpos att ppdat val class found-value element) - (cond ((or (eq condition '-) - (eq (cadr condition) '^)) - (return condition))) - (setq class (pop condition)) - (setq found-value nil) - (setq new-condition (list class)) - (setq ppdat (get class 'ppdat)) - (cond ((null ppdat) (setq ppdat (get 'state-info 'ppdat)))) - (setq curpos 1) - l1 (setq curpos (1+ curpos)) - (cond ((null condition) - (and found-value - (return new-condition)) - (return (nconc new-condition '(^ value nil))))) - (setq element (pop condition)) - (and (null element) - (go l1)) - (setq att (cdr (soarassq curpos ppdat))) - (and (eq att 'value) - (setq found-value t)) - (or att - (setq att curpos)) - (and (eq att 'value) - (setq found-value t)) - (setq val (soarassq element *learn-ids*)) - (cond (val - (setq val (cdr val)) - (and (eq c-or-a 'condition) - (soarputprop val - (1+ (or (get val 'tested) - 0)) - 'tested))) - (t (setq val element))) - (nconc new-condition (list '^ att val)) - (go l1))) - -(defun clear-var-list nil - (setq *learn-ids* nil) - (soarmapc #'soarclearprops *used-var-list*) - (soarmapc #'(lambda (x) (soarputprop x 1 'var-count)) *used-char-list*) - (setq *used-var-list* nil)) - -(defun closure-preference (action subgoal) - (and (test-preference-field (soarnth *goal-index* action) subgoal) - (test-preference-field (soarnth *problem-space-index* action) subgoal) - (test-preference-field (soarnth *state-index* action) subgoal) - (test-preference-field (soarnth *operator-index* action) subgoal))) - -(defun compactify-conditions (condition-list action-list) - (prog (class-list class-name same-class element duplicates duplicate-variable sclass - negations) - (setq duplicates nil) - (setq *save-condition* condition-list) - (setq *save-action* action-list) - (setq negations nil) - (setq class-list nil) - (setq duplicate-variable nil) - l1 (setq element (pop condition-list)) - (cond ((null element) - (return (build-duplicates action-list (reverse class-list) - duplicate-variable duplicates negations))) - ((eq element '-) - (soarpush '- negations) - (soarpush (pop condition-list) negations) - (go l1))) - (setq class-name (car element)) - (setq same-class (get class-name 'condition)) - (cond ((and (neq class-name 'preference) - (free-condition element)) - (setq same-class nil))) - l4 (setq sclass (pop same-class)) - (cond ((null sclass) - (addprop class-name 'condition element) - (and (not (soarmemq class-name class-list)) - (soarpush class-name class-list)) - (go l1))) - (setq *suspected-duplicates* nil) - (cond ((compare-conditions element sclass) - (and (not (soarmemq sclass duplicates)) - (soarpush sclass duplicates)) - (setq duplicate-variable (append duplicate-variable *suspected-duplicates*)) - (go l1))) - (go l4))) - -(defun create-production nil - (prog (chunk wme-list) - (and (null *new-chunks*) - (return)) - (setq *new-chunks* (nreverse *new-chunks*)) - (setq *wme-list-stack* (nreverse *wme-list-stack*)) - l1 (cond ((null *new-chunks*) (setq *wme-list-stack* nil) (return))) - (setq chunk (pop *new-chunks*)) - (setq wme-list (pop *wme-list-stack*)) - (eval (cons 'compile-production chunk)) - (cond ((eq 1 *print-learn*) - (terpri (trace-file)) - (eval (list 'spm (cadar chunk)))) - (*print-learn* (soarprintc "Build:") (soarprinc (cadar chunk)))) - (refract-new-p chunk wme-list) - (go l1))) - -(defun dup-action (condition) - (prog (element action action-list return-list save-action) - (setq action-list *action-list*) - (setq *action-list* nil) - (setq return-list nil) - l1 (setq action (pop action-list)) - (and (null action) - (return return-list)) - (cond ((eq (cadr action) 'preference) (soarpush action *action-list*) (go l1))) - (setq save-action action) - l2 (setq element (pop action)) - (cond ((null element) (soarpush save-action *action-list*) (go l1)) - ((and (variablep element) - (soarmemq element (cddddr condition))) - (soarpush save-action return-list) - (go l1))) - (go l2))) - -(defun find-action-closure (listx) - (soarmapcar #'(lambda (x) (cdr (soarassq x *learn-ids*))) (find-closure listx))) - -(defun find-closure (listx) - (cond ((null listx) listx) - ((eq (car listx) '-) (find-closure (cddr listx))) - (t (merge-not-time (cdar listx) (find-closure (cdr listx)))))) - -(defun find-constant-ids (action-list) - (prog (action-ids element action) - (setq action-ids nil) - l1 (setq action (pop action-list)) - (and (null action) - (return action-ids)) - (setq element (soarnth 4 action)) - (cond ((and (not (variablep element)) - (not (soarassq element action-ids))) - (soarpush (cons element (soargenvar element)) action-ids))) - (go l1))) - -(defun free-condition (elm1) - (prog (carelm found-loser) - (setq elm1 (cddddr elm1)) - (setq found-loser nil) - l1 (setq elm1 (cddr elm1)) - (cond ((null elm1) (return found-loser))) - (setq carelm (pop elm1)) - (and (numberp carelm) - (go l1)) - (cond ((eq (get carelm 'tested) 1) - (cond ((soarmemq carelm *action-closure*) (return nil)) - (t (setq found-loser t))))) - (go l1))) - -(defun get-cav-value (class attribute) - (cdr (soarassq attribute (cdr (soarassq class *cav*))))) - -(defun get-cavi-id (class attribute value) - (cdr (soarassq value (cdr (soarassq attribute (cdr (soarassq class *cavi*))))))) - -(defun knotify (val variables) - (prog (result) - (setq result nil) - l1 (setq result (append result (list '<> (car variables)))) - (setq variables (cdr variables)) - (and variables (go l1)) - (cond ((eq val '<unbound>) (setq *unbound* t) (return (append result '(})))) - (t (return (append result (list val '}))))))) - -(defun knotify-conditions (conditions) - (prog (condition attribute return-conditions new-condition class value values id ids - idds s-condition variable-list) - (setq variable-list - (setq return-conditions - (setq *cav* (setq *cavi* (setq *variable-pairs* nil))))) - l1 (setq condition (pop conditions)) - (cond ((eq condition '-) (soarpush condition return-conditions) (go l1)) - ((null condition) (setq *cav* (setq *cavi* nil)) (return return-conditions))) - (setq s-condition condition) - (setq new-condition (list (setq class (car condition)))) - (setq condition (cddr condition)) - (setq attribute 'worst) - (setq id 'worst) - l2 (cond ((eq (car condition) 'identifier) (setq id (cadr condition))) - ((eq (car condition) 'attribute) (setq attribute (cadr condition))) - ((eq (car condition) 'value) - (setq value (cadr condition)) - (cond ((variablep value) - (setq values (get-cav-value class attribute)) - (cond ((null values) - (put-cav-attribute class attribute) - (put-cav-value class attribute (list value)) - (and (not (soarmemq value variable-list)) - (soarpush value variable-list))) - ((and (not (soarmemq value values)) - (not (soarmemq value variable-list))) - (put-cav-value class attribute (cons value values)) - (setq new-condition - (append new-condition - '(^ value {) - (knotify value values))) - (soarpush (cons value values) *variable-pairs*) - (setq variable-list (cons value variable-list)) - (go l4)) - ((not (soarmemq value values)) - (put-cav-value class attribute (cons value values))))) - ((and (neq id 'worst) - (neq attribute 'worst) - (neq value '{)) - (setq ids (get-cavi-id class attribute value)) - (setq idds (cons id ids)) - (cond ((null ids) - (put-cavi-attribute class attribute) - (put-cavi-value class attribute value) - (put-cavi-id class attribute value idds)) - ((and (not (soarmemq id ids)) - (not (soarassoc id *variable-pairs*))) - (put-cavi-id class attribute value idds) - (soarpush idds *variable-pairs*) - (setq new-condition - (append (list class '^ 'identifier '{) - (knotify id ids) - (list '^ 'attribute attribute '^ 'value value))) - (go l4)))) - ((eq value '{) (nconc new-condition (cons '^ condition)) (go l4))))) - (nconc new-condition (list '^ (car condition) (cadr condition))) - (setq condition (cdddr condition)) - (and condition (go l2)) - l4 (soarpush new-condition return-conditions) - (go l1))) - -(defun ops-learn (z) - (cond ((atom z) (print-status)) - (t (cond ((eq (car z) 'on) - (cond ((and *never-learn* - (neq *cycle-count* 0)) - (terpri (trace-file)) - (soarprint - "Error: Can not turn learning on. Must init-soar first")) - (t (setq *learning* t) (setq *never-learn* nil)))) - ((eq (car z) 'off) - (cond ((and *never-learn* - (neq *cycle-count* 0)) - (terpri (trace-file)) - (soarprint - "Error: Can not turn learning to off. Must init-soar first")) - (t (setq *learning* nil) (setq *never-learn* nil)))) - ((eq (car z) 'never) (setq *learning* nil) (setq *never-learn* t)) - ((eq (car z) 'full-print) (setq *print-learn* 1)) - ((eq (car z) 'print) (setq *print-learn* 0)) - ((eq (car z) 'noprint) (setq *print-learn* nil)) - ((eq (car z) 'full-trace) (setq *ltrace* t) (setq *tracep* t)) - ((eq (car z) 'trace) (setq *tracep* t) (setq *ltrace* nil)) - ((eq (car z) 'notrace) (setq *tracep* nil) (setq *ltrace* nil)) - ((eq (car z) 'always) (setq *always-learn* t)) - ((eq (car z) 'bottom-up) (setq *always-learn* nil)) - (t (terpri (trace-file)) (soarprint "Error: unknown option"))) - (eval (cons 'learn (cdr z)))))) - - -(defun learn-back-trace (old-context prior-context new-context subgoaled) - (prog (return-value condition-list subgoal) - (setq subgoal (get-current old-context 'goal)) - (setq *created-list* (get subgoal 'created)) - (setq *unbound-action-ids* nil) - (soarmapc #'remove-from-wm - (find-subgoal-nonresults subgoal (get-current prior-context 'goal) - *created-list*)) - (cond (*never-learn* (soarclearprops subgoal) (return t))) - (setq return-value - (soarmapcar - #'(lambda (x) - (handle-back-trace-actions x old-context prior-context new-context - subgoaled)) - (cond (*split-actions* (find-action-sets *subgoal-results* subgoal)) - (t (list *subgoal-results*))))) - (soarclearprops subgoal) - (setq *subgoal-results* nil) - (setq *learn-ids* nil) - (return (t-in-list? return-value)))) - -(defun prune-actions (action-list duplicate-variable) - (prog (action save-action return-list) - (setq return-list nil) - l1 (and (null action-list) - (return return-list)) - (setq action (pop action-list)) - (setq save-action action) - l2 (cond ((null action) (soarpush save-action return-list) (go l1)) - ((soarmemq (pop action) duplicate-variable) (go l1))) - (go l2))) - -(defun put-cav-attribute (class attribute) - (cond ((soarassq class *cav*) - (rplacd (soarassq class *cav*) - (cons (list attribute) (cdr (soarassq class *cav*))))) - (t (setq *cav* (cons (cons class (list (list attribute))) *cav*))))) - -(defun put-cav-value (class attribute value) - (rplacd (soarassq attribute (cdr (soarassq class *cav*))) value)) - -(defun put-cavi-attribute (class attribute) - (cond ((soarassq attribute (cdr (soarassq class *cavi*)))) - ((soarassq class *cavi*) - (rplacd (soarassq class *cavi*) - (cons (list attribute) (cdr (soarassq class *cavi*))))) - (t (setq *cavi* (cons (cons class (list (list attribute))) *cavi*))))) - -(defun put-cavi-id (class attribute value id) - (rplacd (soarassq value (cdr (soarassq attribute (cdr (soarassq class *cavi*))))) id)) - -(defun put-cavi-value (class attribute value) - (rplacd (soarassq attribute (cdr (soarassq class *cavi*))) - (cons (list value) (cdr (soarassq attribute (cdr (soarassq class *cavi*))))))) - -(defun rebind-action-ids (action-list copy-list) - (prog (element new-element return-list val val2) - (setq return-list nil) - l1 (and (null action-list) - (return return-list)) - (setq element (pop action-list)) - (setq new-element nil) - l2 (and (null element) - (go l3)) - (setq val2 (pop element)) - (setq val (cdr (soarassq val2 copy-list))) - (or val - (setq val val2)) - (soarpush val new-element) - (go l2) - l3 (soarpush (nreverse new-element) return-list) - (go l1))) - -(defun refract-new-p (new-p wme-list) - (prog (element prior-element) - (setq prior-element nil) - (setq new-p (cadar new-p)) - l1 (cond ((setq element (soarassq new-p *conflict-set*)) - (cond ((soarmemq element prior-element) (return t)) - ((or (null wme-list) - (test-subset (cdr element) wme-list)) - (setq *conflict-set* (dremove element *conflict-set*))) - (t (setq *conflict-set* - (append (dremove element *conflict-set*) - (list element))))) - (soarpush element prior-element) - (go l1)) - (t (return t))))) - -(defun tersify-negations (negations) - (prog (condition return-list new-condition id value) - (setq return-list nil) - l1 (cond ((null negations) (return return-list))) - (setq condition (pop negations)) - (setq new-condition (list (pop condition))) - l2 (cond ((null condition) - (setq new-condition (nreverse new-condition)) - (and (soarmember new-condition return-list) - (go l1)) - (soarpush '- return-list) - (soarpush new-condition return-list) - (go l1))) - (soarpush (pop condition) new-condition) - (soarpush (pop condition) new-condition) - (setq id (pop condition)) - (cond ((eq 1 (get id 'tested)) (soarpush '<unbound> new-condition) (go l2)) - (t (soarpush id new-condition) (go l2))))) - -(defun test-chunk-for-content (conditions) - (prog (condition) - l1 (cond ((null conditions) - (soarwarn - "No chunk was built because no conditions had a class in *chunk-classes*" - " ") - (clear-var-list) - (return t))) - (setq condition (pop conditions)) - (cond ((eq condition '-) (go l1)) - ((soarmemq (conv-type-to-sp (car condition)) *chunk-classes*) (return nil))) - (go l1))) - -(defun ask-for-choice (choice-list) - (prog (choice count) - (setq *elapsed-time* - (+ *elapsed-time* (- (alwaystime) *begin-time*))) - (cond (*interlisp* (return (interlisp-menu choice-list)))) - l1 (terpri (trace-file)) - (soarprint "Choose from this list by position in list (1-n)") - (setq count 1) - (soarmapc - #'(lambda (x) (soarprinc2 count ": ") (print-choice x) (setq count (1+ count))) - choice-list) - (princ "? " (trace-file)) - (setq choice (read)) - (cond ((and (numberp choice) - (> choice 0) - (< choice (1+ (length choice-list)))) - (setq *begin-time* (alwaystime)) - (return (soarnth (1- choice) choice-list)))) - (soarprintc "Your answer was not a number between 1 and n.") - (go l1))) - -(defun classify-decide (instance) - (prog (pname node action goal slot value id id2 compared) - (setq pname (car instance)) - (setq *data-matched* (cdr instance)) - (setq node (get pname 'topnode)) - (init-var-mem (var-part node)) - (init-ce-var-mem (ce-var-part node)) - (setq action (cdddr (cadr (rhs-part node)))) - (setq goal ($varbind (car action))) - (setq action (cdddr action)) - (setq id ($varbind (car action))) - (setq action (cdddr action)) - (setq slot ($varbind (car action))) - (setq action (cdddr action)) - (setq value ($varbind (car action))) - (setq action (cdddr action)) - (setq compared ($varbind (car action))) - (cond ((eq value 'indifferent) (cond (compared (setq value 'equal)))) - ((eq value 'better) - (setq value 'worse) - (setq id2 compared) - (setq compared id) - (setq id id2))) - (addprop goal 'preferences (list slot value id compared (car *data-matched*))))) - -(defun decide-trace (arg) - (setq *decide-trace* arg)) - -(defun decide-tracer (label list) - (cond (*decide-trace* - (terpri (trace-file)) - (soarprinc3 " " label " ") - (soarmapc #'print-id list)))) - -(defun decision-procedure (value-list current) - (prog (new-values saved-values) - (setq new-values (find-acceptable value-list)) - (decide-tracer 'acceptable new-values) - (cond ((null new-values) - (cond ((and (neq current 'undecided) - (null (prune-rejects (list (list current)) value-list current))) - (return '(rejection)))) - (return '(no-change)))) - (setq new-values (process-indifferent new-values value-list)) - (decide-tracer 'post-indifferent new-values) - (setq new-values (set-equals new-values value-list)) - (decide-tracer 'post-equal new-values) - (setq new-values (prune-rejects new-values value-list current)) - (decide-tracer 'post-reject new-values) - (cond ((or (null new-values) - (null (car new-values))) - (return '(rejection)))) - (setq saved-values new-values) - (setq new-values (prune-worse new-values value-list)) - (decide-tracer 'post-worse new-values) - (and (null new-values) - (return (cons 'conflict (soarsort (flatten saved-values))))) - (and (null (car new-values)) - (return (cons 'conflict (soarsort (flatten saved-values))))) - (setq new-values (select-best new-values value-list)) - (decide-tracer 'post-best new-values) - (setq new-values (set-worst new-values value-list)) - (decide-tracer 'post-worst new-values) - (and (cdr new-values) - (return (test-parallel (soarsort (flatten new-values)) value-list 'tie))) - (return (test-parallel new-values value-list nil)))) - -(defun find-acceptable (value-list) - (dremove 'nil (flatten (find-all-assq 'acceptable value-list)))) - -(defun find-all-assq (item alist) - (prog (alist2 element) - (setq alist2 nil) - l1 (and (null alist) - (return alist2)) - (setq element (pop alist)) - (cond ((and (eq item (car element)) - (not (soarmember (cdr element) alist2))) - (soarpush (cdr element) alist2))) - (go l1))) - -(defun find-goal-preferences (context) - (get (car context) 'preferences)) - -(defun find-no-change-slot (context) - (cond ((eq (cadr context) 'undecided) 'goal) - ((eq (caddr context) 'undecided) 'problem-space) - ((eq (cadddr context) 'undecided) 'state) - (t 'operator))) - -(defun find-preference (data) - (prog nil - l1 (cond ((null data) (return nil)) - ((eq (caar data) 'preference) (return (car data)))) - (setq data (cdr data)) - (go l1))) - -(defun find-worse (x ylist) - (cond ((null ylist) nil) ((soarmemq x (car ylist)) t) (t (find-worse x (cdr ylist))))) - -(defun make-info (info goal-id attribute value) - (prog (array) - (setq array (list info goal-id attribute value)) - (add-to-wm array) - (return array))) - -(defun process-decide (phase-set) - (accum-stats) - (setq *new-chunks* nil) - (soarmapcar #'classify-decide phase-set) - (process-context-stack *context-stack*)) - -(defun process-indifferent (new-values value-list) - (prog (worst-set return-list new-equals old-equals worst-list item) - (setq worst-list (find-all-assq 'indifferent value-list)) - (setq new-equals nil) - (setq return-list nil) - l1 (cond ((null new-values) - (and new-equals - (return (cons new-equals return-list))) - (return return-list))) - (setq old-equals (pop new-values)) - (cond ((soarassq old-equals worst-list) (soarpush old-equals new-equals)) - (t (soarpush (list old-equals) return-list))) - (go l1))) - -(defun process-results (results id) - (cond ((null (cdr results)) (car results)) - ((soarmemq id results) id) - ((eq *select-equal* 'first) (car results)) - ((soarlistp *select-equal*) - (cond ((find-selected-result (pop *select-equal*) results)) - (t (setq *select-equal* t) (ask-for-choice results)))) - (*select-equal* (ask-for-choice results)) - (t (soarnth (random (1- (length results))) results)))) - -(defun prune-rejects (new-values value-list current) - (prog (return-list reject-list new-value new-value-list) - (setq reject-list (dremove 'nil (flatten (find-all-assq 'reject value-list)))) - (setq return-list nil) - l1 (cond ((null new-values) - (cond ((and (null return-list) - (eq current 'undecided)) - (return nil)) - ((and (null return-list) - (soarlistp current)) - (return (list (soarmapc - #'(lambda (x) (setq current (remove x current))) - reject-list)))) - ((and (null return-list) - (not (soarmemq current reject-list))) - (return (list current)))) - (return return-list))) - (setq new-value (pop new-values)) - (setq new-value-list nil) - l2 (cond ((null new-value) - (and new-value-list - (soarpush new-value-list return-list)) - (go l1)) - ((not (soarmemq (car new-value) reject-list)) - (soarpush (car new-value) new-value-list))) - (pop new-value) - (go l2))) - -(defun prune-remove (remove-list) - (prog (non-context-list wme) - (setq non-context-list nil) - l1 (and (null remove-list) - (return (nreverse non-context-list))) - (setq wme (pop remove-list)) - (cond ((and (eq (class wme) 'goal-context-info) - (soarmemq (sattribute wme) '(problem-space state operator))) - (remove-from-wm wme)) - (t (soarpush wme non-context-list))) - (go l1))) - -(defun prune-worse (new-values value-list) - (prog (equal-set return-list equals old-equals old-values item item2 worse-list hit - worse-list2) - (setq worse-list (find-all-assq 'worse value-list)) - (setq return-list nil) - (setq old-values new-values) - l1 (and (null new-values) - (return return-list)) - (setq old-equals (setq equal-set (pop new-values))) - (setq equals nil) - l2 (cond ((null equal-set) (soarpush equals return-list) (go l1))) - (setq item (pop equal-set)) - (setq worse-list2 worse-list) - l4 (cond ((null worse-list2) (soarpush item equals) (go l2))) - (setq item2 (pop worse-list2)) - (cond ((and (eq (car item2) item) - (neq item (cadr item2))) - (setq hit (cadr item2)) - (cond ((soarmemq hit old-equals) (go l2)) - ((find-worse hit old-values) (go l1))))) - (go l4))) - -(defun select-best (new-values value-list) - (prog (return-list equal-list old-values best-list save-e-list e-item) - (setq best-list (find-all-assq 'best value-list)) - (setq return-list nil) - (setq old-values new-values) - l1 (and (null new-values) - (null return-list) - (return old-values)) - (and (null new-values) - (return (list return-list))) - (setq equal-list (pop new-values)) - (setq save-e-list equal-list) - l2 (and (null equal-list) - (go l1)) - (setq e-item (pop equal-list)) - (cond ((soarassq e-item best-list) (soarpush e-item return-list))) - (go l2))) - -(defun user-select (x) - (setq *select-equal* x)) - -(defun set-equals (new-values value-list) - (prog (equal-set new-equals return-list hit hit-list old-hit-list equal-list - equal-list2) - (setq equal-list (find-all-assq 'equal value-list)) - (setq return-list nil) - (setq new-equals (pop new-values)) - (setq equal-set nil) - (setq old-hit-list nil) - (setq hit-list nil) - l2 (cond ((null new-equals) - (and equal-set - (soarpush equal-set return-list)) - (and (null new-values) - (return return-list)) - (setq old-hit-list (append old-hit-list hit-list)) - (setq new-equals (pop new-values)) - (setq equal-set nil) - (cond ((soarmemq (car new-equals) old-hit-list) (pop new-equals) (go l2))))) - (setq equal-list2 equal-list) - l4 (cond ((null equal-list2) (soarpush (pop new-equals) equal-set) (go l2))) - (cond ((equal (caar equal-list2) (car new-equals)) - (setq hit (cadar equal-list2)) - (cond ((and (not (soarmemq hit equal-set)) - (not (soarmemq hit new-equals)) - (soarmemq hit (flatten new-values))) - (setq new-equals (append new-equals (list hit))) - (soarpush hit hit-list))))) - (pop equal-list2) - (go l4))) - -(defun set-worst (new-values value-list) - (prog (worst-set return-list new-equals old-equals worst-list item) - (setq worst-list (find-all-assq 'worst value-list)) - (setq return-list nil) - l1 (and (null new-values) - (null return-list) - (return (list worst-set))) - (and (null new-values) - (return return-list)) - (setq old-equals (pop new-values)) - (setq new-equals nil) - l2 (cond ((null old-equals) - (and new-equals - (soarpush new-equals return-list)) - (go l1))) - (setq item (pop old-equals)) - (cond ((soarassq item worst-list) (soarpush item worst-set)) - (t (soarpush item new-equals))) - (go l2))) - -(defun test-parallel (results value-list difficulty) - (prog (parallel-list parallel-results new-results) - (setq parallel-list (find-all-assq 'parallel value-list)) - (setq results (flatten results)) - (and (null parallel-list) - (return (cons difficulty results))) - (setq parallel-results (list (car results))) - (setq new-results (cdr results)) - l1 (cond ((null new-results) - (decide-tracer 'parallel results) - (return (cons 'parallel results)))) - (cond ((soarmember (list (car new-results) (car parallel-results)) parallel-list) - (soarpush (pop new-results) parallel-results) - (go l1)) - (t (return (cons difficulty results)))))) - -(defun change-context (difficulty results old-context slot context-stack preferences) - (prog (new-context subgoaled) - (cond ((and *wtrace* - (cdr context-stack) - (trace-problem-space?)) - (soarprintc "--Removal Phase--"))) - (setq new-context (create-new-context difficulty results old-context slot)) - (setq subgoaled - (soarmapcar #'(lambda (x) (process-sub-contexts x new-context old-context)) - (cdr context-stack))) - (cond ((t-in-list? subgoaled) - (rplaca (soarnthcdr 9 old-context) t) - (rplaca (soarnthcdr 9 new-context) t))) - (cond ((and *wtrace* - (trace-problem-space?)) - (soarprintc "--Decision Phase--"))) - (cond (difficulty - (write-trace " " difficulty slot) - (create-production) - (cond ((and (eq difficulty 'no-change) - (soarlistp results)) - (rplacd context-stack - (soarmapcar - #'(lambda (x) - (create-goal-context difficulty slot x old-context - preferences)) - results))) - (t (rplacd context-stack - (list (create-goal-context difficulty slot results - old-context preferences))))) - (return new-context)) - (t (write-trace " DECIDE " slot results) - (rplacd context-stack nil) - (change-to-new-context new-context old-context preferences) - (return new-context))))) - -(defun change-to-new-context (new-context old-context preferences) - (prog (slots new-contexts slot depth context-changes) - (setq slots '(operator state problem-space)) - (setq new-contexts nil) - (setq *p-name* 'decision-procedure) - (setq *context* new-context) - (setq depth (get-context-depth new-context)) - (setq context-changes nil) - l1 (setq slot (pop slots)) - (cond ((null slot) - (create-production) - (soarmapc #'(lambda (x) (trace-object (car x) (cdr x) depth)) - context-changes) - (soarmapc - #'(lambda (x) - (cond ((neq (svalue x) 'undecided) - (setq *data-matched* - (list (find-acceptable-preference preferences (svalue x)))) - (setq *first-action* t)) - (t (setq *data-matched* nil) (setq *first-action* t))) - (add-to-wm x)) - new-contexts) - (return)) - ((neq (get-current new-context slot) (get-current old-context slot)) - (setq new-contexts - (nconc (remove-current (get-current old-context 'goal) slot - (get-current old-context slot) - (get-current new-context slot)) - new-contexts)) - (soarpush (cons slot (get-current new-context slot)) context-changes))) - (go l1))) - -(defun context-stack nil - (soarmapc #'print *context-stack*) - t) - -(defun create-goal-context (desired slot results context preferences) - (prog (goal-id created-list result superoperator temp supergoal) - (setq *p-name* 'decision-procedure) - (setq *data-matched* nil) - (setq supergoal (get-current context 'goal)) - (setq goal-id (soargensym 'g)) - (soarputprop goal-id (1+ (get supergoal 'goal-depth)) 'goal-depth) - (setq *context* - (list goal-id - 'undecided - 'undecided - 'undecided - 0 - nil - nil - nil - results - nil - (1+ (get-context-depth context)))) - (setq created-list - (list (make-info 'goal-context-info goal-id 'problem-space 'undecided) - (make-info 'goal-context-info goal-id 'supergoal supergoal) - (make-info 'goal-context-info goal-id 'state 'undecided) - (make-info 'goal-context-info goal-id 'operator 'undecided) - (make-info 'goal-context-info goal-id 'choices - (cond ((or (eq desired 'no-change) - (eq desired 'rejection)) - 'none) - (t 'multiple))))) - (cond ((eq desired 'rejection) - (setq slot (cadr (soarmemq slot '(operator state problem-space goal)))) - (create-goal-info (find-reject-preferences preferences) goal-id))) - (nconc created-list - (list (make-info 'goal-context-info goal-id 'impasse desired))) - (setq superoperator 'undecided) - (setq temp nil) - (cond ((eq desired 'no-change) - (cond ((eq slot 'operator) (setq superoperator results)) - ((eq slot 'state) - (setq temp - (list (list 'goal-context-info - supergoal - 'operator - 'undecided)))) - ((eq slot 'problem-space) - (setq temp - (list (list 'goal-context-info supergoal 'state 'undecided)))) - ((eq slot 'goal) - (setq temp - (list (list 'goal-context-info - supergoal - 'problem-space - 'undecided))))))) - (create-goal-info temp goal-id) - (nconc created-list (list (make-info 'goal-context-info goal-id 'role slot))) - (create-goal-info - (list (list 'goal-context-info supergoal 'operator superoperator)) goal-id) - (nconc created-list - (list (make-info 'goal-context-info goal-id 'superoperator superoperator))) - l4 (cond ((or (not results) - (atom results)) - (soarputprop goal-id created-list 'created) - (trace-object 'goal goal-id (1+ (get-context-depth context))) - (return (list *context*)))) - (setq result (pop results)) - (cond ((eq slot 'state) - (create-goal-info - (list (list 'goal-context-info - supergoal - 'operator - (get-current context 'operator)) - (find-acceptable-preference preferences result)) - goal-id)) - (t (create-goal-info (list (find-acceptable-preference preferences result)) - goal-id))) - (nconc created-list (list (make-info 'goal-context-info goal-id 'item result))) - (go l4))) - -(defun create-new-context (difficulty result old-context slot) - (prog (slots found-slot aslot return-list) - (cond (difficulty - (return (list (get-current old-context 'goal) - (get-current old-context 'problem-space) - (get-current old-context 'state) - (get-current old-context 'operator) - (get-context-pnumber old-context) - slot - difficulty - result - (get-context-super-operator old-context) - (get-context-subgoaled old-context) - (get-context-depth old-context))))) - (setq slots '(goal problem-space state operator)) - (setq return-list nil) - (setq found-slot nil) - l1 (setq aslot (pop slots)) - (cond ((null aslot) - (return (append return-list - (list (get-context-pnumber old-context) - nil - nil - nil - (get-context-super-operator old-context) - (get-context-subgoaled old-context) - (get-context-depth old-context)))))) - (cond (found-slot (setq return-list (append return-list '(undecided)))) - ((eq aslot slot) - (setq found-slot t) - (setq return-list (append return-list (list result)))) - (t (setq return-list - (append return-list (list (get-current old-context aslot)))))) - (go l1))) - -(defun get-context-depth (context) - (soarnth 10 context)) - -(defun get-context-difficulty (context) - (soarnth 6 context)) - -(defun get-context-pnumber (context) - (soarnth 4 context)) - -(defun get-context-results (context) - (soarnth 7 context)) - -(defun get-context-slot (context) - (soarnth 5 context)) - -(defun get-context-subgoaled (context) - (soarnth 9 context)) - -(defun get-context-super-operator (context) - (soarnth 8 context)) - -(defun get-current (context slot) - (soarnth - (cdr (soarassq slot '((goal . 0) (problem-space . 1) (state . 2) (operator . 3)))) - context)) - -(defun init-context (problem-space state operator) - (prog (goal-name) - (init-soar) - (setq goal-name (soargensym 'g)) - (setq *context* - (list goal-name - problem-space - state - operator - '0 - 'nil - 'nil - 'nil - 'nil - 'nil - '0)) - (setq *context-stack* (list *context*)) - (return goal-name))) - -(defun neq-result (difficulty result context slot) - (cond (difficulty - (or (neq difficulty (get-context-difficulty context)) - (neq slot (get-context-slot context)) - (not (test-results-subset result context)))) - ((soarlistp result) (not (test-slot-subset result context))) - (t (neq result (get-current context slot))))) - -(defun process-a-parallel-operator (context-stack results prior-context) - (prog nil - (and (soarmemq (get-context-super-operator (car context-stack)) results) - (return (list context-stack))) - (process-sub-contexts context-stack prior-context prior-context) - (return nil))) - -(defun process-context (context context-stack) - (prog (context-preferences slot-preferences preferences slots slot ids results - difficulty pnumber current) - (setq context-preferences (find-goal-preferences context)) - (remprop (car context) 'preferences) - (setq pnumber (length context-preferences)) - (rplaca (soarnthcdr 4 context) pnumber) - (setq slots '(problem-space state operator)) - (setq ids (cdr context)) - l1 (setq current (pop ids)) - (setq slot (pop slots)) - (cond ((null slot) - (setq difficulty 'no-change) - (setq slot (find-no-change-slot context)) - (setq current (get-current context slot)) - (cond ((neq-result difficulty nil context slot) - (rplaca context-stack - (change-context difficulty current context slot - context-stack nil)) - (return t)) - ((and (eq slot 'operator) - (soarlistp current)) - (process-parallel-operators context context-stack) - (return nil)) - (t (return nil))))) - (setq slot-preferences (find-all-assq slot context-preferences)) - (setq preferences (soarmapcar #'(lambda (x) (car (reverse x))) slot-preferences)) - (setq slot-preferences - (soarmapcar #'(lambda (x) (reverse (cdr (reverse x)))) slot-preferences)) - (cond (*decide-trace* (soarprintc slot) (soarprinc " ") (print-id current))) - (setq results (decision-procedure slot-preferences current)) - (setq difficulty (pop results)) - (cond ((eq difficulty 'no-change) (go l1)) - ((not difficulty) (setq results (process-results results current))) - ((eq difficulty 'parallel) (setq difficulty nil))) - (cond ((neq-result difficulty results context slot) - (and (broken2 results) - (setq *remaining-decide* 0)) - (rplaca context-stack - (change-context difficulty results context slot context-stack - preferences)) - (return t)) - (difficulty (return)) - ((eq results 'undecided) (setq slots nil))) - (go l1))) - -(defun process-context-stack (context-stack) - (prog (context) - (setq context (car context-stack)) - (cond ((null (cdr context-stack)) - (process-context context context-stack) - (check-limits) - (return)) - ((test-context context) - (cond ((process-context context context-stack) (check-limits) (return)))) - (t (remprop (car context) 'preferences))) - (soarmapc #'(lambda (x) (process-context-stack x)) (cdr context-stack)))) - -(defun process-parallel-operators (context context-stack) - (rplacd context-stack - (soarmapconc - #'(lambda (x) - (process-a-parallel-operator x (get-current context 'operator) context)) - (cdr context-stack))) - (create-production)) - -(defun process-sub-contexts (context-stack new-context prior-context) - (prog (old-context subgoaled) - (setq old-context (car context-stack)) - (setq subgoaled nil) - (cond ((cdr context-stack) - (setq subgoaled - (t-in-list? - (soarmapcar - #'(lambda (x) (process-sub-contexts x old-context old-context)) - (cdr context-stack)))))) - (return (learn-back-trace old-context prior-context new-context subgoaled)))) - -(defun push-context-stack (context) - (soarpush context *context-stack*) - (setq *context* context)) - -(defun test-context (context) - (neq (length (find-goal-preferences context)) (get-context-pnumber context))) - -(defun test-if-subset (subset set) - (cond ((null subset) t) - ((atom set) nil) - ((soarmemq (car subset) set) (test-if-subset (cdr subset) set)) - (t nil))) - -(defun test-results-subset (result context) - (cond (*impasse-subset-not-equal* (equal result (get-context-results context))) - ((test-if-subset result (get-context-results context)) - (rplaca (soarnthcdr 7 context) result) - t) - (t nil))) - -(defun test-slot-subset (result context) - (cond ((test-if-subset result (get-current context 'operator)) - (rplaca (soarnthcdr 3 context) result) - t) - (t nil))) - -(defun all-bound? (vlist) - (soar-do ((vl1 vlist (cdr vl1))) ((null vl1) t) - (cond ((not (bound-var? (car vl1))) (return nil))))) - -(defun bound-preference? (pr) - (all-bound? (get-context-vars-in-pref pr))) - -(defun bound-var? (v) - (get v 'bound)) - -(defun check-negations (set-vars negations) - (soar-do ((neg negations (cddr neg)) (active) (unactive)) - ((null neg) (cons active unactive)) - (cond ((all-bound? (get-all-vars-in-neg (car neg))) - (soarpush '- active) - (soarpush (strip-condition (car neg)) active)) - (t (soarpush '- unactive) (soarpush (car neg) unactive))))) - -(defun classify (set-vars dup-vars conditions flag) - (prog (attr-type attr-val val-type val-val temp c i mini result) - (setq mini 102) - l1 (setq c (pop conditions)) - (cond ((null c) (return (rplnode *global-pair* mini (nreverse result)))) - ((setq i (get-prev-rank c)) (cond (i (go l2)))) - ((eq (get-condition-type c) 'preference) - (cond ((and (soarmemq 'role (cdr c)) - (eq 'operator (cadr (soarmemq 'role (cdr c))))) - (setq i (+ 6 *default-multi*))) - (t (setq i 3))) - (and flag - (put-rank c i))) - (t (setq temp (get-attr-val-types c)) - (setq attr-type (caar temp)) - (setq val-type (cadr temp)) - (setq attr-val (cdar temp)) - (setq val-val (cddr temp)) - (cond ((and (eq attr-type 'var) - (bound-var? attr-val)) - (setq attr-type 'set-var))) - (cond ((and (eq val-type 'var) - (bound-var? val-val)) - (setq val-type 'set-var))) - (cond ((and (eq attr-type 'const) - (eq val-type 'const)) - (setq i 1) - (put-rank c 1)) - ((and (soarmemq attr-type '(const set-var)) - (soarmemq val-type '(const set-var))) - (setq i 2) - (and flag - (put-rank c 2))) - ((eq (get-condition-type c) 'goal-context-info) - (cond ((eq (get-mult-num (get-condition-type c) attr-val) 1) - (setq i 4)) - (t (setq i 5))) - (put-rank c i)) - ((and (eq attr-type 'const) - (eq val-type 'var) - (soarmemq val-val dup-vars)) - (setq i (+ 6 (get-mult-num (get-condition-type c) attr-val)))) - ((and (soarmemq attr-type '(var set-var)) - (soarmemq attr-val dup-vars) - (soarmemq val-type '(var set-var)) - (soarmemq val-val dup-vars)) - (setq i 100)) - (t (setq i 101) (put-rank c 101))))) - l2 (cond ((< i mini) (setq mini i) (setq result (list c))) - ((= i mini) (soarpush c result))) - (go l1))) - -(defun classify-match-elt (x) - (cond ((eq (car x) '<<) (rplnode *global-pair* (skip-disjunction x) '(other))) - ((predicatep (car x)) (rplnode *global-pair* (next-sym (next-sym x)) '(other))) - ((variablep (car x)) (rplnode *global-pair* (next-sym x) (cons 'var (car x)))) - ((eq (car x) '//) (rplnode *global-pair* (next-sym x) (cons 'const (cadr x)))) - (t (rplnode *global-pair* (next-sym x) (cons 'const (car x)))))) - -(defun classify-term (x) - (prog (result) - (setq result '(other)) - (cond ((eq (car x) '{) - (return (prog (next-elt) - (setq x (cdr x)) - loop (cond ((eq (car x) '}) - (return (rplnode *global-pair* (cdr x) result))) - (t (setq next-elt (pop-match-elt x)) - (cond ((soarmemq (car next-elt) '(var const)) - (setq result next-elt))) - (go loop)))))) - (t (return (classify-match-elt x)))))) - -(defun find-all-vars-in-condition (condition) - (soar-do ((c (cdddr condition)) (vars) (next-elt)) ((null c) vars) - (cond ((variablep (car c)) (soarpush (car c) vars) (setq c (next-sym c))) - ((eq (car c) '<<) (setq c (skip-disjunction c))) - (t (setq c (next-sym c)))))) - -(defun find-best-condition (set-vars dup-vars active-conditions un-active-conditions ccl - recurse-level minsofar) - (prog (ccl1 i c tie-conds minc minrank temp new-vars act-conds un-act-conds s-v best) - (setq i (car ccl)) - (setq tie-conds (cdr ccl)) - (cond ((> i 101) (return nil)) - ((or (<= i 6) - (= i 101) - (and (null (cdr tie-conds)) - (or (not (= i 7)) - (= recurse-level 0))) - (= recurse-level *max-recurse*)) - (setq c (car tie-conds)) - (return (cons (list i) c)))) - (setq minrank '(102)) - (cond ((and minsofar - (or (> i (car minsofar)) - (and (= i (car minsofar)) - (cdr minsofar) - (= 1 (cadr minsofar))))) - (return '((100))))) - l2 (setq c (pop tie-conds)) - (and (null c) - (go l3)) - (setq temp (get-attr-val-types c)) - (cond ((eq (cadr temp) 'const) (setq new-vars (list (cdar temp)))) - (t (setq new-vars (list (cddr temp))))) - (setq act-conds (remove c active-conditions)) - (setq s-v (mark-as-set new-vars)) - (setq temp (get-conditions-with-vars s-v un-active-conditions)) - (setq act-conds (append (car temp) act-conds)) - (setq un-act-conds (cdr temp)) - (setq ccl1 (classify s-v dup-vars act-conds nil)) - (setq best - (find-best-condition s-v dup-vars act-conds un-act-conds ccl1 - (+ 1 recurse-level) (cdr minrank))) - (unmark-as-set s-v) - (cond ((or (and (equal (car best) minrank) - (eq (get-id-var c) *last-value-var*)) - (lexless (car best) minrank)) - (setq minrank (car best)) - (setq minc c))) - (cond ((eq (car minrank) 1) (go l3))) - (go l2) - l3 (return (cons (cons i minrank) minc)))) - -(defun find-info-on-cond (c flag) - (prog (label attr val id vars next-term prefvars) - (setq attr '(const)) - (setq val '(const)) - (setq c (cdr c)) - l1 (setq c (cdr c)) - (cond ((null c) - (cond (flag (return (list id vars prefvars nil))) - (t (return (list id vars (cons attr val) nil)))))) - (setq label (pop c)) - (setq next-term (pop-term c)) - (cond ((eq (car next-term) 'var) (soarpush (cdr next-term) vars))) - (cond ((and flag - (soarmemq label '(goal problem-space state operator)) - (eq (car next-term) 'var) - (soarpush (cdr next-term) prefvars)))) - (cond ((eq label 'identifier) - (cond ((eq (car next-term) 'const) - (soarwarn "Constant identifier field in: " c) - (setq id 'const)) - ((eq (car next-term) 'other) - (soarwarn "Identifier field not constant or variable in: " c) - (setq id nil)) - (t (setq id (cdr next-term))))) - ((eq label 'object) - (cond ((eq (car next-term) 'const) - (soarwarn "Constant object field in: " c) - (setq id 'const)) - ((eq (car next-term) 'other) - (soarwarn "Object field not constant or variable in: " c) - (setq id nil)) - (t (setq id (cdr next-term))))) - ((eq label 'attribute) (setq attr next-term)) - ((eq label 'value) (setq val next-term))) - (go l1))) - -(defun find-pred-vars-in-condition (c) - (soar-do ((type) (varlist)) ((null c) varlist) - (cond ((predicatep (car c)) - (setq c (next-sym c)) - (setq type (pop-match-elt c)) - (cond ((eq (car type) 'var) (setq varlist (cons (cdr type) varlist))))) - ((eq (car c) '<<) (setq c (skip-disjunction c))) - (t (setq c (next-sym c)))))) - -(defun get-all-vars-in-neg (neg) - (car neg)) - -(defun get-attr-val-types (x) - (cadr (cddar x))) - -(defun get-condition-type (c) - (cadr c)) - -(defun get-conditions-with-vars (vars cl) - (cond ((null vars) nil) - (t (soar-do ((cl1 cl (cdr cl1)) (result-with) (result-wo) (id)) - ((null cl1) (cons (nreverse result-with) (nreverse result-wo))) - (setq id (get-id-var (car cl1))) - (cond ((and (or (and (not (eq (get-condition-type (car cl1)) 'preference)) - (bound-var? id)) - (eq id 'const) - (and (eq (get-condition-type (car cl1)) 'preference) - (bound-preference? (car cl1)))) - (no-unbound-predicates? vars (car cl1))) - (soarpush (car cl1) result-with)) - (t (soarpush (car cl1) result-wo))))))) - -(defun get-context-vars-in-pref (pr) - (cadr (cddar pr))) - -(defun get-id-var (c) - (cadr (car c))) - -(defun get-mult-num (type attr) - (soar-do ((l *multi-attribute* (cdr l))) ((null l) 1) - (cond ((and (eq (caar l) type) - (eq (cadar l) attr)) - (cond ((car (cddar l)) (return (car (cddar l)))) (t (return *default-multi*))))))) - -(defun get-pred-vars-in-condition (c) - (car (car c))) - -(defun get-prev-rank (c) - (car (cddddr (car c)))) - -(defun get-twice-used-vars (cl) - (prog (varlist dup-vars) - (soar-do ((cl1 cl (cdr cl1))) ((null cl1)) - (setq varlist - (append (get-pred-vars-in-condition (car cl1)) - (append (get-vars-in-condition (car cl1)) varlist)))) - (soar-do ((vl varlist (cdr vl))) ((null vl)) - (cond ((and (soarmemq (car vl) (cdr vl)) - (not (soarmemq (car vl) dup-vars))) - (soarpush (car vl) dup-vars)))) - (return dup-vars))) - -(defun get-vars-in-condition (c) - (caddr (car c))) - -(defun insert-ne-undec (c2 dup-vars) - (prog (undecflag braceflag c1 var label c x) - (setq c c2) - (setq c (cdr c)) - l1 (cond ((null c) (return c2))) - (setq undecflag nil) - (setq braceflag nil) - (setq var nil) - (pop c) - (setq label (pop c)) - (cond ((and (eq label 'attribute) - (not (soarmemq (car c) '(problem-space state operator)))) - (return c2))) - (setq c1 c) - l2 (setq x (car c)) - (cond ((eq x '{) (setq braceflag t) (pop c)) - ((and (eq x '<>) - (eq (cadr c) 'undecided)) - (setq undecflag t) - (pop c) - (pop c)) - ((and (not undecflag) - (not (eq label 'identifier)) - (not (eq label 'object)) - (variablep x) - (not (soarmemq x dup-vars))) - (setq var x) - (pop c)) - ((eq x '}) (go l3)) - (t (pop-match-elt c))) - (cond (braceflag (go l2))) - l3 (cond ((and var - (not undecflag)) - (cond (braceflag (rplacd c1 (append '(<> undecided) (cdr c1)))) - (t (rplacd c1 (append '(<> undecided) (cons x (cons '} (cdr c1))))) - (rplaca c1 '{))))) - (go l1))) - -(defun lexless (a b) - (soar-do ((a1 a (cdr a1)) (b1 b (cdr b1))) ((null a1) t) - (cond ((null a1) (return t)) - ((null b1) (return nil)) - ((< (car a1) (car b1)) (return t)) - ((< (car b1) (car a1)) (return nil))))) - -(defun mark-as-set (vlist) - (cond ((or (null vlist) - (equal vlist '(nil))) - nil) - (t (soar-do - ((vl1 (cond ((atom vlist) (list vlist)) (t vlist)) (cdr vl1)) (result)) - ((null vl1) result) - (cond ((and (atom (car vl1)) - (not (get (car vl1) 'bound))) - (soarputprop (car vl1) t 'bound) - (soarpush (car vl1) result))))))) - -(defun next-sym (x) - (cond ((eq (car x) '//) (cddr x)) (t (cdr x)))) - -(defun no-unbound-predicates? (vars c) - (all-bound? (get-pred-vars-in-condition c))) - -(defun predicatep (x) - (and (symbolp x) - (get x 'predicate))) - -(defun put-rank (c n) - (rplaca (cddddr (car c)) n)) - -(defun re-order-conditions (cl) - (prog (un-active-conditions new-conditions set-vars dup ccl best active-conditions - negations temp already-no-active-conditions) - (cond ((null cl) (return nil))) - (setq cl (sort-conditions cl)) - (setq *last-value-var* nil) - (setq negations (cadr cl)) - (setq cl (car cl)) - (setq dup (get-twice-used-vars cl)) - (setq un-active-conditions cl) - (setq active-conditions nil) - (go l4) - l0 (cond ((null un-active-conditions) - (cond (negations - (soar-do nil ((null negations)) (soarpush '- new-conditions) - (soarpush (strip-condition (car negations)) new-conditions) - (setq negations (cddr negations))))) - (unmark-as-set set-vars) - (setq *condition-vars* set-vars) - (return (nreverse new-conditions))) - ((or already-no-active-conditions - (neq 'goal-context-info - (get-condition-type (car un-active-conditions)))) - (soarpush (strip-condition (car un-active-conditions)) new-conditions) - (setq un-active-conditions (cdr un-active-conditions)) - (setq already-no-active-conditions nil) - (cond ((neq (class (car new-conditions)) 'preference) - (soarwarn " Condition not linked to previous conditions " - (car (p-to-sp (list (car new-conditions))))))) - (go l0))) - l4 (setq already-no-active-conditions t) - (setq set-vars - (append (mark-as-set (get-id-var (car un-active-conditions))) set-vars)) - l3 (setq temp (get-conditions-with-vars set-vars un-active-conditions)) - (setq active-conditions (append (car temp) active-conditions)) - (setq un-active-conditions (cdr temp)) - l1 (cond ((null active-conditions) (go l0))) - (setq ccl (classify set-vars dup active-conditions t)) - (setq best - (find-best-condition set-vars dup active-conditions un-active-conditions - ccl 0 nil)) - (setq already-no-active-conditions nil) - (cond ((null best) (go l0))) - (cond (*order-trace* - (progn (soarprint (cons (car best) (strip-condition (cdr best))))))) - (setq best (cdr best)) - (setq active-conditions (dremove best active-conditions)) - l2 (setq set-vars (append (mark-as-set (get-vars-in-condition best)) set-vars)) - (setq temp (get-attr-val-types best)) - (cond ((eq (cadr temp) 'var) (setq *last-value-var* (cddr temp))) - (t (setq *last-value-var* nil))) - (setq temp (strip-condition best)) - (cond ((eq (get-condition-type best) 'goal-context-info) - (insert-ne-undec temp dup))) - (soarpush temp new-conditions) - (setq temp (check-negations set-vars negations)) - (setq new-conditions (append (car temp) new-conditions)) - (setq negations (cdr temp)) - (go l3))) - -(defun reorder-p-conds (spxs) - (prog (type conds action) - (pop spxs) - (setq *p-name* (pop spxs)) - (setq type - (cond ((or (eq (car spxs) 'elaborate-once) - (eq (car spxs) 'elaborate) - (eq (car spxs) 'decide)) - (pop spxs)) - (t 'elaborate))) - (setq conds nil) -condloop (soarpush (pop spxs) conds) - (cond ((and spxs - (neq (car spxs) '-->)) - (go condloop))) - (setq action spxs) - (setq spxs (append (re-order-conditions (nreverse conds)) spxs)) - (test-connected-actions action) - (soarpush type spxs) - (soarpush *p-name* spxs) - (soarpush 'p spxs) - (return spxs))) - -(defun skip-disjunction (x) - (soar-do nil ((eq (car x) '>>) (cdr x)) (setq x (next-sym x)))) - -(defun sort-conditions (cl) - (prog (regulars c negations goal-contexts) - (setq negations nil) - (setq regulars nil) - (setq goal-contexts nil) - l1 (setq c (pop cl)) - (cond ((null c) - (return (list (append (nreverse goal-contexts) (nreverse regulars)) - (nreverse negations)))) - ((eq c '-) - (setq c (pop cl)) - (soarpush (cons (find-all-vars-in-condition c) c) negations) - (unmark-as-set (get-all-vars-in-neg (car negations))) - (soarpush '- negations)) - ((eq (car c) 'preference) - (soarpush - (cons (cons (find-pred-vars-in-condition c) - (find-info-on-cond c 'preference)) - c) - regulars) - (unmark-as-set (get-pred-vars-in-condition (car regulars))) - (unmark-as-set (get-vars-in-condition (car regulars)))) - ((eq (car c) 'goal-context-info) - (soarpush - (cons (cons (find-pred-vars-in-condition c) (find-info-on-cond c nil)) c) - goal-contexts) - (unmark-as-set (get-pred-vars-in-condition (car goal-contexts))) - (unmark-as-set (get-vars-in-condition (car goal-contexts)))) - (t (soarpush - (cons (cons (find-pred-vars-in-condition c) (find-info-on-cond c nil)) - c) - regulars) - (unmark-as-set (get-pred-vars-in-condition (car regulars))) - (unmark-as-set (get-vars-in-condition (car regulars))))) - (go l1))) - -(defun strip-condition (x) - (cond ((atom x) x) (t (cdr x)))) - -(defun unmark-as-set (vlist) - (soar-do ((vl1 (cond ((atom vlist) (list vlist)) (t vlist)) (cdr vl1))) - ((null vl1) vlist) (remprop (car vl1) 'bound))) - -(start-soar) -(terpri) diff --git a/clx/CHANGES b/clx/CHANGES deleted file mode 100644 index 36bbe0da86c9ddb45e40b56921784cc9af3bf79e..0000000000000000000000000000000000000000 --- a/clx/CHANGES +++ /dev/null @@ -1,40 +0,0 @@ -Details of changes since R5: - -Changes in CLX 5.01: - -Support for MIT-MAGIC-COOKIE-1 authorization has been added. - -All VALUES declarations have been changed to CLX-VALUES declarations. -VALUES is a CL type name and cannot be used as a declaration name. - -All ARRAY-REGISTER declarations have been removed as Genera no longer -needs them. - -Many type declarations have been corrected or tightened up now that some -Lisps look at them. - -Print functions have been defined for bitmap and pixmap formats. - -The DISPLAY-PLIST slot will be initialized to NIL. - -When debugging, don't optimize SPEED in the buffer macros. - -Make the CARD8<->CHAR and the window manager code work for sparse -character sets (where some codes do not have corresponding characters). - -The default gcontext extension set and copy functions will take the -correct number of arguments. - -PUT-IMAGE will now work for 24-bit images. - -The buffer accessors for MEMBER8, etc., will use the standard mechanisms -for reporting type errors. - -Typographical errors in SET-WM-PROPERTIES, SET-STANDARD-COLORMAP, and -POINTER-CONTROL have been fixed. - -Symbolics systems will do lazy macroexpansion in the buffer macros. - -A variety of changes for Symbolics Minima systems have been made. - -Some system-dependent code has been added for CMU Common Lisp. diff --git a/clx/README b/clx/README deleted file mode 100644 index 7f4aa19a846d3cae78674fa500b47193543f1893..0000000000000000000000000000000000000000 --- a/clx/README +++ /dev/null @@ -1,48 +0,0 @@ -These files contain beta code, but they have been tested to some extent under -Symbolics, TI, Lucid and Franz. The files have been given .l suffixes to keep -them within 12 characters, to keep SysV sites happy. Please rename them with -more appropriate suffixes for your system. - - -For Franz systems, see exclREADME. - - -For Symbolics systems, first rename all the .l files to .lisp. Then edit your -sys.translations file so that sys:x11;clx; points to this directory and put a -clx.system file in your sys:site;directory that has the form - - (si:set-system-source-file "clx" "sys:x11;clx;defsystem.lisp") - -in it. After that CLX can be compiled with the "Compile System CLX" command -and loaded with the "Load System CLX" command. - - - -For TI systems, rename all the .l files to .lisp, and make a clx.translations -file in your sys:site; directory pointing to this directory and a -sys:site;clx.system file like the one described for symbolics systems above, -but with the defsystem file being in the clx:clx; directory. Then CLX can be -compiled with (make-system "CLX" :compile :noconfirm) and loaded with -(make-system "CLX" :noconfirm). - - - -For Lucid systems, you should rename all the .l files to .lisp too (This might -not be possible on SysV systems). After loading the defsystem.l file, CLX can -be compiled with the (compile-clx) function and loaded with the -(load-clx) form. - -The ms-patch.uu file is a patch to Lucid version 2 systems. You probably -don't need it, as you are probably running Lucid version 3 or later, but if -you are still using Lucid version 2, you need this patch. You'll need to -uudecode it to produce the binary. - - - -For kcl systems, after loading the defsystem.l file, CLX can be compiled with -the (compile-clx) function and loaded with the (load-clx) form. - - - -For more information, see defsystem.l and provide.l. - diff --git a/clx/attributes.lisp b/clx/attributes.lisp deleted file mode 100644 index 5eb1035d63a5bc1e2a5d330b8fdbe4e1ea4a5f73..0000000000000000000000000000000000000000 --- a/clx/attributes.lisp +++ /dev/null @@ -1,638 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; Window Attributes - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; The special variable *window-attributes* is an alist containg: -;;; (drawable attributes attribute-changes geometry geometry-changes) -;;; Where DRAWABLE is the associated window or pixmap -;;; ATTRIBUTES is NIL or a reply-buffer containing the drawable's -;;; attributes for use by the accessors. -;;; ATTRIBUTE-CHANGES is NIL or an array. The first element -;;; of the array is a "value-mask", indicating which -;;; attributes have changed. The other elements are -;;; integers associated with the changed values, ready -;;; for insertion into a server request. -;;; GEOMETRY is like ATTRIBUTES, but for window geometry -;;; GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry -;;; -;;; Attribute and Geometry accessors and SETF's look on the special variable -;;; *window-attributes* for the drawable. If its not there, the accessor is -;;; NOT within a WITH-STATE, and a server request is made to get or put a value. -;;; If an entry is found in *window-attributes*, the cache buffers are used -;;; for the access. -;;; -;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including -;;; the new drawable. The caches are initialized to NIL and allocated as needed. - -(in-package :xlib) - -(eval-when (compile load eval) ;needed by Franz Lisp -(defconstant *attribute-size* 44) -(defconstant *geometry-size* 24) -(defconstant *context-size* (max *attribute-size* *geometry-size* (* 16 4)))) - -(defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE - -;; Window Attribute reply buffer resource -(defvar *context-free-list* nil) ;; resource of free reply buffers - -(defun allocate-context () - (or (threaded-atomic-pop *context-free-list* reply-next reply-buffer) - (make-reply-buffer *context-size*))) - -(defun deallocate-context (context) - (declare (type reply-buffer context)) - (threaded-atomic-push context *context-free-list* reply-next reply-buffer)) - -(defmacro state-attributes (state) `(second ,state)) -(defmacro state-attribute-changes (state) `(third ,state)) -(defmacro state-geometry (state) `(fourth ,state)) -(defmacro state-geometry-changes (state) `(fifth ,state)) - -(defmacro drawable-equal-function () - (if (member 'drawable *clx-cached-types*) - ''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's - ''drawable-equal)) - -(defmacro window-equal-function () - (if (member 'window *clx-cached-types*) - ''eq - ''drawable-equal)) - -(defmacro with-state ((drawable) &body body) - ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes - ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and - ;; ConfigureWindow. The body is not surrounded by a with-display. Within the - ;; indefinite scope of the body, on a per-process basis in a multi-process - ;; environment, the first call within an Accessor Group on the specified drawable - ;; (the object, not just the variable) causes the complete results of the protocol - ;; request to be retained, and returned in any subsequent accessor calls. Calls - ;; within a Setf Group are delayed, and executed in a single request on exit from - ;; the body. In addition, if a call on a function within an Accessor Group follows - ;; a call on a function in the corresponding Setf Group, then all delayed setfs for - ;; that group are executed, any retained accessor information for that group is - ;; discarded, the corresponding protocol request is (re)issued, and the results are - ;; (again) retained, and returned in any subsequent accessor calls. - - ;; Accessor Group A (for GetWindowAttributes): - ;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity, - ;; window-backing-store, window-backing-planes, window-backing-pixel, - ;; window-save-under, window-colormap, window-colormap-installed-p, - ;; window-map-state, window-all-event-masks, window-event-mask, - ;; window-do-not-propagate-mask, window-override-redirect - - ;; Setf Group A (for ChangeWindowAttributes): - ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes, - ;; window-backing-pixel, window-save-under, window-event-mask, - ;; window-do-not-propagate-mask, window-override-redirect, window-colormap, - ;; window-cursor - - ;; Accessor Group G (for GetGeometry): - ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width, - ;; drawable-height, drawable-border-width - - ;; Setf Group G (for ConfigureWindow): - ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width, - ;; window-priority - (let ((state-entry (gensym))) - ;; alist of (drawable attributes attribute-changes geometry geometry-changes) - `(with-stack-list (,state-entry ,drawable nil nil nil nil) - (with-stack-list* (*window-attributes* ,state-entry *window-attributes*) - (multiple-value-prog1 - (progn ,@body) - (cleanup-state-entry ,state-entry)))))) - -(defun cleanup-state-entry (state) - ;; Return buffers to the free-list - (let ((entry (state-attributes state))) - (when entry (deallocate-context entry))) - (let ((entry (state-attribute-changes state))) - (when entry - (put-window-attribute-changes (car state) entry) - (deallocate-gcontext-state entry))) - (let ((entry (state-geometry state))) - (when entry (deallocate-context entry))) - (let ((entry (state-geometry-changes state))) - (when entry - (put-drawable-geometry-changes (car state) entry) - (deallocate-gcontext-state entry)))) - - - -(defun change-window-attribute (window number value) - ;; Called from window attribute SETF's to alter an attribute value - ;; number is the change-attributes request mask bit number - (declare (type window window) - (type card8 number) - (type card32 value)) - (let ((state-entry nil) - (changes nil)) - (if (and *window-attributes* - (setq state-entry (assoc window (the list *window-attributes*) - :test (window-equal-function)))) - (progn ; Within a WITH-STATE - cache changes - (setq changes (state-attribute-changes state-entry)) - (unless changes - (setq changes (allocate-gcontext-state)) - (setf (state-attribute-changes state-entry) changes) - (setf (aref changes 0) 0)) ;; Initialize mask to zero - (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit - (setf (aref changes (1+ number)) value)) ;; save value - ; Send change to the server - (with-buffer-request ((window-display window) *x-changewindowattributes*) - (window window) - (card32 (ash 1 number) value))))) -;; -;; These two are twins (change-window-attribute change-drawable-geometry) -;; If you change one, you probably need to change the other... -;; -(defun change-drawable-geometry (drawable number value) - ;; Called from drawable geometry SETF's to alter an attribute value - ;; number is the change-attributes request mask bit number - (declare (type drawable drawable) - (type card8 number) - (type card29 value)) - (let ((state-entry nil) - (changes nil)) - (if (and *window-attributes* - (setq state-entry (assoc drawable (the list *window-attributes*) - :test (drawable-equal-function)))) - (progn ; Within a WITH-STATE - cache changes - (setq changes (state-geometry-changes state-entry)) - (unless changes - (setq changes (allocate-gcontext-state)) - (setf (state-geometry-changes state-entry) changes) - (setf (aref changes 0) 0)) ;; Initialize mask to zero - (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit - (setf (aref changes (1+ number)) value)) ;; save value - ; Send change to the server - (with-buffer-request ((drawable-display drawable) *x-configurewindow*) - (drawable drawable) - (card16 (ash 1 number)) - (card29 value))))) - -(defun get-window-attributes-buffer (window) - (declare (type window window)) - (let ((state-entry nil) - (changes nil)) - (or (and *window-attributes* - (setq state-entry (assoc window (the list *window-attributes*) - :test (window-equal-function))) - (null (setq changes (state-attribute-changes state-entry))) - (state-attributes state-entry)) - (let ((display (window-display window))) - (with-display (display) - ;; When SETF's have been done, flush changes to the server - (when changes - (put-window-attribute-changes window changes) - (deallocate-gcontext-state (state-attribute-changes state-entry)) - (setf (state-attribute-changes state-entry) nil)) - ;; Get window attributes - (with-buffer-request-and-reply (display *x-getwindowattributes* size :sizes (8)) - ((window window)) - (let ((repbuf (or (state-attributes state-entry) (allocate-context)))) - (declare (type reply-buffer repbuf)) - ;; Copy into repbuf from reply buffer - (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) - (when state-entry (setf (state-attributes state-entry) repbuf)) - repbuf))))))) - -;; -;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer) -;; If you change one, you probably need to change the other... -;; -(defun get-drawable-geometry-buffer (drawable) - (declare (type drawable drawable)) - (let ((state-entry nil) - (changes nil)) - (or (and *window-attributes* - (setq state-entry (assoc drawable (the list *window-attributes*) - :test (drawable-equal-function))) - (null (setq changes (state-geometry-changes state-entry))) - (state-geometry state-entry)) - (let ((display (drawable-display drawable))) - (with-display (display) - ;; When SETF's have been done, flush changes to the server - (when changes - (put-drawable-geometry-changes drawable changes) - (deallocate-gcontext-state (state-geometry-changes state-entry)) - (setf (state-geometry-changes state-entry) nil)) - ;; Get drawable attributes - (with-buffer-request-and-reply (display *x-getgeometry* size :sizes (8)) - ((drawable drawable)) - (let ((repbuf (or (state-geometry state-entry) (allocate-context)))) - (declare (type reply-buffer repbuf)) - ;; Copy into repbuf from reply buffer - (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) - (when state-entry (setf (state-geometry state-entry) repbuf)) - repbuf))))))) - -(defun put-window-attribute-changes (window changes) - ;; change window attributes - ;; Always from Called within a WITH-DISPLAY - (declare (type window window) - (type gcontext-state changes)) - (let* ((display (window-display window)) - (mask (aref changes 0))) - (declare (type display display) - (type mask32 mask)) - (with-buffer-request (display *x-changewindowattributes*) - (window window) - (card32 mask) - (progn ;; Insert a word in the request for each one bit in the mask - (do ((bits mask (ash bits -1)) - (request-size 2) ;Word count - (i 1 (index+ i 1))) ;Entry count - ((zerop bits) - (card16-put 2 (index-incf request-size)) - (index-incf (buffer-boffset display) (index* request-size 4))) - (declare (type mask32 bits) - (type array-index i request-size)) - (when (oddp bits) - (card32-put (index* (index-incf request-size) 4) (aref changes i)))))))) -;; -;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes) -;; If you change one, you probably need to change the other... -;; -(defun put-drawable-geometry-changes (window changes) - ;; change window attributes or geometry (depending on request-number...) - ;; Always from Called within a WITH-DISPLAY - (declare (type window window) - (type gcontext-state changes)) - (let* ((display (window-display window)) - (mask (aref changes 0))) - (declare (type display display) - (type mask16 mask)) - (with-buffer-request (display *x-configurewindow*) - (window window) - (card16 mask) - (progn ;; Insert a word in the request for each one bit in the mask - (do ((bits mask (ash bits -1)) - (request-size 2) ;Word count - (i 1 (index+ i 1))) ;Entry count - ((zerop bits) - (card16-put 2 (incf request-size)) - (index-incf (buffer-boffset display) (* request-size 4))) - (declare (type mask16 bits) - (type fixnum request-size) - (type array-index i)) - (when (oddp bits) - (card29-put (* (incf request-size) 4) (aref changes i)))))))) - -(defmacro with-attributes ((window &rest options) &body body) - `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window))) - (declare (type reply-buffer .with-attributes-reply-buffer.)) - (prog1 - (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body) - (unless *window-attributes* - (deallocate-context .with-attributes-reply-buffer.))))) -;; -;; These two are twins (with-attributes with-geometry) -;; If you change one, you probably need to change the other... -;; -(defmacro with-geometry ((window &rest options) &body body) - `(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window))) - (declare (type reply-buffer .with-geometry-reply-buffer.)) - (prog1 - (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body) - (unless *window-attributes* - (deallocate-context .with-geometry-reply-buffer.))))) - -;;;----------------------------------------------------------------------------- -;;; Group A: (for GetWindowAttributes) -;;;----------------------------------------------------------------------------- - -(defun window-visual (window) - (declare (type window window)) - (declare (clx-values resource-id)) - (with-attributes (window :sizes 32) - (resource-id-get 8))) - -(defun window-visual-info (window) - (declare (type window window)) - (declare (clx-values visual-info)) - (with-attributes (window :sizes 32) - (visual-info (window-display window) (resource-id-get 8)))) - -(defun window-class (window) - (declare (type window window)) - (declare (clx-values (member :input-output :input-only))) - (with-attributes (window :sizes 16) - (member16-get 12 :copy :input-output :input-only))) - -(defun set-window-background (window background) - (declare (type window window) - (type (or (member :none :parent-relative) pixel pixmap) background)) - (cond ((eq background :none) (change-window-attribute window 0 0)) - ((eq background :parent-relative) (change-window-attribute window 0 1)) - ((integerp background) ;; Background pixel - (change-window-attribute window 0 0) ;; pixmap :NONE - (change-window-attribute window 1 background)) - ((type? background 'pixmap) ;; Background pixmap - (change-window-attribute window 0 (pixmap-id background))) - (t (x-type-error background '(or (member :none :parent-relative) integer pixmap)))) - background) - -#+Genera (eval-when (compile) (compiler:function-defined 'window-background)) - -(defsetf window-background set-window-background) - -(defun set-window-border (window border) - (declare (type window window) - (type (or (member :copy) pixel pixmap) border)) - (cond ((eq border :copy) (change-window-attribute window 2 0)) - ((type? border 'pixmap) ;; Border pixmap - (change-window-attribute window 2 (pixmap-id border))) - ((integerp border) ;; Border pixel - (change-window-attribute window 3 border)) - (t (x-type-error border '(or (member :copy) integer pixmap)))) - border) - -#+Genera (eval-when (compile) (compiler:function-defined 'window-border)) - -(defsetf window-border set-window-border) - -(defun window-bit-gravity (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values bit-gravity)) - (with-attributes (window :sizes 8) - (member8-vector-get 14 *bit-gravity-vector*))) - -(defun set-window-bit-gravity (window gravity) - (change-window-attribute - window 4 (encode-type (member-vector *bit-gravity-vector*) gravity)) - gravity) - -(defsetf window-bit-gravity set-window-bit-gravity) - -(defun window-gravity (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values win-gravity)) - (with-attributes (window :sizes 8) - (member8-vector-get 15 *win-gravity-vector*))) - -(defun set-window-gravity (window gravity) - (change-window-attribute - window 5 (encode-type (member-vector *win-gravity-vector*) gravity)) - gravity) - -(defsetf window-gravity set-window-gravity) - -(defun window-backing-store (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values (member :not-useful :when-mapped :always))) - (with-attributes (window :sizes 8) - (member8-get 1 :not-useful :when-mapped :always))) - -(defun set-window-backing-store (window when) - (change-window-attribute - window 6 (encode-type (member :not-useful :when-mapped :always) when)) - when) - -(defsetf window-backing-store set-window-backing-store) - -(defun window-backing-planes (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values pixel)) - (with-attributes (window :sizes 32) - (card32-get 16))) - -(defun set-window-backing-planes (window planes) - (change-window-attribute window 7 (encode-type card32 planes)) - planes) - -(defsetf window-backing-planes set-window-backing-planes) - -(defun window-backing-pixel (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values pixel)) - (with-attributes (window :sizes 32) - (card32-get 20))) - -(defun set-window-backing-pixel (window pixel) - (change-window-attribute window 8 (encode-type card32 pixel)) - pixel) - -(defsetf window-backing-pixel set-window-backing-pixel) - -(defun window-save-under (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values (member :off :on))) - (with-attributes (window :sizes 8) - (member8-get 24 :off :on))) - -(defun set-window-save-under (window when) - (change-window-attribute window 10 (encode-type (member :off :on) when)) - when) - -(defsetf window-save-under set-window-save-under) - -(defun window-override-redirect (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values (member :off :on))) - (with-attributes (window :sizes 8) - (member8-get 27 :off :on))) - -(defun set-window-override-redirect (window when) - (change-window-attribute window 9 (encode-type (member :off :on) when)) - when) - -(defsetf window-override-redirect set-window-override-redirect) - -(defun window-event-mask (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values mask32)) - (with-attributes (window :sizes 32) - (card32-get 36))) - -(defsetf window-event-mask (window) (event-mask) - (let ((em (gensym))) - `(let ((,em ,event-mask)) - (declare (type event-mask ,em)) - (change-window-attribute ,window 11 (encode-event-mask ,em)) - ,em))) - -(defun window-do-not-propagate-mask (window) - ;; setf'able - (declare (type window window)) - (declare (clx-values mask32)) - (with-attributes (window :sizes 32) - (card32-get 40))) - -(defsetf window-do-not-propagate-mask (window) (device-event-mask) - (let ((em (gensym))) - `(let ((,em ,device-event-mask)) - (declare (type device-event-mask ,em)) - (change-window-attribute ,window 12 (encode-device-event-mask ,em)) - ,em))) - -(defun window-colormap (window) - (declare (type window window)) - (declare (clx-values (or null colormap))) - (with-attributes (window :sizes 32) - (let ((id (resource-id-get 28))) - (if (zerop id) nil - (lookup-colormap (window-display window) id))))) - -(defun set-window-colormap (window colormap) - (change-window-attribute - window 13 (encode-type (or (member :copy) colormap) colormap)) - colormap) - -(defsetf window-colormap set-window-colormap) - -(defun window-cursor (window) - (declare (type window window)) - (declare (clx-values cursor)) - window - (error "~S can only be set" 'window-cursor)) - -(defun set-window-cursor (window cursor) - (change-window-attribute - window 14 (encode-type (or (member :none) cursor) cursor)) - cursor) - -(defsetf window-cursor set-window-cursor) - -(defun window-colormap-installed-p (window) - (declare (type window window)) - (declare (clx-values boolean)) - (with-attributes (window :sizes 8) - (boolean-get 25))) - -(defun window-all-event-masks (window) - (declare (type window window)) - (declare (clx-values mask32)) - (with-attributes (window :sizes 32) - (card32-get 32))) - -(defun window-map-state (window) - (declare (type window window)) - (declare (clx-values (member :unmapped :unviewable :viewable))) - (with-attributes (window :sizes 8) - (member8-get 26 :unmapped :unviewable :viewable))) - - -;;;----------------------------------------------------------------------------- -;;; Group G: (for GetGeometry) -;;;----------------------------------------------------------------------------- - -(defun drawable-root (drawable) - (declare (type drawable drawable)) - (declare (clx-values window)) - (with-geometry (drawable :sizes 32) - (window-get 8 (drawable-display drawable)))) - -(defun drawable-x (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (clx-values int16)) - (with-geometry (drawable :sizes 16) - (int16-get 12))) - -(defun set-drawable-x (drawable x) - (change-drawable-geometry drawable 0 (encode-type int16 x)) - x) - -(defsetf drawable-x set-drawable-x) - -(defun drawable-y (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (clx-values int16)) - (with-geometry (drawable :sizes 16) - (int16-get 14))) - -(defun set-drawable-y (drawable y) - (change-drawable-geometry drawable 1 (encode-type int16 y)) - y) - -(defsetf drawable-y set-drawable-y) - -(defun drawable-width (drawable) - ;; setf'able - ;; Inside width, excluding border. - (declare (type drawable drawable)) - (declare (clx-values card16)) - (with-geometry (drawable :sizes 16) - (card16-get 16))) - -(defun set-drawable-width (drawable width) - (change-drawable-geometry drawable 2 (encode-type card16 width)) - width) - -(defsetf drawable-width set-drawable-width) - -(defun drawable-height (drawable) - ;; setf'able - ;; Inside height, excluding border. - (declare (type drawable drawable)) - (declare (clx-values card16)) - (with-geometry (drawable :sizes 16) - (card16-get 18))) - -(defun set-drawable-height (drawable height) - (change-drawable-geometry drawable 3 (encode-type card16 height)) - height) - -(defsetf drawable-height set-drawable-height) - -(defun drawable-depth (drawable) - (declare (type drawable drawable)) - (declare (clx-values card8)) - (with-geometry (drawable :sizes 8) - (card8-get 1))) - -(defun drawable-border-width (drawable) - ;; setf'able - (declare (type drawable drawable)) - (declare (clx-values integer)) - (with-geometry (drawable :sizes 16) - (card16-get 20))) - -(defun set-drawable-border-width (drawable width) - (change-drawable-geometry drawable 4 (encode-type card16 width)) - width) - -(defsetf drawable-border-width set-drawable-border-width) - -(defun set-window-priority (mode window sibling) - (declare (type (member :above :below :top-if :bottom-if :opposite) mode) - (type window window) - (type (or null window) sibling)) - (with-state (window) - (change-drawable-geometry - window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode)) - (when sibling - (change-drawable-geometry window 5 (encode-type window sibling)))) - mode) - -#+Genera (eval-when (compile) (compiler:function-defined 'window-priority)) - -(defsetf window-priority (window &optional sibling) (mode) - ;; A bit strange, but retains setf form. - `(set-window-priority ,mode ,window ,sibling)) diff --git a/clx/buffer.lisp b/clx/buffer.lisp deleted file mode 100644 index 113867dceb509d968f44a62b9bb159e091722cd7..0000000000000000000000000000000000000000 --- a/clx/buffer.lisp +++ /dev/null @@ -1,1787 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains definitions for the BUFFER object for Common-Lisp X -;;; windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;; A few notes: -;; -;; 1. The BUFFER implements a two-way buffered byte / half-word -;; / word stream. Hooks are left for implementing this with a -;; shared memory buffer, or with effenciency hooks to the network -;; code. -;; -;; 2. The BUFFER object uses overlapping displaced arrays for -;; inserting and removing bytes half-words and words. -;; -;; 3. The BYTE component of these arrays is written to a STREAM -;; associated with the BUFFER. The stream has its own buffer. -;; This may be made more efficient by using the Zetalisp -;; :Send-Output-Buffer operation. -;; -;; 4. The BUFFER object is INCLUDED in the DISPLAY object. -;; This was done to reduce access time when sending requests, -;; while maintaing some code modularity. -;; Several buffer functions are duplicated (with-buffer, -;; buffer-force-output, close-buffer) to keep the naming -;; conventions consistent. -;; -;; 5. A nother layer of software is built on top of this for generating -;; both client and server interface routines, given a specification -;; of the protocol. (see the INTERFACE file) -;; -;; 6. Care is taken to leave the buffer pointer (buffer-bbuf) set to -;; a point after a complete request. This is to ensure that a partial -;; request won't be left after aborts (e.g. control-abort on a lispm). - -(in-package :xlib) - -(defconstant *requestsize* 160) ;; Max request size (excluding variable length requests) - -;;; This is here instead of in bufmac so that with-display can be -;;; compiled without macros and bufmac being loaded. - -(defmacro with-buffer ((buffer &key timeout inline) - &body body &environment env) - ;; This macro is for use in a multi-process environment. It provides - ;; exclusive access to the local buffer object for request generation and - ;; reply processing. - `(macrolet ((with-buffer ((buffer &key timeout) &body body) - ;; Speedup hack for lexically nested with-buffers - `(progn - (progn ,buffer ,@(and timeout `(,timeout)) nil) - ,@body))) - ,(if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.with-buffer-body. () ,@body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.with-buffer-body.)) - (with-buffer-function ,buffer ,timeout #'.with-buffer-body.)) - (let ((buf (if (or (symbolp buffer) (constantp buffer)) - buffer - '.buffer.))) - `(let (,@(unless (eq buf buffer) `((,buf ,buffer)))) - ,@(unless (eq buf buffer) `((declare (type buffer ,buf)))) - ,(declare-bufmac) - (when (buffer-dead ,buf) - (x-error 'closed-display :display ,buf)) - (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))))) - -(defun with-buffer-function (buffer timeout function) - (declare (type display buffer) - (type (or null number) timeout) - (type function function) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) - (with-buffer (buffer :timeout timeout :inline t) - (funcall function))) - -;;; The following are here instead of in bufmac so that event-case can -;;; be compiled without macros and bufmac being loaded. - -(defmacro read-card8 (byte-index) - `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int8 (byte-index) - `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card16 (byte-index) - #+clx-overlapping-arrays - `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int16 (byte-index) - #+clx-overlapping-arrays - `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card32 (byte-index) - #+clx-overlapping-arrays - `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-int32 (byte-index) - #+clx-overlapping-arrays - `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro read-card29 (byte-index) - #+clx-overlapping-arrays - `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro event-code (reply-buffer) - ;; The reply-buffer structure is used for events. - ;; The size slot is used for the event code. - `(reply-size ,reply-buffer)) - -(defmacro reading-event ((event &rest options) &body body) - (declare (arglist (buffer &key sizes) &body body)) - ;; BODY may contain calls to (READ32 &optional index) etc. - ;; These calls will read from the input buffer at byte - ;; offset INDEX. If INDEX is not supplied, then the next - ;; word, half-word or byte is returned. - `(with-buffer-input (,event ,@options) ,@body)) - -(defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index) - &body body) - (unless (listp sizes) (setq sizes (list sizes))) - ;; 160 is a special hack for client-message-events - (when (set-difference sizes '(0 8 16 32 160 256)) - (error "Illegal sizes in ~a" sizes)) - `(let ((%reply-buffer ,reply-buffer) - ,@(and display `((%buffer ,display)))) - (declare (type reply-buffer %reply-buffer) - ,@(and display '((type display %buffer)))) - ,(declare-bufmac) - ,@(and display '(%buffer)) - (let* ((buffer-boffset (the array-index ,(or index 0))) - #-clx-overlapping-arrays - (buffer-bbuf (reply-ibuf8 %reply-buffer)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - `((buffer-bbuf (reply-ibuf8 %reply-buffer)))) - (when (or (member 16 sizes) (member 160 sizes)) - `((buffer-woffset (index-ash buffer-boffset -1)) - (buffer-wbuf (reply-ibuf16 %reply-buffer)))) - (when (member 32 sizes) - `((buffer-loffset (index-ash buffer-boffset -2)) - (buffer-lbuf (reply-ibuf32 %reply-buffer)))))) - (declare (type array-index buffer-boffset)) - #-clx-overlapping-arrays - (declare (type buffer-bytes buffer-bbuf)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - '((declare (type buffer-bytes buffer-bbuf)))) - (when (member 16 sizes) - '((declare (type array-index buffer-woffset)) - (declare (type buffer-words buffer-wbuf)))) - (when (member 32 sizes) - '((declare (type array-index buffer-loffset)) - (declare (type buffer-longs buffer-lbuf))))) - buffer-boffset - #-clx-overlapping-arrays - buffer-bbuf - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) '(buffer-bbuf)) - (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) - (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) - #+clx-overlapping-arrays - (macrolet ((%buffer-sizes () ',sizes)) - ,@body) - #-clx-overlapping-arrays - ,@body))) - -(defun make-buffer (output-size constructor &rest options) - (declare (dynamic-extent options)) - ;; Output-Size is the output-buffer size in bytes. - (let ((byte-output (make-array output-size :element-type 'card8 - :initial-element 0))) - (apply constructor - :size output-size - :obuf8 byte-output - #+clx-overlapping-arrays - :obuf16 - #+clx-overlapping-arrays - (make-array (index-ash output-size -1) - :element-type 'overlap16 - :displaced-to byte-output) - #+clx-overlapping-arrays - :obuf32 - #+clx-overlapping-arrays - (make-array (index-ash output-size -2) - :element-type 'overlap32 - :displaced-to byte-output) - options))) - -(defun make-reply-buffer (size) - ;; Size is the buffer size in bytes - (let ((byte-input (make-array size :element-type 'card8 - :initial-element 0))) - (make-reply-buffer-internal - :size size - :ibuf8 byte-input - #+clx-overlapping-arrays - :ibuf16 - #+clx-overlapping-arrays - (make-array (index-ash size -1) - :element-type 'overlap16 - :displaced-to byte-input) - #+clx-overlapping-arrays - :ibuf32 - #+clx-overlapping-arrays - (make-array (index-ash size -2) - :element-type 'overlap32 - :displaced-to byte-input)))) - -(defun buffer-ensure-size (buffer size) - (declare (type buffer buffer) - (type array-index size)) - (when (index> size (buffer-size buffer)) - (with-buffer (buffer) - (buffer-flush buffer) - (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size)))) - (new-buffer (make-array new-buffer-size :element-type 'card8 - :initial-element 0))) - (setf (buffer-obuf8 buffer) new-buffer) - #+clx-overlapping-arrays - (setf (buffer-obuf16 buffer) - (make-array (index-ash new-buffer-size -1) - :element-type 'overlap16 - :displaced-to new-buffer) - (buffer-obuf32 buffer) - (make-array (index-ash new-buffer-size -2) - :element-type 'overlap32 - :displaced-to new-buffer)))))) - -(defun buffer-pad-request (buffer pad) - (declare (type buffer buffer) - (type array-index pad)) - (unless (index-zerop pad) - (when (index> (index+ (buffer-boffset buffer) pad) - (buffer-size buffer)) - (buffer-flush buffer)) - (incf (buffer-boffset buffer) pad) - (unless (index-zerop (index-mod (buffer-boffset buffer) 4)) - (buffer-flush buffer)))) - -(declaim (inline buffer-new-request-number)) - -(defun buffer-new-request-number (buffer) - (declare (type buffer buffer)) - (setf (buffer-request-number buffer) - (ldb (byte 16 0) (1+ (buffer-request-number buffer))))) - -(defun with-buffer-request-function (display gc-force request-function) - (declare (type display display) - (type (or null gcontext) gc-force)) - (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) - (with-buffer (display :inline t) - (multiple-value-prog1 - (progn - (when gc-force (force-gcontext-changes-internal gc-force)) - (without-aborts (funcall request-function display))) - (display-invoke-after-function display)))) - -(defun with-buffer-request-function-nolock (display gc-force request-function) - (declare (type display display) - (type (or null gcontext) gc-force)) - (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) - (multiple-value-prog1 - (progn - (when gc-force (force-gcontext-changes-internal gc-force)) - (without-aborts (funcall request-function display))) - (display-invoke-after-function display))) - -(defstruct (pending-command (:copier nil) (:predicate nil)) - (sequence 0 :type card16) - (reply-buffer nil :type (or null reply-buffer)) - (process nil) - (next nil #-explorer :type #-explorer (or null pending-command))) - -(defun with-buffer-request-and-reply-function - (display multiple-reply request-function reply-function) - (declare (type display display) - (type boolean multiple-reply)) - (declare (type function request-function reply-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function reply-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function reply-function)) - (let ((pending-command nil) - (reply-buffer nil)) - (declare (type (or null pending-command) pending-command) - (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (progn - (with-buffer (display :inline t) - (setq pending-command (start-pending-command display)) - (without-aborts (funcall request-function display)) - (buffer-force-output display) - (display-invoke-after-function display)) - (cond (multiple-reply - (loop - (setq reply-buffer (read-reply display pending-command)) - (when (funcall reply-function display reply-buffer) (return nil)) - (deallocate-reply-buffer (shiftf reply-buffer nil)))) - (t - (setq reply-buffer (read-reply display pending-command)) - (funcall reply-function display reply-buffer)))) - (when reply-buffer (deallocate-reply-buffer reply-buffer)) - (when pending-command (stop-pending-command display pending-command))))) - -;; -;; Buffer stream operations -;; - -(defun buffer-write (vector buffer start end) - ;; Write out VECTOR from START to END into BUFFER - ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER - (declare (type buffer buffer) - (type array-index start end)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (wrap-buf-output (buffer) - (funcall (buffer-write-function buffer) vector buffer start end)) - nil) - -(defun buffer-flush (buffer) - ;; Write the buffer contents to the server stream - doesn't force-output the stream - ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER - (declare (type buffer buffer)) - (unless (buffer-flush-inhibit buffer) - (let ((boffset (buffer-boffset buffer))) - (declare (type array-index boffset)) - (when (index-plusp boffset) - (buffer-write (buffer-obuf8 buffer) buffer 0 boffset) - (setf (buffer-boffset buffer) 0) - (setf (buffer-last-request buffer) nil)))) - nil) - -(defmacro with-buffer-flush-inhibited ((buffer) &body body) - (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.))) - `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer))) - (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf))) - (unwind-protect - (progn - (setf (buffer-flush-inhibit ,buf) t) - ,@body) - (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.))))) - -(defun buffer-force-output (buffer) - ;; Output is normally buffered, this forces any buffered output to the server. - (declare (type buffer buffer)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (buffer-flush buffer) - (wrap-buf-output (buffer) - (without-aborts - (funcall (buffer-force-output-function buffer) buffer))) - nil) - -(defun close-buffer (buffer &key abort) - ;; Close the host connection in BUFFER - (declare (type buffer buffer)) - (unless (null (buffer-output-stream buffer)) - (wrap-buf-output (buffer) - (funcall (buffer-close-function buffer) buffer :abort abort)) - (setf (buffer-dead buffer) t) - ;; Zap pointers to the streams, to ensure they're GC'd - (setf (buffer-output-stream buffer) nil) - (setf (buffer-input-stream buffer) nil) - ) - nil) - -(defun buffer-input (buffer vector start end &optional timeout) - ;; Read into VECTOR from the buffer stream - ;; Timeout, when non-nil, is in seconds - ;; Returns non-nil if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type buffer buffer) - (type vector vector) - (type array-index start end) - (type (or null number) timeout)) - (declare (clx-values eof-p)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (unless (= start end) - (let ((result - (wrap-buf-input (buffer) - (funcall (buffer-input-function buffer) - buffer vector start end timeout)))) - (unless (or (null result) (eq result :timeout)) - (close-buffer buffer)) - result))) - -(defun buffer-input-wait (buffer timeout) - ;; Timeout, when non-nil, is in seconds - ;; Returns non-nil if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type buffer buffer) - (type (or null number) timeout)) - (declare (clx-values timeout)) - (when (buffer-dead buffer) - (x-error 'closed-display :display buffer)) - (let ((result - (wrap-buf-input (buffer) - (funcall (buffer-input-wait-function buffer) - buffer timeout)))) - (unless (or (null result) (eq result :timeout)) - (close-buffer buffer)) - result)) - -(defun buffer-listen (buffer) - ;; Returns T if there is input available for the buffer. This should never - ;; block, so it can be called from the scheduler. - (declare (type buffer buffer)) - (declare (clx-values input-available)) - (or (not (null (buffer-dead buffer))) - (wrap-buf-input (buffer) - (funcall (buffer-listen-function buffer) buffer)))) - -;;; Reading sequences of strings - -;;; a list of pascal-strings with card8 lengths, no padding in between -;;; can't use read-sequence-char -(defun read-sequence-string (buffer-bbuf length nitems result-type - &optional (buffer-boffset 0)) - (declare (type buffer-bytes buffer-bbuf) - (type array-index length nitems buffer-boffset)) - length - (with-vector (buffer-bbuf buffer-bytes) - (let ((result (make-sequence result-type nitems))) - (do* ((index 0 (index+ index 1 string-length)) - (count 0 (index1+ count)) - (string-length 0) - (string "")) - ((index>= count nitems) - result) - (declare (type array-index index count string-length) - (type string string)) - (setq string-length (read-card8 index) - string (make-sequence 'string string-length)) - (do ((i (index1+ index) (index1+ i)) - (j 0 (index1+ j))) - ((index>= j string-length) - (setf (elt result count) string)) - (declare (type array-index i j)) - (setf (aref string j) (card8->char (read-card8 i)))))))) - -;;; Reading sequences of chars - -(defun read-sequence-char (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (character) t)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (if transform - (flet ((card8->char->transform (v) - (declare (type card8 v)) - (funcall transform (card8->char v)))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'card8->char->transform)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->char->transform - data start index)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->char - data start index))) - -;;; Reading sequences of card8's - -(defun read-list-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 1))) - ((index-zerop j)) - (declare (type array-index j index) - (type cons lst)) - (setf (car lst) (read-card8 index))))) - -(defun read-list-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (declare (type (function (card8) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 1))) - ((index-zerop j)) - (declare (type array-index j index) - (type cons lst)) - (setf (car lst) (funcall transform (read-card8 index)))))) - -#-lispm -(defun read-simple-array-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card8 (*)) data)) - (with-vector (data (simple-array card8 (*))) - (with-buffer-input (reply-buffer :sizes (8)) - (buffer-replace data buffer-bbuf start (index+ start nitems) index)))) - -#-lispm -(defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card8 (*)) data)) - (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card8 (*))) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card8 (funcall transform (read-card8 index)))))))) - -(defun read-vector-card8 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card8 index)))))) - -(defun read-vector-card8-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data)) - (declare (type (function (card8) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (8) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card8 index))))))) - -(defun read-sequence-card8 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (card8) t)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (read-list-card8-with-transform - reply-buffer nitems result transform start index) - (read-list-card8 reply-buffer nitems result start index))) - #-lispm - ((simple-array card8 (*)) - (if transform - (read-simple-array-card8-with-transform - reply-buffer nitems result transform start index) - (read-simple-array-card8 reply-buffer nitems result start index))) - (t - (if transform - (read-vector-card8-with-transform - reply-buffer nitems result transform start index) - (read-vector-card8 reply-buffer nitems result start index)))) - result)) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun read-sequence-int8 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (int8) t)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (if transform - (flet ((card8->int8->transform (v) - (declare (type card8 v)) - (funcall transform (card8->int8 v)))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'card8->int8->transform)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->int8->transform - data start index)) - (read-sequence-card8 - reply-buffer result-type nitems #'card8->int8 - data start index))) - -;;; Reading sequences of card16's - -(defun read-list-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 2))) - ((index-zerop j)) - (declare (type array-index j index) - (type cons lst)) - (setf (car lst) (read-card16 index))))) - -(defun read-list-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (declare (type (function (card16) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 2))) - ((index-zerop j)) - (declare (type array-index j index) - (type cons lst)) - (setf (car lst) (funcall transform (read-card16 index)))))) - -#-lispm -(defun read-simple-array-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card16 (*)) data)) - (with-vector (data (simple-array card16 (*))) - (with-buffer-input (reply-buffer :sizes (16) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card16 (read-card16 index)))) - #+clx-overlapping-arrays - (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) - -#-lispm -(defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card16 (*)) data)) - (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card16 (*))) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card16 (funcall transform (read-card16 index)))))))) - -(defun read-vector-card16 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (16) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card16 index))) - #+clx-overlapping-arrays - (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) - -(defun read-vector-card16-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data)) - (declare (type (function (card16) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (16) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card16 index))))))) - -(defun read-sequence-card16 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (card16) t)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (read-list-card16-with-transform reply-buffer nitems result transform start index) - (read-list-card16 reply-buffer nitems result start index))) - #-lispm - ((simple-array card16 (*)) - (if transform - (read-simple-array-card16-with-transform - reply-buffer nitems result transform start index) - (read-simple-array-card16 reply-buffer nitems result start index))) - (t - (if transform - (read-vector-card16-with-transform - reply-buffer nitems result transform start index) - (read-vector-card16 reply-buffer nitems result start index)))) - result)) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun read-sequence-int16 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (int16) t)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (if transform - (flet ((card16->int16->transform (v) - (declare (type card16 v)) - (funcall transform (card16->int16 v)))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'card16->int16->transform)) - (read-sequence-card16 - reply-buffer result-type nitems #'card16->int16->transform - data start index)) - (read-sequence-card16 - reply-buffer result-type nitems #'card16->int16 - data start index))) - -;;; Reading sequences of card32's - -(defun read-list-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 4))) - ((index-zerop j)) - (declare (type array-index j index) - (type cons lst)) - (setf (car lst) (read-card32 index))))) - -(defun read-list-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) - (declare (type (function (card32) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j nitems (index- j 1)) - (lst (nthcdr start data) (cdr lst)) - (index 0 (index+ index 4))) - ((index-zerop j)) - (declare (type array-index j index) - (type cons lst)) - (setf (car lst) (funcall transform (read-card32 index)))))) - -#-lispm -(defun read-simple-array-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card32 (*)) data)) - (with-vector (data (simple-array card32 (*))) - (with-buffer-input (reply-buffer :sizes (32) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card32 (read-card32 index)))) - #+clx-overlapping-arrays - (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) - -#-lispm -(defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card32 (*)) data)) - (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card32 (*))) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card32 (funcall transform (read-card32 index)))))))) - -(defun read-vector-card32 (reply-buffer nitems data start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (32) :index index) - #-clx-overlapping-arrays - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card32 index))) - #+clx-overlapping-arrays - (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) - -(defun read-vector-card32-with-transform (reply-buffer nitems data transform start index) - (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data)) - (declare (type (function (card32) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (with-buffer-input (reply-buffer :sizes (32) :index index) - (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card32 index))))))) - -(defun read-sequence-card32 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (card32) t)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (let ((result (or data (make-sequence result-type nitems)))) - (typecase result - (list - (if transform - (read-list-card32-with-transform reply-buffer nitems result transform start index) - (read-list-card32 reply-buffer nitems result start index))) - #-lispm - ((simple-array card32 (*)) - (if transform - (read-simple-array-card32-with-transform - reply-buffer nitems result transform start index) - (read-simple-array-card32 reply-buffer nitems result start index))) - (t - (if transform - (read-vector-card32-with-transform - reply-buffer nitems result transform start index) - (read-vector-card32 reply-buffer nitems result start index)))) - result)) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun read-sequence-int32 (reply-buffer result-type nitems &optional transform data - (start 0) (index 0)) - (declare (type reply-buffer reply-buffer) - (type t result-type) ;; CL type - (type array-index nitems start index) - (type (or null sequence) data)) - (declare (type (or null (function (int32) t)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (if transform - (flet ((card32->int32->transform (v) - (declare (type card32 v)) - (funcall transform (card32->int32 v)))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'card32->int32->transform)) - (read-sequence-card32 - reply-buffer result-type nitems #'card32->int32->transform - data start index)) - (read-sequence-card32 - reply-buffer result-type nitems #'card32->int32 - data start index))) - -;;; Writing sequences of chars - -(defun write-sequence-char - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) character)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (if transform - (flet ((transform->char->card8 (x) - (char->card8 (the character (funcall transform x))))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'transform->char->card8)) - (write-sequence-card8 - buffer boffset data start end #'transform->char->card8)) - (write-sequence-card8 buffer boffset data start end #'char->card8))) - -;;; Writing sequences of card8's - -(defun write-list-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card8 - ((lst (nthcdr start data))) - ((type list lst)) - (dotimes (j chunk) - (declare (type array-index j)) - #-ti (write-card8 j (pop lst)) ;TI Compiler bug - #+ti (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop lst)) - )) - nil) - -(defun write-list-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (writing-buffer-chunks card8 - ((lst (nthcdr start data))) - ((type list lst)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (pop lst))))) - nil) - -;;; Should really write directly from data, instead of into the buffer first -#-lispm -(defun write-simple-array-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card8 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card8 (*))) - (writing-buffer-chunks card8 - ((index start (index+ index chunk))) - ((type array-index index)) - (buffer-replace buffer-bbuf data - buffer-boffset - (index+ buffer-boffset chunk) - index))) - nil) - -#-lispm -(defun write-simple-array-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card8 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card8 (*))) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card8 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (with-vector (data vector) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (aref data index)) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card8-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (declare (type (function (t) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) - (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-sequence-card8 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card8)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (typecase data - (list - (if transform - (write-list-card8-with-transform buffer boffset data start end transform) - (write-list-card8 buffer boffset data start end))) - #-lispm - ((simple-array card8 (*)) - (if transform - (write-simple-array-card8-with-transform buffer boffset data start end transform) - (write-simple-array-card8 buffer boffset data start end))) - (t - (if transform - (write-vector-card8-with-transform buffer boffset data start end transform) - (write-vector-card8 buffer boffset data start end))))) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun write-sequence-int8 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) int8)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (if transform - (flet ((transform->int8->card8 (x) - (int8->card8 (the int8 (funcall transform x))))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'transform->int8->card8)) - (write-sequence-card8 - buffer boffset data start end #'transform->int8->card8)) - (write-sequence-card8 buffer boffset data start end #'int8->card8))) - -;;; Writing sequences of card16's - -(defun write-list-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (pop lst)))) - nil) - -(defun write-list-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (pop lst))))) - nil) - -#-lispm -(defun write-simple-array-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -#-lispm -(defun write-simple-array-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card16 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-card16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-sequence-card16 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card16)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (typecase data - (list - (if transform - (write-list-card16-with-transform buffer boffset data start end transform) - (write-list-card16 buffer boffset data start end))) - #-lispm - ((simple-array card16 (*)) - (if transform - (write-simple-array-card16-with-transform buffer boffset data start end transform) - (write-simple-array-card16 buffer boffset data start end))) - (t - (if transform - (write-vector-card16-with-transform buffer boffset data start end transform) - (write-vector-card16 buffer boffset data start end))))) - -;;; Writing sequences of int16's - -(defun write-list-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks int16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (pop lst)))) - nil) - -(defun write-list-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (writing-buffer-chunks int16 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (pop lst))))) - nil) - -#-lispm -(defun write-simple-array-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array int16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array int16 (*))) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -#-lispm -(defun write-simple-array-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array int16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (int16) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array int16 (*))) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-int16 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (with-vector (data vector) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-int16-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (declare (type (function (t) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of int16's big - (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-sequence-int16 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) int16)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (typecase data - (list - (if transform - (write-list-int16-with-transform buffer boffset data start end transform) - (write-list-int16 buffer boffset data start end))) - #-lispm - ((simple-array int16 (*)) - (if transform - (write-simple-array-int16-with-transform buffer boffset data start end transform) - (write-simple-array-int16 buffer boffset data start end))) - (t - (if transform - (write-vector-int16-with-transform buffer boffset data start end transform) - (write-vector-int16 buffer boffset data start end))))) - -;;; Writing sequences of card32's - -(defun write-list-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card32 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (pop lst)))) - nil) - -(defun write-list-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (writing-buffer-chunks card32 - ((lst (nthcdr start data))) - ((type list lst)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (pop lst))))) - nil) - -#-lispm -(defun write-simple-array-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card32 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card32 (*))) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 4))) - (buffer-replace buffer-lbuf data - buffer-loffset - (index+ buffer-loffset length) - index) - (setq index (index+ index length))))) - nil) - -#-lispm -(defun write-simple-array-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card32 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card32 (*))) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-card32 (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (with-vector (data vector) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (aref data index)) - (setq index (index+ index 1))) - ;; overlapping case - (let ((length (floor chunk 4))) - (buffer-replace buffer-lbuf data - buffer-loffset - (index+ buffer-loffset length) - index) - (setq index (index+ index length))))) - nil) - -(defun write-vector-card32-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (declare (type (function (t) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) - ;; Depends upon the chunks being an even multiple of card32's big - (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-sequence-card32 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card32)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (typecase data - (list - (if transform - (write-list-card32-with-transform buffer boffset data start end transform) - (write-list-card32 buffer boffset data start end))) - #-lispm - ((simple-array card32 (*)) - (if transform - (write-simple-array-card32-with-transform buffer boffset data start end transform) - (write-simple-array-card32 buffer boffset data start end))) - (t - (if transform - (write-vector-card32-with-transform buffer boffset data start end transform) - (write-vector-card32 buffer boffset data start end))))) - -;;; For now, perhaps performance it isn't worth doing better? - -(defun write-sequence-int32 - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) int32)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (if transform - (flet ((transform->int32->card32 (x) - (int32->card32 (the int32 (funcall transform x))))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'transform->int32->card32)) - (write-sequence-card32 - buffer boffset data start end #'transform->int32->card32)) - (write-sequence-card32 buffer boffset data start end #'int32->card32))) - -(defun read-bitvector256 (buffer-bbuf boffset data) - (declare (type buffer-bytes buffer-bbuf) - (type array-index boffset) - (type (or null (simple-bit-vector 256)) data)) - (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0)))) - (declare (type (simple-bit-vector 256) result)) - (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte - (j 8 (index+ j 8))) - ((index>= j 256)) - (declare (type array-index i j)) - (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1)) - (k j (index+ k 1))) - ((zerop byte) - (when data ;; Clear uninitialized bits in data - (do ((end (index+ j 8))) - ((index= k end)) - (declare (type array-index end)) - (setf (aref result k) 0) - (index-incf k)))) - (declare (type array-index k) - (type card8 byte)) - (setf (aref result k) (the bit (logand byte 1))))) - result)) - -(defun write-bitvector256 (buffer boffset map) - (declare (type buffer buffer) - (type array-index boffset) - (type (simple-array bit (*)) map)) - (with-buffer-output (buffer :index boffset :sizes 8) - (do* ((i (index+ buffer-boffset 1) (index+ i 1)) ; Skip first byte - (j 8 (index+ j 8))) - ((index>= j 256)) - (declare (type array-index i j)) - (do ((byte 0) - (bit (index+ j 7) (index- bit 1))) - ((index< bit j) - (aset-card8 byte buffer-bbuf i)) - (declare (type array-index bit) - (type card8 byte)) - (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit)))))))) - -;;; Writing sequences of char2b's - -(defun write-list-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (pop lst)))) - nil) - -(defun write-list-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type list data) - (type array-index boffset start end)) - (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (writing-buffer-chunks card16 - ((lst (nthcdr start data))) - ((type list lst)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (pop lst))))) - nil) - -#-lispm -(defun write-simple-array-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (aref data index)) - (setq index (index+ index 1))))) - nil) - -#-lispm -(defun write-simple-array-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) - (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data (simple-array card16 (*))) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-char2b (buffer boffset data start end) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (aref data index)) - (setq index (index+ index 1))))) - nil) - -(defun write-vector-char2b-with-transform (buffer boffset data start end transform) - (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) - (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (with-vector (data vector) - (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) - (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (aref data index))) - (setq index (index+ index 1))))) - nil) - -(defun write-sequence-char2b - (buffer boffset data &optional (start 0) (end (length data)) transform) - (declare (type buffer buffer) - (type sequence data) - (type array-index boffset start end)) - (declare (type (or null (function (t) card16)) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) - (typecase data - (list - (if transform - (write-list-char2b-with-transform buffer boffset data start end transform) - (write-list-char2b buffer boffset data start end))) - #-lispm - ((simple-array card16 (*)) - (if transform - (write-simple-array-char2b-with-transform buffer boffset data start end transform) - (write-simple-array-char2b buffer boffset data start end))) - (t - (if transform - (write-vector-char2b-with-transform buffer boffset data start end transform) - (write-vector-char2b buffer boffset data start end))))) - diff --git a/clx/bufmac.lisp b/clx/bufmac.lisp deleted file mode 100644 index 1e002b824dfa240e93c10b6bd2858ab36f44bb8c..0000000000000000000000000000000000000000 --- a/clx/bufmac.lisp +++ /dev/null @@ -1,184 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains macro definitions for the BUFFER object for Common-Lisp -;;; X windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them. - -(defmacro write-card8 (byte-index item) - `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro write-int8 (byte-index item) - `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) - -(defmacro write-card16 (byte-index item) - #+clx-overlapping-arrays - `(aset-card16 (the card16 ,item) buffer-wbuf - (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aset-card16 (the card16 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-int16 (byte-index item) - #+clx-overlapping-arrays - `(aset-int16 (the int16 ,item) buffer-wbuf - (index+ buffer-woffset (index-ash ,byte-index -1))) - #-clx-overlapping-arrays - `(aset-int16 (the int16 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-card32 (byte-index item) - #+clx-overlapping-arrays - `(aset-card32 (the card32 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aset-card32 (the card32 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-int32 (byte-index item) - #+clx-overlapping-arrays - `(aset-int32 (the int32 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aset-int32 (the int32 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -(defmacro write-card29 (byte-index item) - #+clx-overlapping-arrays - `(aset-card29 (the card29 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) - #-clx-overlapping-arrays - `(aset-card29 (the card29 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) - -;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries -;; and always are written high-order byte first. -(defmacro write-char2b (byte-index item) - ;; It is impossible to do an overlapping write, so only nonoverlapping here. - `(let ((%item ,item) - (%byte-index (index+ buffer-boffset ,byte-index))) - (declare (type card16 %item) - (type array-index %byte-index)) - (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index) - (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1)))) - -(defmacro set-buffer-offset (value &environment env) - env - `(let ((.boffset. ,value)) - (declare (type array-index .boffset.)) - (setq buffer-boffset .boffset.) - #+clx-overlapping-arrays - ,@(when (member 16 (macroexpand '(%buffer-sizes) env)) - `((setq buffer-woffset (index-ash .boffset. -1)))) - #+clx-overlapping-arrays - ,@(when (member 32 (macroexpand '(%buffer-sizes) env)) - `((setq buffer-loffset (index-ash .boffset. -2)))) - #+clx-overlapping-arrays - .boffset.)) - -(defmacro advance-buffer-offset (value) - `(set-buffer-offset (index+ buffer-boffset ,value))) - -(defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body) - (unless (listp sizes) (setq sizes (list sizes))) - `(let ((%buffer ,buffer)) - (declare (type display %buffer)) - ,(declare-bufmac) - ,(when length - `(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer)) - (buffer-flush %buffer))) - (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer)))) - #-clx-overlapping-arrays - (buffer-bbuf (buffer-obuf8 %buffer)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - `((buffer-bbuf (buffer-obuf8 %buffer)))) - (when (or (member 16 sizes) (member 160 sizes)) - `((buffer-woffset (index-ash buffer-boffset -1)) - (buffer-wbuf (buffer-obuf16 %buffer)))) - (when (member 32 sizes) - `((buffer-loffset (index-ash buffer-boffset -2)) - (buffer-lbuf (buffer-obuf32 %buffer)))))) - (declare (type array-index buffer-boffset)) - #-clx-overlapping-arrays - (declare (type buffer-bytes buffer-bbuf)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - '((declare (type buffer-bytes buffer-bbuf)))) - (when (member 16 sizes) - '((declare (type array-index buffer-woffset)) - (declare (type buffer-words buffer-wbuf)))) - (when (member 32 sizes) - '((declare (type array-index buffer-loffset)) - (declare (type buffer-longs buffer-lbuf))))) - buffer-boffset - #-clx-overlapping-arrays - buffer-bbuf - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) '(buffer-bbuf)) - (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) - (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) - #+clx-overlapping-arrays - (macrolet ((%buffer-sizes () ',sizes)) - ,@body) - #-clx-overlapping-arrays - ,@body))) - -;;; This macro is just used internally in buffer - -(defmacro writing-buffer-chunks (type args decls &body body) - (when (> (length body) 2) - (error "writing-buffer-chunks called with too many forms")) - (let* ((size (* 8 (index-increment type))) - (form #-clx-overlapping-arrays - (first body) - #+clx-overlapping-arrays ; XXX type dependencies - (or (second body) - (first body)))) - `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8)))) - ;; Loop filling the buffer - (do* (,@args - ;; Number of bytes needed to output - (len ,(if (= size 8) - `(index- end start) - `(index-ash (index- end start) ,(truncate size 16))) - (index- len chunk)) - ;; Number of bytes available in buffer - (chunk (index-min len (index- (buffer-size buffer) buffer-boffset)) - (index-min len (index- (buffer-size buffer) buffer-boffset)))) - ((not (index-plusp len))) - (declare ,@decls - (type array-index len chunk)) - ,form - (index-incf buffer-boffset chunk) - ;; Flush the buffer - (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer))) - (setf (buffer-boffset buffer) buffer-boffset) - (buffer-flush buffer) - (setq buffer-boffset (buffer-boffset buffer)) - #+clx-overlapping-arrays - ,(case size - (16 '(setq buffer-woffset (index-ash buffer-boffset -1))) - (32 '(setq buffer-loffset (index-ash buffer-boffset -2)))))) - (setf (buffer-boffset buffer) (lround buffer-boffset))))) diff --git a/clx/build-clx.lisp b/clx/build-clx.lisp deleted file mode 100644 index 09673145192b43fad394b5ece2fe675d61e087f7..0000000000000000000000000000000000000000 --- a/clx/build-clx.lisp +++ /dev/null @@ -1,25 +0,0 @@ -;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- - -;;; Load this file if you want to compile CLX in its entirety. -#+nil -(proclaim '(optimize (speed 3) (safety 0) (space 1) - (compilation-speed 0))) - - -;;; Hide CLOS from CLX, so objects stay implemented as structures. -;;; -(when (find-package "CLOS") - (rename-package (find-package "CLOS") "NO-CLOS-HERE")) -(when (find-package "PCL") - (rename-package (find-package "PCL") "NO-PCL-HERE")) - - -(when (find-package "XLIB") - (rename-package (find-package "XLIB") "OLD-XLIB")) - -;(make-package "XLIB" :use '("LISP")) - -(compile-file "clx:defsystem.lisp" :error-file nil :load t) - -(with-compilation-unit () - (xlib:compile-clx (pathname "clx:"))) diff --git a/clx/clx.lisp b/clx/clx.lisp deleted file mode 100644 index ab87349231dd132e6f183950124968b06f60d3c7..0000000000000000000000000000000000000000 --- a/clx/clx.lisp +++ /dev/null @@ -1,922 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;; Primary Interface Author: -;; Robert W. Scheifler -;; MIT Laboratory for Computer Science -;; 545 Technology Square, Room 418 -;; Cambridge, MA 02139 -;; rws@zermatt.lcs.mit.edu - -;; Design Contributors: -;; Dan Cerys, Texas Instruments -;; Scott Fahlman, CMU -;; Charles Hornig, Symbolics -;; John Irwin, Franz -;; Kerry Kimbrough, Texas Instruments -;; Chris Lindblad, MIT -;; Rob MacLachlan, CMU -;; Mike McMahon, Symbolics -;; David Moon, Symbolics -;; LaMott Oren, Texas Instruments -;; Daniel Weinreb, Symbolics -;; John Wroclawski, MIT -;; Richard Zippel, Symbolics - -;; Primary Implementation Author: -;; LaMott Oren, Texas Instruments - -;; Implementation Contributors: -;; Charles Hornig, Symbolics -;; John Irwin, Franz -;; Chris Lindblad, MIT -;; Robert Scheifler, MIT - -;;; -;;; Change history: -;;; -;;; Date Author Description -;;; ------------------------------------------------------------------------------------- -;;; 04/07/87 R.Scheifler Created code stubs -;;; 04/08/87 L.Oren Started Implementation -;;; 05/11/87 L.Oren Included draft 3 revisions -;;; 07/07/87 L.Oren Untested alpha release to MIT -;;; 07/17/87 L.Oren Alpha release -;;; 08/**/87 C.Lindblad Rewrite of buffer code -;;; 08/**/87 et al Various random bug fixes -;;; 08/**/87 R.Scheifler General syntactic and portability cleanups -;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing -;;; 09/02/87 L.Oren Change events from resource-ids to objects -;;; 12/24/87 R.Budzianowski KCL support -;;; 12/**/87 J.Irwin ExCL 2.0 support -;;; 01/20/88 L.Oren Add server extension mechanisms -;;; 01/20/88 L.Oren Only force output when blocking on input -;;; 01/20/88 L.Oren Uniform support for :event-window on events -;;; 01/28/88 L.Oren Add window manager property functions -;;; 01/28/88 L.Oren Add character translation facility -;;; 02/**/87 J.Irwin Allegro 2.2 support - -;;; This is considered a somewhat changeable interface. Discussion of better -;;; integration with CLOS, support for user-specified subclassess of basic -;;; objects, and the additional functionality to match the C Xlib is still in -;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu. - -;; Note: all of the following is in the package XLIB. - -(in-package :xlib) - -(pushnew :clx *features*) -(pushnew :xlib *features*) - -(defparameter *version* "MIT R5.01") -(pushnew :clx-mit-r4 *features*) -(pushnew :clx-mit-r5 *features*) - -(defparameter *protocol-major-version* 11.) -(defparameter *protocol-minor-version* 0) - -(defparameter *x-tcp-port* 6000) ;; add display number - -;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of -;; the relationships should be fairly obvious. We have no intention of writing yet -;; another moby document for this interface. - -;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color. -;; These types are defined solely by a functional interface; we do not specify -;; whether they are implemented as structures or flavors or ... Although functions -;; below are written using DEFUN, this is not an implementation requirement (although -;; it is a requirement that they be functions as opposed to macros or special forms). -;; It is unclear whether with-slots in the Common Lisp Object System must work on -;; them. - -;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as -;; compound objects, rather than as integer resource-ids. This allows applications -;; to deal with multiple displays without having an explicit display argument in the -;; most common functions. Every function uses the display object indicated by the -;; first argument that is or contains a display; it is an error if arguments contain -;; different displays, and predictable results are not guaranteed. - -;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following -;; five functions: - -;(defun make-<mumble> (display resource-id) -; ;; This function should almost never be called by applications, except in handling -; ;; events. To minimize consing in some implementations, this may use a cache in -; ;; the display. Make-gcontext creates with :cache-p nil. Make-font creates with -; ;; cache-p true. -; (declare (type display display) -; (type integer resource-id) -; (clx-values <mumble>))) - -;(defun <mumble>-display (<mumble>) -; (declare (type <mumble> <mumble>) -; (clx-values display))) - -;(defun <mumble>-id (<mumble>) -; (declare (type <mumble> <mumble>) -; (clx-values integer))) - -;(defun <mumble>-equal (<mumble>-1 <mumble>-2) -; (declare (type <mumble> <mumble>-1 <mumble>-2))) - -;(defun <mumble>-p (<mumble>-1 <mumble>-2) -; (declare (type <mumble> <mumble>-1 <mumble>-2) -; (clx-values boolean))) - -(deftype boolean () '(or null (not null))) - -(deftype card32 () '(unsigned-byte 32)) - -(deftype card29 () '(unsigned-byte 29)) - -(deftype card24 () '(unsigned-byte 24)) - -(deftype int32 () '(signed-byte 32)) - -(deftype card16 () '(unsigned-byte 16)) - -(deftype int16 () '(signed-byte 16)) - -(deftype card8 () '(unsigned-byte 8)) - -(deftype int8 () '(signed-byte 8)) - -(deftype card4 () '(unsigned-byte 4)) - -#-clx-ansi-common-lisp -(deftype real (&optional (min '*) (max '*)) - (labels ((convert (limit floatp) - (typecase limit - (number (if floatp (float limit 0s0) (rational limit))) - (list (map 'list #'convert limit)) - (otherwise limit)))) - `(or (float ,(convert min t) ,(convert max t)) - (rational ,(convert min nil) ,(convert max nil))))) - -#-clx-ansi-common-lisp -(deftype base-char () - 'string-char) - -; Note that we are explicitly using a different rgb representation than what -; is actually transmitted in the protocol. - -(deftype rgb-val () '(real 0 1)) - -; Note that we are explicitly using a different angle representation than what -; is actually transmitted in the protocol. - -(deftype angle () '(real #.(* -2 pi) #.(* 2 pi))) - -(deftype mask32 () 'card32) - -(deftype mask16 () 'card16) - -(deftype pixel () '(unsigned-byte 32)) -(deftype image-depth () '(integer 0 32)) - -(deftype resource-id () 'card29) - -(deftype keysym () 'card32) - -; The following functions are provided by color objects: - -; The intention is that IHS and YIQ and CYM interfaces will also exist. -; Note that we are explicitly using a different spectrum representation -; than what is actually transmitted in the protocol. - -(def-clx-class (color (:constructor make-color-internal (red green blue)) - (:copier nil) (:print-function print-color)) - (red 0.0 :type rgb-val) - (green 0.0 :type rgb-val) - (blue 0.0 :type rgb-val)) - -(defun print-color (color stream depth) - (declare (type color color) - (ignore depth)) - (print-unreadable-object (color stream :type t) - (prin1 (color-red color) stream) - (write-string " " stream) - (prin1 (color-green color) stream) - (write-string " " stream) - (prin1 (color-blue color) stream))) - -(defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys) - (declare (type rgb-val red green blue)) - (declare (clx-values color)) - (make-color-internal red green blue)) - -(defun color-rgb (color) - (declare (type color color)) - (declare (clx-values red green blue)) - (values (color-red color) (color-green color) (color-blue color))) - -(def-clx-class (bitmap-format (:copier nil) (:print-function print-bitmap-format)) - (unit 8 :type (member 8 16 32)) - (pad 8 :type (member 8 16 32)) - (lsb-first-p nil :type boolean)) - -(defun print-bitmap-format (bitmap-format stream depth) - (declare (type bitmap-format bitmap-format) - (ignore depth)) - (print-unreadable-object (bitmap-format stream :type t) - (format stream "unit ~D pad ~D ~:[M~;L~]SB first" - (bitmap-format-unit bitmap-format) - (bitmap-format-pad bitmap-format) - (bitmap-format-lsb-first-p bitmap-format)))) - -(def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format)) - (depth 0 :type image-depth) - (bits-per-pixel 8 :type (member 1 4 8 16 24 32)) - (scanline-pad 8 :type (member 8 16 32))) - -(defun print-pixmap-format (pixmap-format stream depth) - (declare (type pixmap-format pixmap-format) - (ignore depth)) - (print-unreadable-object (pixmap-format stream :type t) - (format stream "depth ~D bits-per-pixel ~D scanline-pad ~D" - (pixmap-format-depth pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format) - (pixmap-format-scanline-pad pixmap-format)))) - -(defparameter *atom-cache-size* 200) -(defparameter *resource-id-map-size* 500) - -(def-clx-class (display (:include buffer) - (:constructor make-display-internal) - (:print-function print-display) - (:copier nil)) - (host) ; Server Host - (display 0 :type integer) ; Display number on host - (after-function nil) ; Function to call after every request - (event-lock - (make-process-lock "CLX Event Lock")) ; with-event-queue lock - (event-queue-lock - (make-process-lock "CLX Event Queue Lock")) ; new-events/event-queue lock - (event-queue-tail ; last event in the event queue - nil :type (or null reply-buffer)) - (event-queue-head ; Threaded queue of events - nil :type (or null reply-buffer)) - (atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*) - :type hash-table) ; Hash table relating atoms keywords - ; to atom id's - (font-cache nil) ; list of font - (protocol-major-version 0 :type card16) ; Major version of server's X protocol - (protocol-minor-version 0 :type card16) ; minor version of servers X protocol - (vendor-name "" :type string) ; vendor of the server hardware - (resource-id-base 0 :type resource-id) ; resouce ID base - (resource-id-mask 0 :type resource-id) ; resource ID mask bits - (resource-id-byte nil) ; resource ID mask field (used with DPB & LDB) - (resource-id-count 0 :type resource-id) ; resource ID mask count - ; (used for allocating ID's) - (resource-id-map (make-hash-table :test (resource-id-map-test) - :size *resource-id-map-size*) - :type hash-table) ; hash table maps resource-id's to - ; objects (used in lookup functions) - (xid 'resourcealloc) ; allocator function - (byte-order #+clx-little-endian :lsbfirst ; connection byte order - #-clx-little-endian :msbfirst) - (release-number 0 :type card32) ; release of the server - (max-request-length 0 :type card16) ; maximum number 32 bit words in request - (default-screen) ; default screen for operations - (roots nil :type list) ; List of screens - (motion-buffer-size 0 :type card32) ; size of motion buffer - (xdefaults) ; contents of defaults from server - (image-lsb-first-p nil :type boolean) - (bitmap-format (make-bitmap-format) ; Screen image info - :type bitmap-format) - (pixmap-formats nil :type sequence) ; list of pixmap formats - (min-keycode 0 :type card8) ; minimum key-code - (max-keycode 0 :type card8) ; maximum key-code - (error-handler 'default-error-handler) ; Error handler function - (close-down-mode :destroy) ; Close down mode saved by Set-Close-Down-Mode - (authorization-name "" :type string) - (authorization-data "" :type string) - (last-width nil :type (or null card29)) ; Accumulated width of last string - (keysym-mapping nil ; Keysym mapping cached from server - :type (or null (array * (* *)))) - (modifier-mapping nil :type list) ; ALIST of (keysym . state-mask) for all modifier keysyms - (keysym-translation nil :type list) ; An alist of (keysym object function) - ; for display-local keysyms - (extension-alist nil :type list) ; extension alist, which has elements: - ; (name major-opcode first-event first-error) - (event-extensions '#() :type vector) ; Vector mapping X event-codes to event keys - (performance-info) ; Hook for gathering performance info - (trace-history) ; Hook for debug trace - (plist nil :type list) ; hook for extension to hang data - ;; These slots are used to manage multi-process input. - (input-in-progress nil) ; Some process reading from the stream. - ; Updated with CONDITIONAL-STORE. - (pending-commands nil) ; Threaded list of PENDING-COMMAND objects - ; for all commands awaiting replies. - ; Protected by WITH-EVENT-QUEUE-INTERNAL. - (asynchronous-errors nil) ; Threaded list of REPLY-BUFFER objects - ; containing error messages for commands - ; which did not expect replies. - ; Protected by WITH-EVENT-QUEUE-INTERNAL. - (report-asynchronous-errors ; When to report asynchronous errors - '(:immediately) :type list) ; The keywords that can be on this list - ; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING, - ; and :AFTER-FINISH-OUTPUT - (event-process nil) ; Process ID of process awaiting events. - ; Protected by WITH-EVENT-QUEUE. - (new-events nil :type (or null reply-buffer)) ; Pointer to the first new event in the - ; event queue. - ; Protected by WITH-EVENT-QUEUE. - (current-event-symbol ; Bound with PROGV by event handling macros - (list (gensym) (gensym)) :type cons) - (atom-id-map (make-hash-table :test (resource-id-map-test) - :size *atom-cache-size*) - :type hash-table) - ) - -(defun print-display-name (display stream) - (declare (type (or null display) display)) - (cond (display - #-allegro (princ (display-host display) stream) - #+allegro (write-string (string (display-host display)) stream) - (write-string ":" stream) - (princ (display-display display) stream)) - (t - (write-string "(no display)" stream))) - display) - -(defun print-display (display stream depth) - (declare (type display display) - (ignore depth)) - (print-unreadable-object (display stream :type t) - (print-display-name display stream) - (write-string " (" stream) - (write-string (display-vendor-name display) stream) - (write-string " R" stream) - (prin1 (display-release-number display) stream) - (write-string ")" stream))) - -;;(deftype drawable () '(or window pixmap)) - -(def-clx-class (drawable (:copier nil) (:print-function print-drawable)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - ) - -(defun print-drawable (drawable stream depth) - (declare (type drawable drawable) - (ignore depth)) - (print-unreadable-object (drawable stream :type t) - (print-display-name (drawable-display drawable) stream) - (write-string " " stream) - (prin1 (drawable-id drawable) stream))) - -(def-clx-class (window (:include drawable) (:copier nil) - (:print-function print-drawable)) - ) - -(def-clx-class (pixmap (:include drawable) (:copier nil) - (:print-function print-drawable)) - ) - -(def-clx-class (visual-info (:copier nil) (:print-function print-visual-info)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (class :static-gray :type (member :static-gray :static-color :true-color - :gray-scale :pseudo-color :direct-color)) - (red-mask 0 :type pixel) - (green-mask 0 :type pixel) - (blue-mask 0 :type pixel) - (bits-per-rgb 1 :type card8) - (colormap-entries 0 :type card16) - (plist nil :type list) ; Extension hook - ) - -(defun print-visual-info (visual-info stream depth) - (declare (type visual-info visual-info) - (ignore depth)) - (print-unreadable-object (visual-info stream :type t) - (prin1 (visual-info-bits-per-rgb visual-info) stream) - (write-string "-bit " stream) - (princ (visual-info-class visual-info) stream) - (write-string " " stream) - (print-display-name (visual-info-display visual-info) stream) - (write-string " " stream) - (prin1 (visual-info-id visual-info) stream))) - -(def-clx-class (colormap (:copier nil) (:print-function print-colormap)) - (id 0 :type resource-id) - (display nil :type (or null display)) - (visual-info nil :type (or null visual-info)) - ) - -(defun print-colormap (colormap stream depth) - (declare (type colormap colormap) - (ignore depth)) - (print-unreadable-object (colormap stream :type t) - (when (colormap-visual-info colormap) - (princ (visual-info-class (colormap-visual-info colormap)) stream) - (write-string " " stream)) - (print-display-name (colormap-display colormap) stream) - (write-string " " stream) - (prin1 (colormap-id colormap) stream))) - -(def-clx-class (cursor (:copier nil) (:print-function print-cursor)) - (id 0 :type resource-id) - (display nil :type (or null display)) - ) - -(defun print-cursor (cursor stream depth) - (declare (type cursor cursor) - (ignore depth)) - (print-unreadable-object (cursor stream :type t) - (print-display-name (cursor-display cursor) stream) - (write-string " " stream) - (prin1 (cursor-id cursor) stream))) - -; Atoms are accepted as strings or symbols, and are always returned as keywords. -; Protocol-level integer atom ids are hidden, using a cache in the display object. - -(deftype xatom () '(or string symbol)) - -(defconstant *predefined-atoms* - '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP - :CARDINAL :COLORMAP :CURSOR - :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7 - :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE - :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP - :RGB_BLUE_MAP :RGB_DEFAULT_MAP - :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING - :VISUALID :WINDOW :WM_COMMAND :WM_HINTS - :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE - :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS - :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE - :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y - :SUBSCRIPT_X :SUBSCRIPT_Y - :UNDERLINE_POSITION :UNDERLINE_THICKNESS - :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT - :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT - :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE - :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT - :WM_CLASS :WM_TRANSIENT_FOR)) - -(deftype stringable () '(or string symbol)) - -(deftype fontable () '(or stringable font)) - -; Nil stands for CurrentTime. - -(deftype timestamp () '(or null card32)) - -(defconstant *bit-gravity-vector* - '#(:forget :north-west :north :north-east :west - :center :east :south-west :south - :south-east :static)) - -(deftype bit-gravity () - '(member :forget :north-west :north :north-east :west - :center :east :south-west :south :south-east :static)) - -(defconstant *win-gravity-vector* - '#(:unmap :north-west :north :north-east :west - :center :east :south-west :south :south-east - :static)) - -(deftype win-gravity () - '(member :unmap :north-west :north :north-east :west - :center :east :south-west :south :south-east :static)) - -(deftype grab-status () - '(member :success :already-grabbed :invalid-time :not-viewable)) - -; An association list. - -(deftype alist (key-type-and-name datum-type-and-name) - (declare (ignore key-type-and-name datum-type-and-name)) - 'list) - -(deftype clx-list (&optional element-type) (declare (ignore element-type)) 'list) -(deftype clx-sequence (&optional element-type) (declare (ignore element-type)) 'sequence) - -; A sequence, containing zero or more repetitions of the given elements, -; with the elements expressed as (type name). - -(deftype repeat-seq (&rest elts) elts 'sequence) - -(deftype point-seq () '(repeat-seq (int16 x) (int16 y))) - -(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2))) - -(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height))) - -(deftype arc-seq () - '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) - (angle angle1) (angle angle2))) - -(deftype gcontext-state () 'simple-vector) - -(def-clx-class (gcontext (:copier nil) (:print-function print-gcontext)) - ;; The accessors convert to CLX data types. - (id 0 :type resource-id) - (display nil :type (or null display)) - (drawable nil :type (or null drawable)) - (cache-p t :type boolean) - (server-state (allocate-gcontext-state) :type gcontext-state) - (local-state (allocate-gcontext-state) :type gcontext-state) - (plist nil :type list) ; Extension hook - (next nil #-explorer :type #-explorer (or null gcontext)) - ) - -(defun print-gcontext (gcontext stream depth) - (declare (type gcontext gcontext) - (ignore depth)) - (print-unreadable-object (gcontext stream :type t) - (print-display-name (gcontext-display gcontext) stream) - (write-string " " stream) - (prin1 (gcontext-id gcontext) stream))) - -(defconstant *event-mask-vector* - '#(:key-press :key-release :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state :exposure :visibility-change - :structure-notify :resize-redirect :substructure-notify :substructure-redirect - :focus-change :property-change :colormap-change :owner-grab-button)) - -(deftype event-mask-class () - '(member :key-press :key-release :owner-grab-button :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :exposure :visibility-change - :structure-notify :resize-redirect :substructure-notify :substructure-redirect - :focus-change :property-change :colormap-change :keymap-state)) - -(deftype event-mask () - '(or mask32 (clx-list event-mask-class))) - -(defconstant *pointer-event-mask-vector* - '#(%error %error :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state)) - -(deftype pointer-event-mask-class () - '(member :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state)) - -(deftype pointer-event-mask () - '(or mask32 (clx-list pointer-event-mask-class))) - -(defconstant *device-event-mask-vector* - '#(:key-press :key-release :button-press :button-release :pointer-motion - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion)) - -(deftype device-event-mask-class () - '(member :key-press :key-release :button-press :button-release :pointer-motion - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion)) - -(deftype device-event-mask () - '(or mask32 (clx-list device-event-mask-class))) - -(defconstant *state-mask-vector* - '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5 - :button-1 :button-2 :button-3 :button-4 :button-5)) - -(deftype modifier-key () - '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) - -(deftype modifier-mask () - '(or (member :any) mask16 (clx-list modifier-key))) - -(deftype state-mask-key () - '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) - -(defconstant *gcontext-components* - '(:function :plane-mask :foreground :background - :line-width :line-style :cap-style :join-style :fill-style - :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode - :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes - :arc-mode)) - -(deftype gcontext-key () - '(member :function :plane-mask :foreground :background - :line-width :line-style :cap-style :join-style :fill-style - :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode - :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes - :arc-mode)) - -(deftype event-key () - '(member :key-press :key-release :button-press :button-release :motion-notify - :enter-notify :leave-notify :focus-in :focus-out :keymap-notify - :exposure :graphics-exposure :no-exposure :visibility-notify - :create-notify :destroy-notify :unmap-notify :map-notify :map-request - :reparent-notify :configure-notify :gravity-notify :resize-request - :configure-request :circulate-notify :circulate-request :property-notify - :selection-clear :selection-request :selection-notify - :colormap-notify :client-message :mapping-notify)) - -(deftype error-key () - '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice - :illegal-request :implementation :length :match :name :pixmap :value :window)) - -(deftype draw-direction () - '(member :left-to-right :right-to-left)) - -(defconstant *boole-vector* - '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1 - #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior - #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2 - #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)) - -(deftype boole-constant () - `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1 - ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior - ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2 - ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set)) - -(def-clx-class (screen (:copier nil) (:print-function print-screen)) - (root nil :type (or null window)) - (width 0 :type card16) - (height 0 :type card16) - (width-in-millimeters 0 :type card16) - (height-in-millimeters 0 :type card16) - (depths nil :type (alist (image-depth depth) ((clx-list visual-info) visuals))) - (root-depth 1 :type image-depth) - (root-visual-info nil :type (or null visual-info)) - (default-colormap nil :type (or null colormap)) - (white-pixel 0 :type pixel) - (black-pixel 1 :type pixel) - (min-installed-maps 1 :type card16) - (max-installed-maps 1 :type card16) - (backing-stores :never :type (member :never :when-mapped :always)) - (save-unders-p nil :type boolean) - (event-mask-at-open 0 :type mask32) - (plist nil :type list) ; Extension hook - ) - -(defun print-screen (screen stream depth) - (declare (type screen screen) - (ignore depth)) - (print-unreadable-object (screen stream :type t) - (let ((display (drawable-display (screen-root screen)))) - (print-display-name display stream) - (write-string "." stream) - (princ (position screen (display-roots display)) stream)) - (write-string " " stream) - (prin1 (screen-width screen) stream) - (write-string "x" stream) - (prin1 (screen-height screen) stream) - (write-string "x" stream) - (prin1 (screen-root-depth screen) stream) - (when (screen-root-visual-info screen) - (write-string " " stream) - (princ (visual-info-class (screen-root-visual-info screen)) stream)))) - -(defun screen-root-visual (screen) - (declare (type screen screen) - (clx-values resource-id)) - (visual-info-id (screen-root-visual-info screen))) - -;; The list contains alternating keywords and integers. -(deftype font-props () 'list) - -(def-clx-class (font-info (:copier nil) (:predicate nil)) - (direction :left-to-right :type draw-direction) - (min-char 0 :type card16) ;; First character in font - (max-char 0 :type card16) ;; Last character in font - (min-byte1 0 :type card8) ;; The following are for 16 bit fonts - (max-byte1 0 :type card8) ;; and specify min&max values for - (min-byte2 0 :type card8) ;; the two character bytes - (max-byte2 0 :type card8) - (all-chars-exist-p nil :type boolean) - (default-char 0 :type card16) - (min-bounds nil :type (or null vector)) - (max-bounds nil :type (or null vector)) - (ascent 0 :type int16) - (descent 0 :type int16) - (properties nil :type font-props)) - -(def-clx-class (font (:constructor make-font-internal) (:copier nil) - (:print-function print-font)) - (id-internal nil :type (or null resource-id)) ;; NIL when not opened - (display nil :type (or null display)) - (reference-count 0 :type fixnum) - (name "" :type (or null string)) ;; NIL when ID is for a GContext - (font-info-internal nil :type (or null font-info)) - (char-infos-internal nil :type (or null (simple-array int16 (*)))) - (local-only-p t :type boolean) ;; When T, always calculate text extents locally - (plist nil :type list) ; Extension hook - ) - -(defun print-font (font stream depth) - (declare (type font font) - (ignore depth)) - (print-unreadable-object (font stream :type t) - (if (font-name font) - (princ (font-name font) stream) - (write-string "(gcontext)" stream)) - (write-string " " stream) - (print-display-name (font-display font) stream) - (when (font-id-internal font) - (write-string " " stream) - (prin1 (font-id font) stream)))) - -(defun font-id (font) - ;; Get font-id, opening font if needed - (or (font-id-internal font) - (open-font-internal font))) - -(defun font-font-info (font) - (or (font-font-info-internal font) - (query-font font))) - -(defun font-char-infos (font) - (or (font-char-infos-internal font) - (progn (query-font font) - (font-char-infos-internal font)))) - -(defun make-font (&key id - display - (reference-count 0) - (name "") - (local-only-p t) - font-info-internal) - (make-font-internal :id-internal id - :display display - :reference-count reference-count - :name name - :local-only-p local-only-p - :font-info-internal font-info-internal)) - -; For each component (<name> <unspec> :type <type>) of font-info, -; there is a corresponding function: - -;(defun font-<name> (font) -; (declare (type font font) -; (clx-values <type>))) - -(macrolet ((make-font-info-accessors (useless-name &body fields) - `(within-definition (,useless-name make-font-info-accessors) - ,@(mapcar - #'(lambda (field) - (let* ((type (second field)) - (n (string (first field))) - (name (xintern 'font- n)) - (accessor (xintern 'font-info- n))) - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values ,type)) - (,accessor (font-font-info font))))) - fields)))) - (make-font-info-accessors ignore - (direction draw-direction) - (min-char card16) - (max-char card16) - (min-byte1 card8) - (max-byte1 card8) - (min-byte2 card8) - (max-byte2 card8) - (all-chars-exist-p boolean) - (default-char card16) - (min-bounds vector) - (max-bounds vector) - (ascent int16) - (descent int16) - (properties font-props))) - -(defun font-property (font name) - (declare (type font font) - (type keyword name)) - (declare (clx-values (or null int32))) - (getf (font-properties font) name)) - -(macrolet ((make-mumble-equal (type) - ;; When cached, EQ works fine, otherwise test resource id's and displays - (let ((predicate (xintern type '-equal)) - (id (xintern type '-id)) - (dpy (xintern type '-display))) - (if (member type *clx-cached-types*) - `(within-definition (,type make-mumble-equal) - (declaim (inline ,predicate)) - (defun ,predicate (a b) (eq a b))) - `(within-definition (,type make-mumble-equal) - (defun ,predicate (a b) - (declare (type ,type a b)) - (and (= (,id a) (,id b)) - (eq (,dpy a) (,dpy b))))))))) - (make-mumble-equal window) - (make-mumble-equal pixmap) - (make-mumble-equal cursor) - (make-mumble-equal font) - (make-mumble-equal gcontext) - (make-mumble-equal colormap) - (make-mumble-equal drawable)) - -;;; -;;; Event-mask encode/decode functions -;;; Converts from keyword-lists to integer and back -;;; -(defun encode-mask (key-vector key-list key-type) - ;; KEY-VECTOR is a vector containg bit-position keywords. The position of the - ;; keyword in the vector indicates its bit position in the resulting mask - ;; KEY-LIST is either a mask or a list of KEY-TYPE - ;; Returns NIL when KEY-LIST is not a list or mask. - (declare (type (simple-array keyword (*)) key-vector) - (type (or mask32 list) key-list)) - (declare (clx-values (or mask32 null))) - (typecase key-list - (mask32 key-list) - (list (let ((mask 0)) - (dolist (key key-list mask) - (let ((bit (position key (the vector key-vector) :test #'eq))) - (unless bit - (x-type-error key key-type)) - (setq mask (logior mask (ash 1 bit))))))))) - -(defun decode-mask (key-vector mask) - (declare (type (simple-array keyword (*)) key-vector) - (type mask32 mask)) - (declare (clx-values list)) - (do ((m mask (ash m -1)) - (bit 0 (1+ bit)) - (len (length key-vector)) - (result nil)) - ((or (zerop m) (>= bit len)) result) - (declare (type mask32 m) - (fixnum bit len) - (list result)) - (when (oddp m) - (push (aref key-vector bit) result)))) - -(defun encode-event-mask (event-mask) - (declare (type event-mask event-mask)) - (declare (clx-values mask32)) - (or (encode-mask *event-mask-vector* event-mask 'event-mask-class) - (x-type-error event-mask 'event-mask))) - -(defun make-event-mask (&rest keys) - ;; This is only defined for core events. - ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask. - (declare (type (clx-list event-mask-class) keys)) - (declare (clx-values mask32)) - (encode-mask *event-mask-vector* keys 'event-mask-class)) - -(defun make-event-keys (event-mask) - ;; This is only defined for core events. - (declare (type mask32 event-mask)) - (declare (clx-values (clx-list event-mask-class))) - (decode-mask *event-mask-vector* event-mask)) - -(defun encode-device-event-mask (device-event-mask) - (declare (type device-event-mask device-event-mask)) - (declare (clx-values mask32)) - (or (encode-mask *device-event-mask-vector* device-event-mask - 'device-event-mask-class) - (x-type-error device-event-mask 'device-event-mask))) - -(defun encode-modifier-mask (modifier-mask) - (declare (type modifier-mask modifier-mask)) - (declare (clx-values mask16)) - (or (encode-mask *state-mask-vector* modifier-mask 'modifier-key) - (and (eq modifier-mask :any) #x8000) - (x-type-error modifier-mask 'modifier-mask))) - -(defun encode-state-mask (state-mask) - (declare (type (or mask16 (clx-list state-mask-key)) state-mask)) - (declare (clx-values mask16)) - (or (encode-mask *state-mask-vector* state-mask 'state-mask-key) - (x-type-error state-mask '(or mask16 (clx-list state-mask-key))))) - -(defun make-state-mask (&rest keys) - ;; Useful for constructing modifier-mask, state-mask. - (declare (type (clx-list state-mask-key) keys)) - (declare (clx-values mask16)) - (encode-mask *state-mask-vector* keys 'state-mask-key)) - -(defun make-state-keys (state-mask) - (declare (type mask16 state-mask)) - (declare (clx-values (clx-list state-mask-key))) - (decode-mask *state-mask-vector* state-mask)) - -(defun encode-pointer-event-mask (pointer-event-mask) - (declare (type pointer-event-mask pointer-event-mask)) - (declare (clx-values mask32)) - (or (encode-mask *pointer-event-mask-vector* pointer-event-mask - 'pointer-event-mask-class) - (x-type-error pointer-event-mask 'pointer-event-mask))) diff --git a/clx/cmudep.lisp b/clx/cmudep.lisp deleted file mode 100644 index c77d181cdbcd965b488e67beceb6634d57652b94..0000000000000000000000000000000000000000 --- a/clx/cmudep.lisp +++ /dev/null @@ -1,19 +0,0 @@ -;;; -*- Package: XLIB -*- -;;; -;;; ********************************************************************** -;;; 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/clx/cmudep.lisp,v 1.1 1992/08/11 15:15:34 ram Exp $") -;;; -;;; ********************************************************************** -;;; -(in-package "XLIB") - -(alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) - c-call:int - (host c-call:c-string) - (port c-call:int)) diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp deleted file mode 100644 index e1174d1c0c151930b2f8c774854ce95912b20e2b..0000000000000000000000000000000000000000 --- a/clx/defsystem.lisp +++ /dev/null @@ -1,530 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: T; -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Portions Copyright (C) 1987 Texas Instruments Incorporated. -;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; -;;; Franz Incorporated provides this software "as is" without express or -;;; implied warranty. - -;;; #+ features used in this file -;;; clx-ansi-common-lisp -;;; lispm -;;; genera -;;; minima -;;; lucid -;;; lcl3.0 -;;; apollo -;;; kcl -;;; ibcl -;;; excl -;;; CMU - -#+(or Genera Minima) -(eval-when (:compile-toplevel :load-toplevel :execute) - (common-lisp:pushnew :clx-ansi-common-lisp common-lisp:*features*)) - -#+(and Genera clx-ansi-common-lisp) -(eval-when (:compile-toplevel :load-toplevel :execute) - (setf *readtable* si:*ansi-common-lisp-readtable*)) - -#-clx-ansi-common-lisp -(lisp:in-package :user) - -#+clx-ansi-common-lisp -(common-lisp:in-package :common-lisp-user) - - -;;;; Lisp Machines - -#+(and lispm (not genera)) -(global:defsystem CLX - (:pathname-default "clx:clx;") - (:patchable "clx:patch;" clx-ti) - (:initial-status :experimental) - - (:module package "package") - (:module depdefs "depdefs") - (:module clx "clx") - (:module dependent "dependent") - (:module macros "macros") - (:module bufmac "bufmac") - (:module buffer "buffer") - (:module display "display") - (:module gcontext "gcontext") - (:module requests "requests") - (:module input "input") - (:module fonts "fonts") - (:module graphics "graphics") - (:module text "text") - (:module attributes "attributes") - (:module translate "translate") - (:module keysyms "keysyms") - (:module manager "manager") - (:module image "image") - (:module resource "resource") - (:module doc "doc") - - (:compile-load package) - (:compile-load depdefs - (:fasload package)) - (:compile-load clx - (:fasload package depdefs)) - (:compile-load dependent - (:fasload package depdefs clx)) - ;; Macros only needed for compilation - (:skip :compile-load macros - (:fasload package depdefs clx dependent)) - ;; Bufmac only needed for compilation - (:skip :compile-load bufmac - (:fasload package depdefs clx dependent macros)) - (:compile-load buffer - (:fasload package depdefs clx dependent macros bufmac)) - (:compile-load display - (:fasload package depdefs clx dependent macros bufmac buffer)) - (:compile-load gcontext - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load input - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load requests - (:fasload package depdefs clx dependent macros bufmac buffer display input)) - (:compile-load fonts - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load graphics - (:fasload package depdefs clx dependent macros fonts bufmac buffer display - fonts)) - (:compile-load text - (:fasload package depdefs clx dependent macros fonts bufmac buffer display - gcontext fonts)) - (:compile-load-init attributes - (dependent) - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load translate - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load keysyms - (:fasload package depdefs clx dependent macros bufmac buffer display - translate)) - (:compile-load manager - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load image - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:compile-load resource - (:fasload package depdefs clx dependent macros bufmac buffer display)) - (:auxiliary doc) - ) - - -;;; Symbolics Lisp Machines -#+Genera -(scl:defsystem CLX - (:default-pathname "SYS:X11;CLX;" - :pretty-name "CLX" - :maintaining-sites (:scrc) - :distribute-sources t - :distribute-binaries t - :source-category :basic) - (:module doc ("doc") - (:type :lisp-example)) - (:serial - "package" "depdefs" "generalock" "clx" "dependent" "macros" "bufmac" - "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" - "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) - -#+Minima -(zl:::scl:defsystem Minima-CLX - (:default-pathname "SYS:X11;CLX;" - :pretty-name "Minima CLX" - :maintain-journals nil - :maintaining-sites (:scrc) - :distribute-sources t - :distribute-binaries t - :source-category :basic - :default-module-type :minima-lisp) - (:module doc ("doc") - (:type :lisp-example)) - (:serial - "package" "depdefs" "clx" "dependent" "macros" "bufmac" - "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" - "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) - - -;;; Franz - -;; -;; The following is a suggestion. If you comment out this form be -;; prepared for possible deadlock, since no interrupts will be recognized -;; while reading from the X socket if the scheduler is not running. -;; -#+excl -(setq compiler::generate-interrupt-checks-switch - (compile nil - '(lambda (safety size speed &optional debug) - (declare (ignore size debug)) - (or (< speed 3) (> safety 0))))) - - -;;; Allegro - -#+allegro -(excl:defsystem :clx - () - |package| - (|excldep| - :load-before-compile (|package|) - :recompile-on (|package|)) - (|depdefs| - :load-before-compile (|package| |excldep|) - :recompile-on (|excldep|)) - (|clx| - :load-before-compile (|package| |excldep| |depdefs|) - :recompile-on (|package| |excldep| |depdefs|)) - (|dependent| - :load-before-compile (|package| |excldep| |depdefs| |clx|) - :recompile-on (|clx|)) - (|exclcmac| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|) - :recompile-on (|dependent|)) - (|macros| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac|) - :recompile-on (|exclcmac|)) - (|bufmac| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros|) - :recompile-on (|macros|)) - (|buffer| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac|) - :recompile-on (|bufmac|)) - (|display| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer|) - :recompile-on (|buffer|)) - (|gcontext| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - (|input| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - (|requests| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |input|) - :recompile-on (|display|)) - (|fonts| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - (|graphics| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |fonts|) - :recompile-on (|fonts|)) - (|text| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |gcontext| |fonts|) - :recompile-on (|gcontext| |fonts|) - :load-after (|translate|)) - ;; The above line gets around a compiler macro expansion bug. - - (|attributes| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - (|translate| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |text|) - :recompile-on (|display|)) - (|keysyms| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |translate|) - :recompile-on (|translate|)) - (|manager| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - (|image| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - - ;; Don't know if l-b-c list is correct. XX - (|resource| - :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) - :recompile-on (|display|)) - ) - -#+allegro -(excl:defsystem :clx-debug - (:default-pathname "debug/" - :needed-systems (:clx) - :load-before-compile (:clx)) - |describe| |keytrans| |trace| |util|) - - -;;;; Compile CLX - -;;; COMPILE-CLX compiles the lisp source files and loads the binaries. -;;; It goes to some trouble to let the source files be in one directory -;;; and the binary files in another. Thus the same set of sources can -;;; be used for different machines and/or lisp systems. It also allows -;;; you to supply explicit extensions, so source files do not have to -;;; be renamed to fit into the naming conventions of an implementation. - -;;; For example, -;;; (compile-clx "*.lisp" "machine/") -;;; compiles source files from the connected directory and puts them -;;; into the "machine" subdirectory. You can then load CLX out of the -;;; machine directory. - -;;; The code has no knowledge of the source file types (eg, ".l" or -;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin"). Calling -;;; compile-file and load with a file type of NIL usually sorts things -;;; out correctly, but you may have to explicitly give the source and -;;; binary file types. - -;;; An attempt at compiling the C language sources is also made, -;;; but you may have to set different compiler switches -;;; should be. If it doesn't do the right thing, then do -;;; (compile-clx "" "" :compile-c NIL) -;;; to prevent the compilation. - -;;; compilation notes -;;; lucid2.0/hp9000s300 -;;; must uudecode the file make-sequence-patch.uu - -#+(or lucid kcl ibcl) -(defun clx-foreign-files (binary-path) - - #+(and lucid (not lcl3.0) (or mc68000 mc68020)) - (load (merge-pathnames "make-sequence-patch" binary-path)) - - #+(and lucid apollo) - (lucid::load-foreign-file - (namestring (merge-pathnames "socket" binary-path)) - :preserve-pathname t) - - #+(and lucid (not apollo)) - (lucid::load-foreign-files - (list (namestring (merge-pathnames "socket.o" binary-path))) - '("-lc")) - - #+(or kcl ibcl) - (progn - (let ((pathname (merge-pathnames "sockcl.o" binary-path)) - (options - (concatenate - 'string - (namestring (merge-pathnames "socket.o" binary-path)) - " -lc"))) - (format t "~&Faslinking ~A with ~A.~%" pathname options) - (si:faslink (namestring pathname) options) - (format t "~&Finished faslinking ~A.~%" pathname))) - ) - -#-(or lispm allegro Minima) -(defun compile-clx (&optional - (source-pathname-defaults "") - (binary-pathname-defaults "") - &key - (compile-c t)) - - ;; The pathname-defaults above might only be strings, so coerce them - ;; to pathnames. Build a default binary path with every component - ;; of the source except the file type. This should prevent - ;; (compile-clx "*.lisp") from destroying source files. - (let* ((source-path (pathname source-pathname-defaults)) - (path (make-pathname - :host (pathname-host source-path) - :device (pathname-device source-path) - :directory (pathname-directory source-path) - :name (pathname-name source-path) - :type nil - :version (pathname-version source-path))) - (binary-path (merge-pathnames binary-pathname-defaults - path)) - #+clx-ansi-common-lisp (*compile-verbose* t) - (*load-verbose* t)) - - ;; Make sure source-path and binary-path file types are distinct so - ;; we don't accidently overwrite the source files. NIL should be an - ;; ok type, but anything else spells trouble. - (if (and (equal (pathname-type source-path) - (pathname-type binary-path)) - (not (null (pathname-type binary-path)))) - (error "Source and binary pathname defaults have same type ~s ~s" - source-path binary-path)) - - (format t "~&;;; Default paths: ~s ~s~%" source-path binary-path) - - ;; In lucid make sure we're using the compiler in production mode. - #+lcl3.0 - (progn - (unless (member :pqc *features*) - (cerror - "Go ahead anyway." - "Lucid's production mode compiler must be loaded to compile CLX.")) - (proclaim '(optimize (speed 3) - (safety 1) - (space 0) - (compilation-speed 0)))) - - (labels ((compile-lisp (filename) - (let ((source (merge-pathnames filename source-path)) - (binary (merge-pathnames filename binary-path))) - ;; If the source and binary pathnames are the same, - ;; then don't supply an output file just to be sure - ;; compile-file defaults correctly. - #+(or kcl ibcl) (load source) - (if (equal source binary) - (compile-file source) - (compile-file source :output-file binary)) - binary)) - (compile-and-load (filename) - (load (compile-lisp filename))) - #+(or lucid kcl ibcl) - (compile-c (filename) - (let* ((c-filename (concatenate 'string filename ".c")) - (o-filename (concatenate 'string filename ".o")) - (src (merge-pathnames c-filename source-path)) - (obj (merge-pathnames o-filename binary-path)) - (args (list "-c" (namestring src) - "-o" (namestring obj) - #+mips "-G 0" - #+(or hp sysv) "-DSYSV" - #+(and mips (not dec)) "-I/usr/include/bsd" - #-(and mips (not dec)) "-DUNIXCONN" - #+(and lucid pa) "-DHPUX -DHPUX7.0" - ))) - (format t ";;; cc~{ ~A~}~%" args) - (unless - (zerop - #+lucid - (multiple-value-bind (iostream estream exitstatus pid) - ;; in 2.0, run-program is exported from system: - ;; in 3.0, run-program is exported from lcl: - ;; system inheirits lcl - (system::run-program "cc" :arguments args) - (declare (ignore iostream estream pid)) - exitstatus) - #+(or kcl ibcl) - (system (format nil "cc~{ ~A~}" args))) - (error "Compile of ~A failed." src))))) - - ;; Now compile and load all the files. - ;; Defer compiler warnings until everything's compiled, if possible. - (#+(or clx-ansi-common-lisp CMU) with-compilation-unit - #+lcl3.0 lucid::with-deferred-warnings - #-(or lcl3.0 clx-ansi-common-lisp CMU) progn - () - - (compile-and-load "package") - #+(or lucid kcl ibcl) (when compile-c (compile-c "socket")) - #+(or kcl ibcl) (compile-lisp "sockcl") - #+(or lucid kcl ibcl) (clx-foreign-files binary-path) - #+excl (compile-and-load "excldep") - (compile-and-load "depdefs") - (compile-and-load "clx") - (compile-and-load "dependent") - #+excl (compile-and-load "exclcmac") ; these are just macros - (compile-and-load "macros") ; these are just macros - (compile-and-load "bufmac") ; these are just macros - (compile-and-load "buffer") - (compile-and-load "display") - (compile-and-load "gcontext") - (compile-and-load "input") - (compile-and-load "requests") - (compile-and-load "fonts") - (compile-and-load "graphics") - (compile-and-load "text") - (compile-and-load "attributes") - (compile-and-load "translate") - (compile-and-load "keysyms") - (compile-and-load "manager") - (compile-and-load "image") - (compile-and-load "resource") - )))) - - -;;;; Load CLX - -;;; This procedure loads the binaries for CLX. All of the binaries -;;; should be in the same directory, so setting the default pathname -;;; should point load to the right place. - -;;; You should have a module definition somewhere so the require/provide -;;; mechanism can avoid reloading CLX. In an ideal world, somebody would -;;; just put -;;; (REQUIRE 'CLX) -;;; in their file (some implementations don't have a central registry for -;;; modules, so a pathname needs to be supplied). - -;;; The REQUIRE should find a file that does -;;; (IN-PACKAGE 'XLIB :USE '(LISP)) -;;; (PROVIDE 'CLX) -;;; (LOAD <clx-defsystem-file>) -;;; (LOAD-CLX <binary-specific-clx-directory>) - -#-(or lispm allegro Minima) -(defun load-clx (&optional (binary-pathname-defaults "") - &key (macrosp nil)) - - (let* ((source-path (pathname "")) - (path (make-pathname - :host (pathname-host source-path) - :device (pathname-device source-path) - :directory (pathname-directory source-path) - :name (pathname-name source-path) - :type nil - :version (pathname-version source-path))) - (binary-path (merge-pathnames binary-pathname-defaults - path)) - (*load-verbose* t)) - - (flet ((load-binary (filename) - (let ((binary (merge-pathnames filename binary-path))) - (load binary)))) - - (load-binary "package") - #+(or lucid kcl ibcl) (clx-foreign-files binary-path) - #+excl (load-binary "excldep") - (load-binary "depdefs") - (load-binary "clx") - (load-binary "dependent") - (when macrosp - #+excl (load-binary "exclcmac") - (load-binary "macros") - (load-binary "bufmac")) - (load-binary "buffer") - (load-binary "display") - (load-binary "gcontext") - (load-binary "input") - (load-binary "requests") - (load-binary "fonts") - (load-binary "graphics") - (load-binary "text") - (load-binary "attributes") - (load-binary "translate") - (load-binary "keysyms") - (load-binary "manager") - (load-binary "image") - (load-binary "resource") - ))) diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp deleted file mode 100644 index 6a89c31a8f43f6c219dbdf27a59f7d90ef62a2e0..0000000000000000000000000000000000000000 --- a/clx/depdefs.lisp +++ /dev/null @@ -1,652 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;;;------------------------------------------------------------------------- -;;; Declarations -;;;------------------------------------------------------------------------- - -;;; fix a bug in kcl's RATIONAL... -;;; redefine both the function and the type. - -#+(or kcl ibcl) -(progn - (defun rational (x) - (if (rationalp x) - x - (lisp:rational x))) - (deftype rational (&optional l u) `(lisp:rational ,l ,u))) - -;;; DECLAIM - -#-clx-ansi-common-lisp -(defmacro declaim (&rest decl-specs) - (if (cdr decl-specs) - `(progn - ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec)) - decl-specs)) - `(proclaim ',(car decl-specs)))) - -;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function. - -#-Genera -(declaim (declaration clx-values)) - -#+Genera -(setf (get 'clx-values 'si:declaration-alias) 'scl:values) - -;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides -;;; the documentation that might get generated by the real arglist of the -;;; function. - -#-(or lispm lcl3.0) -(declaim (declaration arglist)) - -;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has -;;; dynamic extent and therefore can be kept on the stack and not copied to -;;; the heap, even though the value is passed out of the function. - -#-(or clx-ansi-common-lisp lcl3.0) -(declaim (declaration dynamic-extent)) - -;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used. - -#-clx-ansi-common-lisp -(declaim (declaration ignorable)) - -;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to -;;; indent calls to the function or macro containing the declaration. - -#-genera -(declaim (declaration indentation)) - -;;;------------------------------------------------------------------------- -;;; Declaration macros -;;;------------------------------------------------------------------------- - -;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local -;;; and then does a type declaration and array register declaration -(defmacro with-vector ((var type) &body body) - `(let ((,var ,var)) - (declare (type ,type ,var)) - ,@body)) - -;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for -;;; Meta-. - -#+lispm -(defmacro within-definition ((name type) &body body) - `(zl:local-declare - ((sys:function-parent ,name ,type)) - (sys:record-source-file-name ',name ',type) - ,@body)) - -#-lispm -(defmacro within-definition ((name type) &body body) - (declare (ignore name type)) - `(progn ,@body)) - - -;;;------------------------------------------------------------------------- -;;; CLX can maintain a mapping from X server ID's to local data types. If -;;; one takes the view that CLX objects will be instance variables of -;;; objects at the next higher level, then PROCESS-EVENT will typically map -;;; from resource-id to higher-level object. In that case, the lower-level -;;; CLX mapping will almost never be used (except in rare cases like -;;; query-tree), and only serve to consume space (which is difficult to -;;; GC), in which case always-consing versions of the make-<mumble>s will -;;; be better. Even when maps are maintained, it isn't clear they are -;;; useful for much beyond xatoms and windows (since almost nothing else -;;; ever comes back in events). -;;;-------------------------------------------------------------------------- -(defconstant *clx-cached-types* - '( drawable - window - pixmap -; gcontext - cursor - colormap - font)) - -(defmacro resource-id-map-test () - #+excl '#'equal - #-excl '#'eql) - ; (eq fixnum fixnum) is not guaranteed. -(defmacro atom-cache-map-test () - #+excl '#'equal - #-excl '#'eq) - -(defmacro keysym->character-map-test () - #+excl '#'equal - #-excl '#'eql) - -;;; You must define this to match the real byte order. It is used by -;;; overlapping array and image code. - -#+(or lispm vax little-endian Minima) -(eval-when (eval compile load) - (pushnew :clx-little-endian *features*)) - -#+lcl3.0 -(eval-when (compile eval load) - (ecase lucid::machine-endian - (:big nil) - (:little (pushnew :clx-little-endian *features*)))) - -#+cmu -(eval-when (compile eval load) - (ecase #.(c:backend-byte-order c:*backend*) - (:big-endian) - (:little-endian (pushnew :clx-little-endian *features*)))) - -;;; Steele's Common-Lisp states: "It is an error if the array specified -;;; as the :displaced-to argument does not have the same :element-type -;;; as the array being created" If this is the case on your lisp, then -;;; leave the overlapping-arrays feature turned off. Lisp machines -;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays -;;; with different element types to overlap. CLX will take advantage of -;;; this to do fast array packing/unpacking when the overlapping-arrays -;;; feature is enabled. - -#+(and clx-little-endian lispm) -(eval-when (eval compile load) - (pushnew :clx-overlapping-arrays *features*)) - -#+(and clx-overlapping-arrays genera) -(progn -(deftype overlap16 () '(unsigned-byte 16)) -(deftype overlap32 () '(signed-byte 32)) -) - -#+(and clx-overlapping-arrays (or explorer lambda cadr)) -(progn -(deftype overlap16 () '(unsigned-byte 16)) -(deftype overlap32 () '(unsigned-byte 32)) -) - -(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*))) - -#+clx-overlapping-arrays -(progn -(deftype buffer-words () `(vector overlap16)) -(deftype buffer-longs () `(vector overlap32)) -) - -;;; This defines a type which is a subtype of the integers. -;;; This type is used to describe all variables that can be array indices. -;;; It is here because it is used below. -;;; This is inclusive because start/end can be 1 past the end. -(deftype array-index () `(integer 0 ,array-dimension-limit)) - - -;; this is the best place to define these? - -#-Genera -(progn - -(defun make-index-typed (form) - (if (constantp form) form `(the array-index ,form))) - -(defun make-index-op (operator args) - `(the array-index - (values - ,(case (length args) - (0 `(,operator)) - (1 `(,operator - ,(make-index-typed (first args)))) - (2 `(,operator - ,(make-index-typed (first args)) - ,(make-index-typed (second args)))) - (otherwise - `(,operator - ,(make-index-op operator (subseq args 0 (1- (length args)))) - ,(make-index-typed (first (last args))))))))) - -(defmacro index+ (&rest numbers) (make-index-op '+ numbers)) -(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers)) -(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers)) -(defmacro index- (&rest numbers) (make-index-op '- numbers)) -(defmacro index* (&rest numbers) (make-index-op '* numbers)) - -(defmacro index1+ (number) (make-index-op '1+ (list number))) -(defmacro index1- (number) (make-index-op '1- (list number))) - -(defmacro index-incf (place &optional (delta 1)) - (make-index-op 'incf (list place delta))) -(defmacro index-decf (place &optional (delta 1)) - (make-index-op 'decf (list place delta))) - -(defmacro index-min (&rest numbers) (make-index-op 'min numbers)) -(defmacro index-max (&rest numbers) (make-index-op 'max numbers)) - -(defmacro index-floor (number divisor) - (make-index-op 'floor (list number divisor))) -(defmacro index-ceiling (number divisor) - (make-index-op 'ceiling (list number divisor))) -(defmacro index-truncate (number divisor) - (make-index-op 'truncate (list number divisor))) - -(defmacro index-mod (number divisor) - (make-index-op 'mod (list number divisor))) - -(defmacro index-ash (number count) - (make-index-op 'ash (list number count))) - -(defmacro index-plusp (number) `(plusp (the array-index ,number))) -(defmacro index-zerop (number) `(zerop (the array-index ,number))) -(defmacro index-evenp (number) `(evenp (the array-index ,number))) -(defmacro index-oddp (number) `(oddp (the array-index ,number))) - -(defmacro index> (&rest numbers) - `(> ,@(mapcar #'make-index-typed numbers))) -(defmacro index= (&rest numbers) - `(= ,@(mapcar #'make-index-typed numbers))) -(defmacro index< (&rest numbers) - `(< ,@(mapcar #'make-index-typed numbers))) -(defmacro index>= (&rest numbers) - `(>= ,@(mapcar #'make-index-typed numbers))) -(defmacro index<= (&rest numbers) - `(<= ,@(mapcar #'make-index-typed numbers))) - -) - -#+Genera -(progn - -(defmacro index+ (&rest numbers) `(+ ,@numbers)) -(defmacro index-logand (&rest numbers) `(logand ,@numbers)) -(defmacro index-logior (&rest numbers) `(logior ,@numbers)) -(defmacro index- (&rest numbers) `(- ,@numbers)) -(defmacro index* (&rest numbers) `(* ,@numbers)) - -(defmacro index1+ (number) `(1+ ,number)) -(defmacro index1- (number) `(1- ,number)) - -(defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta))) -(defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta))) - -(defmacro index-min (&rest numbers) `(min ,@numbers)) -(defmacro index-max (&rest numbers) `(max ,@numbers)) - -(defun positive-power-of-two-p (x) - (when (symbolp x) - (multiple-value-bind (constantp value) (lt:named-constant-p x) - (when constantp (setq x value)))) - (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x))))) - -(defmacro index-floor (number divisor) - (cond ((eql divisor 1) number) - ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) - `(si:%fixnum-floor ,number ,divisor)) - (t `(floor ,number ,divisor)))) - -(defmacro index-ceiling (number divisor) - (cond ((eql divisor 1) number) - ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling)) - `(si:%fixnum-ceiling ,number ,divisor)) - (t `(ceiling ,number ,divisor)))) - -(defmacro index-truncate (number divisor) - (cond ((eql divisor 1) number) - ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) - `(si:%fixnum-floor ,number ,divisor)) - (t `(truncate ,number ,divisor)))) - -(defmacro index-mod (number divisor) - (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod)) - `(si:%fixnum-mod ,number ,divisor)) - (t `(mod ,number ,divisor)))) - -(defmacro index-ash (number count) - (cond ((eql count 0) number) - ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor)) - `(si:%fixnum-floor ,number ,(expt 2 (- count)))) - ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply)) - `(si:%fixnum-multiply ,number ,(expt 2 count))) - (t `(ash ,number ,count)))) - -(defmacro index-plusp (number) `(plusp ,number)) -(defmacro index-zerop (number) `(zerop ,number)) -(defmacro index-evenp (number) `(evenp ,number)) -(defmacro index-oddp (number) `(oddp ,number)) - -(defmacro index> (&rest numbers) `(> ,@numbers)) -(defmacro index= (&rest numbers) `(= ,@numbers)) -(defmacro index< (&rest numbers) `(< ,@numbers)) -(defmacro index>= (&rest numbers) `(>= ,@numbers)) -(defmacro index<= (&rest numbers) `(<= ,@numbers)) - -) - -;;;; Stuff for BUFFER definition - -(defconstant *replysize* 32.) - -;; used in defstruct initializations to avoid compiler warnings -(defvar *empty-bytes* (make-sequence 'buffer-bytes 0)) -(declaim (type buffer-bytes *empty-bytes*)) -#+clx-overlapping-arrays -(progn -(defvar *empty-words* (make-sequence 'buffer-words 0)) -(declaim (type buffer-words *empty-words*)) -) -#+clx-overlapping-arrays -(progn -(defvar *empty-longs* (make-sequence 'buffer-longs 0)) -(declaim (type buffer-longs *empty-longs*)) -) - -(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal) - (:copier nil) (:predicate nil)) - (size 0 :type array-index) ;Buffer size - ;; Byte (8 bit) input buffer - (ibuf8 *empty-bytes* :type buffer-bytes) - ;; Word (16bit) input buffer - #+clx-overlapping-arrays - (ibuf16 *empty-words* :type buffer-words) - ;; Long (32bit) input buffer - #+clx-overlapping-arrays - (ibuf32 *empty-longs* :type buffer-longs) - (next nil #-explorer :type #-explorer (or null reply-buffer)) - (data-size 0 :type array-index) - ) - -(defconstant *buffer-text16-size* 256) -(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*))) - -;; These are here because. - -(defparameter *xlib-package* (find-package :xlib)) - -(defun xintern (&rest parts) - (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*)) - -(defparameter *keyword-package* (find-package :keyword)) - -(defun kintern (name) - (intern (string name) *keyword-package*)) - -;;; Pseudo-class mechanism. - -(eval-when (eval compile load) -(defvar *def-clx-class-use-defclass* #+Genera t #-Genera nil - "Controls whether DEF-CLX-CLASS uses DEFCLASS. - If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names - for which DEFCLASS should be used. - If it is not a list, then DEFCLASS is always used. - If it is NIL, then DEFCLASS is never used, since NIL is the empty list.") -) - -(defmacro def-clx-class ((name &rest options) &body slots) - (if (or (not (listp *def-clx-class-use-defclass*)) - (member name *def-clx-class-use-defclass*)) - (let ((clos-package #+clx-ansi-common-lisp - (find-package :common-lisp) - #-clx-ansi-common-lisp - (or (find-package :clos) - (find-package :pcl) - (let ((lisp-pkg (find-package :lisp))) - (and (find-symbol (string 'defclass) lisp-pkg) - lisp-pkg)))) - (constructor t) - (constructor-args t) - (include nil) - (print-function nil) - (copier t) - (predicate t)) - (dolist (option options) - (ecase (pop option) - (:constructor - (setf constructor (pop option)) - (setf constructor-args (if (null option) t (pop option)))) - (:include - (setf include (pop option))) - (:print-function - (setf print-function (pop option))) - (:copier - (setf copier (pop option))) - (:predicate - (setf predicate (pop option))))) - (flet ((cintern (&rest symbols) - (intern (apply #'concatenate 'simple-string - (mapcar #'symbol-name symbols)) - *package*)) - (kintern (symbol) - (intern (symbol-name symbol) (find-package :keyword))) - (closintern (symbol) - (intern (symbol-name symbol) clos-package))) - (when (eq constructor t) - (setf constructor (cintern 'make- name))) - (when (eq copier t) - (setf copier (cintern 'copy- name))) - (when (eq predicate t) - (setf predicate (cintern name '-p))) - (when include - (setf slots (append (get include 'def-clx-class) slots))) - (let* ((n-slots (length slots)) - (slot-names (make-list n-slots)) - (slot-initforms (make-list n-slots)) - (slot-types (make-list n-slots))) - (dotimes (i n-slots) - (let ((slot (elt slots i))) - (setf (elt slot-names i) (pop slot)) - (setf (elt slot-initforms i) (pop slot)) - (setf (elt slot-types i) (getf slot :type t)))) - `(progn - - (eval-when (compile load eval) - (setf (get ',name 'def-clx-class) ',slots)) - - ;; From here down are the system-specific expansions: - - (within-definition (,name def-clx-class) - (,(closintern 'defclass) - ,name ,(and include `(,include)) - (,@(map 'list - #'(lambda (slot-name slot-initform slot-type) - `(,slot-name - :initform ,slot-initform :type ,slot-type - :accessor ,(cintern name '- slot-name) - ,@(when (and constructor - (or (eq constructor-args t) - (member slot-name - constructor-args))) - `(:initarg ,(kintern slot-name))) - )) - slot-names slot-initforms slot-types))) - ,(when constructor - (if (eq constructor-args t) - `(defun ,constructor (&rest args) - (apply #',(closintern 'make-instance) - ',name args)) - `(defun ,constructor ,constructor-args - (,(closintern 'make-instance) ',name - ,@(mapcan #'(lambda (slot-name) - (and (member slot-name slot-names) - `(,(kintern slot-name) ,slot-name))) - constructor-args))))) - ,(when predicate - #+allegro - `(progn - (,(closintern 'defmethod) ,predicate (object) - (declare (ignore object)) - nil) - (,(closintern 'defmethod) ,predicate ((object ,name)) - t)) - #-allegro - `(defun ,predicate (object) - (typep object ',name))) - ,(when copier - `(,(closintern 'defmethod) ,copier ((.object. ,name)) - (,(closintern 'with-slots) ,slot-names .object. - (,(closintern 'make-instance) ',name - ,@(mapcan #'(lambda (slot-name) - `(,(kintern slot-name) ,slot-name)) - slot-names))))) - ,(when print-function - `(,(closintern 'defmethod) - ,(closintern 'print-object) - ((object ,name) stream) - (,print-function object stream 0)))))))) - `(within-definition (,name def-clx-class) - (defstruct (,name ,@options) - ,@slots)))) - -#+Genera -(progn - (scl:defprop def-clx-class "CLX Class" si:definition-type-name) - (scl:defprop def-clx-class zwei:defselect-function-spec-finder - zwei:definition-function-spec-finder)) - - -;; We need this here so we can define DISPLAY for CLX. -;; -;; This structure is :INCLUDEd in the DISPLAY structure. -;; Overlapping (displaced) arrays are provided for byte -;; half-word and word access on both input and output. -;; -(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil)) - ;; Lock for multi-processing systems - (lock (make-process-lock "CLX Buffer Lock")) - #-excl (output-stream nil :type (or null stream)) - #+excl (output-stream -1 :type fixnum) - ;; Buffer size - (size 0 :type array-index) - (request-number 0 :type (unsigned-byte 16)) - ;; Byte position of start of last request - ;; used for appending requests and error recovery - (last-request nil :type (or null array-index)) - ;; Byte position of start of last flushed request - (last-flushed-request nil :type (or null array-index)) - ;; Current byte offset - (boffset 0 :type array-index) - ;; Byte (8 bit) output buffer - (obuf8 *empty-bytes* :type buffer-bytes) - ;; Word (16bit) output buffer - #+clx-overlapping-arrays - (obuf16 *empty-words* :type buffer-words) - ;; Long (32bit) output buffer - #+clx-overlapping-arrays - (obuf32 *empty-longs* :type buffer-longs) - ;; Holding buffer for 16-bit text - (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0)) - ;; Probably EQ to Output-Stream - #-excl (input-stream nil :type (or null stream)) - #+excl (input-stream -1 :type fixnum) - ;; T when the host connection has gotten errors - (dead nil :type (or null (not null))) - ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited. - (flush-inhibit nil :type (or null (not null))) - - ;; Change these functions when using shared memory buffers to the server - ;; Function to call when writing the buffer - (write-function 'buffer-write-default) - ;; Function to call when flushing the buffer - (force-output-function 'buffer-force-output-default) - ;; Function to call when closing a connection - (close-function 'buffer-close-default) - ;; Function to call when reading the buffer - (input-function 'buffer-read-default) - ;; Function to call to wait for data to be input - (input-wait-function 'buffer-input-wait-default) - ;; Function to call to listen for input data - (listen-function 'buffer-listen-default) - - #+Genera (debug-io nil :type (or null stream)) - ) - -;;----------------------------------------------------------------------------- -;; Printing routines. -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera) -(defun print-unreadable-object-function (object stream type identity function) - (declare #+lispm - (sys:downward-funarg function)) - (princ "#<" stream) - (when type - (let ((type (type-of object)) - (pcl-package (find-package :pcl))) - ;; Handle pcl type-of lossage - (when (and pcl-package - (symbolp type) - (eq (symbol-package type) pcl-package) - (string-equal (symbol-name type) "STD-INSTANCE")) - (setq type - (funcall (intern (symbol-name 'class-name) pcl-package) - (funcall (intern (symbol-name 'class-of) pcl-package) - object)))) - (prin1 type stream))) - (when (and type function) (princ " " stream)) - (when function (funcall function)) - (when (and (or type function) identity) (princ " " stream)) - (when identity (princ "???" stream)) - (princ ">" stream) - nil) - -#-(or clx-ansi-common-lisp Genera) -(defmacro print-unreadable-object - ((object stream &key type identity) &body body) - (if body - `(flet ((.print-unreadable-object-body. () ,@body)) - (print-unreadable-object-function - ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) - `(print-unreadable-object-function ,object ,stream ,type ,identity nil))) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -(defconstant *image-bit-lsb-first-p* - #+clx-little-endian t - #-clx-little-endian nil) - -(defconstant *image-byte-lsb-first-p* - #+clx-little-endian t - #-clx-little-endian nil) - -(defconstant *image-unit* 32) - -(defconstant *image-pad* 32) - - -;;----------------------------------------------------------------------------- -;; Foreign Functions -;;----------------------------------------------------------------------------- - -#+(and lucid apollo (not lcl3.0)) -(lucid::define-foreign-function '(connect-to-server "connect_to_server") - '((:val host :string) - (:val display :integer32)) - :integer32) - -#+(and lucid (not apollo) (not lcl3.0)) -(lucid::define-c-function connect-to-server (host display) - :result-type :integer) - -#+lcl3.0 -(lucid::def-foreign-function - (connect-to-server - (:language :c) - (:return-type :signed-32bit)) - (host :simple-string) - (display :signed-32bit)) diff --git a/clx/dependent.lisp b/clx/dependent.lisp deleted file mode 100644 index 4d7cf24222d4c5548024cfff9904a50a519508d4..0000000000000000000000000000000000000000 --- a/clx/dependent.lisp +++ /dev/null @@ -1,3546 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;; This file contains some of the system dependent code for CLX - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;;; The size of the output buffer. Must be a multiple of 4. -(defparameter *output-buffer-size* 8192) - -#+explorer -(zwei:define-indentation event-case (1 1)) - -;;; Number of seconds to wait for a reply to a server request -(defparameter *reply-timeout* nil) - -#-(or clx-overlapping-arrays (not clx-little-endian)) -(progn - (defconstant *word-0* 0) - (defconstant *word-1* 1) - - (defconstant *long-0* 0) - (defconstant *long-1* 1) - (defconstant *long-2* 2) - (defconstant *long-3* 3)) - -#-(or clx-overlapping-arrays clx-little-endian) -(progn - (defconstant *word-0* 1) - (defconstant *word-1* 0) - - (defconstant *long-0* 3) - (defconstant *long-1* 2) - (defconstant *long-2* 1) - (defconstant *long-3* 0)) - -;;; Set some compiler-options for often used code - -(eval-when (eval compile load) - -(defconstant *buffer-speed* #+clx-debugging 1 #-clx-debugging 3 - "Speed compiler option for buffer code.") -(defconstant *buffer-safety* #+clx-debugging 3 #-clx-debugging 0 - "Safety compiler option for buffer code.") - -(defun declare-bufmac () - `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*)))) - -;;; It's my impression that in lucid there's some way to make a declaration -;;; called fast-entry or something that causes a function to not do some -;;; checking on args. Sadly, we have no lucid manuals here. If such a -;;; declaration is available, it would be a good idea to make it here when -;;; *buffer-speed* is 3 and *buffer-safety* is 0. -(defun declare-buffun () - `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*)))) - -) - -(declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) - -#-Genera -(progn - -(defun card8->int8 (x) - (declare (type card8 x)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) - -(defun int8->card8 (x) - (declare (type int8 x)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (ldb (byte 8 0) x))) - -(defun card16->int16 (x) - (declare (type card16 x)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) - -(defun int16->card16 (x) - (declare (type int16 x)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (ldb (byte 16 0) x))) - -(defun card32->int32 (x) - (declare (type card32 x)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) - -(defun int32->card32 (x) - (declare (type int32 x)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (ldb (byte 32 0) x))) - -) - -#+Genera -(progn - -(defun card8->int8 (x) - (declare lt:(side-effects simple reducible)) - (if (logbitp 7 x) (- x #x100) x)) - -(defun int8->card8 (x) - (declare lt:(side-effects simple reducible)) - (ldb (byte 8 0) x)) - -(defun card16->int16 (x) - (declare lt:(side-effects simple reducible)) - (if (logbitp 15 x) (- x #x10000) x)) - -(defun int16->card16 (x) - (declare lt:(side-effects simple reducible)) - (ldb (byte 16 0) x)) - -(defun card32->int32 (x) - (declare lt:(side-effects simple reducible)) - (sys:%logldb (byte 32 0) x)) - -(defun int32->card32 (x) - (declare lt:(side-effects simple reducible)) - (ldb (byte 32 0) x)) - -) - -(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) - -#-(or Genera lcl3.0 excl) -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (aref a i))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (card8->int8 (aref a i))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a i) (int8->card8 v))) - -) - -#+Genera -(progn - -(defun aref-card8 (a i) - (aref a i)) - -(defun aset-card8 (v a i) - (zl:aset v a i)) - -(defun aref-int8 (a i) - (card8->int8 (aref a i))) - -(defun aset-int8 (v a i) - (zl:aset (int8->card8 v) a i)) - -) - -#+(or excl lcl3.0 clx-overlapping-arrays) -(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 - aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) - -#+(and clx-overlapping-arrays Genera) -(progn - -(defun aref-card16 (a i) - (aref a i)) - -(defun aset-card16 (v a i) - (zl:aset v a i)) - -(defun aref-int16 (a i) - (card16->int16 (aref a i))) - -(defun aset-int16 (v a i) - (zl:aset (int16->card16 v) a i) - v) - -(defun aref-card32 (a i) - (int32->card32 (aref a i))) - -(defun aset-card32 (v a i) - (zl:aset (card32->int32 v) a i)) - -(defun aref-int32 (a i) (aref a i)) - -(defun aset-int32 (v a i) - (zl:aset v a i)) - -(defun aref-card29 (a i) - (aref a i)) - -(defun aset-card29 (v a i) - (zl:aset v a i)) - -) - -#+(and clx-overlapping-arrays (not Genera)) -(progn - -(defun aref-card16 (a i) - (aref a i)) - -(defun aset-card16 (v a i) - (setf (aref a i) v)) - -(defun aref-int16 (a i) - (card16->int16 (aref a i))) - -(defun aset-int16 (v a i) - (setf (aref a i) (int16->card16 v)) - v) - -(defun aref-card32 (a i) - (aref a i)) - -(defun aset-card32 (v a i) - (setf (aref a i) v)) - -(defun aref-int32 (a i) - (card32->int32 (aref a i))) - -(defun aset-int32 (v a i) - (setf (aref a i) (int32->card32 v)) - v) - -(defun aref-card29 (a i) - (aref a i)) - -(defun aset-card29 (v a i) - (setf (aref a i) v)) - -) - -#+excl -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card8)) - #.(declare-buffun) - (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-byte))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-byte) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int8)) - #.(declare-buffun) - (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-byte))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-byte) v)) - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-word))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-word) v)) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-word))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-word) v)) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long) v)) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-long))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-long) v)) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long) v)) - -) - -#+lcl3.0 -(progn - -(defun aref-card8 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card8)) - #.(declare-buffun) - (the card8 (lucid::%svref-8bit a i))) - -(defun aset-card8 (v a i) - (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-8bit a i) v)) - -(defun aref-int8 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values int8)) - #.(declare-buffun) - (the int8 (lucid::%svref-signed-8bit a i))) - -(defun aset-int8 (v a i) - (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-signed-8bit a i) v)) - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card16)) - #.(declare-buffun) - (the card16 (lucid::%svref-16bit a (index-ash i -1)))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-16bit a (index-ash i -1)) v)) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values int16)) - #.(declare-buffun) - (the int16 (lucid::%svref-signed-16bit a (index-ash i -1)))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v)) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card32)) - #.(declare-buffun) - (the card32 (lucid::%svref-32bit a (index-ash i -2)))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-32bit a (index-ash i -2)) v)) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values int32)) - #.(declare-buffun) - (the int32 (lucid::%svref-signed-32bit a (index-ash i -2)))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v)) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i) - (clx-values card29)) - #.(declare-buffun) - (the card29 (lucid::%svref-32bit a (index-ash i -2)))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (lucid::%svref-32bit a (index-ash i -2)) v)) - -) - - - -#-(or excl lcl3.0 clx-overlapping-arrays) -(progn - -(defun aref-card16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card16)) - #.(declare-buffun) - (the card16 - (logior (the card16 - (ash (the card8 (aref a (index+ i *word-1*))) 8)) - (the card8 - (aref a (index+ i *word-0*)))))) - -(defun aset-card16 (v a i) - (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-int16 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 - (logior (the int16 - (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8)) - (the card8 - (aref a (index+ i *word-0*)))))) - -(defun aset-int16 (v a i) - (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-card32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card32)) - #.(declare-buffun) - (the card32 - (logior (the card32 - (ash (the card8 (aref a (index+ i *long-3*))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i *long-2*))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i *long-1*))) 8)) - (the card8 - (aref a (index+ i *long-0*)))))) - -(defun aset-card32 (v a i) - (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-int32 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values int32)) - #.(declare-buffun) - (the int32 - (logior (the int32 - (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i *long-2*))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i *long-1*))) 8)) - (the card8 - (aref a (index+ i *long-0*)))))) - -(defun aset-int32 (v a i) - (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v))) - v) - -(defun aref-card29 (a i) - (declare (type buffer-bytes a) - (type array-index i)) - (declare (clx-values card29)) - #.(declare-buffun) - (the card29 - (logior (the card29 - (ash (the card8 (aref a (index+ i *long-3*))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i *long-2*))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i *long-1*))) 8)) - (the card8 - (aref a (index+ i *long-0*)))))) - -(defun aset-card29 (v a i) - (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) - #.(declare-buffun) - (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v))) - v) - -) - -(defsetf aref-card8 (a i) (v) - `(aset-card8 ,v ,a ,i)) - -(defsetf aref-int8 (a i) (v) - `(aset-int8 ,v ,a ,i)) - -(defsetf aref-card16 (a i) (v) - `(aset-card16 ,v ,a ,i)) - -(defsetf aref-int16 (a i) (v) - `(aset-int16 ,v ,a ,i)) - -(defsetf aref-card32 (a i) (v) - `(aset-card32 ,v ,a ,i)) - -(defsetf aref-int32 (a i) (v) - `(aset-int32 ,v ,a ,i)) - -(defsetf aref-card29 (a i) (v) - `(aset-card29 ,v ,a ,i)) - -;;; Other random conversions - -(defun rgb-val->card16 (value) - ;; Short floats are good enough - (declare (type rgb-val value)) - (declare (clx-values card16)) - #.(declare-buffun) - ;; Convert VALUE from float to card16 - (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) - -(defun card16->rgb-val (value) - ;; Short floats are good enough - (declare (type card16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - ;; Convert VALUE from card16 to float - (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) - -(defun radians->int16 (value) - ;; Short floats are good enough - (declare (type angle value)) - (declare (clx-values int16)) - #.(declare-buffun) - (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) - -(defun int16->radians (value) - ;; Short floats are good enough - (declare (type int16 value)) - (declare (clx-values short-float)) - #.(declare-buffun) - (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) - - -;;----------------------------------------------------------------------------- -;; Character transformation -;;----------------------------------------------------------------------------- - - -;;; This stuff transforms chars to ascii codes in card8's and back. -;;; You might have to hack it a little to get it to work for your machine. - -(declaim (inline char->card8 card8->char)) - -(macrolet ((char-translators () - (let ((alist - `(#-lispm - ;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - ;; One the lispm, #\Newline is #\Return, but we'd really like - ;; #\Newline to translate to ascii code 10, so we swap the - ;; Ascii codes for #\Return and #\Linefeed. We also provide - ;; mappings from the counterparts of these control characters - ;; so that the character mapping from the lisp machine - ;; character set to ascii is invertible. - #+lispm - ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) - (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) - (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) - (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) - (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) - (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) - (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) - (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) - ;; The rest of the common lisp charater set with the normal - ;; ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant *char-to-card8-translation-table* - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant *card8-to-char-translation-table* - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - #-Genera - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - *char-to-card8-translation-table*) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector *card8-to-char-translation-table*) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - #+Genera - (progn - (defun char->card8 (char) - (declare lt:(side-effects reader reducible)) - (aref *char-to-card8-translation-table* (char-code char))) - (defun card8->char (card8) - (declare lt:(side-effects reader reducible)) - (aref *card8-to-char-translation-table* card8)) - ) - #-Minima - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - #-Minima - (dotimes (i (length *char-to-card8-translation-table*)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) - (char-translators)) - -;;----------------------------------------------------------------------------- -;; Process Locking -;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. -;;----------------------------------------------------------------------------- - -;;; MAKE-PROCESS-LOCK: Creating a process lock. - -#-(or LispM excl Minima) -(defun make-process-lock (name) - (declare (ignore name)) - nil) - -#+excl -(defun make-process-lock (name) - (mp:make-process-lock :name name)) - -#+(and LispM (not Genera)) -(defun make-process-lock (name) - (vector nil name)) - -#+Genera -(defun make-process-lock (name) - (process:make-lock name :flavor 'clx-lock)) - -#+Minima -(defun make-process-lock (name) - (minima:make-lock name :recursive t)) - -;;; HOLDING-LOCK: Execute a body of code with a lock held. - -;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN -;;; passes its timeout to the holding-lock macro, so any timeout you want to -;;; work for event-listen you should do for holding-lock. - -;; If you're not sharing DISPLAY objects within a multi-processing -;; shared-memory environment, this is sufficient -#-(or lispm excl lcl3.0 Minima CMU) -(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) - (declare (ignore locator display whostate timeout)) - `(progn ,@body)) - -;;; HOLDING-LOCK for CMU Common Lisp. -;;; -;;; We are not multi-processing, but we use this macro to try to protect -;;; against re-entering request functions. This can happen if an interrupt -;;; occurs and the handler attempts to use X over the same display connection. -;;; This can happen if the GC hooks are used to notify the user over the same -;;; display connection. We lock out GC's just as a dummy check for our users. -;;; Locking out interrupts has the problem that CLX always waits for replies -;;; within this dynamic scope, so if the server cannot reply for some reason, -;;; we potentially dead-lock without interrupts. -;;; -#+CMU -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore locator display whostate timeout)) - `(lisp::without-gcing (system:without-interrupts (progn ,@body)))) - -#+Genera -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore whostate)) - `(process:with-lock (,locator :timeout ,timeout) - (let ((.debug-io. (buffer-debug-io ,display))) - (scl:let-if .debug-io. ((*debug-io* .debug-io.)) - ,@body)))) - -#+(and lispm (not Genera)) -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - ;; This macro is for use in a multi-process environment. - (let ((lock (gensym)) - (have-lock (gensym)) - (timeo (gensym))) - `(let* ((,lock (zl:locf (svref ,locator 0))) - (,have-lock (eq (car ,lock) sys:current-process)) - (,timeo ,timeout)) - (unwind-protect - (when (cond (,have-lock) - ((#+explorer si:%store-conditional - #-explorer sys:store-conditional - ,lock nil sys:current-process)) - ((null ,timeo) - (sys:process-lock ,lock nil ,(or whostate "CLX Lock"))) - ((sys:process-wait-with-timeout - ,(or whostate "CLX Lock") (round (* ,timeo 60.)) - #'(lambda (lock process) - (#+explorer si:%store-conditional - #-explorer sys:store-conditional - lock nil process)) - ,lock sys:current-process))) - ,@body) - (unless ,have-lock - (#+explorer si:%store-conditional - #-explorer sys:store-conditional - ,lock sys:current-process nil)))))) - -;; Lucid has a process locking mechanism as well under release 3.0 -#+lcl3.0 -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - (if timeout - ;; Hair to support timeout. - `(let ((.have-lock. (eq ,locator lcl:*current-process*)) - (.timeout. ,timeout)) - (unwind-protect - (when (cond (.have-lock.) - ((conditional-store ,locator nil lcl:*current-process*)) - ((null .timeout.) - (lcl:process-lock ,locator) - t) - ((lcl:process-wait-with-timeout ,whostate .timeout. - #'(lambda () - (conditional-store ,locator nil lcl:*current-process*)))) - ;; abort the PROCESS-UNLOCK if actually timing out - (t - (setf .have-lock. :abort) - nil)) - ,@body) - (unless .have-lock. - (lcl:process-unlock ,locator)))) - `(lcl:with-process-lock (,locator) - ,@body))) - - -#+excl -(defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) - (declare (ignore display)) - `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) - (unwind-protect - (block .hl-doit. - (when mp::*scheduler-stack-group* ; fast test for scheduler running - (setq .hl-lock. ,locator - .hl-curproc. mp::*current-process*) - (when (and .hl-curproc. ; nil if in process-wait fun - (not (eq (mp::process-lock-locker .hl-lock.) - .hl-curproc.))) - ;; Then we need to grab the lock. - ,(if timeout - `(if (not (mp::process-lock .hl-lock. .hl-curproc. - ,whostate ,timeout)) - (return-from .hl-doit. nil)) - `(mp::process-lock .hl-lock. .hl-curproc. - ,@(when whostate `(,whostate)))) - ;; There is an apparent race condition here. However, there is - ;; no actual race condition -- our implementation of mp:process- - ;; lock guarantees that the lock will still be held when it - ;; returns, and no interrupt can happen between that and the - ;; execution of the next form. -- jdi 2/27/91 - (setq .hl-obtained-lock. t))) - ,@body) - (if (and .hl-obtained-lock. - ;; Note -- next form added to allow error handler inside - ;; body to unlock the lock prematurely if it knows that - ;; the current process cannot possibly continue but will - ;; throw out (or is it throw up?). - (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) - (mp::process-unlock .hl-lock. .hl-curproc.))))) - -#+Minima -(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) - `(holding-lock-1 #'(lambda () ,@body) ,locator ,display - ,@(and whostate `(:whostate ,whostate)) - ,@(and timeout `(:timeout ,timeout)))) - -#+Minima -(defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout) - (declare (dynamic-extent continuation)) - (declare (ignore display whostate timeout)) - (minima:with-lock (lock) - (funcall continuation))) - -;;; WITHOUT-ABORTS - -;;; If you can inhibit asynchronous keyboard aborts inside the body of this -;;; macro, then it is a good idea to do this. This macro is wrapped around -;;; request writing and reply reading to ensure that requests are atomically -;;; written and replies are atomically read from the stream. - -#-(or Genera excl lcl3.0) -(defmacro without-aborts (&body body) - `(progn ,@body)) - -#+Genera -(defmacro without-aborts (&body body) - `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.") - ,@body)) - -#+excl -(defmacro without-aborts (&body body) - `(without-interrupts ,@body)) - -#+lcl3.0 -(defmacro without-aborts (&body body) - `(lcl:with-interruptions-inhibited ,@body)) - -;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. -;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's -;;; value changes. - -#-(or lispm excl lcl3.0 Minima) -(defun process-block (whostate predicate &rest predicate-args) - (declare (ignore whostate)) - (or (apply predicate predicate-args) - (error "Program tried to wait with no scheduler."))) - -#+Genera -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) - (apply #'process:block-process whostate predicate predicate-args)) - -#+(and lispm (not Genera)) -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) - (apply #'global:process-wait whostate predicate predicate-args)) - -#+excl -(defun process-block (whostate predicate &rest predicate-args) - (if mp::*scheduler-stack-group* - (apply #'mp::process-wait whostate predicate predicate-args) - (or (apply predicate predicate-args) - (error "Program tried to wait with no scheduler.")))) - -#+lcl3.0 -(defun process-block (whostate predicate &rest predicate-args) - (declare (dynamic-extent predicate-args)) - (apply #'lcl:process-wait whostate predicate predicate-args)) - -#+Minima -(defun process-block (whostate predicate &rest predicate-args) - (declare (type function predicate) - (dynamic-extent predicate)) - (apply #'minima:process-wait whostate predicate predicate-args)) - -;;; PROCESS-WAKEUP: Check some other process' wait function. - -(declaim (inline process-wakeup)) - -#-(or excl Genera Minima) -(defun process-wakeup (process) - (declare (ignore process)) - nil) - -#+excl -(defun process-wakeup (process) - (let ((curproc mp::*current-process*)) - (when (and curproc process) - (unless (mp::process-p curproc) - (error "~s is not a process" curproc)) - (unless (mp::process-p process) - (error "~s is not a process" process)) - (if (> (mp::process-priority process) (mp::process-priority curproc)) - (mp::process-allow-schedule process))))) - -#+Genera -(defun process-wakeup (process) - (process:wakeup process)) - -#+Minima -(defun process-wakeup (process) - (when process - (minima:process-wakeup process))) - -;;; CURRENT-PROCESS: Return the current process object for input locking and -;;; for calling PROCESS-WAKEUP. - -(declaim (inline current-process)) - -;;; Default return NIL, which is acceptable even if there is a scheduler. - -#-(or lispm excl lcl3.0 Minima) -(defun current-process () - nil) - -#+lispm -(defun current-process () - sys:current-process) - -#+excl -(defun current-process () - (and mp::*scheduler-stack-group* - mp::*current-process*)) - -#+lcl3.0 -(defun current-process () - lcl:*current-process*) - -#+Minima -(defun current-process () - (minima:current-process)) - -;;; WITHOUT-INTERRUPTS -- provide for atomic operations. - -#-(or lispm excl lcl3.0 Minima) -(defmacro without-interrupts (&body body) - `(progn ,@body)) - -#+(and lispm (not Genera)) -(defmacro without-interrupts (&body body) - `(sys:without-interrupts ,@body)) - -#+Genera -(defmacro without-interrupts (&body body) - `(process:with-no-other-processes ,@body)) - -#+LCL3.0 -(defmacro without-interrupts (&body body) - `(lcl:with-scheduling-inhibited ,@body)) - -#+Minima -(defmacro without-interrupts (&body body) - `(minima:with-no-other-processes ,@body)) - -;;; CONDITIONAL-STORE: - -;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. -;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. -(defmacro conditional-store (place old-value new-value) - `(without-interrupts - (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t)))) - -;;;---------------------------------------------------------------------------- -;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. -;;; -;;;---------------------------------------------------------------------------- - -#-Genera -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(unless (buffer-dead ,buffer) - ,@body)) - -#+Genera -(defmacro wrap-buf-output ((buffer) &body body) - ;; Error recovery wrapper - `(let ((.buffer. ,buffer)) - (unless (buffer-dead .buffer.) - (scl:condition-bind - (((sys:network-error) - #'(lambda (error) - (scl:condition-case () - (funcall (buffer-close-function .buffer.) .buffer. :abort t) - (sys:network-error)) - (setf (buffer-dead .buffer.) error) - (setf (buffer-output-stream .buffer.) nil) - (setf (buffer-input-stream .buffer.) nil) - nil))) - ,@body)))) - -#-Genera -(defmacro wrap-buf-input ((buffer) &body body) - (declare (ignore buffer)) - ;; Error recovery wrapper - `(progn ,@body)) - -#+Genera -(defmacro wrap-buf-input ((buffer) &body body) - ;; Error recovery wrapper - `(let ((.buffer. ,buffer)) - (scl:condition-bind - (((sys:network-error) - #'(lambda (error) - (scl:condition-case () - (funcall (buffer-close-function .buffer.) .buffer. :abort t) - (sys:network-error)) - (setf (buffer-dead .buffer.) error) - (setf (buffer-output-stream .buffer.) nil) - (setf (buffer-input-stream .buffer.) nil) - nil))) - ,@body))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. -;;;---------------------------------------------------------------------------- - -;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X -;;; server - -#-(or explorer Genera lucid kcl ibcl excl Minima CMU) -(defun open-x-stream (host display protocol) - host display protocol ;; unused - (error "OPEN-X-STREAM not implemented yet.")) - -;;; Genera: - -;;; TCP and DNA are both layered products, so try to work with either one. - -#+Genera -(when (fboundp 'tcp:add-tcp-port-for-protocol) - (tcp:add-tcp-port-for-protocol :x-window-system 6000)) - -#+Genera -(when (fboundp 'dna:add-dna-contact-id-for-protocol) - (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0")) - -#+Genera -(net:define-protocol :x-window-system (:x-window-system :byte-stream) - (:invoke-with-stream ((stream :characters nil :ascii-translation nil)) - stream)) - -#+Genera -(eval-when (compile) - (compiler:function-defined 'tcp:open-tcp-stream) - (compiler:function-defined 'dna:open-dna-bidirectional-stream)) - -#+Genera -(defun open-x-stream (host display protocol) - (let ((host (net:parse-host host))) - (if (or protocol (plusp display)) - ;; The protocol was specified or the display isn't 0, so we - ;; can't use the Generic Network System. If the protocol was - ;; specified, then use that protocol, otherwise, blindly use - ;; TCP. - (ccase protocol - ((:tcp nil) - (tcp:open-tcp-stream - host (+ *x-tcp-port* display) nil - :direction :io - :characters nil - :ascii-translation nil)) - ((:dna) - (dna:open-dna-bidirectional-stream - host (format nil "X$X~D" display) - :characters nil - :ascii-translation nil))) - (let ((neti:*invoke-service-automatic-retry* t)) - (net:invoke-service-on-host :x-window-system host))))) - -#+explorer -(defun open-x-stream (host display protocol) - (declare (ignore protocol)) - (net:open-connection-on-medium - (net:parse-host host) ;Host - :byte-stream ;Medium - "X11" ;Logical contact name - :stream-type :character-stream - :direction :bidirectional - :timeout-after-open nil - :remote-port (+ *x-tcp-port* display))) - -#+explorer -(net:define-logical-contact-name - "X11" - `((:local "X11") - (:chaos "X11") - (:nsp-stream "X11") - (:tcp ,*x-tcp-port*))) - -#+lucid -(defun open-x-stream (host display protocol) - protocol ;; unused - (let ((fd (connect-to-server host display))) - (when (minusp fd) - (error "Failed to connect to server: ~A ~D" host display)) - (user::make-lisp-stream :input-handle fd - :output-handle fd - :element-type 'unsigned-byte - #-lcl3.0 :stream-type #-lcl3.0 :ephemeral))) - -#+(or kcl ibcl) -(defun open-x-stream (host display protocol) - protocol ;; unused - (let ((stream (open-socket-stream host display))) - (if (streamp stream) - stream - (error "Cannot connect to server: ~A:~D" host display)))) - -#+excl -;; -;; Note that since we don't use the CL i/o facilities to do i/o, the display -;; input and output "stream" is really a file descriptor (fixnum). -;; -(defun open-x-stream (host display protocol) - (declare (ignore protocol));; unused - (let ((fd (connect-to-server (string host) display))) - (when (minusp fd) - (error "Failed to connect to server: ~A ~D" host display)) - fd)) - -#+Minima -(defun open-x-stream (host display protocol) - (declare (ignore protocol));; unused - (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address - (cdr (host-address host))) - :foreign-port (+ *x-tcp-port* display))) - -;;; OPEN-X-STREAM -- for CMU Common Lisp. -;;; -;;; The file descriptor here just gets tossed into the stream slot of the -;;; display object instead of a stream. -;;; -#+CMU -(defun open-x-stream (host display protocol) - (declare (ignore protocol)) - (let ((server-fd (connect-to-server host display))) - (unless (plusp server-fd) - (error "Failed to connect to X11 server: ~A (display ~D)" host display)) - (system:make-fd-stream server-fd :input t :output t - :element-type '(unsigned-byte 8)))) - -;;; This loads the C foreign function used to make an IPC connection -;;; to the X11 server. It also defines the necessary types and things -;;; to actually make the foreign call. See the OPEN-X-STREAM function -;;; in the dependent.lisp file. -;;; -#+CMU -(ext:def-c-routine ("connect_to_server" connect-to-server) (ext:int) - (host system:null-terminated-string) - (port ext:int)) - -;;; BUFFER-READ-DEFAULT - read data from the X stream - -#+(or Genera explorer) -(defun buffer-read-default (display vector start end timeout) - ;; returns non-NIL if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (or (cond ((null stream)) - ((funcall stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (multiple-value-bind (ignore eofp) - (funcall stream :string-in nil vector start end) - eofp)))) - - -#+excl -;; -;; Rewritten 10/89 to not use foreign function interface to do I/O. -;; -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - - (let* ((howmany (- end start)) - (fd (display-input-stream display))) - (declare (type array-index howmany) - (fixnum fd)) - (or (cond ((fd-char-avail-p fd) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (fd-read-bytes fd vector start howmany)))) - - -#+lcl3.0 -(defmacro with-underlying-stream ((variable stream display direction) &body body) - `(let ((,variable - (or (getf (display-plist ,display) ',direction) - (setf (getf (display-plist ,display) ',direction) - (lucid::underlying-stream - ,stream ,(if (eq direction 'input) :input :output)))))) - ,@body)) - -#+lcl3.0 -(defun buffer-read-default (display vector start end timeout) - ;;Note that LISTEN must still be done on "slow stream" or the I/O system - ;;gets confused. But reading should be done from "fast stream" for speed. - ;;We used to inhibit scheduling because there were races in Lucid's - ;;multitasking system. Empirical evidence suggests they may be gone now. - ;;Should you decide you need to inhibit scheduling, do it around the - ;;lcl:read-array. - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (with-underlying-stream (stream stream display input) - (eq (lcl:read-array stream vector start end nil :eof) :eof))))) - -#+Minima -(defun buffer-read-default (display vector start end timeout) - ;; returns non-NIL if EOF encountered - ;; Returns :TIMEOUT when timeout exceeded - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (eq :eof (minima:read-vector vector stream nil start end))))) - -;;; BUFFER-READ-DEFAULT for CMU Common Lisp. -;;; -;;; If timeout is 0, then we call LISTEN to see if there is any input. -;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without -;;; first calling BUFFER-INPUT-WAIT-DEFAULT. -;;; -#+CMU -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (cond ((and (and timeout (= timeout 0)) - (not (listen (display-input-stream display)))) - :timeout) - (t - (system:read-n-bytes (display-input-stream display) - vector start (- end start)) - nil))) - -;;; WARNING: -;;; CLX performance will suffer if your lisp uses read-byte for -;;; receiving all data from the X Window System server. -;;; You are encouraged to write a specialized version of -;;; buffer-read-default that does block transfers. -#-(or Genera explorer excl lcl3.0 Minima CMU) -(defun buffer-read-default (display vector start end timeout) - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (do* ((index start (index1+ index))) - ((index>= index end) nil) - (declare (type array-index index)) - (let ((c (read-byte stream nil nil))) - (declare (type (or null card8) c)) - (if (null c) - (return t) - (setf (aref vector index) (the card8 c)))))))) - -;;; BUFFER-WRITE-DEFAULT - write data to the X stream - -#+(or Genera explorer) -(defun buffer-write-default (vector display start end) - ;; The default buffer write function for use with common-lisp streams - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (write-string vector stream :start start :end end)))) - -#+excl -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (excl::filesys-write-bytes (display-output-stream display) vector start - (- end start))) - -#+lcl3.0 -(defun buffer-write-default (vector display start end) - ;;We used to inhibit scheduling because there were races in Lucid's - ;;multitasking system. Empirical evidence suggests they may be gone now. - ;;Should you decide you need to inhibit scheduling, do it around the - ;;lcl:write-array. - (declare (type display display) - (type buffer-bytes vector) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (with-underlying-stream (stream stream display output) - (lcl:write-array stream vector start end))))) - -#+Minima -(defun buffer-write-default (vector display start end) - ;; The default buffer write function for use with common-lisp streams - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (minima:write-vector vector stream start end)))) - -#+CMU -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (system:output-raw-bytes (display-output-stream display) vector start end) - nil) - -;;; WARNING: -;;; CLX performance will be severely degraded if your lisp uses -;;; write-byte to send all data to the X Window System server. -;;; You are STRONGLY encouraged to write a specialized version -;;; of buffer-write-default that does block transfers. - -#-(or Genera explorer excl lcl3.0 Minima CMU) -(defun buffer-write-default (vector display start end) - ;; The default buffer write function for use with common-lisp streams - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (with-vector (vector buffer-bytes) - (do ((index start (index1+ index))) - ((index>= index end)) - (declare (type array-index index)) - (write-byte (aref vector index) stream)))))) - -;;; buffer-force-output-default - force output to the X stream - -#+excl -(defun buffer-force-output-default (display) - ;; buffer-write-default does the actual writing. - (declare (ignore display))) - -#-excl -(defun buffer-force-output-default (display) - ;; The default buffer force-output function for use with common-lisp streams - (declare (type display display)) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (force-output stream)))) - -;;; BUFFER-CLOSE-DEFAULT - close the X stream - -#+excl -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display) - (ignore abort)) - #.(declare-buffun) - (excl::filesys-checking-close (display-output-stream display))) - -#-excl -(defun buffer-close-default (display &key abort) - ;; The default buffer close function for use with common-lisp streams - (declare (type display display)) - #.(declare-buffun) - (let ((stream (display-output-stream display))) - (declare (type (or null stream) stream)) - (unless (null stream) - (close stream :abort abort)))) - -;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the -;;; buffer. This is called in read-input between requests, so that a process -;;; waiting for input is abortable when between requests. Should return -;;; :TIMEOUT if it times out, NIL otherwise. - -;;; The default implementation - -;; Poll for input every *buffer-read-polling-time* SECONDS. -#-(or Genera explorer excl lcl3.0 CMU) -(defparameter *buffer-read-polling-time* 0.5) - -#-(or Genera explorer excl lcl3.0 CMU) -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((not (null timeout)) - (multiple-value-bind (npoll fraction) - (truncate timeout *buffer-read-polling-time*) - (dotimes (i npoll) ; Sleep for a time, then listen again - (sleep *buffer-read-polling-time*) - (when (listen stream) - (return-from buffer-input-wait-default nil))) - (when (plusp fraction) - (sleep fraction) ; Sleep a fraction of a second - (when (listen stream) ; and listen one last time - (return-from buffer-input-wait-default nil))) - :timeout))))) - -#+CMU -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - (t - (if (system:wait-until-fd-usable (system:fd-stream-fd stream) - :input timeout) - nil - :timeout))))) - -#+Genera -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((scl:send stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((null timeout) (si:stream-input-block stream "CLX Input")) - (t - (scl:condition-bind ((neti:protocol-timeout - #'(lambda (error) - (when (eq stream (scl:send error :stream)) - (return-from buffer-input-wait-default :timeout))))) - (neti:with-stream-timeout (stream :input timeout) - (si:stream-input-block stream "CLX Input"))))) - nil)) - -#+explorer -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((zl:send stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((null timeout) - (si:process-wait "CLX Input" stream :listen)) - (t - (unless (si:process-wait-with-timeout - "CLX Input" (round (* timeout 60.)) stream :listen) - (return-from buffer-input-wait-default :timeout)))) - nil)) - -#+excl -;; -;; This is used so an 'eq' test may be used to find out whether or not we can -;; safely throw this process out of the CLX read loop. -;; -(defparameter *read-whostate* "waiting for input from X server") - -;; -;; Note that this function returns nil on error if the scheduler is running, -;; t on error if not. This is ok since buffer-read will detect the error. -;; -#+excl -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - (let ((fd (display-input-stream display))) - (declare (fixnum fd)) - (when (>= fd 0) - (cond ((fd-char-avail-p fd) - nil) - - ;; Otherwise no bytes were available on the socket - ((and timeout (= timeout 0)) - ;; If there aren't enough and timeout == 0, timeout. - :timeout) - - ;; If the scheduler is running let it do timeouts. - (mp::*scheduler-stack-group* - #+allegro - (if (not - (mp:wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p - :timeout timeout)) - (return-from buffer-input-wait-default :timeout)) - #-allegro - (mp::wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p)) - - ;; Otherwise we have to handle timeouts by hand, and call select() - ;; to block until input is available. Note we don't really handle - ;; the interaction of interrupts and (numberp timeout) here. XX - (t - (let ((res 0)) - (declare (fixnum res)) - (with-interrupt-checking-on - (loop - (setq res (fd-wait-for-input fd (if (null timeout) 0 - (truncate timeout)))) - (cond ((plusp res) ; success - (return nil)) - ((eq res 0) ; timeout - (return :timeout)) - ((eq res -1) ; error - (return t)) - ;; Otherwise we got an interrupt -- go around again. - ))))))))) - - -#+lcl3.0 -(defun buffer-input-wait-default (display timeout) - (declare (type display display) - (type (or null (real 0 *)) timeout) - (clx-values timeout)) - #.(declare-buffun) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((with-underlying-stream (stream stream display input) - (lucid::waiting-for-input-from-stream stream - (lucid::with-io-unlocked - (if (null timeout) - (lcl:process-wait "CLX Input" #'listen stream) - (lcl:process-wait-with-timeout - "CLX Input" timeout #'listen stream))))) - nil) - (:timeout)))) - - -;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the -;;; buffer. This should never block, so it can be called from the scheduler. - -;;; The default implementation is to just use listen. -#-excl -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((stream (display-input-stream display))) - (declare (type (or null stream) stream)) - (if (null stream) - t - (listen stream)))) - -#+excl -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((fd (display-input-stream display))) - (declare (type fixnum fd)) - (if (= fd -1) - t - (fd-char-avail-p fd)))) - - -;;;---------------------------------------------------------------------------- -;;; System dependent speed hacks -;;;---------------------------------------------------------------------------- - -;; -;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. -;; If your lisp doesn't have stack-lists, and you're worried about -;; consing garbage, you may want to re-write this to allocate and -;; initialize lists from a resource. -;; -#-lispm -(defmacro with-stack-list ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -#-lispm -(defmacro with-stack-list* ((var &rest elements) &body body) - ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) - ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) - ;; except that the list produced by MAPCAR resides on the stack and - ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. - `(let ((,var (list* ,@elements))) - (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) - ,@body)) - -(declaim (inline buffer-replace)) - -#+lispm -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type vector buf1 buf2) - (type array-index start1 end1 start2)) - (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1)) - -#+excl -(defun buffer-replace (target-sequence source-sequence target-start - target-end &optional (source-start 0)) - (declare (type buffer-bytes target-sequence source-sequence) - (type array-index target-start target-end source-start) - (optimize (speed 3) (safety 0))) - - (let ((source-end (length source-sequence))) - (declare (type array-index source-end)) - - (excl:if* (and (eq target-sequence source-sequence) - (> target-start source-start)) - then (let ((nelts (min (- target-end target-start) - (- source-end source-start)))) - (do ((target-index (+ target-start nelts -1) (1- target-index)) - (source-index (+ source-start nelts -1) (1- source-index))) - ((= target-index (1- target-start)) target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))) - else (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index))) - ((or (= target-index target-end) (= source-index source-end)) - target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))))) - -#+cmu -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - #.(declare-buffun) - (kernel:bit-bash-copy - buf2 (+ (* start2 vm:byte-bits) - (* vm:vector-data-offset vm:word-bits)) - buf1 (+ (* start1 vm:byte-bits) - (* vm:vector-data-offset vm:word-bits)) - (* (- end1 start1) vm:byte-bits))) - -#+lucid -;;;The compiler is *supposed* to optimize calls to replace, but in actual -;;;fact it does not. -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - #.(declare-buffun) - (let ((end2 (lucid::%simple-8bit-vector-length buf2))) - (declare (type array-index end2)) - (lucid::simple-8bit-vector-replace-internal - buf1 buf2 start1 end1 start2 end2))) - -#+(and clx-overlapping-arrays (not (or lispm excl))) -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type vector buf1 buf2) - (type array-index start1 end1 start2)) - (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) - -#-(or lispm lucid excl CMU clx-overlapping-arrays) -(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) - (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) - (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) - -#+ti -(defun with-location-bindings (sys:"e bindings &rest body) - (do ((bindings bindings (cdr bindings))) - ((null bindings) - (sys:eval-body-as-progn body)) - (sys:bind (sys:*eval `(sys:locf ,(caar bindings))) - (sys:*eval (cadar bindings))))) - -#+ti -(compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form) - (let ((bindings (cadr form)) - (body (cddr form))) - `(let () - ,@(loop for (accessor value) in bindings - collect `(si:bind (si:locf ,accessor) ,value)) - ,@body))) - -#+ti -(defun (:property with-location-bindings compiler::cw-handler) (exp) - (let* ((bindlist (mapcar #'compiler::cw-clause (second exp))) - (body (compiler::cw-clause (cddr exp)))) - (and compiler::cw-return-expansion-flag - (list* (first exp) bindlist body)))) - -#+(and lispm (not ti)) -(defmacro with-location-bindings (bindings &body body) - `(sys:letf* ,bindings ,@body)) - -#+lispm -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - ;; don't use svref on LHS because Symbolics didn't define locf for it - (let* ((local-state (gensym)) - (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway - (dolist (index indexes) - (push `((aref ,local-state ,index) (svref ,saved-state ,index)) - bindings)) - `(let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - (unwind-protect - (with-location-bindings ,bindings - ,@body) - (setf (svref ,local-state ,ts-index) 0) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state))))) - -#-lispm -(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) - (let ((local-state (gensym)) - (resets nil)) - (dolist (index indexes) - (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) - `(unwind-protect - (progn - ,@body) - (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state)))) - -;;;---------------------------------------------------------------------------- -;;; How error detection should CLX do? -;;; Several levels are possible: -;;; -;;; 1. Do the equivalent of check-type on every argument. -;;; -;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format -;;; strings generated by check-type. -;;; -;;; 3. Do error checking only on arguments that are likely to have errors -;;; (like keyword names) -;;; -;;; 4. Do error checking only where not doing so may dammage the envirnment -;;; on a non-tagged machine (i.e. when storing into a structure that has -;;; been passed in) -;;; -;;; 5. No extra error detection code. On lispm's, ASET may barf trying to -;;; store a non-integer into a number array. -;;; -;;; How extensive should the error checking be? For example, if the server -;;; expects a CARD16, is is sufficient for CLX to check for integer, or -;;; should it also check for non-negative and less than 65536? -;;;---------------------------------------------------------------------------- - -;; The *TYPE-CHECK?* constant controls how much error checking is done. -;; Possible values are: -;; NIL - Don't do any error checking -;; t - Do the equivalent of checktype on every argument -;; :minimal - Do error checking only where errors are likely - -;;; This controls macro expansion, and isn't changable at run-time You will -;;; probably want to set this to nil if you want good performance at -;;; production time. -(defconstant *type-check?* #+(or Genera Minima CMU) nil #-(or Genera Minima CMU) t) - -;; TYPE? is used to allow the code to do error checking at a different level from -;; the declarations. It also does some optimizations for systems that don't have -;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. -;; include range checks. You can modify TYPE? to do less extensive checking -;; for these types if you desire. - -;; -;; ### This comment is a lie! TYPE? is really also used for run-time type -;; dispatching, not just type checking. -- Ram. - -(defmacro type? (object type) - #+cmu - `(typep ,object ,type) - #-cmu - (if (not (constantp type)) - `(typep ,object ,type) - (progn - (setq type (eval type)) - #+(or Genera explorer Minima) - (if *type-check?* - `(locally (declare (optimize safety)) (typep ,object ',type)) - `(typep ,object ',type)) - #-(or Genera explorer Minima) - (let ((predicate (assoc type - '((drawable drawable-p) (window window-p) - (pixmap pixmap-p) (cursor cursor-p) - (font font-p) (gcontext gcontext-p) - (colormap colormap-p) (null null) - (integer integerp))))) - (cond (predicate - `(,(second predicate) ,object)) - ((eq type 'boolean) - 't) ; Everything is a boolean. - (*type-check?* - `(locally (declare (optimize safety)) (typep ,object ',type))) - (t - `(typep ,object ',type))))))) - -;; X-TYPE-ERROR is the function called for type errors. -;; If you want lots of checking, but are concerned about code size, -;; this can be made into a macro that ignores some parameters. - -(defun x-type-error (object type &optional error-string) - (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) - - -;;----------------------------------------------------------------------------- -;; Error handlers -;; Hack up KMP error signaling using zetalisp until the real thing comes -;; along -;;----------------------------------------------------------------------------- - -(defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) - (declare (type boolean asynchronous) - (dynamic-extent key-vals)) - ;; The default display-error-handler. - ;; It signals the conditions listed in the DISPLAY file. - (if asynchronous - (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) - (apply #'x-error error-key :display display :error-key error-key key-vals))) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (apply #'sys:signal condition keyargs)) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (sys:signal (apply #'zl:make-condition condition keyargs) - :proceed-types proceed-format-string)) - -#+(and Genera (not clx-ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition keyargs)) - -#+(and Genera (not clx-ansi-common-lisp)) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs)) - -#+(or clx-ansi-common-lisp excl lcl3.0) -(defun x-error (condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'error condition keyargs)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dynamic-extent keyargs)) - (apply #'cerror proceed-format-string condition keyargs)) - -;;; X-ERROR for CMU Common Lisp -;;; -;;; We detect a couple condition types for which we disable event handling in -;;; our system. This prevents going into the debugger or returning to a -;;; command prompt with CLX repeatedly seeing the same condition. This occurs -;;; because CMU Common Lisp provides for all events (that is, X, input on file -;;; descriptors, Mach messages, etc.) to come through one routine anyone can -;;; use to wait for input. -;;; -#+CMU -(defun x-error (condition &rest keyargs) - (let ((condx (apply #'make-condition condition keyargs))) - (typecase condx - ;; This condition no longer exists. - #|| - (server-disconnect - (let ((disp (server-disconnect-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp))) - ||# - (closed-display - (let ((disp (closed-display-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp)))) - (error condx))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU) -(defun x-error (condition &rest keyargs) - (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -#+lcl3.0 -(defmacro define-condition (name parent-types &optional slots &rest args) - `(lcl:define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and excl (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(excl::define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and CMU (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(lisp:define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and lispm (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &body options) - (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil)) - (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) - `(within-definition (,name define-condition) - (zl:defflavor ,name ,slot-names ,parent-types - :initable-instance-variables - #-Genera - (:accessor-prefix ,conc-name) - #+Genera - (:conc-name ,conc-name) - #-Genera - (:outside-accessible-instance-variables ,@slot-names) - #+Genera - (:readable-instance-variables ,@slot-names)) - ,(when reporter ;; when no reporter, parent's is inherited - `(zl:defmethod #-Genera (,name :report) - #+Genera (dbg:report ,name) (stream) - ,(if (stringp reporter) - `(write-string ,reporter stream) - `(,reporter global:self stream)) - global:self)) - (zl:compile-flavor-methods ,name) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ',name))) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(zl:defflavor x-error () (global:error)) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defflavor x-error - ((dbg:proceed-types '(:continue)) ; - continue-format-string) - (sys:error) - (:initable-instance-variables continue-format-string)) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defmethod (scl:make-instance x-error) (&rest ignore) - (when (not (sys:variable-boundp continue-format-string)) - (setf dbg:proceed-types (remove :continue dbg:proceed-types)))) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defmethod (dbg:proceed x-error :continue) () - :continue) - -#+(and Genera (not clx-ansi-common-lisp)) -(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream) - (format stream continue-format-string)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) -(define-condition x-error (error) ()) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU) -(defstruct x-error - report-function) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU) -(defmacro define-condition (name parent-types &body options) - ;; Define a structure that when printed displays an error message - (flet ((reporter-for-condition (name) - (xintern "." name '-reporter.))) - (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil) - (condition (gensym)) - (stream (gensym)) - (report-function (reporter-for-condition name))) - (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) - (unless reporter - (setq report-function (reporter-for-condition (first parent-types)))) - `(within-definition (,name define-condition) - (defstruct (,name (:conc-name ,(intern conc-name)) - (:print-function condition-print) - (:include ,(first parent-types) - (report-function ',report-function))) - ,@slot-names) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ,(when reporter - `(defun ,report-function (,condition ,stream) - ,(if (stringp reporter) - `(write-string ,reporter ,stream) - `(,reporter ,condition ,stream)) - ,condition)) - ',name)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU) -(defun condition-print (condition stream depth) - (declare (type x-error condition) - (type stream stream) - (ignore depth)) - (if *print-escape* - (print-unreadable-object (condition stream :type t)) - (funcall (x-error-report-function condition) condition stream)) - condition) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU) -(defun make-condition (type &rest slot-initializations) - (declare (dynamic-extent slot-initializations)) - (let ((make-function (intern (concatenate 'string (string 'make-) (string type)) - (symbol-package type)))) - (apply make-function slot-initializations))) - -#-(or clx-ansi-common-lisp excl lcl3.0 CMU) -(define-condition type-error (x-error) - ((datum :reader type-error-datum :initarg :datum) - (expected-type :reader type-error-expected-type :initarg :expected-type)) - (:report - (lambda (condition stream) - (format stream "~s isn't a ~a" - (type-error-datum condition) - (type-error-expected-type condition))))) - - -;;----------------------------------------------------------------------------- -;; HOST hacking -;;----------------------------------------------------------------------------- - -#-(or explorer Genera Minima Allegro CMU) -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - host family - (error "HOST-ADDRESS not implemented yet.")) - -#+explorer -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (ecase family - ((:internet nil 0) - (let ((addr (ip:get-ip-address host))) - (unless addr (error "~s isn't an internet host name" host)) - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr)))) - ((:chaos 2) - (let ((addr (first (chaos:chaos-addresses host)))) - (unless addr (error "~s isn't a chaos host name" host)) - (list :chaos - (ldb (byte 8 0) addr) - (ldb (byte 8 8) addr)))))) - -#+Genera -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (setf host (string host)) - (let ((net-type (ecase family - ((:internet nil 0) :internet) - ((:DECnet 1) :dna) - ((:chaos 2) :chaos)))) - (dolist (addr - (sys:send (net:parse-host host) :network-addresses) - (error "~S isn't a valid ~(~A~) host name" host family)) - (let ((network (car addr)) - (address (cadr addr))) - (when (sys:send network :network-typep net-type) - (return (ecase family - ((:internet nil 0) - (multiple-value-bind (a b c d) (tcp:explode-internet-address address) - (list :internet a b c d))) - ((:DECnet 1) - (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address))) - ((:chaos 2) - (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) - -#+Minima -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (etypecase family - ((:internet nil 0) - (list* :internet - (multiple-value-list - (minima:ip-address-components (minima:parse-ip-address (string host)))))))) - -#+Allegro -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - (let ((hostent 0)) - (unwind-protect - (progn - (setf hostent (ipc::gethostbyname (string host))) - (when (zerop hostent) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (ipc::hostent-addrtype hostent) 2) - (no-address-error)) - (assert (= (ipc::hostent-length hostent) 4)) - (let ((addr (ipc::hostent-addr hostent))) - (when (or (member comp::.target. - '(:hp :sgi4d :sony :dec3100) - :test #'eq) - (probe-file "/lib/ld.so")) - ;; BSD 4.3 based systems require an extra indirection - (setq addr (si:memref-int addr 0 0 :unsigned-long))) - (list :internet - (si:memref-int addr 0 0 :unsigned-byte) - (si:memref-int addr 1 0 :unsigned-byte) - (si:memref-int addr 2 0 :unsigned-byte) - (si:memref-int addr 3 0 :unsigned-byte)))))) - (ff:free-cstruct hostent))))) - -#+CMU -(defun host-address (host &optional (family :internet)) - ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (declare (clx-values list)) - (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) - (let ((hostent (ext:lookup-host-entry (string host)))) - (when (not hostent) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (ext::host-entry-addr-type hostent) 2) - (no-address-error)) - (let ((addr (first (ext::host-entry-addr-list hostent)))) - (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr)))))))) - -;;; - -#+explorer ;; This isn't required, but it helps make sense of the results from access-hosts -(defun get-host (host-object) - ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type list host-object)) - (declare (clx-values string family)) - (let* ((family (first host-object)) - (address (ecase family - (:internet - (dpb (second host-object) - (byte 8 24) - (dpb (third host-object) - (byte 8 16) - (dpb (fourth host-object) - (byte 8 8) - (fifth host-object))))) - (:chaos - (dpb (third host-object) (byte 8 8) (second host-object)))))) - (when (eq family :internet) (setq family :ip)) - (let ((host (si:get-host-from-address address family))) - (values (and host (funcall host :name)) family)))) - -;;; This isn't required, but it helps make sense of the results from access-hosts -#+Genera -(defun get-host (host-object) - ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type list host-object)) - (declare (clx-values string family)) - (let ((family (first host-object))) - (values (sys:send (net:get-host-from-address - (ecase family - (:internet - (apply #'tcp:build-internet-address (rest host-object))) - ((:chaos :DECnet) - (dpb (third host-object) (byte 8 8) (second host-object)))) - (net:local-network-of-type (if (eq family :DECnet) - :DNA - family))) - :name) - family))) - -;;; This isn't required, but it helps make sense of the results from access-hosts -#+Minima -(defun get-host (host-object) - ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) - ;; and cdr is a list of network address bytes. - (declare (type list host-object)) - (declare (clx-values string family)) - (let ((family (first host-object))) - (values (ecase family - (:internet - (minima:ip-address-string - (apply #'minima:make-ip-address (rest host-object))))) - family))) - - -;;----------------------------------------------------------------------------- -;; Whether to use closures for requests or not. -;;----------------------------------------------------------------------------- - -;;; If this macro expands to non-NIL, then request and locking code is -;;; compiled in a much more compact format, as the common code is shared, and -;;; the specific code is built into a closure that is funcalled by the shared -;;; code. If your compiler makes efficient use of closures then you probably -;;; want to make this expand to T, as it makes the code more compact. - -(defmacro use-closures () - #+(or lispm Minima) t - #-(or lispm Minima) nil) - -#+(or Genera Minima) -(defun clx-macroexpand (form env) - (declare (ignore env)) - form) - -#-(or Genera Minima) -(defun clx-macroexpand (form env) - (macroexpand form env)) - - -;;----------------------------------------------------------------------------- -;; Resource stuff -;;----------------------------------------------------------------------------- - - -;;; Utilities - -(defun getenv (name) - #+excl (sys:getenv name) - #+lcl3.0 (lcl:environment-value name) - #+CMU (cdr (assoc name ext:*environment-list* :test #'string=)) - #-(or excl lcl3.0 CMU) (progn name nil)) - -(defun homedir-file-pathname (name) - (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) - (merge-pathnames (user-homedir-pathname) (pathname name)))) - -;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if -;;; a resource manager isn't running. - -(defun default-resources-pathname () - (homedir-file-pathname ".Xdefaults")) - -;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the -;;; defaults have been loaded. - -(defun resources-pathname () - (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) - (homedir-file-pathname (concatenate 'string ".Xdefaults-" - #+excl (short-site-name) - #-excl (machine-instance))))) - -;;; AUTHORITY-PATHNAME - The pathname of the authority file. - -(defun authority-pathname () - (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) - (homedir-file-pathname ".Xauthority"))) - - -;;----------------------------------------------------------------------------- -;; GC stuff -;;----------------------------------------------------------------------------- - -(defun gc-cleanup () - (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) - (setq *event-free-list* nil) - (setq *pending-command-free-list* nil) - (when (boundp '*reply-buffer-free-lists*) - (fill *reply-buffer-free-lists* nil)) - (setq *gcontext-local-state-cache* nil) - (setq *temp-gcontext-cache* nil) - nil) - -#+Genera -(si:define-gc-cleanup clx-cleanup ("CLX Cleanup") - (gc-cleanup)) - - -;;----------------------------------------------------------------------------- -;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera) -(defun with-standard-io-syntax-function (function) - (declare #+lispm - (sys:downward-funarg function)) - (let ((*package* (find-package :user)) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - #+ticl (ticl:*print-structure* t) - #+lucid (lucid::*print-structure* t)) - (funcall function))) - -#-(or clx-ansi-common-lisp Genera) -(defmacro with-standard-io-syntax (&body body) - `(flet ((.with-standard-io-syntax-body. () ,@body)) - (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) - - -;;----------------------------------------------------------------------------- -;; DEFAULT-KEYSYM-TRANSLATE -;;----------------------------------------------------------------------------- - -;;; If object is a character, char-bits are set from state. -;;; -;;; [the following isn't implemented (should it be?)] -;;; If object is a list, it is an alist with entries: -;;; (base-char [modifiers] [mask-modifiers]) -;;; When MODIFIERS are specified, this character translation -;;; will only take effect when the specified modifiers are pressed. -;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. -;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. -;;; In ambiguous cases, the most specific translation is used. - -#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU) -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (clx-values t) - (special left-meta-keysym right-meta-keysym - left-super-keysym right-super-keysym - left-hyper-keysym right-hyper-keysym)) - (when (characterp object) - (when (logbitp (position :control *state-mask-vector*) state) - (setf (char-bit object :control) 1)) - (when (or (state-keysymp display state left-meta-keysym) - (state-keysymp display state right-meta-keysym)) - (setf (char-bit object :meta) 1)) - (when (or (state-keysymp display state left-super-keysym) - (state-keysymp display state right-super-keysym)) - (setf (char-bit object :super) 1)) - (when (or (state-keysymp display state left-hyper-keysym) - (state-keysymp display state right-hyper-keysym)) - (setf (char-bit object :hyper) 1))) - object) - -#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU) -(defun default-keysym-translate (display state object) - (declare (type display display) - (type card16 state) - (type t object) - (ignore display state) - (clx-values t)) - object) - - -;;----------------------------------------------------------------------------- -;; Image stuff -;;----------------------------------------------------------------------------- - -;;; Types - -(deftype pixarray-1-element-type () - 'bit) - -(deftype pixarray-4-element-type () - '(unsigned-byte 4)) - -(deftype pixarray-8-element-type () - '(unsigned-byte 8)) - -(deftype pixarray-16-element-type () - '(unsigned-byte 16)) - -(deftype pixarray-24-element-type () - '(unsigned-byte 24)) - -(deftype pixarray-32-element-type () - #-(or Genera Minima) '(unsigned-byte 32) - #+(or Genera Minima) 'fixnum) - -(deftype pixarray-1 () - '(array pixarray-1-element-type (* *))) - -(deftype pixarray-4 () - '(array pixarray-4-element-type (* *))) - -(deftype pixarray-8 () - '(array pixarray-8-element-type (* *))) - -(deftype pixarray-16 () - '(array pixarray-16-element-type (* *))) - -(deftype pixarray-24 () - '(array pixarray-24-element-type (* *))) - -(deftype pixarray-32 () - '(array pixarray-32-element-type (* *))) - -(deftype pixarray () - '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) - -(deftype bitmap () - 'pixarray-1) - -;;; WITH-UNDERLYING-SIMPLE-VECTOR - -#+Genera -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - (let ((bits-per-element - (sys:array-bits-per-element - (symbol-value (sys:type-array-element-type element-type))))) - `(scl:stack-let ((,variable - (make-array - (index-ceiling - (index* (array-total-size ,pixarray) - (sys:array-element-size ,pixarray)) - ,bits-per-element) - :element-type ',element-type - :displaced-to ,pixarray))) - (declare (type (vector ,element-type) ,variable)) - ,@body))) - -#+lcl3.0 -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - `(let ((,variable (sys:underlying-simple-vector ,pixarray))) - (declare (type (simple-array ,element-type (*)) ,variable)) - ,@body)) - -#+excl -(defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) - `(let ((,variable (cdr (excl::ah_data ,pixarray)))) - (declare (type (simple-array ,element-type (*)) ,variable)) - ,@body)) - -;;; These are used to read and write pixels from and to CARD8s. - -;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. - -(defmacro read-image-load-byte (size position integer) - (unless *image-bit-lsb-first-p* (setq position (- 7 position))) - `(the (unsigned-byte ,size) - (#-Genera ldb #+Genera sys:%logldb - (byte ,size ,position) - (the card8 ,integer)))) - -;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from -;;; the appropriate number of CARD8s. - -(defmacro read-image-assemble-bytes (&rest bytes) - (unless *image-byte-lsb-first-p* (setq bytes (reverse bytes))) - (let ((it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it - `(#-Genera dpb #+Genera sys:%logdpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) - #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) - #+Genera it)) - -;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit -;;; pixel. - -(defmacro write-image-load-byte (position integer integer-size) - integer-size - (unless *image-byte-lsb-first-p* (setq position (- integer-size 8 position))) - `(the card8 - (#-Genera ldb #+Genera sys:%logldb - (byte 8 ,position) - #-Genera (the (unsigned-byte ,integer-size) ,integer) - #+Genera ,integer - ))) - -;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit -;;; pixels. - -(defmacro write-image-assemble-bytes (&rest bytes) - (unless *image-bit-lsb-first-p* (setq bytes (reverse bytes))) - (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) - (dolist (byte (rest bytes)) - (setq it `(#-Genera dpb #+Genera sys:%logdpb - (the (unsigned-byte ,size) ,byte) - (byte ,size ,(incf count size)) - (the (unsigned-byte ,count) ,it)))) - `(the card8 ,it))) - -#+(or Genera lcl3.0 excl) -(defvar *computed-image-byte-lsb-first-p* *image-byte-lsb-first-p*) - -#+(or Genera lcl3.0 excl) -(defvar *computed-image-bit-lsb-first-p* *image-bit-lsb-first-p*) - -;;; The following table gives the bit ordering within bytes (when accessed -;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to -;;; 31, where bit 0 should be leftmost on the display. For a given byte -;;; labelled A-B, A is for the most significant bit of the byte, and B is -;;; for the least significant bit. -;;; -;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant -;;; -;;; -;;; format ordering -;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 - -#+(or Genera lcl3.0 excl) -(defconstant - *image-bit-ordering-table* - '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) - ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) - ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) - ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) - ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) - ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) - ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) - ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) - ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) - ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) - -#+(or Genera lcl3.0 excl) -(defun compute-image-byte-and-bit-ordering () - (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) - ;; First compute the ordering - (let ((ordering nil) - (a (make-array '(1 32) :element-type 'bit :initial-element 0))) - (dotimes (i 4) - (push (flet ((bitpos (a i n) - (declare (optimize (speed 3) (safety 0) (space 0))) - (declare (type (simple-array bit (* *)) a) - (type fixnum i n)) - (with-underlying-simple-vector (v (unsigned-byte 8) a) - (prog2 - (setf (aref v i) n) - (dotimes (i 32) - (unless (zerop (aref a 0 i)) - (return i))) - (setf (aref v i) 0))))) - (list (bitpos a i #b10000000) - (bitpos a i #b00000001))) - ordering)) - (setq ordering (cons (floor *image-unit* 8) (nreverse ordering))) - ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p - (let ((byte-and-bit-ordering - (second (assoc ordering *image-bit-ordering-table* - :test #'equal)))) - (unless byte-and-bit-ordering - (error "Couldn't determine image byte and bit ordering~@ - measured image ordering = ~A" - ordering)) - (values-list byte-and-bit-ordering)))) - -#+(or Genera lcl3.0 excl) -(multiple-value-setq - (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (compute-image-byte-and-bit-ordering)) - -;;; If you can write fast routines that can read and write pixarrays out of a -;;; buffer-bytes, do it! It makes the image code a lot faster. The -;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines -;;; return T if they can do it, NIL if they can't. - -;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-1-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (index-mod (index- x) 8)) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (index- width left-bits right-bits)) - (middle-bytes (index-floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y - left-bits right-bits middle-bits middle-bytes)) - (cond ((index< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-bits) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (array-row-major-index - array y (index+ left-bits middle-bits)))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref vector (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) - t) - -#+(or lcl3.0 excl) -(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-4-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (index-mod (index- x) 2)) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-nibbles) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) - t) - -#+(or Genera lcl3.0 excl) -(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y 0) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref vector x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) - t) - -#+lispm -(defun fast-read-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (#+Genera sys:stack-let* #-Genera let* - ((dimensions (list (+ y height) - (floor (* padded-bytes-per-line 8) bits-per-pixel))) - (a (make-array - dimensions - :element-type (array-element-type pixarray) - :displaced-to bbuf - :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) - (sys:bitblt boole-1 width height a x y pixarray 0 0)) - t) - -#+(or Genera lcl3.0 excl) -(defun fast-read-pixarray-with-swap - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (x-bits (index* x bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line x-bits)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod x-bits 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line *image-unit*)) - (index-zerop (index-mod x-bits *image-unit*)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - *image-unit* *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p*) - (declare (type symbol image-swap-function) - (type boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (dst card8 pixarray) - (funcall - (symbol-function image-swap-function) bbuf dst - (index+ boffset - (index* y padded-bytes-per-line) - (index-floor x-bits 8)) - 0 (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line - (index-floor pixarray-padded-bits-per-line 8) - height image-swap-lsb-first-p))) - t)))) - -(defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - #+(or Genera lcl3.0 excl) - (fast-read-pixarray-with-swap - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-read-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-read-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-read-pixarray-4) - #+(or Genera lcl3.0 excl) - (and (index= bits-per-pixel 24) - #'fast-read-pixarray-24)))) - (when function - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - unit byte-lsb-first-p bit-lsb-first-p - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*))))) - -;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-1-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (array-row-major-index - array y (index+ start-x middle-bits)))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (if (index> right-bits 1) - (aref vector (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref vector (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref vector (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref vector (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref vector (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref vector (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)) - (aref vector (index+ x 2)) - (aref vector (index+ x 3)) - (aref vector (index+ x 4)) - (aref vector (index+ x 5)) - (aref vector (index+ x 6)) - (aref vector (index+ x 7)))))))) - t) - -#+(or lcl3.0 excl) -(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-4-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)))))))) - t) - -#+(or Genera lcl3.0 excl) -(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (with-underlying-simple-vector (vector pixarray-24-element-type array) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y x) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref vector x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) - t) - -#+lispm -(defun fast-write-pixarray-using-bitblt - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (#+Genera sys:stack-let* #-Genera let* - ((dimensions (list (+ y height) - (floor (* padded-bytes-per-line 8) bits-per-pixel))) - (a (make-array - dimensions - :element-type (array-element-type pixarray) - :displaced-to bbuf - :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) - (sys:bitblt boole-1 width height pixarray x y a 0 0)) - t) - -#+(or Genera lcl3.0 excl) -(defun fast-write-pixarray-with-swap - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line *image-unit*)) - (index-zerop (index-mod pixarray-start-bit-offset *image-unit*)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - *image-unit* *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p* - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (src card8 pixarray) - (funcall - (symbol-function image-swap-function) - src bbuf (index-floor pixarray-start-bit-offset 8) boffset - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - padded-bytes-per-line height image-swap-lsb-first-p)) - t))))) - -(defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (or - #+(or Genera lcl3.0 excl) - (fast-write-pixarray-with-swap - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-write-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-write-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-write-pixarray-4) - #+(or Genera lcl3.0 excl) - (and (index= bits-per-pixel 24) - #'fast-write-pixarray-24)))) - (when function - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p* - unit byte-lsb-first-p bit-lsb-first-p))))) - -;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another - -(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) - (declare (type pixarray pixarray copy) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (progn pixarray copy x y width height bits-per-pixel nil) - (or - #+lispm - (let* ((pixarray-padded-pixels-per-line - #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1)) - (pixarray-padded-bits-per-line - (* pixarray-padded-pixels-per-line bits-per-pixel)) - (copy-padded-pixels-per-line - #+Genera (sys:array-row-span copy) - #-Genera (array-dimension copy 1)) - (copy-padded-bits-per-line - (* copy-padded-pixels-per-line bits-per-pixel))) - (when (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod pixarray-padded-bits-per-line 32)) - (zerop (index-mod copy-padded-bits-per-line 32))) - (sys:bitblt boole-1 width height pixarray x y copy 0 0) - t)) - #+(or lcl3.0 excl) - (unless (index= bits-per-pixel 24) - (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (copy-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index copy 1 0) - (array-row-major-index copy 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - copy-padded-bits-per-line pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod copy-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line *image-unit*)) - (index-zerop (index-mod copy-padded-bits-per-line *image-unit*)) - (index-zerop (index-mod pixarray-start-bit-offset *image-unit*)))) - (with-underlying-simple-vector (src card8 pixarray) - (with-underlying-simple-vector (dst card8 copy) - (image-noswap - src dst - (index-floor pixarray-start-bit-offset 8) 0 - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - (index-floor copy-padded-bits-per-line 8) - height nil))) - t))) - #+(or lcl3.0 excl) - (macrolet - ((copy (type element-type) - `(let ((pixarray pixarray) - (copy copy)) - (declare (type ,type pixarray copy)) - #.(declare-buffun) - (with-underlying-simple-vector (src ,element-type pixarray) - (with-underlying-simple-vector (dst ,element-type copy) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-idx (array-row-major-index copy dst-y 0) - (index1+ dst-idx)) - (dst-end (index+ dst-idx width)) - (src-idx (array-row-major-index pixarray src-y x) - (index1+ src-idx))) - ((index>= dst-idx dst-end)) - (declare (type array-index dst-idx src-idx dst-end)) - (setf (aref dst dst-idx) - (the ,element-type (aref src src-idx)))))))))) - (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))) - t))) diff --git a/clx/display.lisp b/clx/display.lisp deleted file mode 100644 index a8f5307b5058439593764c51b9a7dda48ef96cee..0000000000000000000000000000000000000000 --- a/clx/display.lisp +++ /dev/null @@ -1,574 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;;; Authorizaton - -(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1")) - -(defun get-best-authorization (host display protocol) - (labels ((read-short (stream &optional (eof-errorp t)) - (let ((high-byte (read-byte stream eof-errorp))) - (and high-byte - (dpb high-byte (byte 8 8) (read-byte stream))))) - (read-short-length-string (stream) - (let ((length (read-short stream))) - (let ((string (make-string length))) - (dotimes (k length) - (setf (schar string k) (card8->char (read-byte stream)))) - string))) - (read-short-length-vector (stream) - (let ((length (read-short stream))) - (let ((vector (make-array length :element-type '(unsigned-byte 8)))) - (dotimes (k length) - (setf (aref vector k) (read-byte stream))) - vector)))) - (let ((pathname (authority-pathname))) - (when pathname - (with-open-file (stream pathname :element-type '(unsigned-byte 8) - :if-does-not-exist nil) - (when stream - (let* ((host-family (ecase protocol - ((:tcp :internet nil) 0) - ((:dna :DECnet) 1) - ((:chaos) 2))) - (host-address (rest (host-address host host-family))) - (best-name nil) - (best-data nil)) - (loop - (let ((family (read-short stream nil))) - (when (null family) - (return)) - (let* ((address (read-short-length-vector stream)) - (number (parse-integer (read-short-length-string stream))) - (name (read-short-length-string stream)) - (data (read-short-length-vector stream))) - (when (and (= family host-family) - (equal host-address (coerce address 'list)) - (= number display) - (let ((pos1 (position name *known-authorizations* :test #'string=))) - (and pos1 - (or (null best-name) - (< pos1 (position best-name *known-authorizations* - :test #'string=)))))) - (setf best-name name) - (setf best-data data))))) - (when best-name - (return-from get-best-authorization - (values best-name best-data))))))))) - (values "" "")) - -;; -;; Resource id management -;; -(defun initialize-resource-allocator (display) - ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask - (let ((id-mask (display-resource-id-mask display))) - (unless (zerop id-mask) ;; zero mask is an error - (do ((first 0 (index1+ first)) - (mask id-mask (the mask32 (ash mask -1)))) - ((oddp mask) - (setf (display-resource-id-byte display) - (byte (integer-length mask) first))) - (declare (type array-index first) - (type mask32 mask)))))) - -(defun resourcealloc (display) - ;; Allocate a resource-id for in DISPLAY - (declare (type display display)) - (declare (clx-values resource-id)) - (dpb (incf (display-resource-id-count display)) - (display-resource-id-byte display) - (display-resource-id-base display))) - -(defmacro allocate-resource-id (display object type) - ;; Allocate a resource-id for OBJECT in DISPLAY - (if (member (eval type) *clx-cached-types*) - `(let ((id (funcall (display-xid ,display) ,display))) - (save-id ,display id ,object) - id) - `(funcall (display-xid ,display) ,display))) - -(defmacro deallocate-resource-id (display id type) - ;; Deallocate a resource-id for OBJECT in DISPLAY - (when (member (eval type) *clx-cached-types*) - `(deallocate-resource-id-internal ,display ,id))) - -(defun deallocate-resource-id-internal (display id) - (remhash id (display-resource-id-map display))) - -(defun lookup-resource-id (display id) - ;; Find the object associated with resource ID - (gethash id (display-resource-id-map display))) - -(defun save-id (display id object) - ;; Register a resource-id from another display. - (declare (type display display) - (type integer id) - (type t object)) - (declare (clx-values object)) - (setf (gethash id (display-resource-id-map display)) object)) - -;; Define functions to find the CLX data types given a display and resource-id -;; If the data type is being cached, look there first. -(macrolet ((generate-lookup-functions (useless-name &body types) - `(within-definition (,useless-name generate-lookup-functions) - ,@(mapcar - #'(lambda (type) - `(defun ,(xintern 'lookup- type) - (display id) - (declare (type display display) - (type resource-id id)) - (declare (clx-values ,type)) - ,(if (member type *clx-cached-types*) - `(let ((,type (lookup-resource-id display id))) - (cond ((null ,type) ;; Not found, create and save it. - (setq ,type (,(xintern 'make- type) - :display display :id id)) - (save-id display id ,type)) - ;; Found. Check the type - ,(cond ((null *type-check?*) - `(t ,type)) - ((member type '(window pixmap)) - `((type? ,type 'drawable) ,type)) - (t `((type? ,type ',type) ,type))) - ,@(when *type-check?* - `((t (x-error 'lookup-error - :id id - :display display - :type ',type - :object ,type)))))) - ;; Not being cached. Create a new one each time. - `(,(xintern 'make- type) - :display display :id id)))) - types)))) - (generate-lookup-functions ignore - drawable - window - pixmap - gcontext - cursor - colormap - font)) - -(defun id-atom (id display) - ;; Return the cached atom for an atom ID - (declare (type resource-id id) - (type display display)) - (declare (clx-values (or null keyword))) - (gethash id (display-atom-id-map display))) - -(defun atom-id (atom display) - ;; Return the ID for an atom in DISPLAY - (declare (type xatom atom) - (type display display)) - (declare (clx-values (or null resource-id))) - (gethash (if (or (null atom) (keywordp atom)) atom (kintern atom)) - (display-atom-cache display))) - -(defun set-atom-id (atom display id) - ;; Set the ID for an atom in DISPLAY - (declare (type xatom atom) - (type display display) - (type resource-id id)) - (declare (clx-values resource-id)) - (let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom)))) - (setf (gethash id (display-atom-id-map display)) atom) - (setf (gethash atom (display-atom-cache display)) id) - id)) - -(defsetf atom-id set-atom-id) - -(defun initialize-predefined-atoms (display) - (dotimes (i (length *predefined-atoms*)) - (declare (type resource-id i)) - (setf (atom-id (svref *predefined-atoms* i) display) i))) - -(defun visual-info (display visual-id) - (declare (type display display) - (type resource-id visual-id) - (clx-values visual-info)) - (when (zerop visual-id) - (return-from visual-info nil)) - (dolist (screen (display-roots display)) - (declare (type screen screen)) - (dolist (depth (screen-depths screen)) - (declare (type cons depth)) - (dolist (visual-info (rest depth)) - (declare (type visual-info visual-info)) - (when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info)) - (return-from visual-info visual-info))))) - (error "Visual info not found for id #x~x in display ~s." visual-id display)) - - -;; -;; Display functions -;; -(defmacro with-display ((display &key timeout inline) - &body body) - ;; This macro is for use in a multi-process environment. It provides exclusive - ;; access to the local display object for multiple request generation. It need not - ;; provide immediate exclusive access for replies; that is, if another process is - ;; waiting for a reply (while not in a with-display), then synchronization need not - ;; (but can) occur immediately. Except where noted, all routines effectively - ;; contain an implicit with-display where needed, so that correct synchronization - ;; is always provided at the interface level on a per-call basis. Nested uses of - ;; this macro will work correctly. This macro does not prevent concurrent event - ;; processing; see with-event-queue. - `(with-buffer (,display - ,@(and timeout `(:timeout ,timeout)) - ,@(and inline `(:inline ,inline))) - ,@body)) - -(defmacro with-event-queue ((display &key timeout inline) - &body body &environment env) - ;; exclusive access to event queue - `(macrolet ((with-event-queue ((display &key timeout) &body body) - ;; Speedup hack for lexically nested with-event-queues - `(progn - (progn ,display ,@(and timeout `(,timeout)) nil) - ,@body))) - ,(if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.with-event-queue-body. () ,@body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.with-event-queue-body.)) - (with-event-queue-function - ,display ,timeout #'.with-event-queue-body.)) - (let ((disp (if (or (symbolp display) (constantp display)) - display - '.display.))) - `(let (,@(unless (eq disp display) `((,disp ,display)))) - (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))))) - -(defun with-event-queue-function (display timeout function) - (declare (type display display) - (type (or null number) timeout) - (type function function) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) - (with-event-queue (display :timeout timeout :inline t) - (funcall function))) - -(defmacro with-event-queue-internal ((display &key timeout) &body body) - ;; exclusive access to the internal event queues - (let ((disp (if (or (symbolp display) (constantp display)) display '.display.))) - `(let (,@(unless (eq disp display) `((,disp ,display)))) - (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))) - -(defun open-display (host &key (display 0) protocol authorization-name authorization-data) - ;; Implementation specific routine to setup the buffer for a specific host and display. - ;; This must interface with the local network facilities, and will probably do special - ;; things to circumvent the nework when displaying on the local host. - ;; - ;; A string must be acceptable as a host, but otherwise the possible types - ;; for host and protocol are not constrained, and will likely be very - ;; system dependent. The default protocol is system specific. Authorization, - ;; if any, is assumed to come from the environment somehow. - (declare (type integer display)) - (declare (clx-values display)) - ;; Get the authorization mechanism from the environment. - (when (null authorization-name) - (multiple-value-setq (authorization-name authorization-data) - (get-best-authorization host display protocol))) - ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. - (let* ((stream (open-x-stream host display protocol)) - (disp (make-buffer *output-buffer-size* #'make-display-internal - :host host :display display - :output-stream stream :input-stream stream)) - (ok-p nil)) - (unwind-protect - (progn - (display-connect disp - :authorization-name authorization-name - :authorization-data authorization-data) - (setf (display-authorization-name disp) authorization-name) - (setf (display-authorization-data disp) authorization-data) - (initialize-resource-allocator disp) - (initialize-predefined-atoms disp) - (initialize-extensions disp) - (setq ok-p t)) - (unless ok-p (close-display disp :abort t))) - disp)) - -(defun display-force-output (display) - ; Output is normally buffered, this forces any buffered output to the server. - (declare (type display display)) - (with-display (display) - (buffer-force-output display))) - -(defun close-display (display &key abort) - ;; Close the host connection in DISPLAY - (declare (type display display)) - (close-buffer display :abort abort)) - -(defun display-connect (display &key authorization-name authorization-data) - (with-buffer-output (display :sizes (8 16)) - (card8-put - 0 - (ecase (display-byte-order display) - (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First - (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First - (card16-put 2 *protocol-major-version*) - (card16-put 4 *protocol-minor-version*) - (card16-put 6 (length authorization-name)) - (card16-put 8 (length authorization-data)) - (write-sequence-char display 12 authorization-name) - (if (stringp authorization-data) - (write-sequence-char display (lround (+ 12 (length authorization-name))) - authorization-data) - (write-sequence-card8 display (lround (+ 12 (length authorization-name))) - authorization-data))) - (buffer-force-output display) - (let ((reply-buffer nil)) - (declare (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (progn - (setq reply-buffer (allocate-reply-buffer #x1000)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (buffer-input display buffer-bbuf 0 8) - (let ((success (boolean-get 0)) - (reason-length (card8-get 1)) - (major-version (card16-get 2)) - (minor-version (card16-get 4)) - (total-length (card16-get 6)) - vendor-length - num-roots - num-formats) - (declare (ignore total-length)) - (unless success - (x-error 'connection-failure - :major-version major-version - :minor-version minor-version - :host (display-host display) - :display (display-display display) - :reason - (progn (buffer-input display buffer-bbuf 0 reason-length) - (string-get reason-length 0 :reply-buffer reply-buffer)))) - (buffer-input display buffer-bbuf 0 32) - (setf (display-protocol-major-version display) major-version) - (setf (display-protocol-minor-version display) minor-version) - (setf (display-release-number display) (card32-get 0)) - (setf (display-resource-id-base display) (card32-get 4)) - (setf (display-resource-id-mask display) (card32-get 8)) - (setf (display-motion-buffer-size display) (card32-get 12)) - (setq vendor-length (card16-get 16)) - (setf (display-max-request-length display) (card16-get 18)) - (setq num-roots (card8-get 20)) - (setq num-formats (card8-get 21)) - ;; Get the image-info - (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) - (let ((format (display-bitmap-format display))) - (declare (type bitmap-format format)) - (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) - (setf (bitmap-format-unit format) (card8-get 24)) - (setf (bitmap-format-pad format) (card8-get 25))) - (setf (display-min-keycode display) (card8-get 26)) - (setf (display-max-keycode display) (card8-get 27)) - ;; 4 bytes unused - ;; Get the vendor string - (buffer-input display buffer-bbuf 0 (lround vendor-length)) - (setf (display-vendor-name display) - (string-get vendor-length 0 :reply-buffer reply-buffer)) - ;; Initialize the pixmap formats - (dotimes (i num-formats) ;; loop gathering pixmap formats - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 8) - (push (make-pixmap-format :depth (card8-get 0) - :bits-per-pixel (card8-get 1) - :scanline-pad (card8-get 2)) - ; 5 unused bytes - (display-pixmap-formats display))) - (setf (display-pixmap-formats display) - (nreverse (display-pixmap-formats display))) - ;; Initialize the screens - (dotimes (i num-roots) - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 40) - (let* ((root-id (card32-get 0)) - (root (make-window :id root-id :display display)) - (root-visual (card32-get 32)) - (default-colormap-id (card32-get 4)) - (default-colormap - (make-colormap :id default-colormap-id :display display)) - (screen - (make-screen - :root root - :default-colormap default-colormap - :white-pixel (card32-get 8) - :black-pixel (card32-get 12) - :event-mask-at-open (card32-get 16) - :width (card16-get 20) - :height (card16-get 22) - :width-in-millimeters (card16-get 24) - :height-in-millimeters (card16-get 26) - :min-installed-maps (card16-get 28) - :max-installed-maps (card16-get 30) - :backing-stores (member8-get 36 :never :when-mapped :always) - :save-unders-p (boolean-get 37) - :root-depth (card8-get 38))) - (num-depths (card8-get 39)) - (depths nil)) - ;; Save root window for event reporting - (save-id display root-id root) - (save-id display default-colormap-id default-colormap) - ;; Create the depth AList for a screen, (depth . visual-infos) - (dotimes (j num-depths) - (declare (ignorable j)) - (buffer-input display buffer-bbuf 0 8) - (let ((depth (card8-get 0)) - (num-visuals (card16-get 2)) - (visuals nil)) ;; 4 bytes unused - (dotimes (k num-visuals) - (declare (ignorable k)) - (buffer-input display buffer-bbuf 0 24) - (let* ((visual (card32-get 0)) - (visual-info (make-visual-info - :id visual - :display display - :class (member8-get 4 :static-gray :gray-scale - :static-color :pseudo-color - :true-color :direct-color) - :bits-per-rgb (card8-get 5) - :colormap-entries (card16-get 6) - :red-mask (card32-get 8) - :green-mask (card32-get 12) - :blue-mask (card32-get 16) - ;; 4 bytes unused - ))) - (push visual-info visuals) - (when (funcall (resource-id-map-test) root-visual visual) - (setf (screen-root-visual-info screen) - (setf (colormap-visual-info default-colormap) - visual-info))))) - (push (cons depth (nreverse visuals)) depths))) - (setf (screen-depths screen) (nreverse depths)) - (push screen (display-roots display)))) - (setf (display-roots display) (nreverse (display-roots display))) - (setf (display-default-screen display) (first (display-roots display)))))) - (when reply-buffer - (deallocate-reply-buffer reply-buffer)))) - display) - -(defun display-protocol-version (display) - (declare (type display display)) - (declare (clx-values major minor)) - (values (display-protocol-major-version display) - (display-protocol-minor-version display))) - -(defun display-vendor (display) - (declare (type display display)) - (declare (clx-values name release)) - (values (display-vendor-name display) - (display-release-number display))) - -(defun display-nscreens (display) - (declare (type display display)) - (length (display-roots display))) - -#+comment ;; defined by the DISPLAY defstruct -(defsetf display-error-handler (display) (handler) - ;; All errors (synchronous and asynchronous) are processed by calling an error - ;; handler in the display. If handler is a sequence it is expected to contain - ;; handler functions specific to each error; the error code is used to index the - ;; sequence, fetching the appropriate handler. Any results returned by the handler - ;; are ignored; it is assumed the handler either takes care of the error - ;; completely, or else signals. For all core errors, the keyword/value argument - ;; pairs are: - ;; :display display - ;; :error-key error-key - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; :current-sequence integer - ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and - ;; :window errors another pair is: - ;; :resource-id integer - ;; For :atom errors, another pair is: - ;; :atom-id integer - ;; For :value errors, another pair is: - ;; :value integer - ) - - ;; setf'able - ;; If defined, called after every protocol request is generated, even those inside - ;; explicit with-display's, but never called from inside the after-function itself. - ;; The function is called inside the effective with-display for the associated - ;; request. Default value is nil. Can be set, for example, to - ;; #'display-force-output or #'display-finish-output. - -(defvar *inside-display-after-function* nil) - -(defun display-invoke-after-function (display) - ; Called after every protocal request is generated - (declare (type display display)) - (when (and (display-after-function display) - (not *inside-display-after-function*)) - (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls - (funcall (display-after-function display) display)))) - -(defun display-finish-output (display) - ;; Forces output, then causes a round-trip to ensure that all possible - ;; errors and events have been received. - (declare (type display display)) - (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32)) - () - ) - ;; Report asynchronous errors here if the user wants us to. - (report-asynchronous-errors display :after-finish-output)) - -(defparameter - *request-names* - '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes" - "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow" - "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows" - "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree" - "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty" - "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner" - "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer" - "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard" - "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents" - "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents" - "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus" - "QueryKeymap" "OpenFont" "CloseFont" "QueryFont" - "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath" - "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC" - "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles" - "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane" - "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle" - "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc" - "PutImage" "GetImage" "PolyText8" "PolyText16" - "ImageText8" "ImageText16" "CreateColormap" "FreeColormap" - "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps" - "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes" - "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors" - "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor" - "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions" - "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl" - "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver" - "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl" - "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver" - "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping")) diff --git a/clx/doc.lisp b/clx/doc.lisp deleted file mode 100644 index bff618e145a667cfd9f1371932014bde3a35d233..0000000000000000000000000000000000000000 --- a/clx/doc.lisp +++ /dev/null @@ -1,3803 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; Copyright 1987, 1988 Massachusetts Institute of Technology, and -;;; Texas Instruments Incorporated - -;;; Permission to use, copy, modify, and distribute this document for any purpose -;;; and without fee is hereby granted, provided that the above copyright notice -;;; appear in all copies and that both that copyright notice and this permission -;;; notice are retained, and that the name of M.I.T. not be used in advertising or -;;; publicity pertaining to this document without specific, written prior -;;; permission. M.I.T. makes no representations about the suitability of this -;;; document or the protocol defined in this document for any purpose. It is -;;; provided "as is" without express or implied warranty. - -;;; Texas Instruments Incorporated provides this document "as is" without -;;; express or implied warranty. - -;; Version 4 - -;; This is considered a somewhat changeable interface. Discussion of better -;; integration with CLOS, support for user-specified subclassess of basic -;; objects, and the additional functionality to match the C Xlib is still in -;; progress. - -;; Primary Interface Author: -;; Robert W. Scheifler -;; MIT Laboratory for Computer Science -;; 545 Technology Square, Room 418 -;; Cambridge, MA 02139 -;; rws@zermatt.lcs.mit.edu - -;; Design Contributors: -;; Dan Cerys, Texas Instruments -;; Scott Fahlman, CMU -;; Charles Hornig, Symbolics -;; John Irwin, Franz -;; Kerry Kimbrough, Texas Instruments -;; Chris Lindblad, MIT -;; Rob MacLachlan, CMU -;; Mike McMahon, Symbolics -;; David Moon, Symbolics -;; LaMott Oren, Texas Instruments -;; Daniel Weinreb, Symbolics -;; John Wroclawski, MIT -;; Richard Zippel, Symbolics - -;; CLX Extensions -;; Adds some of the functionality provided by the C XLIB library. -;; -;; Primary Author -;; LaMott G. Oren -;; Texas Instruments -;; -;; Design Contributors: -;; Robert W. Scheifler, MIT - - -;; Note: all of the following is in the package XLIB. - -(declaim (declaration arglist clx-values)) - -;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of -;; the relationships should be fairly obvious. We have no intention of writing yet -;; another moby document for this interface. - -(deftype card32 () '(unsigned-byte 32)) - -(deftype card29 () '(unsigned-byte 29)) - -(deftype int32 () '(signed-byte 32)) - -(deftype card16 () '(unsigned-byte 16)) - -(deftype int16 () '(signed-byte 16)) - -(deftype card8 () '(unsigned-byte 8)) - -(deftype int8 () '(signed-byte 8)) - -(deftype mask32 () 'card32) - -(deftype mask16 () 'card16) - -(deftype resource-id () 'card29) - -;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color. -;; These types are defined solely by a functional interface; we do not specify -;; whether they are implemented as structures or flavors or ... Although functions -;; below are written using DEFUN, this is not an implementation requirement (although -;; it is a requirement that they be functions as opposed to macros or special forms). -;; It is unclear whether with-slots in the Common Lisp Object System must work on -;; them. - -;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as -;; compound objects, rather than as integer resource-ids. This allows applications -;; to deal with multiple displays without having an explicit display argument in the -;; most common functions. Every function uses the display object indicated by the -;; first argument that is or contains a display; it is an error if arguments contain -;; different displays, and predictable results are not guaranteed. - -;; Each of window, pixmap, drawable, cursor, font, gcontext, and colormap have the -;; following five functions: - -(defun <mumble>-display (<mumble>) - (declare (type <mumble> <mumble>) - (clx-values display))) - -(defun <mumble>-id (<mumble>) - (declare (type <mumble> <mumble>) - (clx-values resource-id))) - -(defun <mumble>-equal (<mumble>-1 <mumble>-2) - (declare (type <mumble> <mumble>-1 <mumble>-2))) - -(defun <mumble>-p (<mumble>) - (declare (type <mumble> <mumble>) - (clx-values boolean))) - -;; The following functions are provided by color objects: - -;; The intention is that IHS and YIQ and CYM interfaces will also exist. Note that -;; we are explicitly using a different spectrum representation than what is actually -;; transmitted in the protocol. - -(deftype rgb-val () '(real 0 1)) - -(defun make-color (&key red green blue &allow-other-keys) ; for expansion - (declare (type rgb-val red green blue) - (clx-values color))) - -(defun color-rgb (color) - (declare (type color color) - (clx-values red green blue))) - -(defun color-red (color) - ;; setf'able - (declare (type color color) - (clx-values rgb-val))) - -(defun color-green (color) - ;; setf'able - (declare (type color color) - (clx-values rgb-val))) - -(defun color-blue (color) - ;; setf'able - (declare (type color color) - (clx-values rgb-val))) - -(deftype drawable () '(or window pixmap)) - -;; Atoms are accepted as strings or symbols, and are always returned as keywords. -;; Protocol-level integer atom ids are hidden, using a cache in the display object. - -(deftype xatom () '(or string symbol)) - -(deftype stringable () '(or string symbol)) - -(deftype fontable () '(or stringable font)) - -;; Nil stands for CurrentTime. - -(deftype timestamp () '(or null card32)) - -(deftype bit-gravity () '(member :forget :static :north-west :north :north-east - :west :center :east :south-west :south :south-east)) - -(deftype win-gravity () '(member :unmap :static :north-west :north :north-east - :west :center :east :south-west :south :south-east)) - -(deftype grab-status () - '(member :success :already-grabbed :frozen :invalid-time :not-viewable)) - -(deftype boolean () '(or null (not null))) - -(deftype pixel () '(unsigned-byte 32)) -(deftype image-depth () '(integer 0 32)) - -(deftype keysym () 'card32) - -(deftype array-index () `(integer 0 ,array-dimension-limit)) - -;; An association list. - -(deftype alist (key-type-and-name datum-type-and-name) 'list) - -(deftype clx-list (&optional element-type) 'list) -(deftype clx-sequence (&optional element-type) 'sequence) - -;; A sequence, containing zero or more repetitions of the given elements, -;; with the elements expressed as (type name). - -(deftype repeat-seq (&rest elts) 'sequence) - -(deftype point-seq () '(repeat-seq (int16 x) (int16 y))) - -(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2))) - -(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height))) - -;; Note that we are explicitly using a different angle representation than what -;; is actually transmitted in the protocol. - -(deftype angle () '(real #.(* -2 pi) #.(* 2 pi))) - -(deftype arc-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) - (angle angle1) (angle angle2))) - -(deftype event-mask-class () - '(member :key-press :key-release :owner-grab-button :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :exposure :visibility-change - :structure-notify :resize-redirect :substructure-notify :substructure-redirect - :focus-change :property-change :colormap-change :keymap-state)) - -(deftype event-mask () - '(or mask32 (clx-list event-mask-class))) - -(deftype pointer-event-mask-class () - '(member :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state)) - -(deftype pointer-event-mask () - '(or mask32 (clx-list pointer-event-mask-class))) - -(deftype device-event-mask-class () - '(member :key-press :key-release :button-press :button-release :pointer-motion - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion)) - -(deftype device-event-mask () - '(or mask32 (clx-list device-event-mask-class))) - -(deftype modifier-key () - '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) - -(deftype modifier-mask () - '(or (member :any) mask16 (clx-list modifier-key))) - -(deftype state-mask-key () - '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) - -(deftype gcontext-key () - '(member :function :plane-mask :foreground :background - :line-width :line-style :cap-style :join-style :fill-style :fill-rule - :arc-mode :tile :stipple :ts-x :ts-y :font :subwindow-mode - :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes)) - -(deftype event-key () - '(member :key-press :key-release :button-press :button-release :motion-notify - :enter-notify :leave-notify :focus-in :focus-out :keymap-notify - :exposure :graphics-exposure :no-exposure :visibility-notify - :create-notify :destroy-notify :unmap-notify :map-notify :map-request - :reparent-notify :configure-notify :gravity-notify :resize-request - :configure-request :circulate-notify :circulate-request :property-notify - :selection-clear :selection-request :selection-notify - :colormap-notify :client-message)) - -(deftype error-key () - '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice - :illegal-request :implementation :length :match :name :pixmap :value :window)) - -(deftype draw-direction () - '(member :left-to-right :right-to-left)) - -(defstruct bitmap-format - (unit <unspec> :type (member 8 16 32)) - (pad <unspec> :type (member 8 16 32)) - (lsb-first-p <unspec> :type boolean)) - -(defstruct pixmap-format - (depth <unspec> :type image-depth) - (bits-per-pixel <unspec> :type (member 1 4 8 16 24 32)) - (pad <unspec> :type (member 8 16 32))) - -(defstruct visual-info - (id <unspec> :type resource-id) - (display <unspec> :type display) - (class <unspec> :type (member :static-gray :static-color :true-color - :gray-scale :pseudo-color :direct-color)) - (red-mask <unspec> :type pixel) - (green-mask <unspec> :type pixel) - (blue-mask <unspec> :type pixel) - (bits-per-rgb <unspec> :type card8) - (colormap-entries <unspec> :type card16)) - -(defstruct screen - (root <unspec> :type window) - (width <unspec> :type card16) - (height <unspec> :type card16) - (width-in-millimeters <unspec> :type card16) - (height-in-millimeters <unspec> :type card16) - (depths <unspec> :type (alist (image-depth depth) ((clx-list visual-info) visuals))) - (root-depth <unspec> :type image-depth) - (root-visual-info <unspec> :type visual-info) - (default-colormap <unspec> :type colormap) - (white-pixel <unspec> :type pixel) - (black-pixel <unspec> :type pixel) - (min-installed-maps <unspec> :type card16) - (max-installed-maps <unspec> :type card16) - (backing-stores <unspec> :type (member :never :when-mapped :always)) - (save-unders-p <unspec> :type boolean) - (event-mask-at-open <unspec> :type mask32)) - -(defun screen-root-visual (screen) - (declare (type screen screen) - (clx-values resource-id))) - -;; The list contains alternating keywords and integers. - -(deftype font-props () 'list) - -(defun open-display (host &key (display 0) protocol) - ;; A string must be acceptable as a host, but otherwise the possible types for host - ;; and protocol are not constrained, and will likely be very system dependent. The - ;; default protocol is system specific. Authorization, if any, is assumed to come - ;; from the environment somehow. - (declare (type integer display) - (clx-values display))) - -(defun display-protocol-major-version (display) - (declare (type display display) - (clx-values card16))) - -(defun display-protocol-minor-version (display) - (declare (type display display) - (clx-values card16))) - -(defun display-vendor-name (display) - (declare (type display display) - (clx-values string))) - -(defun display-release-number (display) - (declare (type display display) - (clx-values card32))) - -(defun display-image-lsb-first-p (display) - (declare (type display display) - (clx-values boolean))) - -(defun display-bitmap-formap (display) - (declare (type display display) - (clx-values bitmap-format))) - -(defun display-pixmap-formats (display) - (declare (type display display) - (clx-values (clx-list pixmap-formats)))) - -(defun display-roots (display) - (declare (type display display) - (clx-values (clx-list screen)))) - -(defun display-motion-buffer-size (display) - (declare (type display display) - (clx-values card32))) - -(defun display-max-request-length (display) - (declare (type display display) - (clx-values card16))) - -(defun display-min-keycode (display) - (declare (type display display) - (clx-values card8))) - -(defun display-max-keycode (display) - (declare (type display display) - (clx-values card8))) - -(defun close-display (display) - (declare (type display display))) - -(defun display-error-handler (display) - (declare (type display display) - (clx-values handler))) - -(defsetf display-error-handler (display) (handler) - ;; All errors (synchronous and asynchronous) are processed by calling an error - ;; handler in the display. If handler is a sequence it is expected to contain - ;; handler functions specific to each error; the error code is used to index the - ;; sequence, fetching the appropriate handler. Any results returned by the handler - ;; are ignored; it is assumed the handler either takes care of the error - ;; completely, or else signals. For all core errors, the keyword/value argument - ;; pairs are: - ;; :major card8 - ;; :minor card16 - ;; :sequence card16 - ;; :current-sequence card16 - ;; :asynchronous (member t nil) - ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and - ;; :window errors another pair is: - ;; :resource-id card32 - ;; For :atom errors, another pair is: - ;; :atom-id card32 - ;; For :value errors, another pair is: - ;; :value card32 - (declare (type display display) - (type (or (clx-sequence (function (display symbol &key &allow-other-keys))) - (function (display symbol &key &allow-other-keys))) - handler))) - -(defsetf display-report-asynchronous-errors (display) (when) - ;; Most useful in multi-process lisps. - ;; - ;; Synchronous errors are always signalled in the process that made the - ;; synchronous request. An error is considered synchronous if a process is - ;; waiting for a reply with the same request-id as the error. - ;; - ;; Asynchronous errors can be signalled at any one of these three times: - ;; - ;; 1. As soon as they are read. They get signalled in whichever process - ;; was doing the reading. This is enabled by - ;; (setf (xlib:display-report-asynchronous-errors display) - ;; '(:immediately)) - ;; This is the default. - ;; - ;; 2. Before any events are to be handled. You get these by doing an - ;; event-listen with any timeout value other than 0, or in of the event - ;; processing forms. This is useful if you using a background process to - ;; handle input. This is enabled by - ;; (setf (xlib:display-report-asynchronous-errors display) - ;; '(:before-event-handling)) - ;; - ;; 3. After a display-finish-output. You get these by doing a - ;; display-finish-output. A cliche using this might have a with-display - ;; wrapped around the display operations that possibly cause an asynchronous - ;; error, with a display-finish-output right the end of the with-display to - ;; catch any asynchronous errors. This is enabled by - ;; (setf (xlib:display-report-asynchronous-errors display) - ;; '(:after-finish-output)) - ;; - ;; You can select any combination of the three keywords. For example, to - ;; get errors reported before event handling and after finish-output, - ;; (setf (xlib:display-report-asynchronous-errors display) - ;; '(:before-event-handling :after-finish-output)) - (declare (type list when)) - ) - -(defmacro define-condition (name base &body items) - ;; just a place-holder here for the real thing - ) - -(define-condition request-error error - display - major - minor - sequence - current-sequence - asynchronous) - -(defun default-error-handler (display error-key &key &allow-other-keys) - ;; The default display-error-handler. - ;; It signals the conditions listed below. - (declare (type display display) - (type symbol error-key)) - ) - -(define-condition resource-error request-error - resource-id) - -(define-condition access-error request-error) - -(define-condition alloc-error request-error) - -(define-condition atom-error request-error - atom-id) - -(define-condition colormap-error resource-error) - -(define-condition cursor-error resource-error) - -(define-condition drawable-error resource-error) - -(define-condition font-error resource-error) - -(define-condition gcontext-error resource-error) - -(define-condition id-choice-error resource-error) - -(define-condition illegal-request-error request-error) - -(define-condition implementation-error request-error) - -(define-condition length-error request-error) - -(define-condition match-error request-error) - -(define-condition name-error request-error) - -(define-condition pixmap-error resource-error) - -(define-condition value-error request-error - value) - -(define-condition window-error resource-error) - -(defmacro with-display ((display) &body body) - ;; This macro is for use in a multi-process environment. It provides exclusive - ;; access to the local display object for multiple request generation. It need not - ;; provide immediate exclusive access for replies; that is, if another process is - ;; waiting for a reply (while not in a with-display), then synchronization need not - ;; (but can) occur immediately. Except where noted, all routines effectively - ;; contain an implicit with-display where needed, so that correct synchronization - ;; is always provided at the interface level on a per-call basis. Nested uses of - ;; this macro will work correctly. This macro does not prevent concurrent event - ;; processing; see with-event-queue. - ) - -(defun display-force-output (display) - ;; Output is normally buffered; this forces any buffered output. - (declare (type display display))) - -(defun display-finish-output (display) - ;; Forces output, then causes a round-trip to ensure that all possible errors and - ;; events have been received. - (declare (type display display))) - -(defun display-after-function (display) - ;; setf'able - ;; If defined, called after every protocol request is generated, even those inside - ;; explicit with-display's, but never called from inside the after-function itself. - ;; The function is called inside the effective with-display for the associated - ;; request. Default value is nil. Can be set, for example, to - ;; #'display-force-output or #'display-finish-output. - (declare (type display display) - (clx-values (or null (function (display)))))) - -(defun create-window (&key parent x y width height (depth 0) (border-width 0) - (class :copy) (visual :copy) - background border gravity bit-gravity - backing-store backing-planes backing-pixel save-under - event-mask do-not-propagate-mask override-redirect - colormap cursor) - ;; Display is obtained from parent. Only non-nil attributes are passed on in the - ;; request: the function makes no assumptions about what the actual protocol - ;; defaults are. Width and height are the inside size, excluding border. - (declare (type window parent) - (type int16 x y) - (type card16 width height depth border-width) - (type (member :copy :input-output :input-only) class) - (type (or (member :copy) visual-info) visual) - (type (or null (member :none :parent-relative) pixel pixmap) background) - (type (or null (member :copy) pixel pixmap) border) - (type (or null win-gravity) gravity) - (type (or null bit-gravity) bit-gravity) - (type (or null (member :not-useful :when-mapped :always) backing-store)) - (type (or null pixel) backing-planes backing-pixel) - (type (or null event-mask) event-mask) - (type (or null device-event-mask) do-not-propagate-mask) - (type (or null (member :on :off)) save-under override-redirect) - (type (or null (member :copy) colormap) colormap) - (type (or null (member :none) cursor) cursor) - (clx-values window))) - -(defun window-class (window) - (declare (type window window) - (clx-values (member :input-output :input-only)))) - -(defun window-visual-info (window) - (declare (type window window) - (clx-values visual-info))) - -(defun window-visual (window) - (declare (type window window) - (clx-values resource-id))) - -(defsetf window-background (window) (background) - (declare (type window window) - (type (or (member :none :parent-relative) pixel pixmap) background))) - -(defsetf window-border (window) (border) - (declare (type window window) - (type (or (member :copy) pixel pixmap) border))) - -(defun window-gravity (window) - ;; setf'able - (declare (type window window) - (clx-values win-gravity))) - -(defun window-bit-gravity (window) - ;; setf'able - (declare (type window window) - (clx-values bit-gravity))) - -(defun window-backing-store (window) - ;; setf'able - (declare (type window window) - (clx-values (member :not-useful :when-mapped :always)))) - -(defun window-backing-planes (window) - ;; setf'able - (declare (type window window) - (clx-values pixel))) - -(defun window-backing-pixel (window) - ;; setf'able - (declare (type window window) - (clx-values pixel))) - -(defun window-save-under (window) - ;; setf'able - (declare (type window window) - (clx-values (member :on :off)))) - -(defun window-event-mask (window) - ;; setf'able - (declare (type window window) - (clx-values mask32))) - -(defun window-do-not-propagate-mask (window) - ;; setf'able - (declare (type window window) - (clx-values mask32))) - -(defun window-override-redirect (window) - ;; setf'able - (declare (type window window) - (clx-values (member :on :off)))) - -(defun window-colormap (window) - (declare (type window window) - (clx-values (or null colormap)))) - -(defsetf window-colormap (window) (colormap) - (declare (type window window) - (type (or (member :copy) colormap) colormap))) - -(defsetf window-cursor (window) (cursor) - (declare (type window window) - (type (or (member :none) cursor) cursor))) - -(defun window-colormap-installed-p (window) - (declare (type window window) - (clx-values boolean))) - -(defun window-all-event-masks (window) - (declare (type window window) - (clx-values mask32))) - -(defun window-map-state (window) - (declare (type window window) - (clx-values (member :unmapped :unviewable :viewable)))) - -(defsetf drawable-x (window) (x) - (declare (type window window) - (type int16 x))) - -(defsetf drawable-y (window) (y) - (declare (type window window) - (type int16 y))) - -(defsetf drawable-width (window) (width) - ;; Inside width, excluding border. - (declare (type window window) - (type card16 width))) - -(defsetf drawable-height (window) (height) - ;; Inside height, excluding border. - (declare (type window window) - (type card16 height))) - -(defsetf drawable-border-width (window) (border-width) - (declare (type window window) - (type card16 border-width))) - -(defsetf window-priority (window &optional sibling) (mode) - ;; A bit strange, but retains setf form. - (declare (type window window) - (type (or null window) sibling) - (type (member :above :below :top-if :bottom-if :opposite) mode))) - -(defmacro with-state ((drawable) &body body) - ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes - ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and - ;; ConfigureWindow. The body is not surrounded by a with-display. Within the - ;; indefinite scope of the body, on a per-process basis in a multi-process - ;; environment, the first call within an Accessor Group on the specified drawable - ;; (the object, not just the variable) causes the complete results of the protocol - ;; request to be retained, and returned in any subsequent accessor calls. Calls - ;; within a Setf Group are delayed, and executed in a single request on exit from - ;; the body. In addition, if a call on a function within an Accessor Group follows - ;; a call on a function in the corresponding Setf Group, then all delayed setfs for - ;; that group are executed, any retained accessor information for that group is - ;; discarded, the corresponding protocol request is (re)issued, and the results are - ;; (again) retained, and returned in any subsequent accessor calls. - - ;; Accessor Group A (for GetWindowAttributes): - ;; window-visual-info, window-visual, window-class, window-gravity, window-bit-gravity, - ;; window-backing-store, window-backing-planes, window-backing-pixel, - ;; window-save-under, window-colormap, window-colormap-installed-p, - ;; window-map-state, window-all-event-masks, window-event-mask, - ;; window-do-not-propagate-mask, window-override-redirect - - ;; Setf Group A (for ChangeWindowAttributes): - ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes, - ;; window-backing-pixel, window-save-under, window-event-mask, - ;; window-do-not-propagate-mask, window-override-redirect, window-colormap, - ;; window-cursor - - ;; Accessor Group G (for GetGeometry): - ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width, - ;; drawable-height, drawable-border-width - - ;; Setf Group G (for ConfigureWindow): - ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width, - ;; window-priority - ) - -(defun destroy-window (window) - (declare (type window window))) - -(defun destroy-subwindows (window) - (declare (type window window))) - -(defun add-to-save-set (window) - (declare (type window window))) - -(defun remove-from-save-set (window) - (declare (type window window))) - -(defun reparent-window (window parent x y) - (declare (type window window parent) - (type int16 x y))) - -(defun map-window (window) - (declare (type window window))) - -(defun map-subwindows (window) - (declare (type window window))) - -(defun unmap-window (window) - (declare (type window window))) - -(defun unmap-subwindows (window) - (declare (type window window))) - -(defun circulate-window-up (window) - (declare (type window window))) - -(defun circulate-window-down (window) - (declare (type window window))) - -(defun drawable-root (drawable) - (declare (type drawable drawable) - (clx-values window))) - -(defun drawable-depth (drawable) - (declare (type drawable drawable) - (clx-values card8))) - -(defun drawable-x (drawable) - (declare (type drawable drawable) - (clx-values int16))) - -(defun drawable-y (drawable) - (declare (type drawable drawable) - (clx-values int16))) - -(defun drawable-width (drawable) - ;; For windows, inside width, excluding border. - (declare (type drawable drawable) - (clx-values card16))) - -(defun drawable-height (drawable) - ;; For windows, inside height, excluding border. - (declare (type drawable drawable) - (clx-values card16))) - -(defun drawable-border-width (drawable) - (declare (type drawable drawable) - (clx-values card16))) - -(defun query-tree (window &key (result-type 'list)) - (declare (type window window) - (type type result-type) - (clx-values (clx-sequence window) parent root))) - -(defun change-property (window property data type format - &key (mode :replace) (start 0) end transform) - ;; Start and end affect sub-sequence extracted from data. - ;; Transform is applied to each extracted element. - (declare (type window window) - (type xatom property type) - (type (member 8 16 32) format) - (type sequence data) - (type (member :replace :prepend :append) mode) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (t) integer)) transform))) - -(defun delete-property (window property) - (declare (type window window) - (type xatom property))) - -(defun get-property (window property - &key type (start 0) end delete-p (result-type 'list) transform) - ;; Transform is applied to each integer retrieved. - ;; Nil is returned for type when the protocol returns None. - (declare (type window window) - (type xatom property) - (type (or null xatom) type) - (type array-index start) - (type (or null array-index) end) - (type boolean delete-p) - (type type result-type) - (type (or null (function (integer) t)) transform) - (clx-values data type format bytes-after))) - -(defun rotate-properties (window properties &optional (delta 1)) - ;; Postive rotates left, negative rotates right (opposite of actual protocol request). - (declare (type window window) - (type (clx-sequence xatom) properties) - (type int16 delta))) - -(defun list-properties (window &key (result-type 'list)) - (declare (type window window) - (type type result-type) - (clx-values (clx-sequence keyword)))) - -;; Although atom-ids are not visible in the normal user interface, atom-ids might -;; appear in window properties and other user data, so conversion hooks are needed. - -(defun intern-atom (display name) - (declare (type display display) - (type xatom name) - (clx-values resource-id))) - -(defun find-atom (display name) - (declare (type display display) - (type xatom name) - (clx-values (or null resource-id)))) - -(defun atom-name (display atom-id) - (declare (type display display) - (type resource-id atom-id) - (clx-values keyword))) - -(defun selection-owner (display selection) - (declare (type display display) - (type xatom selection) - (clx-values (or null window)))) - -(defsetf selection-owner (display selection &optional time) (owner) - ;; A bit strange, but retains setf form. - (declare (type display display) - (type xatom selection) - (type (or null window) owner) - (type timestamp time))) - -(defun convert-selection (selection type requestor &optional property time) - (declare (type xatom selection type) - (type window requestor) - (type (or null xatom) property) - (type timestamp time))) - -(defun send-event (window event-key event-mask &rest args - &key propagate-p display &allow-other-keys) - ;; Additional arguments depend on event-key, and are as specified further below - ;; with declare-event, except that both resource-ids and resource objects are - ;; accepted in the event components. The display argument is only required if the - ;; window is :pointer-window or :input-focus. If an argument has synonyms, it is - ;; only necessary to supply a value for one of them; it is an error to specify - ;; different values for synonyms. - (declare (type (or window (member :pointer-window :input-focus)) window) - (type (or null event-key) event-key) - (type event-mask event-mask) - (type boolean propagate-p) - (type (or null display) display))) - -(defun grab-pointer (window event-mask - &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) - (declare (type window window) - (type pointer-event-mask event-mask) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor) - (type timestamp time) - (clx-values grab-status))) - -(defun ungrab-pointer (display &key time) - (declare (type display display) - (type timestamp time))) - -(defun grab-button (window button event-mask - &key (modifiers 0) - owner-p sync-pointer-p sync-keyboard-p confine-to cursor) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers) - (type pointer-event-mask event-mask) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor))) - -(defun ungrab-button (window button &key (modifiers 0)) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers))) - -(defun change-active-pointer-grab (display event-mask &optional cursor time) - (declare (type display display) - (type pointer-event-mask event-mask) - (type (or null cursor) cursor) - (type timestamp time))) - -(defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time) - (declare (type window window) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type timestamp time) - (clx-values grab-status))) - -(defun ungrab-keyboard (display &key time) - (declare (type display display) - (type timestamp time))) - -(defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) - (declare (type window window) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or (member :any) card8) key) - (type modifier-mask modifiers))) - -(defun ungrab-key (window key &key (modifiers 0)) - (declare (type window window) - (type (or (member :any) card8) key) - (type modifier-mask modifiers))) - -(defun allow-events (display mode &optional time) - (declare (type display display) - (type (member :async-pointer :sync-pointer :reply-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both) - mode) - (type timestamp time))) - -(defun grab-server (display) - (declare (type display display))) - -(defun ungrab-server (display) - (declare (type display display))) - -(defmacro with-server-grabbed ((display) &body body) - ;; The body is not surrounded by a with-display. - ) - -(defun query-pointer (window) - (declare (type window window) - (clx-values x y same-screen-p child mask root-x root-y root))) - -(defun pointer-position (window) - (declare (type window window) - (clx-values x y same-screen-p))) - -(defun global-pointer-position (display) - (declare (type display display) - (clx-values root-x root-y root))) - -(defun motion-events (window &key start stop (result-type 'list)) - (declare (type window window) - (type timestamp start stop) - (type type result-type) - (clx-values (repeat-seq (int16 x) (int16 y) (timestamp time))))) - -(defun translate-coordinates (src src-x src-y dst) - ;; If src and dst are not on the same screen, nil is returned. - (declare (type window src) - (type int16 src-x src-y) - (type window dst) - (clx-values dst-x dst-y child))) - -(defun warp-pointer (dst dst-x dst-y) - (declare (type window dst) - (type int16 dst-x dst-y))) - -(defun warp-pointer-relative (display x-off y-off) - (declare (type display display) - (type int16 x-off y-off))) - -(defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. A null src-width or - ;; src-height translates into a zero value in the protocol request. - (declare (type window dst src) - (type int16 dst-x dst-y src-x src-y) - (type (or null card16) src-width src-height))) - -(defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. A null src-width or - ;; src-height translates into a zero value in the protocol request. - (declare (type window src) - (type int16 x-off y-off src-x src-y) - (type (or null card16) src-width src-height))) - -(defun set-input-focus (display focus revert-to &optional time) - ;; Setf ought to allow multiple values. - (declare (type display display) - (type (or (member :none :pointer-root) window) focus) - (type (member :none :parent :pointer-root) revert-to) - (type timestamp time))) - -(defun input-focus (display) - (declare (type display display) - (clx-values focus revert-to))) - -(defun query-keymap (display) - (declare (type display display) - (clx-values (bit-vector 256)))) - -(defun open-font (display name) - ;; Font objects may be cached and reference counted locally within the display - ;; object. This function might not execute a with-display if the font is cached. - ;; The protocol QueryFont request happens on-demand under the covers. - (declare (type display display) - (type stringable name) - (clx-values font))) - -;; We probably want a per-font bit to indicate whether caching on -;; text-extents/width calls is desirable. But what to name it? - -(defun discard-font-info (font) - ;; Discards any state that can be re-obtained with QueryFont. This is simply - ;; a performance hint for memory-limited systems. - (declare (type font font))) - -;; This can be signalled anywhere a pseudo font access fails. - -(define-condition invalid-font error - font) - -;; Note: font-font-info removed. - -(defun font-name (font) - ;; Returns nil for a pseudo font returned by gcontext-font. - (declare (type font font) - (clx-values (or null string)))) - -(defun font-direction (font) - (declare (type font font) - (clx-values draw-direction))) - -(defun font-min-char (font) - (declare (type font font) - (clx-values card16))) - -(defun font-max-char (font) - (declare (type font font) - (clx-values card16))) - -(defun font-min-byte1 (font) - (declare (type font font) - (clx-values card8))) - -(defun font-max-byte1 (font) - (declare (type font font) - (clx-values card8))) - -(defun font-min-byte2 (font) - (declare (type font font) - (clx-values card8))) - -(defun font-max-byte2 (font) - (declare (type font font) - (clx-values card8))) - -(defun font-all-chars-exist-p (font) - (declare (type font font) - (clx-values boolean))) - -(defun font-default-char (font) - (declare (type font font) - (clx-values card16))) - -(defun font-ascent (font) - (declare (type font font) - (clx-values int16))) - -(defun font-descent (font) - (declare (type font font) - (clx-values int16))) - -;; The list contains alternating keywords and int32s. - -(deftype font-props () 'list) - -(defun font-properties (font) - (declare (type font font) - (clx-values font-props))) - -(defun font-property (font name) - (declare (type font font) - (type keyword name) - (clx-values (or null int32)))) - -;; For each of left-bearing, right-bearing, width, ascent, descent, attributes: - -(defun char-<metric> (font index) - ;; Note: I have tentatively chosen to return nil for an out-of-bounds index - ;; (or an in-bounds index on a pseudo font), although returning zero or - ;; signalling might be better. - (declare (type font font) - (type card16 index) - (clx-values (or null int16)))) - -(defun max-char-<metric> (font) - ;; Note: I have tentatively chosen separate accessors over allowing :min and - ;; :max as an index above. - (declare (type font font) - (clx-values int16))) - -(defun min-char-<metric> (font) - (declare (type font font) - (clx-values int16))) - -;; Note: char16-<metric> accessors could be defined to accept two-byte indexes. - -(defun close-font (font) - ;; This might not generate a protocol request if the font is reference - ;; counted locally or if it is a pseudo font. - (declare (type font font))) - -(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) - (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type type result-type) - (clx-values (clx-sequence string)))) - -(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list)) - ;; Returns "pseudo" fonts that contain basic font metrics and properties, but - ;; no per-character metrics and no resource-ids. These pseudo fonts will be - ;; converted (internally) to real fonts dynamically as needed, by issuing an - ;; OpenFont request. However, the OpenFont might fail, in which case the - ;; invalid-font error can arise. - (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type type result-type) - (clx-values (clx-sequence font)))) - -(defun font-path (display &key (result-type 'list)) - (declare (type display display) - (type type result-type) - (clx-values (clx-sequence (or string pathname))))) - -(defsetf font-path (display) (paths) - (declare (type display display) - (type (clx-sequence (or string pathname)) paths))) - -(defun create-pixmap (&key width height depth drawable) - (declare (type card16 width height) - (type card8 depth) - (type drawable drawable) - (clx-values pixmap))) - -(defun free-pixmap (pixmap) - (declare (type pixmap pixmap))) - -(defun create-gcontext (&key drawable function plane-mask foreground background - line-width line-style cap-style join-style fill-style fill-rule - arc-mode tile stipple ts-x ts-y font subwindow-mode - exposures clip-x clip-y clip-mask clip-ordering - dash-offset dashes - (cache-p t)) - ;; Only non-nil components are passed on in the request, but for effective caching - ;; assumptions have to be made about what the actual protocol defaults are. For - ;; all gcontext components, a value of nil causes the default gcontext value to be - ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented - ;; as a list. Note: use of stringable as font will cause an implicit open-font. - ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If - ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext - ;; component will have no effect unless the new value differs from the cached - ;; value. Component changes (setfs and with-gcontext) are always deferred - ;; regardless of the cache mode, and sent over the protocol only when required by a - ;; local operation or by an explicit call to force-gcontext-changes. - (declare (type drawable drawable) - (type (or null boole-constant) function) - (type (or null pixel) plane-mask foreground background) - (type (or null card16) line-width dash-offset) - (type (or null int16) ts-x ts-y clip-x clip-y) - (type (or null (member :solid :dash :double-dash)) line-style) - (type (or null (member :not-last :butt :round :projecting)) cap-style) - (type (or null (member :miter :round :bevel)) join-style) - (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) - (type (or null (member :even-odd :winding)) fill-rule) - (type (or null (member :chord :pie-slice)) arc-mode) - (type (or null pixmap) tile stipple) - (type (or null fontable) font) - (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) - (type (or null (member :on :off)) exposures) - (type (or null (member :none) pixmap rect-seq) clip-mask) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) - (type (or null (or card8 (clx-sequence card8))) dashes) - (type boolean cache) - (clx-values gcontext))) - -;; For each argument to create-gcontext (except font, clip-mask and -;; clip-ordering) declared as (type <type> <name>), there is an accessor: - -(defun gcontext-<name> (gcontext) - ;; The value will be nil if the last value stored is unknown (e.g., the cache was - ;; off, or the component was copied from a gcontext with unknown state). - (declare (type gcontext gcontext) - (clx-values <type>))) - -;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared -;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor: - -(defsetf gcontext-<name> (gcontext) (value) - (declare (type gcontext gcontext) - (type <type> value))) - -(defun gcontext-font (gcontext &optional metrics-p) - ;; If the stored font is known, it is returned. If it is not known and - ;; metrics-p is false, then nil is returned. If it is not known and - ;; metrics-p is true, then a pseudo font is returned. Full metric and - ;; property information can be obtained, but the font does not have a name or - ;; a resource-id, and attempts to use it where a resource-id is required will - ;; result in an invalid-font error. - (declare (type gcontext gcontext) - (type boolean metrics-p) - (clx-values (or null font)))) - -(defun gcontext-clip-mask (gcontext) - (declare (type gcontext gcontext) - (clx-values (or null (member :none) pixmap rect-seq) - (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))) - -(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) - ;; Is nil illegal here, or is it transformed to a vector? - ;; A bit strange, but retains setf form. - (declare (type gcontext gcontext) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) - (type (or (member :none) pixmap rect-seq) clip-mask))) - -(defun force-gcontext-changes (gcontext) - ;; Force any delayed changes. - (declare (type gcontext gcontext))) - -(defmacro with-gcontext ((gcontext &key - function plane-mask foreground background - line-width line-style cap-style join-style fill-style fill-rule - arc-mode tile stipple ts-x ts-y font subwindow-mode - exposures clip-x clip-y clip-mask clip-ordering - dashes dash-offset) - &body body) - ;; Changes gcontext components within the dynamic scope of the body (i.e., - ;; indefinite scope and dynamic extent), on a per-process basis in a multi-process - ;; environment. The values are all evaluated before bindings are performed. The - ;; body is not surrounded by a with-display. If cache-p is nil or the some - ;; component states are unknown, this will implement save/restore by creating a - ;; temporary gcontext and doing gcontext-components to and from it. - ) - -(defun copy-gcontext-components (src dst &rest keys) - (declare (type gcontext src dst) - (type (clx-list gcontext-key) keys))) - -(defun copy-gcontext (src dst) - (declare (type gcontext src dst)) - ;; Copies all components. - ) - -(defun free-gcontext (gcontext) - (declare (type gcontext gcontext))) - -(defun clear-area (window &key (x 0) (y 0) width height exposures-p) - ;; Passing in a zero width or height is a no-op. A null width or height translates - ;; into a zero value in the protocol request. - (declare (type window window) - (type int16 x y) - (type (or null card16) width height) - (type boolean exposures-p))) - -(defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height))) - -(defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type pixel plane) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height))) - -(defun draw-point (drawable gcontext x y) - ;; Should be clever about appending to existing buffered protocol request, provided - ;; gcontext has not been modified. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y))) - -(defun draw-points (drawable gcontext points &optional relative-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type point-seq points) - (type boolean relative-p))) - -(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p) - ;; Should be clever about appending to existing buffered protocol request, provided - ;; gcontext has not been modified. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x1 y1 x2 y2) - (type boolean relative-p))) - -(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) - (declare (type drawable drawable) - (type gcontext gcontext) - (type point-seq points) - (type boolean relative-p fill-p) - (type (member :complex :non-convex :convex) shape))) - -(defun draw-segments (drawable gcontext segments) - (declare (type drawable drawable) - (type gcontext gcontext) - (type seg-seq segments))) - -(defun draw-rectangle (drawable gcontext x y width height &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request, provided - ;; gcontext has not been modified. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type boolean fill-p))) - -(defun draw-rectangles (drawable gcontext rectangles &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type rect-seq rectangles) - (type boolean fill-p))) - -(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request, provided - ;; gcontext has not been modified. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type angle angle1 angle2) - (type boolean fill-p))) - -(defun draw-arcs (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type arc-seq arcs) - (type boolean fill-p))) - -;; The following image routines are bare minimum. It may be useful to define some -;; form of "image" object to hide representation details and format conversions. It -;; also may be useful to provide stream-oriented interfaces for reading and writing -;; the data. - -(defun put-raw-image (drawable gcontext data - &key (start 0) depth x y width height (left-pad 0) format) - ;; Data must be a sequence of 8-bit quantities, already in the appropriate format - ;; for transmission; the caller is responsible for all byte and bit swapping and - ;; compaction. Start is the starting index in data; the end is computed from the - ;; other arguments. - (declare (type drawable drawable) - (type gcontext gcontext) - (type (clx-sequence card8) data) - (type array-index start) - (type card8 depth left-pad) - (type int16 x y) - (type card16 width height) - (type (member :bitmap :xy-pixmap :z-pixmap) format))) - -(defun get-raw-image (drawable &key data (start 0) x y width height - (plane-mask 0xffffffff) format - (result-type '(vector (unsigned-byte 8)))) - ;; If data is given, it is modified in place (and returned), otherwise a new - ;; sequence is created and returned, with a size computed from the other arguments - ;; and the returned depth. The sequence is filled with 8-bit quantities, in - ;; transmission format; the caller is responsible for any byte and bit swapping and - ;; compaction required for further local use. - (declare (type drawable drawable) - (type (or null (clx-sequence card8)) data) - (type array-index start) - (type int16 x y) - (type card16 width height) - (type pixel plane-mask) - (type (member :xy-pixmap :z-pixmap) format) - (clx-values (clx-sequence card8) depth visual-info))) - -(defun translate-default (src src-start src-end font dst dst-start) - ;; dst is guaranteed to have room for (- src-end src-start) integer elements, - ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends - ;; on context. font is the current font, if known. The function should - ;; translate as many elements of src as possible into indexes in the current - ;; font, and store them into dst. The first return value should be the src - ;; index of the first untranslated element. If no further elements need to - ;; be translated, the second return value should be nil. If a horizontal - ;; motion is required before further translation, the second return value - ;; should be the delta in x coordinate. If a font change is required for - ;; further translation, the second return value should be the new font. If - ;; known, the pixel width of the translated text can be returned as the third - ;; value; this can allow for appending of subsequent output to the same - ;; protocol request, if no overall width has been specified at the higher - ;; level. - (declare (type sequence src) - (type array-index src-start src-end dst-start) - (type (or null font) font) - (type vector dst) - (clx-values array-index (or null int16 font) (or null int32)))) - -;; There is a question below of whether translate should always be required, or -;; if not, what the default should be or where it should come from. For -;; example, the default could be something that expected a string as src and -;; translated the CL standard character set to ASCII indexes, and ignored fonts -;; and bits. Or the default could expect a string but otherwise be "system -;; dependent". Or the default could be something that expected a vector of -;; integers and did no translation. Or the default could come from the -;; gcontext (but what about text-extents and text-width?). - -(defun text-extents (font sequence &key (start 0) end translate) - ;; If multiple fonts are involved, font-ascent and font-descent will be the - ;; maximums. If multiple directions are involved, the direction will be nil. - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font) - (type translate translate) - (clx-values width ascent descent left right font-ascent font-descent direction - (or null array-index)))) - -(defun text-width (font sequence &key (start 0) end translate) - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font) - (type translate translate) - (clx-values int32 (or null array-index)))) - -;; This controls the element size of the dst buffer given to translate. If -;; :default is specified, the size will be based on the current font, if known, -;; and otherwise 16 will be used. [An alternative would be to pass the buffer -;; size to translate, and allow it to return the desired size if it doesn't -;; like the current size. The problem is that the protocol doesn't allow -;; switching within a single request, so to allow switching would require -;; knowing the width of text, which isn't necessarily known. We could call -;; text-width to compute it, but perhaps that is doing too many favors?] [An -;; additional possibility is to allow an index-size of :two-byte, in which case -;; translate would be given a double-length 8-bit array, and translate would be -;; expected to store first-byte/second-byte instead of 16-bit integers.] - -(deftype index-size () '(member :default 8 16)) - -;; In the glyph functions below, if width is specified, it is assumed to be the -;; total pixel width of whatever string of glyphs is actually drawn. -;; Specifying width will allow for appending the output of subsequent calls to -;; the same protocol request, provided gcontext has not been modified in the -;; interim. If width is not specified, appending of subsequent output might -;; not occur (unless translate returns the width). Specifying width is simply -;; a hint, for performance. - -(defun draw-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type translate translate) - (type (or null int32) width) - (type index-size size) - (clx-values boolean (or null int32)))) - -(defun draw-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type sequence sequence) - (type array-index start) - (type (or null array-index) end) - (type (or null int32) width) - (type translate translate) - (type index-size size) - (clx-values (or null array-index) (or null int32)))) - -(defun draw-image-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is overall width, if known. An initial font change is - ;; allowed from translate. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type translate translate) - (type (or null int32) width) - (type index-size size) - (clx-values boolean (or null int32)))) - -(defun draw-image-glyphs (drawable gcontext x y sequence - &key (start 0) end width translate (size :default)) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type sequence sequence) - (type array-index start) - (type (or null array-index) end) - (type (or null int32) width) - (type translate translate) - (type index-size size) - (clx-values (or null array-index) (or null int32)))) - -(defun create-colormap (visual window &optional alloc-p) - (declare (type visual-info visual) - (type window window) - (type boolean alloc-p) - (clx-values colormap))) - -(defun free-colormap (colormap) - (declare (type colormap colormap))) - -(defun copy-colormap-and-free (colormap) - (declare (type colormap colormap) - (clx-values colormap))) - -(defun install-colormap (colormap) - (declare (type colormap colormap))) - -(defun uninstall-colormap (colormap) - (declare (type colormap colormap))) - -(defun installed-colormaps (window &key (result-type 'list)) - (declare (type window window) - (type type result-type) - (clx-values (clx-sequence colormap)))) - -(defun alloc-color (colormap color) - (declare (type colormap colormap) - (type (or stringable color) color) - (clx-values pixel screen-color exact-color))) - -(defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors planes) - (type boolean contiguous-p) - (type type result-type) - (clx-values (clx-sequence pixel) (clx-sequence mask)))) - -(defun alloc-color-planes (colormap colors - &key (reds 0) (greens 0) (blues 0) - contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors reds greens blues) - (type boolean contiguous-p) - (type type result-type) - (clx-values (clx-sequence pixel) red-mask green-mask blue-mask))) - -(defun free-colors (colormap pixels &optional (plane-mask 0)) - (declare (type colormap colormap) - (type (clx-sequence pixel) pixels) - (type pixel plane-mask))) - -(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t)) - (declare (type colormap colormap) - (type pixel pixel) - (type (or stringable color) spec) - (type boolean red-p green-p blue-p))) - -(defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t)) - ;; If stringables are specified for colors, it is unspecified whether all - ;; stringables are first resolved and then a single StoreColors protocol request is - ;; issued, or whether multiple StoreColors protocol requests are issued. - (declare (type colormap colormap) - (type (repeat-seq (pixel pixel) ((or stringable color) color)) specs) - (type boolean red-p green-p blue-p))) - -(defun query-colors (colormap pixels &key (result-type 'list)) - (declare (type colormap colormap) - (type (clx-sequence pixel) pixels) - (type type result-type) - (clx-values (clx-sequence color)))) - -(defun lookup-color (colormap name) - (declare (type colormap colormap) - (type stringable name) - (clx-values screen-color true-color))) - -(defun create-cursor (&key source mask x y foreground background) - (declare (type pixmap source) - (type (or null pixmap) mask) - (type card16 x y) - (type color foreground background) - (clx-values cursor))) - -(defun create-glyph-cursor (&key source-font source-char mask-font mask-char - foreground background) - (declare (type font source-font) - (type card16 source-char) - (type (or null font) mask-font) - (type (or null card16) mask-char) - (type color foreground background) - (clx-values cursor))) - -(defun free-cursor (cursor) - (declare (type cursor cursor))) - -(defun recolor-cursor (cursor foreground background) - (declare (type cursor cursor) - (type color foreground background))) - -(defun query-best-cursor (width height drawable) - (declare (type card16 width height) - (type drawable display) - (clx-values width height))) - -(defun query-best-tile (width height drawable) - (declare (type card16 width height) - (type drawable drawable) - (clx-values width height))) - -(defun query-best-stipple (width height drawable) - (declare (type card16 width height) - (type drawable drawable) - (clx-values width height))) - -(defun query-extension (display name) - (declare (type display display) - (type stringable name) - (clx-values major-opcode first-event first-error))) - -(defun list-extensions (display &key (result-type 'list)) - (declare (type display display) - (type type result-type) - (clx-values (clx-sequence string)))) - -;; Should pointer-mapping setf be changed to set-pointer-mapping? - -(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) - ;; Can signal device-busy. - ;; Setf ought to allow multiple values. - ;; Returns true for success, nil for failure - (declare (type display display) - (type (clx-sequence card8) shift lock control mod1 mod2 mod3 mod4 mod5) - (clx-values (member :success :busy :failed)))) - -(defun modifier-mapping (display) - ;; each value is a list of card8s - (declare (type display display) - (clx-values shift lock control mod1 mod2 mod3 mod4 mod5))) - -;; Either we will want lots of defconstants for well-known values, or perhaps -;; an integer-to-keyword translation function for well-known values. - -(defun change-keyboard-mapping (display keysyms - &key (start 0) end (first-keycode start)) - ;; start/end give subrange of keysyms - ;; first-keycode is the first-keycode to store at - (declare (type display display) - (type (array * (* *)) keysyms) - (type array-index start) - (type (or null array-index) end) - (type card8 first-keycode))) - -(defun keyboard-mapping (display &key first-keycode start end data) - ;; First-keycode specifies which keycode to start at (defaults to - ;; min-keycode). Start specifies where (in result) to put first-keycode - ;; (defaults to first-keycode). (- end start) is the number of keycodes to - ;; get (end defaults to (1+ max-keycode)). If data is specified, the results - ;; are put there. - (declare (type display display) - (type (or null card8) first-keycode) - (type (or null array-index) start end) - (type (or null (array * (* *))) data) - (clx-values (array * (* *))))) - -(defun change-keyboard-control (display &key key-click-percent - bell-percent bell-pitch bell-duration - led led-mode key auto-repeat-mode) - (declare (type display display) - (type (or null (member :default) int16) key-click-percent - bell-percent bell-pitch bell-duration) - (type (or null card8) led key) - (type (or null (member :on :off)) led-mode) - (type (or null (member :on :off :default)) auto-repeat-mode))) - -(defun keyboard-control (display) - (declare (type display display) - (clx-values key-click-percent bell-percent bell-pitch bell-duration - led-mask global-auto-repeat auto-repeats))) - -(defun bell (display &optional (percent-from-normal 0)) - ;; It is assumed that an eventual audio extension to X will provide more complete - ;; control. - (declare (type display display) - (type int8 percent-from-normal))) - -(defun pointer-mapping (display &key (result-type 'list)) - (declare (type display display) - (type type result-type) - (clx-values (clx-sequence card8)))) - -(defsetf pointer-mapping (display) (map) - ;; Can signal device-busy. - (declare (type display display) - (type (clx-sequence card8) map))) - -(defun change-pointer-control (display &key acceleration threshold) - ;; Acceleration is rationalized if necessary. - (declare (type display display) - (type (or null (member :default) number) acceleration) - (type (or null (member :default) integer) threshold))) - -(defun pointer-control (display) - (declare (type display display) - (clx-values acceleration threshold))) - -(defun set-screen-saver (display timeout interval blanking exposures) - ;; Setf ought to allow multiple values. - ;; Timeout and interval are in seconds, will be rounded to minutes. - (declare (type display display) - (type (or (member :default) int16) timeout interval) - (type (member :on :off :default) blanking exposures))) - -(defun screen-saver (display) - ;; Returns timeout and interval in seconds. - (declare (type display display) - (clx-values timeout interval blanking exposures))) - -(defun activate-screen-saver (display) - (declare (type display display))) - -(defun reset-screen-saver (display) - (declare (type display display))) - -(defun add-access-host (display host) - ;; A string must be acceptable as a host, but otherwise the possible types for host - ;; are not constrained, and will likely be very system dependent. - (declare (type display display))) - -(defun remove-access-host (display host) - ;; A string must be acceptable as a host, but otherwise the possible types for host - ;; are not constrained, and will likely be very system dependent. - (declare (type display display))) - -(defun access-hosts (display &key (result-type 'list)) - ;; The type of host objects returned is not constrained, except that the hosts must - ;; be acceptable to add-access-host and remove-access-host. - (declare (type display display) - (type type result-type) - (clx-values (clx-sequence host) enabled-p))) - -(defun access-control (display) - ;; setf'able - (declare (type display display) - (clx-values boolean))) - -(defun close-down-mode (display) - ;; setf'able - ;; Cached locally in display object. - (declare (type display display) - (clx-values (member :destroy :retain-permanent :retain-temporary)))) - -(defun kill-client (display resource-id) - (declare (type display display) - (type resource-id resource-id))) - -(defun kill-temporary-clients (display) - (declare (type display display))) - -(defun make-event-mask (&rest keys) - ;; This is only defined for core events. - ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask. - (declare (type (clx-list event-mask-class) keys) - (clx-values mask32))) - -(defun make-event-keys (event-mask) - ;; This is only defined for core events. - (declare (type mask32 event-mask) - (clx-values (clx-list event-mask-class)))) - -(defun make-state-mask (&rest keys) - ;; Useful for constructing modifier-mask, state-mask. - (declare (type (clx-list state-mask-key) keys) - (clx-values mask16))) - -(defun make-state-keys (state-mask) - (declare (type mask16 mask) - (clx-values (clx-list state-mask-key)))) - -(defmacro with-event-queue ((display) &body body) - ;; Grants exclusive access to event queue. - ) - -(defun event-listen (display &optional (timeout 0)) - (declare (type display display) - (type (or null number) timeout) - (clx-values (or null number) (or null (member :timeout) (not null)))) - ;; Returns the number of events queued locally, if any, else nil. Hangs - ;; waiting for events, forever if timeout is nil, else for the specified - ;; number of seconds. The second value returned is :timeout if the - ;; operation timed out, and some other non-nil value if an EOF has been - ;; detected. - ) - -(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t)) - ;; If force-output-p is true, first invokes display-force-output. Invokes - ;; handler on each queued event until handler returns non-nil, and that - ;; returned object is then returned by process-event. If peek-p is true, - ;; then the event is not removed from the queue. If discard-p is true, then - ;; events for which handler returns nil are removed from the queue, - ;; otherwise they are left in place. Hangs until non-nil is generated for - ;; some event, or for the specified timeout (in seconds, if given); however, - ;; it is acceptable for an implementation to wait only once on network data, - ;; and therefore timeout prematurely. Returns nil on timeout or EOF, with a - ;; second return value being :timeout for a timeout and some other non-nil - ;; value for EOF. If handler is a sequence, it is expected to contain - ;; handler functions specific to each event class; the event code is used to - ;; index the sequence, fetching the appropriate handler. The arguments to - ;; the handler are described further below using declare-event. If - ;; process-event is invoked recursively, the nested invocation begins with - ;; the event after the one currently being processed. - (declare (type display display) - (type (or (clx-sequence (function (&key &allow-other-keys) t)) - (function (&key &allow-other-keys) t)) - handler) - (type (or null number) timeout) - (type boolean peek-p))) - -(defun make-event-handlers (&key (type 'array) default) - (declare (type t type) ;Sequence type specifier - (type function default) - (clx-values sequence)) ;Default handler for initial content - ;; Makes a handler sequence suitable for process-event - ) - -(defun event-handler (handlers event-key) - (declare (type sequence handlers) - (type event-key event-key) - (clx-values function)) - ;; Accessor for a handler sequence - ) - -(defsetf event-handler (handlers event-key) (handler) - (declare (type sequence handlers) - (type event-key event-key) - (type function handler) - (clx-values function)) - ;; Setf accessor for a handler sequence - ) - -(defmacro event-case ((display &key timeout peek-p discard-p (force-output-p t)) - &body clauses) - (declare (arglist (display &key timeout peek-p discard-p force-output-p) - (event-or-events ((&rest args) |...|) &body body) |...|)) - ;; If force-output-p is true, first invokes display-force-output. Executes - ;; the matching clause for each queued event until a clause returns non-nil, - ;; and that returned object is then returned by event-case. If peek-p is - ;; true, then the event is not removed from the queue. If discard-p is - ;; true, then events for which the clause returns nil are removed from the - ;; queue, otherwise they are left in place. Hangs until non-nil is - ;; generated for some event, or for the specified timeout (in seconds, if - ;; given); however, it is acceptable for an implementation to wait only once - ;; on network data, and therefore timeout prematurely. Returns nil on - ;; timeout or EOF with a second return value being :timeout for a timeout - ;; and some other non-nil value for EOF. In each clause, event-or-events is - ;; an event-key or a list of event-keys (but they need not be typed as - ;; keywords) or the symbol t or otherwise (but only in the last clause). - ;; The keys are not evaluated, and it is an error for the same key to appear - ;; in more than one clause. Args is the list of event components of - ;; interest; corresponding values (if any) are bound to variables with these - ;; names (i.e., the args are variable names, not keywords, the keywords are - ;; derived from the variable names). An arg can also be a (keyword var) - ;; form, as for keyword args in a lambda lists. If no t/otherwise clause - ;; appears, it is equivalent to having one that returns nil. If - ;; process-event is invoked recursively, the nested invocation begins with - ;; the event after the one currently being processed. - ) - -(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) - &body clauses) - ;; The clauses of event-cond are of the form: - ;; (event-or-events binding-list test-form . body-forms) - ;; - ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they - ;; need not be typed as keywords) or the symbol t - ;; or otherwise (but only in the last clause). If - ;; no t/otherwise clause appears, it is equivalent - ;; to having one that returns nil. The keys are - ;; not evaluated, and it is an error for the same - ;; key to appear in more than one clause. - ;; - ;; BINDING-LIST The list of event components of interest. - ;; corresponding values (if any) are bound to - ;; variables with these names (i.e., the binding-list - ;; has variable names, not keywords, the keywords are - ;; derived from the variable names). An arg can also - ;; be a (keyword var) form, as for keyword args in a - ;; lambda list. - ;; - ;; The matching TEST-FORM for each queued event is executed until a - ;; clause's test-form returns non-nil. Then the BODY-FORMS are - ;; evaluated, returning the (possibly multiple) values of the last - ;; form from event-cond. If there are no body-forms then, if the - ;; test-form is non-nil, the value of the test-form is returned as a - ;; single value. - ;; - ;; Options: - ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no - ;; input is pending. - ;; - ;; PEEK-P When true, then the event is not removed from the queue. - ;; - ;; DISCARD-P When true, then events for which the clause returns nil - ;; are removed from the queue, otherwise they are left in place. - ;; - ;; TIMEOUT If NIL, hang until non-nil is generated for some event's - ;; test-form. Otherwise return NIL after TIMEOUT seconds have - ;; elapsed. NIL is also returned whenever EOF is read. - ;; Whenever NIL is returned a second value is returned which - ;; is either :TIMEOUT if a timeout occurred or some other - ;; non-NIL value if an EOF is detected. - ;; - (declare (arglist (display &key timeout peek-p discard-p force-output-p) - (event-or-events (&rest args) test-form &body body) |...|)) - ) - -(defun discard-current-event (display) - (declare (type display display) - (clx-values boolean)) - ;; Discard the current event for DISPLAY. - ;; Returns NIL when the event queue is empty, else T. - ;; To ensure events aren't ignored, application code should only call - ;; this when throwing out of event-case or process-next-event, or from - ;; inside even-case, event-cond or process-event when :peek-p is T and - ;; :discard-p is NIL. - ) - -(defmacro declare-event (event-codes &rest declares) - ;; Used to indicate the keyword arguments for handler functions in process-event - ;; and event-case. In the declares, an argument listed as (name1 name2) indicates - ;; synonyms for the same argument. All process-event handlers can have - ;; (display display), (event-key event-key), and (boolean send-event-p) as keyword - ;; arguments, and an event-case clause can also have event-key and send-event-p as - ;; arguments. - (declare (arglist event-key-or-keys &rest (type &rest keywords)))) - -(declare-event (:key-press :key-release :button-press :button-release) - (card16 sequence) - (window (window event-window) root) - ((or null window) child) - (boolean same-screen-p) - (int16 x y root-x root-y) - (card16 state) - ((or null card32) time) - ;; for key-press and key-release, code is the keycode - ;; for button-press and button-release, code is the button number - (card8 code)) - -(declare-event :motion-notify - (card16 sequence) - (window (window event-window) root) - ((or null window) child) - (boolean same-screen-p) - (int16 x y root-x root-y) - (card16 state) - ((or null card32) time) - (boolean hint-p)) - -(declare-event (:enter-notify :leave-notify) - (card16 sequence) - (window (window event-window) root) - ((or null window) child) - (boolean same-screen-p) - (int16 x y root-x root-y) - (card16 state) - ((or null card32) time) - ((member :normal :grab :ungrab) mode) - ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual) kind) - (boolean focus-p)) - -(declare-event (:focus-in :focus-out) - (card16 sequence) - (window (window event-window)) - ((member :normal :while-grabbed :grab :ungrab) mode) - ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual - :pointer :pointer-root :none) - kind)) - -(declare-event :keymap-notify - ((bit-vector 256) keymap)) - -(declare-event :exposure - (card16 sequence) - (window (window event-window)) - (card16 x y width height count)) - -(declare-event :graphics-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card16 x y width height count) - (card8 major) - (card16 minor)) - -(declare-event :no-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card8 major) - (card16 minor)) - -(declare-event :visibility-notify - (card16 sequence) - (window (window event-window)) - ((member :unobscured :partially-obscured :fully-obscured) state)) - -(declare-event :create-notify - (card16 sequence) - (window window (parent event-window)) - (int16 x y) - (card16 width height border-width) - (boolean override-redirect-p)) - -(declare-event :destroy-notify - (card16 sequence) - (window event-window window)) - -(declare-event :unmap-notify - (card16 sequence) - (window event-window window) - (boolean configure-p)) - -(declare-event :map-notify - (card16 sequence) - (window event-window window) - (boolean override-redirect-p)) - -(declare-event :map-request - (card16 sequence) - (window (parent event-window) window)) - -(declare-event :reparent-notify - (card16 sequence) - (window event-window window parent) - (int16 x y) - (boolean override-redirect-p)) - -(declare-event :configure-notify - (card16 sequence) - (window event-window window) - (int16 x y) - (card16 width height border-width) - ((or null window) above-sibling) - (boolean override-redirect-p)) - -(declare-event :gravity-notify - (card16 sequence) - (window event-window window) - (int16 x y)) - -(declare-event :resize-request - (card16 sequence) - (window (window event-window)) - (card16 width height)) - -(declare-event :configure-request - (card16 sequence) - (window (parent event-window) window) - (int16 x y) - (card16 width height border-width) - ((member :above :below :top-if :bottom-if :opposite) stack-mode) - ((or null window) above-sibling) - (mask16 value-mask)) - -(declare-event :circulate-notify - (card16 sequence) - (window event-window window) - ((member :top :bottom) place)) - -(declare-event :circulate-request - (card16 sequence) - (window (parent event-window) window) - ((member :top :bottom) place)) - -(declare-event :property-notify - (card16 sequence) - (window (window event-window)) - (keyword atom) - ((member :new-value :deleted) state) - ((or null card32) time)) - -(declare-event :selection-clear - (card16 sequence) - (window (window event-window)) - (keyword selection) - ((or null card32) time)) - -(declare-event :selection-request - (card16 sequence) - (window (window event-window) requestor) - (keyword selection target) - ((or null keyword) property) - ((or null card32) time)) - -(declare-event :selection-notify - (card16 sequence) - (window (window event-window)) - (keyword selection target) - ((or null keyword) property) - ((or null card32) time)) - -(declare-event :colormap-notify - (card16 sequence) - (window (window event-window)) - ((or null colormap) colormap) - (boolean new-p installed-p)) - -(declare-event :mapping-notify - (card16 sequence) - ((member :modifier :keyboard :pointer) request) - (card8 start count)) - -(declare-event :client-message - (card16 sequence) - (window (window event-window)) - ((member 8 16 32) format) - (sequence data)) - -(defun queue-event (display event-key &rest args &key append-p &allow-other-keys) - ;; The event is put at the head of the queue if append-p is nil, else the tail. - ;; Additional arguments depend on event-key, and are as specified above with - ;; declare-event, except that both resource-ids and resource objects are accepted - ;; in the event components. - (declare (type display display) - (type event-key event-key) - (type boolean append-p))) - - - -;;; From here on, there has been less coherent review of the interface: - -;;;----------------------------------------------------------------------------- -;;; Window Manager Property functions - -(defun wm-name (window) - (declare (type window window) - (clx-values string))) - -(defsetf wm-name (window) (name)) - -(defun wm-icon-name (window) - (declare (type window window) - (clx-values string))) - -(defsetf wm-icon-name (window) (name)) - -(defun get-wm-class (window) - (declare (type window window) - (clx-values (or null name-string) (or null class-string)))) - -(defun set-wm-class (window resource-name resource-class) - (declare (type window window) - (type (or null stringable) resource-name resource-class))) - -(defun wm-command (window) - ;; Returns a list whose car is a command string and - ;; whose cdr is the list of argument strings. - (declare (type window window) - (clx-values (clx-list string)))) - -(defsetf wm-command (window) (command) - ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or - ;; equivalent), with elements of command separated by NULL characters. This - ;; enables - ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) - ;; to recover a lisp command. - (declare (type window window) - (type (clx-list stringable) command))) - -(defun wm-client-machine (window) - ;; Returns a list whose car is a command string and - ;; whose cdr is the list of argument strings. - (declare (type window window) - (clx-values string))) - -(defsetf wm-client-machine (window) (string) - (declare (type window window) - (type stringable string))) - -(defstruct wm-hints - (input nil :type (or null (member :off :on))) - (initial-state nil :type (or null (member :normal :iconic))) - (icon-pixmap nil :type (or null pixmap)) - (icon-window nil :type (or null window)) - (icon-x nil :type (or null card16)) - (icon-y nil :type (or null card16)) - (icon-mask nil :type (or null pixmap)) - (window-group nil :type (or null resource-id)) - (flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field - ;; may be extended in the future - ) - -(defun wm-hints (window) - (declare (type window window) - (clx-values wm-hints))) - -(defsetf wm-hints (window) (wm-hints)) - - -(defstruct wm-size-hints - ;; Defaulted T to put the burden of remembering these on widget programmers. - (user-specified-position-p t :type boolean) ;; True when user specified x y - (user-specified-size-p t :type boolean) ;; True when user specified width height - (x nil :type (or null int16)) ;; Obsolete - (y nil :type (or null int16)) ;; Obsolete - (width nil :type (or null card16)) ;; Obsolete - (height nil :type (or null card16)) ;; Obsolete - (min-width nil :type (or null card16)) - (min-height nil :type (or null card16)) - (max-width nil :type (or null card16)) - (max-height nil :type (or null card16)) - (width-inc nil :type (or null card16)) - (height-inc nil :type (or null card16)) - (min-aspect nil :type (or null number)) - (max-aspect nil :type (or null number)) - (base-width nil :type (or null card16)) - (base-height nil :type (or null card16)) - (win-gravity nil :type (or null win-gravity))) - -(defun wm-normal-hints (window) - (declare (type window window) - (clx-values wm-size-hints))) - -(defsetf wm-normal-hints (window) (wm-size-hints)) - -;; ICON-SIZES uses the SIZE-HINTS structure - -(defun icon-sizes (window) - (declare (type window window) - (clx-values wm-size-hints))) - -(defsetf icon-sizes (window) (wm-size-hints)) - -(defun wm-protocols (window) - (declare (type window window) - (clx-values protocols))) - -(defsetf wm-protocols (window) (protocols) - (declare (type window window) - (type (clx-list keyword) protocols))) - -(defun wm-colormap-windows (window) - (declare (type window window) - (clx-values windows))) - -(defsetf wm-colormap-windows (window) (windows) - (declare (type window window) - (type (clx-list window) windows))) - -(defun transient-for (window) - (declare (type window window) - (clx-values window))) - -(defsetf transient-for (window) (transient) - (declare (type window window transient))) - -(defun set-wm-properties (window &rest options &key - name icon-name resource-name resource-class command - hints normal-hints - ;; the following are used for wm-normal-hints - user-specified-position-p user-specified-size-p - program-specified-position-p program-specified-size-p - min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group) - ;; Set properties for WINDOW. - (declare (type window window) - (type (or null stringable) name icoin-name resource-name resource-class) - (type (or null list) command) - (type (or null wm-hints) hints) - (type (or null wm-size-hints) normal-hints) - (type boolean user-specified-position-p user-specified-size-p) - (type boolean program-specified-position-p program-specified-size-p) - (type (or null card16) min-width min-height max-width max-height width-inc height-inc base-width base-height win-gravity) - (type (or null number) min-aspect max-aspect) - (type (or null (member :off :on)) input) - (type (or null (member :normal :iconic)) initial-state) - (type (or null pixmap) icon-pixmap icon-mask) - (type (or null window) icon-window) - (type (or null card16) icon-x icon-y) - (type (or null resource-id) window-group))) - -(defun iconify-window (window) - (declare (type window window))) - -(defun withdraw-window (window) - (declare (type window window))) - -(defstruct standard-colormap - (colormap nil :type (or null colormap)) - (base-pixel 0 :type pixel) - (max-color nil :type (or null color)) - (mult-color nil :type (or null color)) - (visual nil :type (or null visual-info)) - (kill nil :type (or (member nil :release-by-freeing-colormap) - drawable gcontext cursor colormap font))) - -(defun rgb-colormaps (window property) - (declare (type window window) - (type (member :rgb_default_map :rgb_best_map :rgb_red_map - :rgb_green_map :rgb_blue_map) property) - (clx-values (clx-list standard-colormap)))) - -(defsetf rgb-colormaps (window property) (standard-colormaps) - (declare (type window window) - (type (member :rgb_default_map :rgb_best_map :rgb_red_map - :rgb_green_map :rgb_blue_map) property) - (type (clx-list standard-colormap) standard-colormaps))) - -(defun cut-buffer (display &key (buffer 0) (type :string) (result-type 'string) - (transform #'card8->char) (start 0) end) - ;; Return the contents of cut-buffer BUFFER - (declare (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type array-index start) - (type (or null array-index) end) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform) - (clx-values sequence type format bytes-after))) - -(defsetf cut-buffer (display buffer &key (type :string) (format 8) - (transform #'char->card8) (start 0) end) (data)) - -(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t)) - ;; Positive rotates left, negative rotates right (opposite of actual - ;; protocol request). When careful-p, ensure all cut-buffer - ;; properties are defined, to prevent errors. - (declare (type display display) - (type int16 delta) - (type boolean careful-p))) - -;;;----------------------------------------------------------------------------- -;;; Keycode mapping - -(defun define-keysym-set (set first-keysym last-keysym) - ;; Define all keysyms from first-keysym up to and including - ;; last-keysym to be in SET (returned from the keysym-set function). - ;; Signals an error if the keysym range overlaps an existing set. - (declare (type keyword set) - (type keysym first-keysym last-keysym))) - -(defun keysym-set (keysym) - ;; Return the character code set name of keysym - ;; Note that the keyboard set (255) has been broken up into its parts. - (declare (type keysym keysym) - (clx-values keyword))) - -(defun define-keysym (object keysym &key lowercase translate modifiers mask display) - ;; Define the translation from keysym/modifiers to a (usually - ;; character) object. ANy previous keysym definition with - ;; KEYSYM and MODIFIERS is deleted before adding the new definition. - ;; - ;; MODIFIERS is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying when to use this - ;; keysym-translation. The default is NIL. - ;; - ;; MASK is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying which modifiers to look at - ;; (i.e. modifiers not specified are don't-cares). - ;; If mask is :MODIFIERS then the mask is the same as the modifiers - ;; (i.e. modifiers not specified by modifiers are don't cares) - ;; The default mask is *default-keysym-translate-mask* - ;; - ;; If DISPLAY is specified, the translation will be local to DISPLAY, - ;; otherwise it will be the default translation for all displays. - ;; - ;; LOWERCASE is used for uppercase alphabetic keysyms. The value - ;; is the associated lowercase keysym. This information is used - ;; by the keysym-both-case-p predicate (for caps-lock computations) - ;; and by the keysym-downcase function. - ;; - ;; TRANSLATE will be called with parameters (display state OBJECT) - ;; when translating KEYSYM and modifiers and mask are satisfied. - ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*)) - ;; (or modifiers 0))) - ;; when mask and modifiers aren't lists of keysyms] - ;; The default is #'default-keysym-translate - ;; - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - mask) - (type (or null display) display) - (type (or null keysym) lowercase) - (type (function (display card16 t) t) translate))) - -(defvar *default-keysym-translate-mask* - (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - (logand #xff (lognot (make-state-mask :lock)))) - "Default keysym state mask to use during keysym-translation.") - -(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) - ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS. - ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists. - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null display) display))) - -(defun default-keysym-translate (display state object) - ;; If object is a character, char-bits are set from state. - ;; If object is a list, it is an alist with entries: - ;; (base-char [modifiers] [mask-modifiers) - ;; When MODIFIERS are specified, this character translation - ;; will only take effect when the specified modifiers are pressed. - ;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. - ;; When MASK-MODIFIERS is missing, all other modifiers are ignored. - ;; In ambiguous cases, the most specific translation is used. - (declare (type display display) - (type card16 state) - (type t object) - (clx-values t))) ;; Object returned by keycode->character - -(defmacro keysym (keysym &rest bytes) - ;; Build a keysym. - ;; If KEYSYM is an integer, it is used as the most significant bits of - ;; the keysym, and BYTES are used to specify low order bytes. The last - ;; parameter is always byte4 of the keysym. If KEYSYM is not an - ;; integer, the keysym associated with KEYSYM is returned. - ;; - ;; This is a macro and not a function macro to promote compile-time - ;; lookup. All arguments are evaluated. - (declare (type t keysym) - (type (clx-list card8) bytes) - (clx-values keysym))) - -(defun character->keysyms (character &optional display) - ;; Given a character, return a list of all matching keysyms. - ;; If DISPLAY is given, translations specific to DISPLAY are used, - ;; otherwise only global translations are used. - ;; Implementation dependent function. - ;; May be slow [i.e. do a linear search over all known keysyms] - (declare (type t character) - (type (or null display) display) - (clx-values (clx-list keysym)))) - -(defun keycode->keysym (display keycode keysym-index) - (declare (type display display) - (type card8 code) - (type card16 state) - (type card8 keysym-index) - (clx-values keysym))) - -(defun keysym->keycodes (display keysym) - ;; Return keycodes for keysym, as multiple values - (declare (type display display) - (type keysym keysym) - (clx-values (or null keycode) (or null keycode) (or null keycode))) - ) - -(defun keysym->character (display keysym &optional state) - ;; Find the character associated with a keysym. - ;; STATE is used for adding char-bits to character as follows: - ;; control -> char-control-bit - ;; mod-1 -> char-meta-bit - ;; mod-2 -> char-super-bit - ;; mod-3 -> char-hyper-bit - ;; Implementation dependent function. - (declare (type display display) - (type keysym keysym) - (type (or null card16) state) - (clx-values (or null character)))) - -(defun keycode->character (display keycode state &key keysym-index - (keysym-index-function #'default-keysym-index)) - ;; keysym-index defaults to the result of keysym-index-function which - ;; is called with the following parameters: - ;; (char0 state caps-lock-p keysyms-per-keycode) - ;; where char0 is the "character" object associated with keysym-index 0 and - ;; caps-lock-p is non-nil when the keysym associated with the lock - ;; modifier is for caps-lock. - ;; STATE is also used for setting char-bits: - ;; control -> char-control-bit - ;; mod-1 -> char-meta-bit - ;; mod-2 -> char-super-bit - ;; mod-3 -> char-hyper-bit - ;; Implementation dependent function. - (declare (type display display) - (type card8 keycode) - (type card16 state) - (type (or null card8) keysym-index) - (type (or null (function (char0 state caps-lock-p keysyms-per-keycode) card8)) - keysym-index-function) - (clx-values (or null character)))) - -(defun default-keysym-index (display keycode state) - ;; Returns a keysym-index for use with keycode->character - (declare (clx-values card8)) -) - -;;; default-keysym-index implements the following tables: -;;; -;;; control shift caps-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\8 -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\* -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-8 -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-* -;;; -;;; control shift shift-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\* -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\8 -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-* -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-8 - -(defun state-keysymp (display state keysym) - ;; Returns T when a modifier key associated with KEYSYM is on in STATE - (declare (type display display) - (type card16 state) - (type keysym keysym) - (clx-values boolean))) - -(defun mapping-notify (display request start count) - ;; Called on a mapping-notify event to update - ;; the keyboard-mapping cache in DISPLAY - (declare (type display display) - (type (member :modifier :keyboard :pointer) request) - (type card8 start count))) - -(defun keysym-in-map-p (display keysym keymap) - ;; Returns T if keysym is found in keymap - (declare (type display display) - (type keysym keysym) - (type (bit-vector 256) keymap) - (value boolean))) - -(defun character-in-map-p (display character keymap) - ;; Implementation dependent function. - ;; Returns T if character is found in keymap - (declare (type display display) - (type t character) - (type (bit-vector 256) keymap) - (value boolean))) - -;;;----------------------------------------------------------------------------- -;;; Extensions - -(defmacro define-extension (name &key events errors) - ;; Define extension NAME with EVENTS and ERRORS. - ;; Note: The case of NAME is important. - ;; To define the request, Use: - ;; (with-buffer-request (display (extension-opcode ,name)) ,@body) - ;; See the REQUESTS file for lots of examples. - ;; To define event handlers, use declare-event. - ;; To define error handlers, use declare-error and define-condition. - (declare (type stringable name) - (type (clx-list symbol) events errors))) - -(defmacro extension-opcode (display name) - ;; Returns the major opcode for extension NAME. - ;; This is a macro to enable NAME to be interned for fast run-time - ;; retrieval. - ;; Note: The case of NAME is important. - (declare (type display display) - (type stringable name) - (clx-values card8))) - -(defmacro define-error (error-key function) - ;; Associate a function with ERROR-KEY which will be called with - ;; parameters DISPLAY and REPLY-BUFFER and returns a plist of - ;; keyword/value pairs which will be passed on to the error handler. - ;; A compiler warning is printed when ERROR-KEY is not defined in a - ;; preceding DEFINE-EXTENSION. - ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type - ;; macros for getting error fields. See DECODE-CORE-ERROR for - ; an example. - (declare (type symbol error-key) - (type function function))) - -;; All core errors use this, so we make it available to extensions. -(defun decode-core-error (display event &optional arg) - ;; All core errors have the following keyword/argument pairs: - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; :current-sequence integer - ;; In addition, many have an additional argument that comes from the - ;; same place in the event, but is named differently. When the ARG - ;; argument is specified, the keyword ARG with card32 value starting - ;; at byte 4 of the event is returned with the other keyword/argument - ;; pairs. - (declare (type display display) - (type reply-buffer event) - (type (or null keyword) arg) - (clx-values keyword/arg-plist))) - -;; This isn't new, just extended. -(defmacro declare-event (event-codes &body declares) - ;; Used to indicate the keyword arguments for handler functions in - ;; process-event and event-case. - ;; Generates functions used in SEND-EVENT. - ;; A compiler warning is printed when all of EVENT-CODES are not - ;; defined by a preceding DEFINE-EXTENSION. - ;; See the INPUT file for lots of examples. - (declare (type (or keyword (clx-list keywords)) event-codes) - (type (alist (field-type symbol) (field-names (clx-list symbol))) - declares))) - -(defmacro define-gcontext-accessor (name &key default set-function copy-function) - ;; This will define a new gcontext accessor called NAME. - ;; Defines the gcontext-NAME accessor function and its defsetf. - ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when - ;; gcontext-cache-p is true. The NAME keyword will be allowed in - ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS. - ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE) - ;; from create-gcontext, and force-gcontext-changes. - ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value) - ;; from copy-gcontext and copy-gcontext-components. - ;; The copy-function defaults to: - ;; (lambda (ignore dst-gc value) - ;; (if value - ;; (,set-function dst-gc value) - ;; (error "Can't copy unknown GContext component ~a" ',name))) - (declare (type symbol name) - (type t default) - (type symbol set-function) ;; required - (type symbol copy-function))) - - -;; To aid extension implementors in attaching additional information to -;; clx data structures, the following accessors (with SETF's) are -;; defined. GETF can be used on these to extend the structures. - -display-plist -screen-plist -visual-info-plist -gcontext-plist -font-plist -drawable-plist - - - -;;; These have had perhaps even less review. - -;;; Add some of the functionality provided by the C XLIB library. -;;; -;;; LaMott G. Oren, Texas Instruments 10/87 -;;; -;;; Design Contributors: -;;; Robert W. Scheifler, MIT - -;;;----------------------------------------------------------------------------- -;;; Regions (not yet implemented) - -;;; Regions are arbitrary collections of pixels. This is represented -;;; in the region structure as either a list of rectangles or a bitmap. - -(defun make-region (&optional x y width height) - ;; With no parameters, returns an empty region - ;; If some parameters are given, all must be given. - (declare (type (or null int16) x y width height) - (clx-values region))) - -(defun region-p (thing)) - -(defun copy-region (region)) - -(defun region-empty-p (region) - (declare (type region region) - (clx-values boolean))) - -(defun region-clip-box (region) - ;; Returns a region which is the smallest enclosing rectangle - ;; enclosing REGION - (declare (type region region) - (clx-values region))) - -;; Accessors that return the boundaries of a region -(defun region-x (region)) -(defun region-y (region)) -(defun region-width (region)) -(defun region-height (region)) - -(defsetf region-x (region) (x)) -(defsetf region-y (region) (y)) -;; Setting a region's X/Y translates the region - -(defun region-intersection (&rest regions) - "Returns a region which is the intersection of one or more REGIONS. -Returns an empty region if the intersection is empty. -If there are no regions given, return a very large region." - (declare (type (clx-list region) regions) - (clx-values region))) - -(defun region-union (&rest regions) - "Returns a region which is the union of a number of REGIONS - (i.e. the smallest region that can contain all the other regions) - Returns the empty region if no regions are given." - (declare (type (clx-list region) regions) - (clx-values region))) - -(defun region-subtract (region subtract) - "Returns a region containing the points that are in REGION but not in SUBTRACT" - (declare (type region region subtract) - (clx-values region))) - -(defun point-in-region-p (region x y) - ;; Returns T when X/Y are a point within REGION. - (declare (type region region) - (type int16 x y) - (clx-values boolean))) - -(defun region-equal (a b) - ;; Returns T when regions a and b contain the same points. - ;; That is, return t when for every X/Y (point-in-region-p a x y) - ;; equals (point-in-region-p b x y) - (declare (type region a b) - (clx-values boolean))) - -(defun subregion-p (large small) - "Returns T if SMALL is within LARGE. - That is, return T when for every X/Y (point-in-region-p small X Y) - implies (point-in-region-p large X Y)." - (declare (type region large small) - (clx-values boolean))) - -(defun region-intersect-p (a b) - "Returns T if A intersects B. - That is, return T when there is some point common to regions A and B." - (declare (type region a b) - (clx-values boolean))) - -(defun map-region (region function &rest args) - ;; Calls function with arguments (x y . args) for every point in REGION. - (declare (type region region) - (type (function x y &rest args) function))) - -;; Why isn't it better to augment -;; gcontext-clip-mask to deal with -;; (or null (member :none) pixmap rect-seq region) -;; and force conversions on the caller? -;; Good idea. - -;;(defun gcontext-clip-region (gcontext) -;; ;; If the clip-mask of GCONTEXT is known, return it as a region. -;; (declare (type gcontext gcontext) -;; (clx-values (or null region)))) - -;;(defsetf gcontext-clip-region (gcontext) (region) -;; ;; Set the clip-rectangles or clip-mask for for GCONTEXT to include -;; ;; only the pixels within REGION. -;; (declare (type gcontext gcontext) -;; (type region region))) - -(defun image->region (image) - ;; Returns a region containing the 1 bits of a depth-1 image - ;; Signals an error if image isn't of depth 1. - (declare (type image image) - (clx-values region))) - -(defun region->image (region) - ;; Returns a depth-1 image containg 1 bits for every pixel in REGION. - (declare (type region region) - (clx-values image))) - -(defun polygon-region (points &optional (fill-rule :even-odd)) - (declare (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type (member :even-odd :winding) fill-rule) - (clx-values region))) - -;;;----------------------------------------------------------------------------- -;;; IMAGE functions - - -(deftype bitmap () '(array bit (* *))) -(deftype pixarray () '(array pixel (* *))) - -(defconstant *lisp-byte-lsb-first-p* #+lispm t #-lispm nil - "Byte order in pixel arrays") - -(defstruct image - ;; Public structure - (width 0 :type card16 :read-only t) - (height 0 :type card16 :read-only t) - (depth 1 :type card8 :read-only t) - (plist nil :type list)) - -;; Image-Plist accessors: -(defun image-name (image)) -(defun image-x-hot (image)) -(defun image-y-hot (image)) -(defun image-red-mask (image)) -(defun image-blue-mask (image)) -(defun image-green-mask (image)) - -(defsetf image-name (image) (name)) -(defsetf image-x-hot (image) (x)) -(defsetf image-y-hot (image) (y)) -(defsetf image-red-mask (image) (mask)) -(defsetf image-blue-mask (image) (mask)) -(defsetf image-green-mask (image) (mask)) - -(defstruct (image-x (:include image)) - ;; Use this format for shoveling image data - ;; Private structure. Accessors for these NOT exported. - (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) - (bytes-per-line 0 :type card16) - (scanline-pad 32 :type (member 8 16 32)) - (bits-per-pixel 0 :type (member 1 4 8 16 24 32)) - (bit-lsb-first-p nil :type boolean) ; Bit order - (byte-lsb-first-p nil :type boolean) ; Byte order - (data #() :type (array card8 (*)))) ; row-major - -(defstruct (image-xy (:include image)) - ;; Public structure - ;; Use this format for image processing - (bitmap-list nil :type (clx-list bitmap))) - -(defstruct (image-z (:include image)) - ;; Public structure - ;; Use this format for image processing - (bits-per-pixel 0 :type (member 1 4 8 16 24 32)) - (pixarray #() :type pixarray)) - -(defun create-image (&key (width (required-arg width)) - (height (required-arg height)) - depth data plist name x-hot y-hot - red-mask blue-mask green-mask - bits-per-pixel format scanline-pad bytes-per-line - byte-lsb-first-p bit-lsb-first-p ) - ;; Returns an image-x image-xy or image-z structure, depending on the - ;; type of the :DATA parameter. - (declare - (type card16 width height) ; Required - (type (or null card8) depth) ; Defualts to 1 - (type (or (array card8 (*)) ;Returns image-x - (clx-list bitmap) ;Returns image-xy - pixarray) data) ;Returns image-z - (type list plist) - (type (or null stringable) name) - (type (or null card16) x-hot y-hot) - (type (or null pixel) red-mask blue-mask green-mask) - (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) - - ;; The following parameters are ignored for image-xy and image-z: - (type (or null (member :bitmap :xy-pixmap :z-pixmap)) - format) ; defaults to :z-pixmap - (type (or null (member 8 16 32)) scanline-pad) - (type (or null card16) bytes-per-line) ;default from width and scanline-pad - (type boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image))) - -(defun get-image (drawable &key - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - plane-mask format result-type) - ;; Get an image from the server. - ;; Format defaults to :z-pixmap. Result-Type defaults from Format, - ;; image-z for :z-pixmap, and image-xy for :xy-pixmap. - ;; Plane-mask defaults to #xFFFFFFFF. - ;; Returns an image-x image-xy or image-z structure, depending on the - ;; result-type parameter. - (declare (type drawable drawable) - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (or null pixel) plane-mask) - (type (or null (member :xy-pixmap :z-pixmap)) format) - (type (or null (member image-x image-xy image-z)) result-type) - (clx-values image))) - -(defun put-image (drawable gcontext image &key - (src-x 0) (src-y 0) - (x (required-arg x)) - (y (required-arg y)) - width height - bitmap-p) - ;; When BITMAP-P, force format to be :bitmap when depth=1 - ;; This causes gcontext to supply foreground & background pixels. - (declare (type drawable drawable) - (type gcontext gcontext) - (type image image) - (type int16 x y) ;; required - (type (or null card16) width height) - (type boolean bitmap-p))) - -(defun copy-image (image &key (x 0) (y 0) width height result-type) - ;; Copy with optional sub-imaging and format conversion. - ;; result-type defaults to (type-of image) - (declare (type image image) - (type card16 x y) - (type (or null card16) width height) ;; Default from image - (type (or null (member image-x image-xy image-z)) result-type) - (clx-values image))) - -(defun read-bitmap-file (pathname) - ;; Creates an image from a C include file in standard X11 format - (declare (type (or pathname string stream) pathname) - (clx-values image))) - -(defun write-bitmap-file (pathname image &optional name) - ;; Writes an image to a C include file in standard X11 format - ;; NAME argument used for variable prefixes. Defaults to "image" - (declare (type (or pathname string stream) pathname) - (type image image) - (type (or null stringable) name))) - -;;;----------------------------------------------------------------------------- -;;; Resource data-base - - -(defun make-resource-database () - ;; Returns an empty resource data-base - (declare (clx-values resource-database))) - -(defun get-resource (database value-name value-class full-name full-class) - ;; Return the value of the resource in DATABASE whose partial name - ;; most closely matches (append full-name (list value-name)) and - ;; (append full-class (list value-class)). - (declare (type resource-database database) - (type stringable value-name value-class) - (type (clx-list stringable) full-name full-class) - (clx-values value))) - -(defun add-resource (database name-list value) - ;; name-list is a list of either strings or symbols. If a symbol, - ;; case-insensitive comparisons will be used, if a string, - ;; case-sensitive comparisons will be used. The symbol '* or - ;; string "*" are used as wildcards, matching anything or nothing. - (declare (type resource-database database) - (type (clx-list stringable) name-list) - (type t value))) - -(defun delete-resource (database name-list) - (declare (type resource-database database) - (type (clx-list stringable) name-list))) - -(defun map-resource (database function &rest args) - ;; Call FUNCTION on each resource in DATABASE. - ;; FUNCTION is called with arguments (name-list value . args) - (declare (type resource-database database) - (type (function ((clx-list stringable) t &rest t) t) function) - (clx-values nil))) - -(defun merge-resources (database with-database) - (declare (type resource-database database with-database) - (clx-values resource-database)) - (map-resource #'add-resource database with-database) - with-database) - -;; Note: with-input-from-string can be used with read-resources to define -;; default resources in a program file. - -(defun read-resources (database pathname &key key test test-not) - ;; Merges resources from a file in standard X11 format with DATABASE. - ;; KEY is a function used for converting value-strings, the default is - ;; identity. TEST and TEST-NOT are predicates used for filtering - ;; which resources to include in the database. They are called with - ;; the name and results of the KEY function. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string) t)) key) - (type (or null (function ((clx-list string) t) boolean)) - test test-not) - (clx-values resource-database))) - -(defun write-resources (database pathname &key write test test-not) - ;; Write resources to PATHNAME in the standard X11 format. - ;; WRITE is a function used for writing values, the default is #'princ - ;; TEST and TEST-NOT are predicates used for filtering which resources - ;; to include in the database. They are called with the name and value. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string stream) t)) write) - (type (or null (function ((clx-list string) t) boolean)) - test test-not))) - -(defun root-resources (screen &key database key test test-not) - "Returns a resource database containing the contents of the root window - RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, - then its default screen is used. If an existing DATABASE is given, then - resource values are merged with the DATABASE and the modified DATABASE is - returned. - - TEST and TEST-NOT are predicates for selecting which resources are - read. Arguments are a resource name list and a resource value. The KEY - function, if given, is called to convert a resource value string to the - value given to TEST or TEST-NOT." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (string) t)) key) - (type (or null (function list boolean)) test test-not) - (clx-values resource-database))) - -(defsetf root-resources (screen &key test test-not (write 'princ)) (database) - "Changes the contents of the root window RESOURCE_MANAGER property for the - given SCREEN. If SCREEN is a display, then its default screen is used. - - TEST and TEST-NOT are predicates for selecting which resources from the - DATABASE are written. Arguments are a resource name list and a resource - value. The WRITE function is used to convert a resource value into a - string stored in the property." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function list boolean)) test test-not) - (type (or null (function (string stream) t)) write) - (clx-values resource-database))) - -;;;----------------------------------------------------------------------------- -;;; Shared GContext's - -(defmacro using-gcontext ((var &rest options &key drawable - function plane-mask foreground background - line-width line-style cap-style - join-style fill-style fill-rule arc-mode - tile stipple ts-x ts-y font - subwindow-mode exposures clip-x clip-y - clip-mask clip-ordering dash-offset - dashes) - &body body) - ;; Equivalent to (let ((var (apply #'make-gcontext options))) ,@body) - ;; but more efficient because it uses a gcontext cache associated with - ;; drawable's display. - ) - - - - X11 Request Name CLX Function Name ------------------ ----------------- -AllocColor ALLOC-COLOR -AllocColorCells ALLOC-COLOR-CELLS -AllocColorPlanes ALLOC-COLOR-PLANES -AllocNamedColor ALLOC-COLOR -AllowEvents ALLOW-EVENTS -Bell BELL -ChangeAccessControl (setf (ACCESS-CONTROL display) boolean) -ChangeActivePointerGrab CHANGE-ACTIVE-POINTER-GRAB -ChangeCloseDownMode (setf (CLOSE-DOWN-MODE display) mode) -ChangeGC FORCE-GCONTEXT-CHANGES - ;; See WITH-GCONTEXT - (setf (gcontext-function gc) boole-constant) - (setf (gcontext-plane-mask gc) card32) - (setf (gcontext-foreground gc) card32) - (setf (gcontext-background gc) card32) - (setf (gcontext-line-width gc) card16) - (setf (gcontext-line-style gc) keyword) - (setf (gcontext-cap-style gc) keyword) - (setf (gcontext-join-style gc) keyword) - (setf (gcontext-fill-style gc) keyword) - (setf (gcontext-fill-rule gc) keyword) - (setf (gcontext-tile gc) pixmap) - (setf (gcontext-stipple gc) pixmap) - (setf (gcontext-ts-x gc) int16) ;; Tile-Stipple-X-origin - (setf (gcontext-ts-y gc) int16) ;; Tile-Stipple-Y-origin - (setf (gcontext-font gc &optional metrics-p) font) - (setf (gcontext-subwindow-mode gc) keyword) - (setf (gcontext-exposures gc) (member :on :off)) - (setf (gcontext-clip-x gc) int16) - (setf (gcontext-clip-y gc) int16) - (setf (gcontext-clip-mask gc &optional ordering) - (or (member :none) pixmap rect-seq)) - (setf (gcontext-dash-offset gc) card16) - (setf (gcontext-dashes gc) (or card8 sequence)) - (setf (gcontext-arc-mode gc) (member :chord :pie-slice)) - (setf (gcontext-clip-ordering gc) keyword) - -ChangeHosts ADD-ACCESS-HOST -ChangeHosts REMOVE-ACCESS-HOST -ChangeKeyboardControl CHANGE-KEYBOARD-CONTROL -ChangePointerControl CHANGE-POINTER-CONTROL -ChangeProperty CHANGE-PROPERTY -ChangeSaveSet REMOVE-FROM-SAVE-SET -ChangeSaveSet ADD-TO-SAVE-SET -ChangeWindowAttributes - ;; See WITH-STATE - (setf (window-background window) value) - (setf (window-border window) value) - (setf (window-bit-gravity window) value) - (setf (window-gravity window) value) - (setf (window-backing-store window) value) - (setf (window-backing-planes window) value) - (setf (window-backing-pixel window) value) - (setf (window-override-redirect window) value) - (setf (window-save-under window) value) - (setf (window-colormap window) value) - (setf (window-cursor window) value) - (setf (window-event-mask window) value) - (setf (window-do-not-propagate-mask window) value) - -CirculateWindow CIRCULATE-WINDOW-DOWN -CirculateWindow CIRCULATE-WINDOW-UP -ClearToBackground CLEAR-AREA -CloseFont CLOSE-FONT -ConfigureWindow - ;; See WITH-STATE - (setf (drawable-x drawable) integer) - (setf (drawable-y drawable) integer) - (setf (drawable-width drawable) integer) - (setf (drawable-height drawable) integer) - (setf (drawable-depth drawable) integer) - (setf (drawable-border-width drawable) integer) - (setf (window-priority window &optional sibling) integer) - -ConvertSelection CONVERT-SELECTION -CopyArea COPY-AREA -CopyColormapAndFree COPY-COLORMAP-AND-FREE -CopyGC COPY-GCONTEXT -CopyGC COPY-GCONTEXT-COMPONENTS -CopyPlane COPY-PLANE -CreateColormap CREATE-COLORMAP -CreateCursor CREATE-CURSOR -CreateGC CREATE-GCONTEXT -CreateGlyphCursor CREATE-GLYPH-CURSOR -CreatePixmap CREATE-PIXMAP -CreateWindow CREATE-WINDOW -DeleteProperty DELETE-PROPERTY -DestroySubwindows DESTROY-SUBWINDOWS -DestroyWindow DESTROY-WINDOW -FillPoly DRAW-LINES -ForceScreenSaver RESET-SCREEN-SAVER -ForceScreenSaver ACTIVATE-SCREEN-SAVER -FreeColormap FREE-COLORMAP -FreeColors FREE-COLORS -FreeCursor FREE-CURSOR -FreeGC FREE-GCONTEXT -FreePixmap FREE-PIXMAP -GetAtomName ATOM-NAME -GetFontPath FONT-PATH -GetGeometry ;; See WITH-STATE - DRAWABLE-ROOT - DRAWABLE-X - DRAWABLE-Y - DRAWABLE-WIDTH - DRAWABLE-HEIGHT - DRAWABLE-DEPTH - DRAWABLE-BORDER-WIDTH - -GetImage GET-RAW-IMAGE -GetInputFocus INPUT-FOCUS -GetKeyboardControl KEYBOARD-CONTROL -GetKeyboardMapping KEYBOARD-MAPPING -GetModifierMapping MODIFIER-MAPPING -GetMotionEvents MOTION-EVENTS -GetPointerControl POINTER-CONTROL -GetPointerMapping POINTER-MAPPING -GetProperty GET-PROPERTY -GetScreenSaver SCREEN-SAVER -GetSelectionOwner SELECTION-OWNER -GetWindowAttributes ;; See WITH-STATE - WINDOW-VISUAL-INFO - WINDOW-CLASS - WINDOW-BIT-GRAVITY - WINDOW-GRAVITY - WINDOW-BACKING-STORE - WINDOW-BACKING-PLANES - WINDOW-BACKING-PIXEL - WINDOW-SAVE-UNDER - WINDOW-OVERRIDE-REDIRECT - WINDOW-EVENT-MASK - WINDOW-DO-NOT-PROPAGATE-MASK - WINDOW-COLORMAP - WINDOW-COLORMAP-INSTALLED-P - WINDOW-ALL-EVENT-MASKS - WINDOW-MAP-STATE - -GrabButton GRAB-BUTTON -GrabKey GRAB-KEY -GrabKeyboard GRAB-KEYBOARD -GrabPointer GRAB-POINTER -GrabServer GRAB-SERVER -ImageText16 DRAW-IMAGE-GLYPHS -ImageText16 DRAW-IMAGE-GLYPH -ImageText8 DRAW-IMAGE-GLYPHS -InstallColormap INSTALL-COLORMAP -InternAtom FIND-ATOM -InternAtom INTERN-ATOM -KillClient KILL-TEMPORARY-CLIENTS -KillClient KILL-CLIENT -ListExtensions LIST-EXTENSIONS -ListFonts LIST-FONT-NAMES -ListFontsWithInfo LIST-FONTS -ListHosts ACCESS-CONTROL -ListHosts ACCESS-HOSTS -ListInstalledColormaps INSTALLED-COLORMAPS -ListProperties LIST-PROPERTIES -LookupColor LOOKUP-COLOR -MapSubwindows MAP-SUBWINDOWS -MapWindow MAP-WINDOW -OpenFont OPEN-FONT -PolyArc DRAW-ARC -PolyArc DRAW-ARCS -PolyFillArc DRAW-ARC -PolyFillArc DRAW-ARCS -PolyFillRectangle DRAW-RECTANGLE -PolyFillRectangle DRAW-RECTANGLES -PolyLine DRAW-LINE -PolyLine DRAW-LINES -PolyPoint DRAW-POINT -PolyPoint DRAW-POINTS -PolyRectangle DRAW-RECTANGLE -PolyRectangle DRAW-RECTANGLES -PolySegment DRAW-SEGMENTS -PolyText16 DRAW-GLYPH -PolyText16 DRAW-GLYPHS -PolyText8 DRAW-GLYPHS -PutImage PUT-RAW-IMAGE -QueryBestSize QUERY-BEST-CURSOR -QueryBestSize QUERY-BEST-STIPPLE -QueryBestSize QUERY-BEST-TILE -QueryColors QUERY-COLORS -QueryExtension QUERY-EXTENSION -QueryFont FONT-NAME - FONT-NAME - FONT-DIRECTION - FONT-MIN-CHAR - FONT-MAX-CHAR - FONT-MIN-BYTE1 - FONT-MAX-BYTE1 - FONT-MIN-BYTE2 - FONT-MAX-BYTE2 - FONT-ALL-CHARS-EXIST-P - FONT-DEFAULT-CHAR - FONT-ASCENT - FONT-DESCENT - FONT-PROPERTIES - FONT-PROPERTY - - CHAR-LEFT-BEARING - CHAR-RIGHT-BEARING - CHAR-WIDTH - CHAR-ASCENT - CHAR-DESCENT - CHAR-ATTRIBUTES - - MIN-CHAR-LEFT-BEARING - MIN-CHAR-RIGHT-BEARING - MIN-CHAR-WIDTH - MIN-CHAR-ASCENT - MIN-CHAR-DESCENT - MIN-CHAR-ATTRIBUTES - - MAX-CHAR-LEFT-BEARING - MAX-CHAR-RIGHT-BEARING - MAX-CHAR-WIDTH - MAX-CHAR-ASCENT - MAX-CHAR-DESCENT - MAX-CHAR-ATTRIBUTES - -QueryKeymap QUERY-KEYMAP -QueryPointer GLOBAL-POINTER-POSITION -QueryPointer POINTER-POSITION -QueryPointer QUERY-POINTER -QueryTextExtents TEXT-EXTENTS -QueryTextExtents TEXT-WIDTH -QueryTree QUERY-TREE -RecolorCursor RECOLOR-CURSOR -ReparentWindow REPARENT-WINDOW -RotateProperties ROTATE-PROPERTIES -SendEvent SEND-EVENT -SetClipRectangles FORCE-GCONTEXT-CHANGES - ;; See WITH-GCONTEXT - (setf (gcontext-clip-x gc) int16) - (setf (gcontext-clip-y gc) int16) - (setf (gcontext-clip-mask gc &optional ordering) - (or (member :none) pixmap rect-seq)) - (setf (gcontext-clip-ordering gc) keyword) - -SetDashes FORCE-GCONTEXT-CHANGES - ;; See WITH-GCONTEXT - (setf (gcontext-dash-offset gc) card16) - (setf (gcontext-dashes gc) (or card8 sequence)) - -SetFontPath - (setf (font-path font) paths) - Where paths is (type (clx-sequence (or string pathname))) - -SetInputFocus SET-INPUT-FOCUS -SetKeyboardMapping CHANGE-KEYBOARD-MAPPING -SetModifierMapping SET-MODIFIER-MAPPING -SetPointerMapping SET-POINTER-MAPPING -SetScreenSaver SET-SCREEN-SAVER -SetSelectionOwner SET-SELECTION-OWNER -StoreColors STORE-COLOR -StoreColors STORE-COLORS -StoreNamedColor STORE-COLOR -StoreNamedColor STORE-COLORS -TranslateCoords TRANSLATE-COORDINATES -UngrabButton UNGRAB-BUTTON -UngrabKey UNGRAB-KEY -UngrabKeyboard UNGRAB-KEYBOARD -UngrabPointer UNGRAB-POINTER -UngrabServer UNGRAB-SERVER -UninstallColormap UNINSTALL-COLORMAP -UnmapSubwindows UNMAP-SUBWINDOWS -UnmapWindow UNMAP-WINDOW -WarpPointer WARP-POINTER -WarpPointer WARP-POINTER-IF-INSIDE -WarpPointer WARP-POINTER-RELATIVE -WarpPointer WARP-POINTER-RELATIVE-IF-INSIDE -NoOperation NO-OPERATION - - - - X11 Request Name CLX Function Name ------------------ ----------------- -ListHosts ACCESS-CONTROL -ListHosts ACCESS-HOSTS -ForceScreenSaver ACTIVATE-SCREEN-SAVER -ChangeHosts ADD-ACCESS-HOST -ChangeSaveSet ADD-TO-SAVE-SET -AllocColor ALLOC-COLOR -AllocNamedColor ALLOC-COLOR -AllocColorCells ALLOC-COLOR-CELLS -AllocColorPlanes ALLOC-COLOR-PLANES -AllowEvents ALLOW-EVENTS -GetAtomName ATOM-NAME -Bell BELL -ChangeActivePointerGrab CHANGE-ACTIVE-POINTER-GRAB -ChangeKeyboardControl CHANGE-KEYBOARD-CONTROL -SetKeyboardMapping CHANGE-KEYBOARD-MAPPING -ChangePointerControl CHANGE-POINTER-CONTROL -ChangeProperty CHANGE-PROPERTY -QueryFont CHAR-ASCENT -QueryFont CHAR-ATTRIBUTES -QueryFont CHAR-DESCENT -QueryFont CHAR-LEFT-BEARING -QueryFont CHAR-RIGHT-BEARING -QueryFont CHAR-WIDTH -CirculateWindow CIRCULATE-WINDOW-DOWN -CirculateWindow CIRCULATE-WINDOW-UP -ClearToBackground CLEAR-AREA -CloseFont CLOSE-FONT -ConvertSelection CONVERT-SELECTION -CopyArea COPY-AREA -CopyColormapAndFree COPY-COLORMAP-AND-FREE -CopyGC COPY-GCONTEXT -CopyGC COPY-GCONTEXT-COMPONENTS -CopyPlane COPY-PLANE -CreateColormap CREATE-COLORMAP -CreateCursor CREATE-CURSOR -CreateGC CREATE-GCONTEXT -CreateGlyphCursor CREATE-GLYPH-CURSOR -CreatePixmap CREATE-PIXMAP -CreateWindow CREATE-WINDOW -DeleteProperty DELETE-PROPERTY -DestroySubwindows DESTROY-SUBWINDOWS -DestroyWindow DESTROY-WINDOW -PolyArc DRAW-ARC -PolyArc DRAW-ARCS -PolyText16 DRAW-GLYPH -PolyText16 DRAW-GLYPHS -PolyText8 DRAW-GLYPHS -ImageText16 DRAW-IMAGE-GLYPH -ImageText16 DRAW-IMAGE-GLYPHS -ImageText8 DRAW-IMAGE-GLYPHS -PolyLine DRAW-LINE -PolyLine DRAW-LINES -PolyPoint DRAW-POINT -PolyPoint DRAW-POINTS -PolyFillRectangle DRAW-RECTANGLE -PolyRectangle DRAW-RECTANGLE -PolyFillRectangle DRAW-RECTANGLES -PolyRectangle DRAW-RECTANGLES -PolySegment DRAW-SEGMENTS -GetGeometry DRAWABLE-BORDER-WIDTH -GetGeometry DRAWABLE-DEPTH -GetGeometry DRAWABLE-HEIGHT -GetGeometry DRAWABLE-ROOT -GetGeometry DRAWABLE-WIDTH -GetGeometry DRAWABLE-X -GetGeometry DRAWABLE-Y -FillPoly FILL-POLYGON -InternAtom FIND-ATOM -QueryFont FONT-ALL-CHARS-EXIST-P -QueryFont FONT-ASCENT -QueryFont FONT-DEFAULT-CHAR -QueryFont FONT-DESCENT -QueryFont FONT-DIRECTION -QueryFont FONT-MAX-BYTE1 -QueryFont FONT-MAX-BYTE2 -QueryFont FONT-MAX-CHAR -QueryFont FONT-MIN-BYTE1 -QueryFont FONT-MIN-BYTE2 -QueryFont FONT-MIN-CHAR -QueryFont FONT-NAME -QueryFont FONT-NAME -GetFontPath FONT-PATH -QueryFont FONT-PROPERTIES -QueryFont FONT-PROPERTY -ChangeGC FORCE-GCONTEXT-CHANGES -SetClipRectangles FORCE-GCONTEXT-CHANGES -SetDashes FORCE-GCONTEXT-CHANGES -FreeColormap FREE-COLORMAP -FreeColors FREE-COLORS -FreeCursor FREE-CURSOR -FreeGC FREE-GCONTEXT -FreePixmap FREE-PIXMAP -GetProperty GET-PROPERTY -GetImage GET-RAW-IMAGE -QueryPointer GLOBAL-POINTER-POSITION -GrabButton GRAB-BUTTON -GrabKey GRAB-KEY -GrabKeyboard GRAB-KEYBOARD -GrabPointer GRAB-POINTER -GrabServer GRAB-SERVER -GrabServer WITH-SERVER-GRABBED -GetInputFocus INPUT-FOCUS -InstallColormap INSTALL-COLORMAP -ListInstalledColormaps INSTALLED-COLORMAPS -InternAtom INTERN-ATOM -GetKeyboardControl KEYBOARD-CONTROL -GetKeyboardMapping KEYBOARD-MAPPING -KillClient KILL-CLIENT -KillClient KILL-TEMPORARY-CLIENTS -ListExtensions LIST-EXTENSIONS -ListFonts LIST-FONT-NAMES -ListFontsWithInfo LIST-FONTS -ListProperties LIST-PROPERTIES -LookupColor LOOKUP-COLOR -MapSubwindows MAP-SUBWINDOWS -MapWindow MAP-WINDOW -QueryFont MAX-CHAR-ASCENT -QueryFont MAX-CHAR-ATTRIBUTES -QueryFont MAX-CHAR-DESCENT -QueryFont MAX-CHAR-LEFT-BEARING -QueryFont MAX-CHAR-RIGHT-BEARING -QueryFont MAX-CHAR-WIDTH -QueryFont MIN-CHAR-ASCENT -QueryFont MIN-CHAR-ATTRIBUTES -QueryFont MIN-CHAR-DESCENT -QueryFont MIN-CHAR-LEFT-BEARING -QueryFont MIN-CHAR-RIGHT-BEARING -QueryFont MIN-CHAR-WIDTH -GetModifierMapping MODIFIER-MAPPING -GetMotionEvents MOTION-EVENTS -NoOperation NO-OPERATION -OpenFont OPEN-FONT -GetPointerControl POINTER-CONTROL -GetPointerMapping POINTER-MAPPING -QueryPointer POINTER-POSITION -PutImage PUT-RAW-IMAGE -QueryBestSize QUERY-BEST-CURSOR -QueryBestSize QUERY-BEST-STIPPLE -QueryBestSize QUERY-BEST-TILE -QueryColors QUERY-COLORS -QueryExtension QUERY-EXTENSION -QueryKeymap QUERY-KEYMAP -QueryPointer QUERY-POINTER -QueryTree QUERY-TREE -RecolorCursor RECOLOR-CURSOR -ChangeHosts REMOVE-ACCESS-HOST -ChangeSaveSet REMOVE-FROM-SAVE-SET -ReparentWindow REPARENT-WINDOW -ForceScreenSaver RESET-SCREEN-SAVER -RotateProperties ROTATE-PROPERTIES -GetScreenSaver SCREEN-SAVER -GetSelectionOwner SELECTION-OWNER -SendEvent SEND-EVENT -ChangeAccessControl SET-ACCESS-CONTROL -ChangeCloseDownMode SET-CLOSE-DOWN-MODE -SetInputFocus SET-INPUT-FOCUS -SetModifierMapping SET-MODIFIER-MAPPING -SetPointerMapping SET-POINTER-MAPPING -SetScreenSaver SET-SCREEN-SAVER -SetSelectionOwner SET-SELECTION-OWNER -StoreColors STORE-COLOR -StoreColors STORE-COLORS -StoreNamedColor STORE-COLOR -StoreNamedColor STORE-COLORS -QueryTextExtents TEXT-EXTENTS -QueryTextExtents TEXT-WIDTH -TranslateCoords TRANSLATE-COORDINATES -UngrabButton UNGRAB-BUTTON -UngrabKey UNGRAB-KEY -UngrabKeyboard UNGRAB-KEYBOARD -UngrabPointer UNGRAB-POINTER -UngrabServer UNGRAB-SERVER -UngrabServer WITH-SERVER-GRABBED -UninstallColormap UNINSTALL-COLORMAP -UnmapSubwindows UNMAP-SUBWINDOWS -UnmapWindow UNMAP-WINDOW -WarpPointer WARP-POINTER -WarpPointer WARP-POINTER-IF-INSIDE -WarpPointer WARP-POINTER-RELATIVE -WarpPointer WARP-POINTER-RELATIVE-IF-INSIDE -GetWindowAttributes WINDOW-ALL-EVENT-MASKS -GetWindowAttributes WINDOW-BACKING-PIXEL -GetWindowAttributes WINDOW-BACKING-PLANES -GetWindowAttributes WINDOW-BACKING-STORE -GetWindowAttributes WINDOW-BIT-GRAVITY -GetWindowAttributes WINDOW-CLASS -GetWindowAttributes WINDOW-COLORMAP -GetWindowAttributes WINDOW-COLORMAP-INSTALLED-P -GetWindowAttributes WINDOW-DO-NOT-PROPAGATE-MASK -GetWindowAttributes WINDOW-EVENT-MASK -GetWindowAttributes WINDOW-GRAVITY -GetWindowAttributes WINDOW-MAP-STATE -GetWindowAttributes WINDOW-OVERRIDE-REDIRECT -GetWindowAttributes WINDOW-SAVE-UNDER -GetWindowAttributes WINDOW-VISUAL-INFO - -ConfigureWindow (SETF (DRAWABLE-BORDER-WIDTH DRAWABLE) INTEGER) -ConfigureWindow (SETF (DRAWABLE-DEPTH DRAWABLE) INTEGER) -ConfigureWindow (SETF (DRAWABLE-HEIGHT DRAWABLE) INTEGER) -ConfigureWindow (SETF (DRAWABLE-WIDTH DRAWABLE) INTEGER) -ConfigureWindow (SETF (DRAWABLE-X DRAWABLE) INTEGER) -ConfigureWindow (SETF (DRAWABLE-Y DRAWABLE) INTEGER) -SetFontPath (SETF (FONT-PATH FONT) PATHS) -ChangeGC (SETF (GCONTEXT-ARC-MODE GC) (MEMBER CHORD PIE-SLICE)) -ChangeGC (SETF (GCONTEXT-BACKGROUND GC) CARD32) -ChangeGC (SETF (GCONTEXT-CAP-STYLE GC) KEYWORD) -SetClipRectangles (SETF (GCONTEXT-CLIP-MASK GC &OPTIONAL ORDERING) - (OR (MEMBER NONE) PIXMAP RECT-SEQ)) -SetClipRectangles (SETF (GCONTEXT-CLIP-ORDERING GC) KEYWORD) -SetClipRectangles (SETF (GCONTEXT-CLIP-X GC) INT16) -SetClipRectangles (SETF (GCONTEXT-CLIP-Y GC) INT16) -SetDashes (SETF (GCONTEXT-DASH-OFFSET GC) CARD16) -SetDashes (SETF (GCONTEXT-DASHES GC) (OR CARD8 SEQUENCE)) -ChangeGC (SETF (GCONTEXT-EXPOSURES GC) (MEMBER ON OFF)) -ChangeGC (SETF (GCONTEXT-FILL-RULE GC) KEYWORD) -ChangeGC (SETF (GCONTEXT-FILL-STYLE GC) KEYWORD) -ChangeGC (SETF (GCONTEXT-FONT GC &OPTIONAL METRICS-P) FONT) -ChangeGC (SETF (GCONTEXT-FOREGROUND GC) CARD32) -ChangeGC (SETF (GCONTEXT-FUNCTION GC) BOOLE-CONSTANT) -ChangeGC (SETF (GCONTEXT-JOIN-STYLE GC) KEYWORD) -ChangeGC (SETF (GCONTEXT-LINE-STYLE GC) KEYWORD) -ChangeGC (SETF (GCONTEXT-LINE-WIDTH GC) CARD16) -ChangeGC (SETF (GCONTEXT-PLANE-MASK GC) CARD32) -ChangeGC (SETF (GCONTEXT-STIPPLE GC) PIXMAP) -ChangeGC (SETF (GCONTEXT-SUBWINDOW-MODE GC) KEYWORD) -ChangeGC (SETF (GCONTEXT-TILE GC) PIXMAP) -ChangeGC (SETF (GCONTEXT-TS-X GC) INT16) -ChangeGC (SETF (GCONTEXT-TS-Y GC) INT16) -ChangeWindowAttributes (SETF (WINDOW-BACKGROUND WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-BACKING-PIXEL WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-BACKING-PLANES WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-BACKING-STORE WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-BIT-GRAVITY WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-BORDER WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-COLORMAP WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-CURSOR WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-DO-NOT-PROPAGATE-MASK WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-EVENT-MASK WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-GRAVITY WINDOW) VALUE) -ChangeWindowAttributes (SETF (WINDOW-OVERRIDE-REDIRECT WINDOW) VALUE) -ConfigureWindow (SETF (WINDOW-PRIORITY WINDOW &OPTIONAL SIBLING) INTEGER) -ChangeWindowAttributes (SETF (WINDOW-SAVE-UNDER WINDOW) VALUE) - - - -;; Here's a list of the CLX functions that don't directly correspond to -;; X Window System requests. The've been categorized by function: - - ;Display Management -CLOSE-DISPLAY -CLOSE-DOWN-MODE -DISPLAY-AFTER-FUNCTION ;; SETF'able -DISPLAY-FINISH-OUTPUT -DISPLAY-FORCE-OUTPUT -DISPLAY-INVOKE-AFTER-FUNCTION -OPEN-DISPLAY -WITH-DISPLAY -WITH-EVENT-QUEUE - ;Extensions -DECLARE-EVENT -DECODE-CORE-ERROR -DEFAULT-ERROR-HANDLER -DEFINE-CONDITION -DEFINE-ERROR -DEFINE-EXTENSION -DEFINE-GCONTEXT-ACCESSOR -EXTENSION-OPCODE - ;Events -EVENT-CASE -EVENT-LISTEN -MAPPING-NOTIFY -PROCESS-EVENT -EVENT-HANDLER -MAKE-EVENT-HANDLERS -QUEUE-EVENT - ;Image -COPY-IMAGE -CREATE-IMAGE -GET-IMAGE -IMAGE-BLUE-MASK -IMAGE-DEPTH -IMAGE-GREEN-MASK -IMAGE-HEIGHT -IMAGE-NAME -IMAGE-PIXMAP -IMAGE-PLIST -IMAGE-RED-MASK -IMAGE-WIDTH -IMAGE-X-HOT -IMAGE-Y-HOT -PUT-IMAGE -READ-BITMAP-FILE -WRITE-BITMAP-FILE - ;Keysyms -CHARACTER->KEYSYMS -CHARACTER-IN-MAP-P -DEFAULT-KEYSYM-INDEX -DEFAULT-KEYSYM-TRANSLATE -DEFINE-KEYSYM -DEFINE-KEYSYM-SET -KEYCODE->CHARACTER -KEYCODE->KEYSYM -KEYSYM -KEYSYM->CHARACTER -KEYSYM-IN-MAP-P -KEYSYM-SET -UNDEFINE-KEYSYM - ;Properties -CUT-BUFFER -GET-STANDARD-COLORMAP -GET-WM-CLASS -ICON-SIZES -MAKE-WM-HINTS -MAKE-WM-SIZE-HINTS -ROTATE-CUT-BUFFERS -SET-STANDARD-COLORMAP -SET-WM-CLASS -TRANSIENT-FOR -WM-CLIENT-MACHINE -WM-COMMAND -WM-HINTS -WM-HINTS-FLAGS -WM-HINTS-ICON-MASK -WM-HINTS-ICON-PIXMAP -WM-HINTS-ICON-WINDOW -WM-HINTS-ICON-X -WM-HINTS-ICON-Y -WM-HINTS-INITIAL-STATE -WM-HINTS-INPUT -WM-HINTS-P -WM-HINTS-WINDOW-GROUP -WM-ICON-NAME -WM-NAME -WM-NORMAL-HINTS -WM-SIZE-HINTS-HEIGHT -WM-SIZE-HINTS-HEIGHT-INC -WM-SIZE-HINTS-MAX-ASPECT -WM-SIZE-HINTS-MAX-HEIGHT -WM-SIZE-HINTS-MAX-WIDTH -WM-SIZE-HINTS-MIN-ASPECT -WM-SIZE-HINTS-MIN-HEIGHT -WM-SIZE-HINTS-MIN-WIDTH -WM-SIZE-HINTS-P -WM-SIZE-HINTS-USER-SPECIFIED-POSITION-P -WM-SIZE-HINTS-USER-SPECIFIED-SIZE-P -WM-SIZE-HINTS-WIDTH -WM-SIZE-HINTS-WIDTH-INC -WM-SIZE-HINTS-X -WM-SIZE-HINTS-Y -WM-ZOOM-HINTS - ;Misc. -MAKE-COLOR -MAKE-EVENT-KEYS -MAKE-EVENT-MASK -MAKE-RESOURCE-DATABASE -MAKE-STATE-KEYS -MAKE-STATE-MASK -DISCARD-FONT-INFO -TRANSLATE-DEFAULT - ;Structures -BITMAP-FORMAT-LSB-FIRST-P -BITMAP-FORMAT-P -BITMAP-FORMAT-PAD -BITMAP-FORMAT-UNIT -BITMAP-IMAGE - -COLOR-BLUE -COLOR-GREEN -COLOR-P -COLOR-RED -COLOR-RGB -COLORMAP-DISPLAY -COLORMAP-EQUAL -COLORMAP-ID -COLORMAP-P -COLORMAP-VISUAL-INFO - -CURSOR-DISPLAY -CURSOR-EQUAL -CURSOR-ID -CURSOR-P - -DRAWABLE-DISPLAY -DRAWABLE-EQUAL -DRAWABLE-ID -DRAWABLE-P - -FONT-DISPLAY -FONT-EQUAL -FONT-ID -FONT-MAX-BOUNDS -FONT-MIN-BOUNDS -FONT-P -FONT-PLIST - -GCONTEXT-DISPLAY -GCONTEXT-EQUAL -GCONTEXT-ID -GCONTEXT-P -GCONTEXT-PLIST - -DISPLAY-AUTHORIZATION-DATA -DISPLAY-AUTHORIZATION-NAME -DISPLAY-BITMAP-FORMAT -DISPLAY-BYTE-ORDER -DISPLAY-DEFAULT-SCREEN -DISPLAY-DISPLAY -DISPLAY-ERROR-HANDLER -DISPLAY-IMAGE-LSB-FIRST-P -DISPLAY-KEYCODE-RANGE -DISPLAY-MAX-KEYCODE -DISPLAY-MAX-REQUEST-LENGTH -DISPLAY-MIN-KEYCODE -DISPLAY-MOTION-BUFFER-SIZE -DISPLAY-NSCREENS -DISPLAY-P -DISPLAY-PIXMAP-FORMATS -DISPLAY-PLIST -DISPLAY-PROTOCOL-MAJOR-VERSION -DISPLAY-PROTOCOL-MINOR-VERSION -DISPLAY-PROTOCOL-VERSION -DISPLAY-RELEASE-NUMBER -DISPLAY-RESOURCE-ID-BASE -DISPLAY-RESOURCE-ID-MASK -DISPLAY-ROOTS -DISPLAY-SQUISH -DISPLAY-VENDOR -DISPLAY-VENDOR-NAME -DISPLAY-VERSION-NUMBER -DISPLAY-XDEFAULTS -DISPLAY-XID - -PIXMAP-DISPLAY -PIXMAP-EQUAL -PIXMAP-FORMAT-BITS-PER-PIXEL -PIXMAP-FORMAT-DEPTH -PIXMAP-FORMAT-P -PIXMAP-FORMAT-SCANLINE-PAD -PIXMAP-ID -PIXMAP-P -PIXMAP-PLIST - -SCREEN-BACKING-STORES -SCREEN-BLACK-PIXEL -SCREEN-DEFAULT-COLORMAP -SCREEN-DEPTHS -SCREEN-EVENT-MASK-AT-OPEN -SCREEN-HEIGHT -SCREEN-HEIGHT-IN-MILLIMETERS -SCREEN-MAX-INSTALLED-MAPS -SCREEN-MIN-INSTALLED-MAPS -SCREEN-P -SCREEN-PLIST -SCREEN-ROOT -SCREEN-ROOT-DEPTH -SCREEN-ROOT-VISUAL-INFO -SCREEN-SAVE-UNDERS-P -SCREEN-WHITE-PIXEL -SCREEN-WIDTH -SCREEN-WIDTH-IN-MILLIMETERS - -VISUAL-INFO -VISUAL-INFO-BITS-PER-RGB -VISUAL-INFO-BLUE-MASK -VISUAL-INFO-CLASS -VISUAL-INFO-COLORMAP-ENTRIES -VISUAL-INFO-GREEN-MASK -VISUAL-INFO-ID -VISUAL-INFO-P -VISUAL-INFO-PLIST -VISUAL-INFO-RED-MASK - -WINDOW-DISPLAY -WINDOW-EQUAL -WINDOW-ID -WINDOW-P -WINDOW-PLIST diff --git a/clx/exclMakefile b/clx/exclMakefile deleted file mode 100644 index bd0c93671d47f99086d767b22529d714ae3847f9..0000000000000000000000000000000000000000 --- a/clx/exclMakefile +++ /dev/null @@ -1,168 +0,0 @@ -# -# Makefile for CLX -# (X11 R4.4 release, Franz Allegro Common Lisp version) -# - -# ************************************************************************* -# * Change the next line to point to where you have Common Lisp installed * -# * (make sure the Lisp doesn't already have CLX loaded in) * -# ************************************************************************* -CL = /usr/local/bin/cl - -RM = /bin/rm -SHELL = /bin/sh -ECHO = /bin/echo -TAGS = /usr/local/lib/emacs/etc/etags - -# Name of dumped lisp -CLX = CLX - -CLOPTS = -qq - -# Use this one for Suns -CFLAGS = -O -DUNIXCONN -# Use this one for Silicon Graphics & Mips Inc MIPS based machines -# CFLAGS = -O -G 0 -I/usr/include/bsd -# Use this one for DEC MIPS based machines -# CFLAGS = -O -G 0 -DUNIXCONN -# Use this one for HP machines -# CFLAGS = -O -DSYSV -DUNIXCONN - - -# Lisp optimization for compiling -SPEED = 3 -SAFETY = 0 - - -C_SRC = excldep.c socket.c -C_OBJS = excldep.o socket.o - -L_OBJS = defsystem.fasl package.fasl excldep.fasl depdefs.fasl clx.fasl \ - dependent.fasl exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl \ - display.fasl gcontext.fasl requests.fasl input.fasl fonts.fasl \ - graphics.fasl text.fasl attributes.fasl translate.fasl keysyms.fasl \ - manager.fasl image.fasl resource.fasl - -L_NOMACROS_OBJS = package.fasl excldep.fasl depdefs.fasl clx.fasl \ - dependent.fasl buffer.fasl display.fasl gcontext.fasl \ - requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \ - attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \ - resource.fasl - -L_SRC = defsystem.cl package.cl excldep.cl depdefs.cl clx.cl \ - dependent.cl exclcmac.cl macros.cl bufmac.cl buffer.cl \ - display.cl gcontext.cl requests.cl input.cl fonts.cl \ - graphics.cl text.cl attributes.cl translate.cl keysyms.cl \ - manager.cl image.cl resource.cl - -# default and aliases -all: no-clos -# all: partial-clos -compile-CLX-for-CLUE: compile-partial-clos-CLX -clue: partial-clos - -# -# Three build rules are provided: no-clos, partial-clos, and full-clos. -# The first is no-clos, which results in a CLX whose datastructures are -# all defstructs. partial-clos results in xlib:window, xlib:pixmap, and -# xlib:drawable being CLOS instances, all others defstructs. full-clos -# makes all CLX complex datatypes into CLOS instances. -# -# (note that the :clos feature implies native CLOS *not* PCL). -# - -no-clos: $(C_OBJS) compile-no-clos-CLX cat - -# -# This rule is used to compile CLX to be used with XCW version 2, or CLUE. -# -partial-clos: $(C_OBJS) compile-partial-clos-CLX cat - -full-clos: $(C_OBJS) compile-full-clos-CLX cat - - -c: $(C_OBJS) - - -compile-no-clos-CLX: $(C_OBJS) - $(ECHO) " \ - (set-case-mode :case-sensitive-lower) \ - (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ - #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ - (load \"defsystem\") \ - #+allegro (compile-system :clx) \ - #-allegro (compile-clx) \ - #+allegro (compile-system :clx-debug)" \ - | $(CL) $(CLOPTS) -batch - -compile-partial-clos-CLX: $(C_OBJS) - $(ECHO) " \ - #+clos (set-case-mode :case-sensitive-lower) \ - #-clos (setq excl::*print-nickname* t) \ - (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ - (unless (or (find-package 'clos) (find-package 'pcl)) \ - (let ((spread (sys:gsgc-parameter :generation-spread))) \ - (setf (sys:gsgc-parameter :generation-spread) 1) \ - (require :pcl) \ - (provide :pcl) \ - (gc) (gc) \ - (setf (sys:gsgc-parameter :generation-spread) spread))) \ - #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ - (load \"defsystem\") \ - (load \"package\") \ - (setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \ - #+allegro (compile-system :clx) \ - #-allegro (compile-clx \"\" \"\" :for-clue t) \ - #+allegro (compile-system :clx-debug)" \ - | $(CL) $(CLOPTS) -batch - -compile-full-clos-CLX: $(C_OBJS) - $(ECHO) " \ - #+clos (set-case-mode :case-sensitive-lower) \ - #-clos (setq excl::*print-nickname* t) \ - (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ - (unless (or (find-package 'clos) (find-package 'pcl)) \ - (let ((spread (sys:gsgc-parameter :generation-spread))) \ - (setf (sys:gsgc-parameter :generation-spread) 1) \ - (require :pcl) \ - (provide :pcl) \ - (gc) (gc) \ - (setf (sys:gsgc-parameter :generation-spread) spread))) \ - #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ - (load \"defsystem\") \ - (load \"package\") \ - (setq xlib::*def-clx-class-use-defclass* t) \ - #+allegro (compile-system :clx) \ - #-allegro (compile-clx \"\" \"\" :for-clue t) \ - #+allegro (compile-system :clx-debug)" \ - | $(CL) $(CLOPTS) -batch - - -cat: - -cat $(L_NOMACROS_OBJS) > CLX.fasl - - -load-CLX: - $(ECHO) " \ - (let ((spread (sys:gsgc-parameter :generation-spread))) \ - (setf (sys:gsgc-parameter :generation-spread) 1) \ - (load \"defsystem\") \ - #+allegro (load-system :clx) \ - #-allegro (load-clx) \ - (gc :tenure) \ - (setf (sys:gsgc-parameter :generation-spread) spread)) \ - (gc t)" \ - '(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \ - "(exit)" | $(CL) $(CLOPTS) - -clean: - $(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) make.out - - -install: - mv CLX.fasl $(DEST)/clx.fasl - mv *.o $(DEST) - - -tags: - $(TAGS) $(L_SRC) $(C_SRC) diff --git a/clx/exclREADME b/clx/exclREADME deleted file mode 100644 index c99e388e0cb3d307ab282b1eac73fc74c99886b5..0000000000000000000000000000000000000000 --- a/clx/exclREADME +++ /dev/null @@ -1,56 +0,0 @@ - This file contains instructions on how to make CLX work with Franz -Common Lisp. CLX should work on any machine that supports Allegro Common -Lisp version 3.0.1 or greater. It also works under ExCL version 2.0.10. -However it has been tested extensively with only Allegro CL versions 3.0, -3.1, and 4.0. - - There are three steps to compile and install CLX. The first is simply -moving files around. In this directory, execute (assuming you using csh): - -% foreach i (*.l */*.l) -? mv $i $i:r.cl -? end -% mv exclMakefile Makefile - - The second is compiling the source files into fasl files. The fasl files -will be combined into one big fasl file, CLX.fasl. This file is then installed -in your Common Lisp library directory in the next step. You may need to edit -the Makefile to select the proper CFLAGS for your machine -- look in Makefile -for examples. Then just: - -% make - - Now you must move the CLX.fasl file into the standard CL library. -This is normally "/usr/local/lib/cl/code", but you can find out for sure -by typing: - -<cl> (directory-namestring excl::*library-code-pathname*) - -to a running Lisp. If it prints something other than "/usr/local/lib/cl/code" -substitute what it prints in the below instructions. - -% mv CLX.fasl /usr/local/lib/cl/code/clx.fasl -% mv *.o /usr/local/lib/cl/code - -Now you can just start up Lisp and type: - -<cl> (load "clx") - -to load in CLX. You may want to dump a lisp at this point since CLX is a large -package and can take some time to load into Lisp. You probably also want to -set the :generation-spread to 1 while loading CLX. Please see your Allegro CL -User Guide for more information on :generation-spread. - - - Sophisticated users may wish to peruse the Makefile and defsystem.cl -and note how things are set up. For example we hardwire the compiler -interrupt check switch on, so that CL can still be interrupted while it -is reading from the X11 socket. Please see chapter 7 of the CL User's -guide for more information on compiler switches and their effects. - - -Please report Franz specific CLX bugs to: - - ucbvax!franz!bugs - or - bugs@Franz.COM diff --git a/clx/exclcmac.lisp b/clx/exclcmac.lisp deleted file mode 100644 index 04fd20af87020531a2341a6b0cf82dff28a9aad0..0000000000000000000000000000000000000000 --- a/clx/exclcmac.lisp +++ /dev/null @@ -1,260 +0,0 @@ -;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- -;;; -;;; CLX -- exclcmac.cl -;;; This file provides for inline expansion of some functions. -;;; -;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca. -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. -;;; -;;; Franz Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;; -;; Type predicates -;; -(excl:defcmacro card8p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0))))) - -(excl:defcmacro card16p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0))))) - -(excl:defcmacro int8p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7)))))) - -(excl:defcmacro int16p (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) - (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15)))))) - -;; Card29p, card32p, int32p are too large to expand inline - - -;; -;; Type transformers -;; -(excl:defcmacro card8->int8 (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - ,(declare-bufmac) - (declare (type card8 ,xx)) - (the int8 (if (logbitp 7 ,xx) - (the int8 (- ,xx #x100)) - ,xx))))) -(excl:defcmacro int8->card8 (x) - `(locally ,(declare-bufmac) - (the card8 (ldb (byte 8 0) (the int8 ,x))))) - -(excl:defcmacro card16->int16 (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - ,(declare-bufmac) - (declare (type card16 ,xx)) - (the int16 (if (logbitp 15 ,xx) - (the int16 (- ,xx #x10000)) - ,xx))))) - -(excl:defcmacro int16->card16 (x) - `(locally ,(declare-bufmac) - (the card16 (ldb (byte 16 0) (the int16 ,x))))) - -(excl:defcmacro card32->int32 (x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - ,(declare-bufmac) - (declare (type card32 ,xx)) - (the int32 (if (logbitp 31 ,xx) - (the int32 (- ,xx #x100000000)) - ,xx))))) - -(excl:defcmacro int32->card32 (x) - `(locally ,(declare-bufmac) - (the card32 (ldb (byte 32 0) (the int32 ,x))))) - -(excl:defcmacro char->card8 (char) - `(locally ,(declare-bufmac) - (the card8 (char-code (the string-char ,char))))) - -(excl:defcmacro card8->char (card8) - `(locally ,(declare-bufmac) - (the string-char (code-char (the card8 ,card8))))) - - -;; -;; Array accessors and setters -;; -(excl:defcmacro aref-card8 (a i) - `(locally ,(declare-bufmac) - (the card8 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-byte)))) - -(excl:defcmacro aset-card8 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-byte) - (the card8 ,v)))) - -(excl:defcmacro aref-int8 (a i) - `(locally ,(declare-bufmac) - (the int8 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-byte)))) - -(excl:defcmacro aset-int8 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-byte) - (the int8 ,v)))) - -(excl:defcmacro aref-card16 (a i) - `(locally ,(declare-bufmac) - (the card16 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-word)))) - -(excl:defcmacro aset-card16 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-word) - (the card16 ,v)))) - -(excl:defcmacro aref-int16 (a i) - `(locally ,(declare-bufmac) - (the int16 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-word)))) - -(excl:defcmacro aset-int16 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-word) - (the int16 ,v)))) - -(excl:defcmacro aref-card32 (a i) - `(locally ,(declare-bufmac) - (the card32 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long)))) - -(excl:defcmacro aset-card32 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long) - (the card32 ,v)))) - -(excl:defcmacro aref-int32 (a i) - `(locally ,(declare-bufmac) - (the int32 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-long)))) - -(excl:defcmacro aset-int32 (v a i) - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-long) - (the int32 ,v)))) - -(excl:defcmacro aref-card29 (a i) - ;; Don't need to mask bits here since X protocol guarantees top bits zero - `(locally ,(declare-bufmac) - (the card29 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long)))) - -(excl:defcmacro aset-card29 (v a i) - ;; I also assume here Lisp is passing a number that fits in 29 bits. - `(locally ,(declare-bufmac) - (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long) - (the card29 ,v)))) - -;; -;; Font accessors -;; -(excl:defcmacro font-id (font) - ;; Get font-id, opening font if needed - (let ((f (gensym))) - `(let ((,f ,font)) - (or (font-id-internal ,f) - (open-font-internal ,f))))) - -(excl:defcmacro font-font-info (font) - (let ((f (gensym))) - `(let ((,f ,font)) - (or (font-font-info-internal ,f) - (query-font ,f))))) - -(excl:defcmacro font-char-infos (font) - (let ((f (gensym))) - `(let ((,f ,font)) - (or (font-char-infos-internal ,f) - (progn (query-font ,f) - (font-char-infos-internal ,f)))))) - - -;; -;; Miscellaneous -;; -(excl:defcmacro current-process () - `(the (or mp::process null) (and mp::*scheduler-stack-group* - mp::*current-process*))) - -(excl:defcmacro process-wakeup (process) - (let ((proc (gensym))) - `(let ((.pw-curproc. mp::*current-process*) - (,proc ,process)) - (when (and .pw-curproc. ,proc) - (if (> (mp::process-priority ,proc) - (mp::process-priority .pw-curproc.)) - (mp::process-allow-schedule ,proc)))))) - -(excl:defcmacro buffer-new-request-number (buffer) - (let ((buf (gensym))) - `(let ((,buf ,buffer)) - (declare (type buffer ,buf)) - (setf (buffer-request-number ,buf) - (ldb (byte 16 0) (1+ (buffer-request-number ,buf))))))) - - diff --git a/clx/excldefsys.lisp b/clx/excldefsys.lisp deleted file mode 100644 index abbc5dc7135111047aee6bc8d6d918ed37389bac..0000000000000000000000000000000000000000 --- a/clx/excldefsys.lisp +++ /dev/null @@ -1,186 +0,0 @@ -;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- -;;; -;;; Copyright (c) 1988, 1989 Franz Inc, Berkeley, Ca. -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. -;;; -;;; Franz Incorporated provides this software "as is" without express or -;;; implied warranty. -;;; - -(in-package :xlib :use '(:foreign-functions :lisp :excl)) - -#+allegro -(require :defsystem "defsys") - -(eval-when (load) - (require :clxexcldep "excldep")) - -;; -;; The following is a suggestion. If you comment out this form be -;; prepared for possible deadlock, since no interrupts will be recognized -;; while reading from the X socket if the scheduler is not running. -;; -(setq compiler::generate-interrupt-checks-switch - (compile nil '(lambda (safety size speed) - (declare (ignore size)) - (or (< speed 3) (> safety 0))))) - - -#+allegro -(excl:defsystem :clx - () - |depdefs| - (|clx| :load-before-compile (|depdefs|) - :recompile-on (|depdefs|)) - (|dependent| :load-before-compile (|depdefs| |clx|) - :recompile-on (|clx|)) - (|exclcmac| :load-before-compile (|depdefs| |clx| |dependent|) - :recompile-on (|dependent|)) - (|macros| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|) - :recompile-on (|exclcmac|)) - (|bufmac| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros|) - :recompile-on (|macros|)) - (|buffer| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac|) - :recompile-on (|bufmac|)) - (|display| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer|) - :recompile-on (|buffer|)) - (|gcontext| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) - (|input| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| |display| - ) - :recompile-on (|display|)) - (|requests| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |input|) - :recompile-on (|display|)) - (|fonts| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| |display| - ) - :recompile-on (|display|)) - (|graphics| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |fonts|) - :recompile-on (|fonts|)) - (|text| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| - |bufmac| |buffer| |display| - |gcontext| |fonts|) - :recompile-on (|gcontext| |fonts|) - :load-after (|translate|)) - ;; The above line gets around a compiler macro expansion bug. - - (|attributes| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) - (|translate| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |text|) - :recompile-on (|display|)) - (|keysyms| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |translate|) - :recompile-on (|translate|)) - (|manager| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) - (|image| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| |display| - ) - :recompile-on (|display|)) - - ;; Don't know if l-b-c list is correct. XX - (|resource| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) - ) - -#+allegro -(excl:defsystem :clx-debug - (:default-pathname "debug/" - :needed-systems (:clx) - :load-before-compile (:clx)) - |describe| |keytrans| |trace| |util|) - - -(defun compile-clx (&optional pathname-defaults) - (let ((*default-pathname-defaults* - (or pathname-defaults *default-pathname-defaults*))) - (declare (special *default-pathname-defaults*)) - (compile-file "depdefs") - (load "depdefs") - (compile-file "clx") - (load "clx") - (compile-file "dependent") - (load "dependent") - (compile-file "macros") - (load "macros") - (compile-file "bufmac") - (load "bufmac") - (compile-file "buffer") - (load "buffer") - (compile-file "display") - (load "display") - (compile-file "gcontext") - (load "gcontext") - (compile-file "input") - (load "input") - (compile-file "requests") - (load "requests") - (compile-file "fonts") - (load "fonts") - (compile-file "graphics") - (load "graphics") - (compile-file "text") - (load "text") - (compile-file "attributes") - (load "attributes") - (load "translate") - (compile-file "translate") ; work-around bug in 2.0 and 2.2 - (load "translate") - (compile-file "keysyms") - (load "keysyms") - (compile-file "manager") - (load "manager") - (compile-file "image") - (load "image") - (compile-file "resource") - (load "resource") - )) - - -(defun load-clx (&optional pathname-defaults) - (let ((*default-pathname-defaults* - (or pathname-defaults *default-pathname-defaults*))) - (declare (special *default-pathname-defaults*)) - (load "depdefs") - (load "clx") - (load "dependent") - (load "macros") - (load "bufmac") - (load "buffer") - (load "display") - (load "gcontext") - (load "input") - (load "requests") - (load "fonts") - (load "graphics") - (load "text") - (load "attributes") - (load "translate") - (load "keysyms") - (load "manager") - (load "image") - (load "resource") - )) diff --git a/clx/excldep.c b/clx/excldep.c deleted file mode 100644 index c6fe25c6442a5f85b0dcf312c07046a8ead776d1..0000000000000000000000000000000000000000 --- a/clx/excldep.c +++ /dev/null @@ -1,73 +0,0 @@ -/* - * Allegro CL dependent C helper routines for CLX - */ - -/* - * This code requires select and interval timers. - * This means you probably need BSD, or a version - * of Unix with select and interval timers added. - */ - -#include <sys/types.h> -#include <sys/errno.h> -#include <sys/time.h> -#include <stdio.h> - -#define ERROR -1 -#define INTERRUPT -2 -#define TIMEOUT 0 -#define SUCCESS 1 - -#ifdef FD_SETSIZE -#define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ -#else -#define NUMBER_OF_FDS 32 -#endif - -/* Length of array needed to hold all file descriptor bits */ -#define CHECKLEN ((NUMBER_OF_FDS+8*sizeof(int)-1) / (8 * sizeof(int))) - -extern int errno; - -/* - * This function waits for input to become available on 'fd'. If timeout is - * 0, wait forever. Otherwise wait 'timeout' seconds. If input becomes - * available before the timer expires, return SUCCESS. If the timer expires - * return TIMEOUT. If an error occurs, return ERROR. If an interrupt occurs - * while waiting, return INTERRUPT. - */ -int fd_wait_for_input(fd, timeout) - register int fd; - register int timeout; -{ - struct timeval timer; - register int i; - int checkfds[CHECKLEN]; - - if (fd < 0 || fd >= NUMBER_OF_FDS) { - fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); - fflush(stderr); - } - - for (i = 0; i < CHECKLEN; i++) - checkfds[i] = 0; - checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int))); - - if (timeout) { - timer.tv_sec = timeout; - timer.tv_usec = 0; - i = select(32, checkfds, (int *)0, (int *)0, &timer); - } else - i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0); - - if (i < 0) - /* error condition */ - if (errno == EINTR) - return (INTERRUPT); - else - return (ERROR); - else if (i == 0) - return (TIMEOUT); - else - return (SUCCESS); -} diff --git a/clx/excldep.lisp b/clx/excldep.lisp deleted file mode 100644 index e6e59d2da147eb5217811bc578e8e277db4daa64..0000000000000000000000000000000000000000 --- a/clx/excldep.lisp +++ /dev/null @@ -1,449 +0,0 @@ -;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- -;;; -;;; CLX -- excldep.cl -;;; -;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca. -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. -;;; -;;; Franz Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(eval-when (compile load eval) - (require :foreign) - (require :process) ; Needed even if scheduler is not - ; running. (Must be able to make - ; a process-lock.) - ) - -(eval-when (load) - (provide :clx)) - - -#-(or little-endian big-endian) -(eval-when (eval compile load) - (let ((x '#(1))) - (if (not (eq 0 (sys::memref x - #.(comp::mdparam 'comp::md-svector-data0-adj) - 0 :unsigned-byte))) - (pushnew :little-endian *features*) - (pushnew :big-endian *features*)))) - - -(defmacro correct-case (string) - ;; This macro converts the given string to the - ;; current preferred case, or leaves it alone in a case-sensitive mode. - (let ((str (gensym))) - `(let ((,str ,string)) - (case excl::*current-case-mode* - (:case-insensitive-lower - (string-downcase ,str)) - (:case-insensitive-upper - (string-upcase ,str)) - ((:case-sensitive-lower :case-sensitive-upper) - ,str))))) - - -(defconstant type-pred-alist - '(#-(version>= 4 1 devel 16) - (card8 . card8p) - #-(version>= 4 1 devel 16) - (card16 . card16p) - #-(version>= 4 1 devel 16) - (card29 . card29p) - #-(version>= 4 1 devel 16) - (card32 . card32p) - #-(version>= 4 1 devel 16) - (int8 . int8p) - #-(version>= 4 1 devel 16) - (int16 . int16p) - #-(version>= 4 1 devel 16) - (int32 . int32p) - #-(version>= 4 1 devel 16) - (mask16 . card16p) - #-(version>= 4 1 devel 16) - (mask32 . card32p) - #-(version>= 4 1 devel 16) - (pixel . card32p) - #-(version>= 4 1 devel 16) - (resource-id . card29p) - #-(version>= 4 1 devel 16) - (keysym . card32p) - (angle . anglep) - (color . color-p) - (bitmap-format . bitmap-format-p) - (pixmap-format . pixmap-format-p) - (display . display-p) - (drawable . drawable-p) - (window . window-p) - (pixmap . pixmap-p) - (visual-info . visual-info-p) - (colormap . colormap-p) - (cursor . cursor-p) - (gcontext . gcontext-p) - (screen . screen-p) - (font . font-p) - (image-x . image-x-p) - (image-xy . image-xy-p) - (image-z . image-z-p) - (wm-hints . wm-hints-p) - (wm-size-hints . wm-size-hints-p) - )) - -;; This (if (and ...) t nil) stuff has a purpose -- it lets the old -;; sun4 compiler opencode the `and'. - -#-(version>= 4 1 devel 16) -(defun card8p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0)) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun card16p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0)) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun card29p (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) - (and (excl:bignump x) (> #.(expt 2 29) (the bignum x)) - (>= (the bignum x) 0))) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun card32p (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) - (and (excl:bignump x) (> #.(expt 2 32) (the bignum x)) - (>= (the bignum x) 0))) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun int8p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun int16p (x) - (declare (optimize (speed 3) (safety 0)) - (fixnum x)) - (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) - t - nil)) - -#-(version>= 4 1 devel 16) -(defun int32p (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (excl:fixnump x) - (and (excl:bignump x) (> #.(expt 2 31) (the bignum x)) - (>= (the bignum x) #.(expt -2 31)))) - t - nil)) - -;; This one can be handled better by knowing a little about what we're -;; testing for. Plus this version can handle (single-float pi), which -;; is otherwise larger than pi! -(defun anglep (x) - (declare (optimize (speed 3) (safety 0))) - (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi))) - (<= (the fixnum x) #.(truncate (* 2 pi)))) - (and (excl::single-float-p x) - (>= (the single-float x) #.(float (* -2 pi) 0.0s0)) - (<= (the single-float x) #.(float (* 2 pi) 0.0s0))) - (and (excl::double-float-p x) - (>= (the double-float x) #.(float (* -2 pi) 0.0d0)) - (<= (the double-float x) #.(float (* 2 pi) 0.0d0)))) - t - nil)) - -(eval-when (load eval) - #+(version>= 4 1 devel 16) - (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt))) - type-pred-alist) - #-(version>= 4 1 devel 16) - (nconc excl::type-pred-alist type-pred-alist)) - - -;; Return t if there is a character available for reading or on error, -;; otherwise return nil. -(defun fd-char-avail-p (fd) - (multiple-value-bind (available-p errcode) - (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd) - (excl:if* errcode - then t - else available-p))) - -(defmacro with-interrupt-checking-on (&body body) - `(locally (declare (optimize (safety 1))) - ,@body)) - -;; Read from the given fd into 'vector', which has element type card8. -;; Start storing at index 'start-index' and read exactly 'length' bytes. -;; Return t if an error or eof occurred, nil otherwise. -(defun fd-read-bytes (fd vector start-index length) - (declare (fixnum fd start-index length) - (type (simple-array (unsigned-byte 8) (*)) vector)) - (with-interrupt-checking-on - (do ((rest length)) - ((eq 0 rest) nil) - (declare (fixnum rest)) - (multiple-value-bind (numread errcode) - (comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector - start-index rest) - (declare (fixnum numread)) - (excl:if* errcode - then (if (not (eq errcode - excl::*error-code-interrupted-system-call*)) - (return t)) - elseif (eq 0 numread) - then (return t) - else (decf rest numread) - (incf start-index numread)))))) - - -(when (plusp (ff:get-entry-points - (make-array 1 :initial-contents - (list (ff:convert-to-lang "fd_wait_for_input"))) - (make-array 1 :element-type '(unsigned-byte 32)))) - (ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input")) - (load "excldep.o")) - -(when (plusp (ff:get-entry-points - (make-array 1 :initial-contents - (list (ff:convert-to-lang "connect_to_server"))) - (make-array 1 :element-type '(unsigned-byte 32)))) - (ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c)) - (load "socket.o")) - -(ff:defforeign-list `((connect-to-server - :entry-point - ,(ff:convert-to-lang "connect_to_server") - :return-type :fixnum - :arg-checking nil - :arguments (string fixnum)) - (fd-wait-for-input - :entry-point ,(ff:convert-to-lang "fd_wait_for_input") - :return-type :fixnum - :arg-checking nil - :call-direct t - :callback nil - :allow-other-keys t - :arguments (fixnum fixnum)))) - - -;; special patch for CLX (various process fixes) -;; patch1000.2 - -(eval-when (compile load eval) - (unless (find-package :patch) - (make-package :patch :use '(:lisp :excl)))) - -(in-package :patch) - -(defvar *patches* nil) - -#+allegro -(eval-when (compile eval load) - (when (and (= excl::cl-major-version-number 3) - (or (= excl::cl-minor-version-number 0) - (and (= excl::cl-minor-version-number 1) - excl::cl-generation-number - (< excl::cl-generation-number 9)))) - (push :clx-r4-process-patches *features*))) - -#+clx-r4-process-patches -(push (cons 1000.2 "special patch for CLX (various process fixes)") - *patches*) - - -(in-package :mp) - -#+clx-r4-process-patches -(export 'wait-for-input-available) - - -#+clx-r4-process-patches -(defun with-timeout-event (seconds fnc args) - (unless *scheduler-stack-group* (start-scheduler)) ;[spr670] - (let ((clock-event (make-clock-event))) - (when (<= seconds 0) (setq seconds 0)) - (multiple-value-bind (secs msecs) (truncate seconds) - ;; secs is now a nonegative integer, and msecs is either fixnum zero - ;; or else something interesting. - (unless (eq 0 msecs) - (setq msecs (truncate (* 1000.0 msecs)))) - ;; Now msecs is also a nonnegative fixnum. - (multiple-value-bind (now mnow) (excl::cl-internal-real-time) - (incf secs now) - (incf msecs mnow) - (when (>= msecs 1000) - (decf msecs 1000) - (incf secs)) - (unless (excl:fixnump secs) (setq secs most-positive-fixnum)) - (setf (clock-event-secs clock-event) secs - (clock-event-msecs clock-event) msecs - (clock-event-function clock-event) fnc - (clock-event-args clock-event) args))) - clock-event)) - - -#+clx-r4-process-patches -(defmacro with-timeout ((seconds &body timeout-body) &body body) - `(let* ((clock-event (with-timeout-event ,seconds - #'process-interrupt - (cons *current-process* - '(with-timeout-internal)))) - (excl::*without-interrupts* t) - ret) - (unwind-protect - ;; Warning: Branch tensioner better not reorder this code! - (setq ret (catch 'with-timeout-internal - (add-to-clock-queue clock-event) - (let ((excl::*without-interrupts* nil)) - (multiple-value-list (progn ,@body))))) - (excl:if* (eq ret 'with-timeout-internal) - then (let ((excl::*without-interrupts* nil)) - (setq ret (multiple-value-list (progn ,@timeout-body)))) - else (remove-from-clock-queue clock-event))) - (values-list ret))) - - -#+clx-r4-process-patches -(defun process-lock (lock &optional (lock-value *current-process*) - (whostate "Lock") timeout) - (declare (optimize (speed 3))) - (unless (process-lock-p lock) - (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock)) - (without-interrupts - (excl:if* (null (process-lock-locker lock)) - then (setf (process-lock-locker lock) lock-value) - else (excl:if* timeout - then (excl:if* (or (eq 0 timeout) ;for speed - (zerop timeout)) - then nil - else (with-timeout (timeout) - (process-lock-1 lock lock-value whostate))) - else (process-lock-1 lock lock-value whostate))))) - - -#+clx-r4-process-patches -(defun process-lock-1 (lock lock-value whostate) - (declare (type process-lock lock) - (optimize (speed 3))) - (let ((process *current-process*)) - (declare (type process process)) - (unless process - (error - "PROCESS-LOCK may not be called on the scheduler's stack group.")) - (loop (unless (process-lock-locker lock) - (return (setf (process-lock-locker lock) lock-value))) - (push process (process-lock-waiting lock)) - (let ((saved-whostate (process-whostate process))) - (unwind-protect - (progn (setf (process-whostate process) whostate) - (process-add-arrest-reason process lock)) - (setf (process-whostate process) saved-whostate)))))) - - -#+clx-r4-process-patches -(defun process-wait (whostate function &rest args) - (declare (optimize (speed 3))) - ;; Run the wait function once here both for efficiency and as a - ;; first line check for errors in the function. - (unless (apply function args) - (process-wait-1 whostate function args))) - - -#+clx-r4-process-patches -(defun process-wait-1 (whostate function args) - (declare (optimize (speed 3))) - (let ((process *current-process*)) - (declare (type process process)) - (unless process - (error - "Process-wait may not be called within the scheduler's stack group.")) - (let ((saved-whostate (process-whostate process))) - (unwind-protect - (without-scheduling-internal - (without-interrupts - (setf (process-whostate process) whostate - (process-wait-function process) function - (process-wait-args process) args) - (chain-rem-q process) - (chain-ins-q process *waiting-processes*)) - (process-resume-scheduler nil)) - (setf (process-whostate process) saved-whostate - (process-wait-function process) nil - (process-wait-args process) nil))))) - - -#+clx-r4-process-patches -(defun process-wait-with-timeout (whostate seconds function &rest args) - ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh - ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code. - ;; -- 28Feb90 smh - ;; Run the wait function once here both for efficiency and as a - ;; first line check for errors in the function. - (excl:if* (apply function args) - then t - else (let ((ret (list nil))) - (without-interrupts - (let ((clock-event - (with-timeout-event seconds #'identity '(nil)))) - (add-to-clock-queue clock-event) - (process-wait-1 whostate - #'(lambda (clock-event function args ret) - (or (null (chain-next clock-event)) - (and (apply function args) - (setf (car ret) 't)))) - (list clock-event function args ret)))) - (car ret)))) - - -;; -;; Returns nil on timeout, otherwise t. -;; -#+clx-r4-process-patches -(defun wait-for-input-available - (stream-or-fd &key (wait-function #'listen) - (whostate "waiting for input") - timeout) - (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd - elseif (streamp stream-or-fd) - then (excl::stream-input-fn stream-or-fd) - else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd)))) - ;; At this point fd could be nil, since stream-input-fn returns nil for - ;; streams that are output only, or for certain special purpose streams. - (if fd - (unwind-protect - (progn - (mp::mpwatchfor fd) - (excl:if* timeout - then (mp::process-wait-with-timeout - whostate timeout wait-function stream-or-fd) - else (mp::process-wait whostate wait-function stream-or-fd) - t)) - (mp::mpunwatchfor fd)) - (excl:if* timeout - then (mp::process-wait-with-timeout - whostate timeout wait-function stream-or-fd) - else (mp::process-wait whostate wait-function stream-or-fd) - t)))) diff --git a/clx/fonts.lisp b/clx/fonts.lisp deleted file mode 100644 index fe3c995358b2b0a5e54b4f19f16494c5c96ad497..0000000000000000000000000000000000000000 --- a/clx/fonts.lisp +++ /dev/null @@ -1,365 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;; The char-info stuff is here instead of CLX because of uses of int16->card16. - -; To allow efficient storage representations, the type char-info is not -; required to be a structure. - -;; For each of left-bearing, right-bearing, width, ascent, descent, attributes: - -;(defun char-<metric> (font index) -; ;; Note: I have tentatively chosen to return nil for an out-of-bounds index -; ;; (or an in-bounds index on a pseudo font), although returning zero or -; ;; signalling might be better. -; (declare (type font font) -; (type integer index) -; (clx-values (or null integer)))) - -;(defun max-char-<metric> (font) -; ;; Note: I have tentatively chosen separate accessors over allowing :min and -; ;; :max as an index above. -; (declare (type font font) -; (clx-values integer))) - -;(defun min-char-<metric> (font) -; (declare (type font font) -; (clx-values integer))) - -;; Note: char16-<metric> accessors could be defined to accept two-byte indexes. - -(deftype char-info-vec () '(simple-array int16 (6))) - -(macrolet ((def-char-info-accessors (useless-name &body fields) - `(within-definition (,useless-name def-char-info-accessors) - ,@(do ((field fields (cdr field)) - (n 0 (1+ n)) - (name) (type) - (result nil)) - ((endp field) result) - (setq name (xintern 'char- (caar field))) - (setq type (cadar field)) - (flet ((from (form) - (if (eq type 'int16) - form - `(,(xintern 'int16-> type) ,form)))) - (push - `(defun ,name (font index) - (declare (type font font) - (type array-index index)) - (declare (clx-values (or null ,type))) - (when (and (font-name font) - (index>= (font-max-char font) index (font-min-char font))) - (the ,type - ,(from - `(the int16 - (let ((char-info-vector (font-char-infos font))) - (declare (type char-info-vec char-info-vector)) - (if (index-zerop (length char-info-vector)) - ;; Fixed width font - (aref (the char-info-vec - (font-max-bounds font)) - ,n) - ;; Variable width font - (aref char-info-vector - (index+ - (index* - 6 - (index- - index - (font-min-char font))) - ,n))))))))) - result) - (setq name (xintern 'min-char- (caar field))) - (push - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values (or null ,type))) - (when (font-name font) - (the ,type - ,(from - `(the int16 - (aref (the char-info-vec (font-min-bounds font)) - ,n)))))) - result) - (setq name (xintern 'max-char- (caar field))) - (push - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values (or null ,type))) - (when (font-name font) - (the ,type - ,(from - `(the int16 - (aref (the char-info-vec (font-max-bounds font)) - ,n)))))) - result))) - - (defun make-char-info - (&key ,@(mapcar - #'(lambda (field) - `(,(car field) (required-arg ,(car field)))) - fields)) - (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields)) - (let ((result (make-array ,(length fields) :element-type 'int16))) - (declare (type char-info-vec result)) - ,@(do* ((field fields (cdr field)) - (var (caar field) (caar field)) - (type (cadar field) (cadar field)) - (n 0 (1+ n)) - (result nil)) - ((endp field) (nreverse result)) - (push `(setf (aref result ,n) - ,(if (eq type 'int16) - var - `(,(xintern type '->int16) ,var))) - result)) - result))))) - (def-char-info-accessors ignore - (left-bearing int16) - (right-bearing int16) - (width int16) - (ascent int16) - (descent int16) - (attributes card16))) - -(defun open-font (display name) - ;; Font objects may be cached and reference counted locally within the display - ;; object. This function might not execute a with-display if the font is cached. - ;; The protocol QueryFont request happens on-demand under the covers. - (declare (type display display) - (type stringable name)) - (declare (clx-values font)) - (let* ((name-string (string-downcase (string name))) - (font (car (member name-string (display-font-cache display) - :key 'font-name - :test 'equal))) - font-id) - (unless font - (setq font (make-font :display display :name name-string)) - (setq font-id (allocate-resource-id display font 'font)) - (setf (font-id-internal font) font-id) - (with-buffer-request (display *x-openfont*) - (resource-id font-id) - (card16 (length name-string)) - (pad16 nil) - (string name-string)) - (push font (display-font-cache display))) - (incf (font-reference-count font)) - font)) - -(defun open-font-internal (font) - ;; Called "under the covers" to open a font object - (declare (type font font)) - (declare (clx-values resource-id)) - (let* ((name-string (font-name font)) - (display (font-display font)) - (id (allocate-resource-id display font 'font))) - (setf (font-id-internal font) id) - (with-buffer-request (display *x-openfont*) - (resource-id id) - (card16 (length name-string)) - (pad16 nil) - (string name-string)) - (push font (display-font-cache display)) - (incf (font-reference-count font)) - id)) - -(defun discard-font-info (font) - ;; Discards any state that can be re-obtained with QueryFont. This is - ;; simply a performance hint for memory-limited systems. - (declare (type font font)) - (setf (font-font-info-internal font) nil - (font-char-infos-internal font) nil)) - -(defun query-font (font) - ;; Internal function called by font and char info accessors - (declare (type font font)) - (declare (clx-values font-info)) - (let ((display (font-display font)) - font-id - font-info - props) - (setq font-id (font-id font)) ;; May issue an open-font request - (with-buffer-request-and-reply (display *x-queryfont* 60) - ((resource-id font-id)) - (let* ((min-byte2 (card16-get 40)) - (max-byte2 (card16-get 42)) - (min-byte1 (card8-get 49)) - (max-byte1 (card8-get 50)) - (min-char min-byte2) - (max-char (index+ (index-ash max-byte1 8) max-byte2)) - (nfont-props (card16-get 46)) - (nchar-infos (index* (card32-get 56) 6)) - (char-info (make-array nchar-infos :element-type 'int16))) - (setq font-info - (make-font-info - :direction (member8-get 48 :left-to-right :right-to-left) - :min-char min-char - :max-char max-char - :min-byte1 min-byte1 - :max-byte1 max-byte1 - :min-byte2 min-byte2 - :max-byte2 max-byte2 - :all-chars-exist-p (boolean-get 51) - :default-char (card16-get 44) - :ascent (int16-get 52) - :descent (int16-get 54) - :min-bounds (char-info-get 8) - :max-bounds (char-info-get 24))) - (setq props (sequence-get :length (index* 2 nfont-props) :format int32 - :result-type 'list :index 60)) - (sequence-get :length nchar-infos :format int16 :data char-info - :index (index+ 60 (index* 2 nfont-props 4))) - (setf (font-char-infos-internal font) char-info) - (setf (font-font-info-internal font) font-info))) - ;; Replace atom id's with keywords in the plist - (do ((p props (cddr p))) - ((endp p)) - (setf (car p) (atom-name display (car p)))) - (setf (font-info-properties font-info) props) - font-info)) - -(defun close-font (font) - ;; This might not generate a protocol request if the font is reference - ;; counted locally. - (declare (type font font)) - (when (and (not (plusp (decf (font-reference-count font)))) - (font-id-internal font)) - (let ((display (font-display font)) - (id (font-id-internal font))) - (declare (type display display)) - ;; Remove font from cache - (setf (display-font-cache display) (delete font (display-font-cache display))) - ;; Close the font - (with-buffer-request (display *x-closefont*) - (resource-id id))))) - -(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) - (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence string))) - (let ((string (string pattern))) - (with-buffer-request-and-reply (display *x-listfonts* size :sizes (8 16)) - ((card16 max-fonts (length string)) - (string string)) - (values - (read-sequence-string - buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*))))) - -(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list)) - ;; Note: Was called list-fonts-with-info. - ;; Returns "pseudo" fonts that contain basic font metrics and properties, but - ;; no per-character metrics and no resource-ids. These pseudo fonts will be - ;; converted (internally) to real fonts dynamically as needed, by issuing an - ;; OpenFont request. However, the OpenFont might fail, in which case the - ;; invalid-font error can arise. - (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence font))) - (let ((string (string pattern)) - (result nil)) - (with-buffer-request-and-reply (display *x-listfontswithinfo* 60 - :sizes (8 16) :multiple-reply t) - ((card16 max-fonts (length string)) - (string string)) - (cond ((zerop (card8-get 1)) t) - (t - (let* ((name-len (card8-get 1)) - (min-byte2 (card16-get 40)) - (max-byte2 (card16-get 42)) - (min-byte1 (card8-get 49)) - (max-byte1 (card8-get 50)) - (min-char min-byte2) - (max-char (index+ (index-ash max-byte1 8) max-byte2)) - (nfont-props (card16-get 46)) - (font - (make-font - :display display - :name nil - :font-info-internal - (make-font-info - :direction (member8-get 48 :left-to-right :right-to-left) - :min-char min-char - :max-char max-char - :min-byte1 min-byte1 - :max-byte1 max-byte1 - :min-byte2 min-byte2 - :max-byte2 max-byte2 - :all-chars-exist-p (boolean-get 51) - :default-char (card16-get 44) - :ascent (int16-get 52) - :descent (int16-get 54) - :min-bounds (char-info-get 8) - :max-bounds (char-info-get 24) - :properties (sequence-get :length (index* 2 nfont-props) - :format int32 - :result-type 'list - :index 60))))) - (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4)))) - (push font result)) - nil))) - ;; Replace atom id's with keywords in the plist - (dolist (font result) - (do ((p (font-properties font) (cddr p))) - ((endp p)) - (setf (car p) (atom-name display (car p))))) - (coerce (nreverse result) result-type))) - -(defun font-path (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence (or string pathname)))) - (with-buffer-request-and-reply (display *x-getfontpath* size :sizes (8 16)) - () - (values - (read-sequence-string - buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*)))) - -(defun set-font-path (display paths) - (declare (type display display) - (type (clx-sequence (or string pathname)) paths)) - (let ((path-length (length paths)) - (request-length 8)) - ;; Find the request length - (dotimes (i path-length) - (let* ((string (string (elt paths i))) - (len (length string))) - (incf request-length (1+ len)))) - (with-buffer-request (display *x-setfontpath* :length request-length) - (length (ceiling request-length 4)) - (card16 path-length) - (pad16 nil) - (progn - (incf buffer-boffset 8) - (dotimes (i path-length) - (let* ((string (string (elt paths i))) - (len (length string))) - (card8-put 0 len) - (string-put 1 string :appending t :header-length 1) - (incf buffer-boffset (1+ len)))) - (setf (buffer-boffset display) (lround buffer-boffset))))) - paths) - -(defsetf font-path set-font-path) diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp deleted file mode 100644 index 22150ab0743afe27f4e4ae05bf7999c35bd240b4..0000000000000000000000000000000000000000 --- a/clx/gcontext.lisp +++ /dev/null @@ -1,971 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; GContext - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; GContext values are usually cached locally in the GContext object. -;;; This is required because the X.11 server doesn't have any requests -;;; for getting GContext values back. -;;; -;;; GContext changes are cached until force-GContext-changes is called. -;;; All the requests that use GContext (including the GContext accessors, -;;; but not the SETF's) call force-GContext-changes. -;;; In addition, the macro WITH-GCONTEXT may be used to provide a -;;; local view if a GContext. -;;; -;;; Each GContext keeps a copy of the values the server has seen, and -;;; a copy altered by SETF, called the LOCAL-STATE (bad name...). -;;; The SETF accessors increment a timestamp in the GContext. -;;; When the timestamp in a GContext isn't equal to the timestamp in -;;; the local-state, changes have been made, and force-GContext-changes -;;; loops through the GContext and local-state, sending differences to -;;; the server, and updating GContext. -;;; -;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to -;;; a private copy. This is easy (and fast) for lisp machines, but other -;;; lisps will have problems. Fortunately, most other lisps don't care, -;;; because they don't run in a multi-processing shared-address space -;;; environment. - -(in-package :xlib) - -;; GContext state accessors -;; The state vector contains all card32s to speed server updating - -(eval-when (eval compile load) - -(defconstant *gcontext-fast-change-length* #.(length *gcontext-components*)) - -(macrolet ((def-gc-internals (name &rest extras) - (let ((macros nil) - (indexes nil) - (masks nil) - (index 0)) - (dolist (name *gcontext-components*) - (push `(defmacro ,(xintern 'gcontext-internal- name) (state) - `(svref ,state ,,index)) - macros) - (setf (getf indexes name) index) - (push (ash 1 index) masks) - (incf index)) - (dolist (extra extras) - (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state) - `(svref ,state ,,index)) - macros) - ;; don't override already correct index entries - (unless (or (getf indexes (second extra)) (getf indexes (first extra))) - (setf (getf indexes (or (second extra) (first extra))) index)) - (push (logior (ash 1 index) - (if (second extra) - (ash 1 (position (second extra) *gcontext-components*)) - 0)) - masks) - (incf index)) - `(within-definition (def-gc-internals ,name) - ,@(nreverse macros) - (eval-when (eval compile load) - (defconstant *gcontext-data-length* ,index) - (defconstant *gcontext-indexes* ',indexes) - (defconstant *gcontext-masks* - ',(coerce (nreverse masks) 'simple-vector))))))) - (def-gc-internals ignore - (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))) - -) ;; end EVAL-WHEN - -(deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*)) - -(deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*)) - -(defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named - (name nil :type symbol :read-only t) - (default nil :type t :read-only t) - (set-function #'(lambda (gcontext value) - (declare (ignore gcontext)) - value) - :type (function (gcontext t) t) :read-only t) - (copy-function #'(lambda (from-gc to-gc value) - (declare (ignore from-gc to-gc)) - value) - :type (function (gcontext gcontext t) t) :read-only t)) - -(defvar *gcontext-extensions* nil) ;; list of gcontext-extension - -;; Gcontext state Resource -(defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states - -(defmacro gcontext-state-next (state) - `(svref ,state 0)) - -(defun allocate-gcontext-state () - ;; Allocate a gcontext-state - ;; Loop until a local state is found that's large enough to hold - ;; any extensions that may exist. - (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*)))) - (declare (type array-index length)) - (loop - (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache* - gcontext-state-next gcontext-state) - (make-array length :initial-element nil)))) - (declare (type gcontext-state state)) - (when (index>= (length state) length) - (return state)))))) - -(defun deallocate-gcontext-state (state) - (declare (type gcontext-state state)) - (fill state nil) - (threaded-atomic-push state *gcontext-local-state-cache* - gcontext-state-next gcontext-state)) - -;; Temp-Gcontext Resource -(defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts - -(defun allocate-temp-gcontext () - (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext) - (make-gcontext :local-state '#() :server-state '#()))) - -(defun deallocate-temp-gcontext (gc) - (declare (type gcontext gc)) - (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext)) - -;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared -;; as (type <type> <name>), there is an accessor: - -;(defun gcontext-<name> (gcontext) -; ;; The value will be nil if the last value stored is unknown (e.g., the cache was -; ;; off, or the component was copied from a gcontext with unknown state). -; (declare (type gcontext gcontext) -; (clx-values <type>))) - -;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared -;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor: - -;(defsetf gcontext-<name> (gcontext) (value) -; ) - -;; Generate all the accessors and defsetf's for GContext - -(defmacro xgcmask->gcmask (mask) - `(the gcmask (logand ,mask #.(1- (ash 1 *gcontext-fast-change-length*))))) - -(defmacro access-gcontext ((gcontext local-state) &body body) - `(let ((,local-state (gcontext-local-state ,gcontext))) - (declare (type gcontext-state ,local-state)) - ,@body)) - -(defmacro modify-gcontext ((gcontext local-state) &body body) - ;; The timestamp must be altered after the modification - `(let ((,local-state (gcontext-local-state ,gcontext))) - (declare (type gcontext-state ,local-state)) - (prog1 - (progn ,@body) - (setf (gcontext-internal-timestamp ,local-state) 0)))) - -(defmacro def-gc-accessor (name type) - (let* ((gcontext-name (xintern 'gcontext- name)) - (internal-accessor (xintern 'gcontext-internal- name)) - (internal-setfer (xintern 'set- gcontext-name))) - `(within-definition (,name def-gc-accessor) - - (defun ,gcontext-name (gcontext) - (declare (type gcontext gcontext)) - (declare (clx-values (or null ,type))) - (let ((value (,internal-accessor (gcontext-local-state gcontext)))) - (declare (type (or null card32) value)) - (when value ;; Don't do anything when value isn't known - (let ((%buffer (gcontext-display gcontext))) - (declare (type display %buffer)) - %buffer - (decode-type ,type value))))) - - (defun ,internal-setfer (gcontext value) - (declare (type gcontext gcontext) - (type ,type value)) - (modify-gcontext (gcontext local-state) - (setf (,internal-accessor local-state) (encode-type ,type value)) - ,@(when (eq type 'pixmap) - ;; write-through pixmaps, because the protocol allows - ;; the server to copy the pixmap contents at the time - ;; of the store, rather than continuing to share with - ;; the pixmap. - `((let ((server-state (gcontext-server-state gcontext))) - (setf (,internal-accessor server-state) nil)))) - value)) - - (defsetf ,gcontext-name ,internal-setfer)))) - -(defmacro incf-internal-timestamp (state) - (let ((ts (gensym))) - `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state)))) - (declare (type fixnum ,ts)) - ;; the probability seems low enough - (setq ,ts (if (= ,ts most-positive-fixnum) - 1 - (the fixnum (1+ ,ts)))) - (setf (gcontext-internal-timestamp ,state) ,ts)))) - -(def-gc-accessor function boole-constant) -(def-gc-accessor plane-mask card32) -(def-gc-accessor foreground card32) -(def-gc-accessor background card32) -(def-gc-accessor line-width card16) -(def-gc-accessor line-style (member :solid :dash :double-dash)) -(def-gc-accessor cap-style (member :not-last :butt :round :projecting)) -(def-gc-accessor join-style (member :miter :round :bevel)) -(def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled)) -(def-gc-accessor fill-rule (member :even-odd :winding)) -(def-gc-accessor tile pixmap) -(def-gc-accessor stipple pixmap) -(def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin -(def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin -;; (def-GC-accessor font font) ;; See below -(def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors)) -(def-gc-accessor exposures (member :off :on)) -(def-gc-accessor clip-x int16) -(def-gc-accessor clip-y int16) -;; (def-GC-accessor clip-mask) ;; see below -(def-gc-accessor dash-offset card16) -;; (def-GC-accessor dashes) ;; see below -(def-gc-accessor arc-mode (member :chord :pie-slice)) - - -(defun gcontext-clip-mask (gcontext) - (declare (type gcontext gcontext)) - (declare (clx-values (or null (member :none) pixmap rect-seq) - (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))) - (access-gcontext (gcontext local-state) - (multiple-value-bind (clip clip-mask) - (without-interrupts - (values (gcontext-internal-clip local-state) - (gcontext-internal-clip-mask local-state))) - (if (null clip) - (values (let ((%buffer (gcontext-display gcontext))) - (declare (type display %buffer)) - (decode-type (or (member :none) pixmap) clip-mask)) - nil) - (values (second clip) - (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) - (first clip))))))) - -(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) - ;; A bit strange, but retains setf form. - ;; a nil clip-mask is transformed to an empty vector - `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask)) - -(defun set-gcontext-clip-mask (gcontext ordering clip-mask) - ;; a nil clip-mask is transformed to an empty vector - (declare (type gcontext gcontext) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) - (type (or (member :none) pixmap rect-seq) clip-mask)) - (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq))) - (multiple-value-bind (clip-mask clip) - (typecase clip-mask - (pixmap (values (pixmap-id clip-mask) nil)) - ((member :none) (values 0 nil)) - (sequence - (values nil - (list (encode-type - (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) - ordering) - (copy-seq clip-mask)))) - (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))) - (modify-gcontext (gcontext local-state) - (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-clip local-state) clip - (gcontext-internal-clip-mask local-state) clip-mask) - (if (null clip) - (setf (gcontext-internal-clip server-state) nil) - (setf (gcontext-internal-clip-mask server-state) nil)) - (when (and clip-mask (not (zerop clip-mask))) - ;; write-through clip-mask pixmap, because the protocol allows the - ;; server to copy the pixmap contents at the time of the store, - ;; rather than continuing to share with the pixmap. - (setf (gcontext-internal-clip-mask server-state) nil)))))) - clip-mask) - -(defun gcontext-dashes (gcontext) - (declare (type gcontext gcontext)) - (declare (clx-values (or null card8 sequence))) - (access-gcontext (gcontext local-state) - (multiple-value-bind (dash dashes) - (without-interrupts - (values (gcontext-internal-dash local-state) - (gcontext-internal-dashes local-state))) - (if (null dash) - dashes - dash)))) - -(defsetf gcontext-dashes set-gcontext-dashes) - -(defun set-gcontext-dashes (gcontext dashes) - (declare (type gcontext gcontext) - (type (or card8 sequence) dashes)) - (multiple-value-bind (dashes dash) - (if (type? dashes 'sequence) - (if (zerop (length dashes)) - (x-type-error dashes '(or card8 sequence) "non-empty sequence") - (values nil (or (copy-seq dashes) (vector)))) - (values (encode-type card8 dashes) nil)) - (modify-gcontext (gcontext local-state) - (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-dash local-state) dash - (gcontext-internal-dashes local-state) dashes) - (if (null dash) - (setf (gcontext-internal-dash server-state) nil) - (setf (gcontext-internal-dashes server-state) nil)))))) - dashes) - -(defun gcontext-font (gcontext &optional metrics-p) - ;; If the stored font is known, it is returned. If it is not known and - ;; metrics-p is false, then nil is returned. If it is not known and - ;; metrics-p is true, then a pseudo font is returned. Full metric and - ;; property information can be obtained, but the font does not have a name or - ;; a resource-id, and attempts to use it where a resource-id is required will - ;; result in an invalid-font error. - (declare (type gcontext gcontext) - (type boolean metrics-p)) - (declare (clx-values (or null font))) - (access-gcontext (gcontext local-state) - (let ((font (gcontext-internal-font-obj local-state))) - (or font - (when metrics-p - ;; XXX this isn't correct - (make-font :display (gcontext-display gcontext) - :id (gcontext-id gcontext) - :name nil)))))) - -(defsetf gcontext-font set-gcontext-font) - -(defun set-gcontext-font (gcontext font) - (declare (type gcontext gcontext) - (type fontable font)) - (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font))) - (font (and font-object (font-id font-object)))) - ;; XXX need to check font has id (and name?) - (modify-gcontext (gcontext local-state) - (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font-object - (gcontext-internal-font local-state) font) - ;; check against font, not against font-obj - (if (null font) - (setf (gcontext-internal-font server-state) nil) - (setf (gcontext-internal-font-obj server-state) font-object)))))) - font) - -(defun force-gcontext-changes-internal (gcontext) - ;; Force any delayed changes. - (declare (type gcontext gcontext)) - #.(declare-buffun) - - (let ((display (gcontext-display gcontext)) - (server-state (gcontext-server-state gcontext)) - (local-state (gcontext-local-state gcontext))) - (declare (type display display) - (type gcontext-state server-state local-state)) - - ;; Update server when timestamps don't match - (unless (= (the fixnum (gcontext-internal-timestamp local-state)) - (the fixnum (gcontext-internal-timestamp server-state))) - - ;; The display is already locked. - (macrolet ((with-buffer ((buffer &key timeout) &body body) - `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) - ,@body))) - - ;; Because there is no locking on the local state we have to - ;; assume that state will change and set timestamps up front, - ;; otherwise by the time we figured out there were no changes - ;; and tried to store the server stamp as the local stamp, the - ;; local stamp might have since been modified. - (setf (gcontext-internal-timestamp local-state) - (incf-internal-timestamp server-state)) - - (block no-changes - (let ((last-request (buffer-last-request display))) - (with-buffer-request (display *x-changegc*) - (gcontext gcontext) - (progn - (do ((i 0 (index+ i 1)) - (bit 1 (the xgcmask (ash bit 1))) - (nbyte 12) - (mask 0) - (local 0)) - ((index>= i *gcontext-fast-change-length*) - (when (zerop mask) - ;; If nothing changed, restore last-request and quit - (setf (buffer-last-request display) - (if (zerop (buffer-last-request display)) - nil - last-request)) - (return-from no-changes nil)) - (card29-put 8 mask) - (card16-put 2 (index-ash nbyte -2)) - (index-incf (buffer-boffset display) nbyte)) - (declare (type array-index i nbyte) - (type xgcmask bit) - (type gcmask mask) - (type (or null card32) local)) - (unless (eql (the (or null card32) (svref server-state i)) - (setq local (the (or null card32) (svref local-state i)))) - (setf (svref server-state i) local) - (card32-put nbyte local) - (setq mask (the gcmask (logior mask bit))) - (index-incf nbyte 4))))))) - - ;; Update GContext extensions - (do ((extension *gcontext-extensions* (cdr extension)) - (i *gcontext-data-length* (index+ i 1)) - (local)) - ((endp extension)) - (unless (eql (svref server-state i) - (setq local (svref local-state i))) - (setf (svref server-state i) local) - (funcall (gcontext-extension-set-function (car extension)) gcontext local))) - - ;; Update clipping rectangles - (multiple-value-bind (local-clip server-clip) - (without-interrupts - (values (gcontext-internal-clip local-state) - (gcontext-internal-clip server-state))) - (unless (equalp local-clip server-clip) - (setf (gcontext-internal-clip server-state) nil) - (unless (null local-clip) - (with-buffer-request (display *x-setcliprectangles*) - (data (first local-clip)) - (gcontext gcontext) - ;; XXX treat nil correctly - (card16 (or (gcontext-internal-clip-x local-state) 0) - (or (gcontext-internal-clip-y local-state) 0)) - ;; XXX this has both int16 and card16 values - ((sequence :format int16) (second local-clip))) - (setf (gcontext-internal-clip server-state) local-clip)))) - - ;; Update dashes - (multiple-value-bind (local-dash server-dash) - (without-interrupts - (values (gcontext-internal-dash local-state) - (gcontext-internal-dash server-state))) - (unless (equalp local-dash server-dash) - (setf (gcontext-internal-dash server-state) nil) - (unless (null local-dash) - (with-buffer-request (display *x-setdashes*) - (gcontext gcontext) - ;; XXX treat nil correctly - (card16 (or (gcontext-internal-dash-offset local-state) 0) - (length local-dash)) - ((sequence :format card8) local-dash)) - (setf (gcontext-internal-dash server-state) local-dash)))))))) - -(defun force-gcontext-changes (gcontext) - ;; Force any delayed changes. - (declare (type gcontext gcontext)) - (let ((display (gcontext-display gcontext)) - (server-state (gcontext-server-state gcontext)) - (local-state (gcontext-local-state gcontext))) - (declare (type gcontext-state server-state local-state)) - ;; Update server when timestamps don't match - (unless (= (the fixnum (gcontext-internal-timestamp local-state)) - (the fixnum (gcontext-internal-timestamp server-state))) - (with-display (display) - (force-gcontext-changes-internal gcontext))))) - -;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE -;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN -;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN -;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS -;;; BACK. - -(defmacro with-gcontext ((gcontext &rest options &key clip-ordering - &allow-other-keys) - &body body) - ;; "Binds" the gcontext components specified by options within the - ;; dynamic scope of the body (i.e., indefinite scope and dynamic - ;; extent), on a per-process basis in a multi-process environment. - ;; The body is not surrounded by a with-display. If cache-p is nil or - ;; the some component states are unknown, this will implement - ;; save/restore by creating a temporary gcontext and doing - ;; copy-gcontext-components to and from it. - - (declare (arglist (gcontext &rest options &key - function plane-mask foreground background - line-width line-style cap-style join-style - fill-style fill-rule arc-mode tile stipple ts-x - ts-y font subwindow-mode exposures clip-x clip-y - clip-mask clip-ordering dash-offset dashes - &allow-other-keys) - &body body)) - (remf options :clip-ordering) - - (let ((gc (gensym)) - (saved-state (gensym)) - (temp-gc (gensym)) - (temp-mask (gensym)) - (temp-vars nil) - (setfs nil) - (indexes nil) ; List of gcontext field indices - (extension-indexes nil) ; List of gcontext extension field indices - (ts-index (getf *gcontext-indexes* :timestamp))) - - (do* ((option options (cddr option)) - (name (car option) (car option)) - (value (cadr option) (cadr option))) - ((endp option) (setq setfs (nreverse setfs))) - (let ((index (getf *gcontext-indexes* name))) - (if index - (push index indexes) - (let ((extension (find name *gcontext-extensions* - :key #'gcontext-extension-name))) - (if extension - (progn - (push (xintern "Internal-" 'gcontext- name "-State-Index") - extension-indexes)) - (x-type-error name 'gcontext-key))))) - (let ((accessor `(,(xintern 'gcontext- name) ,gc - ,@(when (eq name :clip-mask) `(,clip-ordering)))) - (temp-var (gensym))) - (when value - (push `(,temp-var ,value) temp-vars) - (push `(when ,temp-var (setf ,accessor ,temp-var)) setfs)))) - (if setfs - `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) - (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) - (declare (type gcontext ,gc) - (type gcontext-state ,saved-state) - (type xgcmask ,temp-mask) - (type (or null resource-id) ,temp-gc)) - (with-gcontext-bindings (,gc ,saved-state - ,(append indexes extension-indexes) - ,ts-index ,temp-mask ,temp-gc) - (let ,temp-vars - ,@setfs) - ,@body)) - `(progn ,@body)))) - -(defun copy-gcontext-local-state (gcontext indexes &rest extension-indices) - ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK - (declare (type gcontext gcontext) - (type list indexes) - (dynamic-extent extension-indices)) - (let ((local-state (gcontext-local-state gcontext)) - (saved-state (allocate-gcontext-state)) - (cache-p (gcontext-cache-p gcontext))) - (declare (type gcontext-state local-state saved-state)) - (setf (gcontext-internal-timestamp saved-state) 1) - (let ((temp-gc nil) - (temp-mask 0) - (extension-mask 0)) - (declare (type xgcmask temp-mask) - (type integer extension-mask)) - (dolist (i indexes) - (when (or (not (setf (svref saved-state i) (svref local-state i))) - (not cache-p)) - (setq temp-mask - (the xgcmask (logior temp-mask - (the xgcmask (svref *gcontext-masks* i))))))) - (dolist (i extension-indices) - (when (or (not (setf (svref saved-state i) (svref local-state i))) - (not cache-p)) - (setq extension-mask - (the xgcmask (logior extension-mask (ash 1 i)))))) - (when (or (plusp temp-mask) - (plusp extension-mask)) - ;; Copy to temporary GC when field unknown or cache-p false - (let ((display (gcontext-display gcontext))) - (declare (type display display)) - (with-display (display) - (setq temp-gc (allocate-temp-gcontext)) - (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext) - (gcontext-display temp-gc) display - (gcontext-drawable temp-gc) (gcontext-drawable gcontext) - (gcontext-server-state temp-gc) saved-state - (gcontext-local-state temp-gc) saved-state) - ;; Create a new (temporary) gcontext - (with-buffer-request (display *x-creategc*) - (gcontext temp-gc) - (drawable (gcontext-drawable gcontext)) - (card29 0)) - ;; Copy changed components to the temporary gcontext - (when (plusp temp-mask) - (with-buffer-request (display *x-copygc*) - (gcontext gcontext) - (gcontext temp-gc) - (card29 (xgcmask->gcmask temp-mask)))) - ;; Copy extension fields to the new gcontext - (when (plusp extension-mask) - ;; Copy extension fields from temp back to gcontext - (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1)) - (i 0 (index+ i 1))) - ((zerop bit)) - (let ((copy-function (gcontext-extension-copy-function - (elt *gcontext-extensions* i)))) - (funcall copy-function gcontext temp-gc - (svref local-state (index+ i *gcontext-data-length*)))))) - ))) - (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) - -(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc) - (declare (type gcontext gcontext temp-gc) - (type xgcmask temp-mask)) - (let ((display (gcontext-display gcontext))) - (declare (type display display)) - (with-display (display) - (with-buffer-request (display *x-copygc*) - (gcontext temp-gc) - (gcontext gcontext) - (card29 (xgcmask->gcmask temp-mask))) - ;; Copy extension fields from temp back to gcontext - (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1)) - (extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1)) - (local-state (gcontext-local-state temp-gc))) - ((zerop bit)) - (let ((copy-function (gcontext-extension-copy-function (car extensions)))) - (funcall copy-function temp-gc gcontext (svref local-state i)))) - ;; free gcontext - (with-buffer-request (display *x-freegc*) - (gcontext temp-gc)) - (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext) - (deallocate-temp-gcontext temp-gc) - ;; Copy saved state back to server state - (do ((server-state (gcontext-server-state gcontext)) - (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1))) - (i 0 (index+ i 1))) - ((zerop bit) - (incf-internal-timestamp server-state)) - (declare (type gcontext-state server-state) - (type gcmask bit) - (type array-index i)) - (when (oddp bit) - (setf (svref server-state i) nil)))))) - -(defun create-gcontext (&rest options &key (drawable (required-arg drawable)) - function plane-mask foreground background - line-width line-style cap-style join-style fill-style fill-rule - arc-mode tile stipple ts-x ts-y font subwindow-mode - exposures clip-x clip-y clip-mask clip-ordering - dash-offset dashes - (cache-p t) - &allow-other-keys) - ;; Only non-nil components are passed on in the request, but for effective caching - ;; assumptions have to be made about what the actual protocol defaults are. For - ;; all gcontext components, a value of nil causes the default gcontext value to be - ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented - ;; as a list. Note: use of stringable as font will cause an implicit open-font. - ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If - ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext - ;; component will have no effect unless the new value differs from the cached - ;; value. Component changes (setfs and with-gcontext) are always deferred - ;; regardless of the cache mode, and sent over the protocol only when required by a - ;; local operation or by an explicit call to force-gcontext-changes. - (declare (type drawable drawable) ; Required to be non-null - (type (or null boole-constant) function) - (type (or null pixel) plane-mask foreground background) - (type (or null card16) line-width dash-offset) - (type (or null int16) ts-x ts-y clip-x clip-y) - (type (or null (member :solid :dash :double-dash)) line-style) - (type (or null (member :not-last :butt :round :projecting)) cap-style) - (type (or null (member :miter :round :bevel)) join-style) - (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) - (type (or null (member :even-odd :winding)) fill-rule) - (type (or null (member :chord :pie-slice)) arc-mode) - (type (or null pixmap) tile stipple) - (type (or null fontable) font) - (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) - (type (or null (member :on :off)) exposures) - (type (or null (member :none) pixmap rect-seq) clip-mask) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) - (type (or null card8 sequence) dashes) - (dynamic-extent options) - (type boolean cache-p)) - (declare (clx-values gcontext)) - (let* ((display (drawable-display drawable)) - (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p)) - (local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext)) - (gcontextid (allocate-resource-id display gcontext 'gcontext))) - (declare (type display display) - (type gcontext gcontext) - (type resource-id gcontextid) - (type gcontext-state local-state server-state)) - (setf (gcontext-id gcontext) gcontextid) - - (unless function (setf (gcontext-function gcontext) boole-1)) - ;; using the depth of the drawable would be better, but ... - (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff)) - (unless foreground (setf (gcontext-foreground gcontext) 0)) - (unless background (setf (gcontext-background gcontext) 1)) - (unless line-width (setf (gcontext-line-width gcontext) 0)) - (unless line-style (setf (gcontext-line-style gcontext) :solid)) - (unless cap-style (setf (gcontext-cap-style gcontext) :butt)) - (unless join-style (setf (gcontext-join-style gcontext) :miter)) - (unless fill-style (setf (gcontext-fill-style gcontext) :solid)) - (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd)) - (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice)) - (unless ts-x (setf (gcontext-ts-x gcontext) 0)) - (unless ts-y (setf (gcontext-ts-y gcontext) 0)) - (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext) - :clip-by-children)) - (unless exposures (setf (gcontext-exposures gcontext) :on)) - (unless clip-mask (setf (gcontext-clip-mask gcontext) :none)) - (unless clip-x (setf (gcontext-clip-x gcontext) 0)) - (unless clip-y (setf (gcontext-clip-y gcontext) 0)) - (unless dashes (setf (gcontext-dashes gcontext) 4)) - (unless dash-offset (setf (gcontext-dash-offset gcontext) 0)) - ;; a bit kludgy, but ... - (replace server-state local-state) - - (when function (setf (gcontext-function gcontext) function)) - (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask)) - (when foreground (setf (gcontext-foreground gcontext) foreground)) - (when background (setf (gcontext-background gcontext) background)) - (when line-width (setf (gcontext-line-width gcontext) line-width)) - (when line-style (setf (gcontext-line-style gcontext) line-style)) - (when cap-style (setf (gcontext-cap-style gcontext) cap-style)) - (when join-style (setf (gcontext-join-style gcontext) join-style)) - (when fill-style (setf (gcontext-fill-style gcontext) fill-style)) - (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule)) - (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode)) - (when tile (setf (gcontext-tile gcontext) tile)) - (when stipple (setf (gcontext-stipple gcontext) stipple)) - (when ts-x (setf (gcontext-ts-x gcontext) ts-x)) - (when ts-y (setf (gcontext-ts-y gcontext) ts-y)) - (when font (setf (gcontext-font gcontext) font)) - (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode)) - (when exposures (setf (gcontext-exposures gcontext) exposures)) - (when clip-x (setf (gcontext-clip-x gcontext) clip-x)) - (when clip-y (setf (gcontext-clip-y gcontext) clip-y)) - (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask)) - (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset)) - (when dashes (setf (gcontext-dashes gcontext) dashes)) - - (setf (gcontext-internal-timestamp server-state) 1) - (setf (gcontext-internal-timestamp local-state) - ;; SetClipRectangles or SetDashes request need to be sent? - (if (or (gcontext-internal-clip local-state) - (gcontext-internal-dash local-state)) - ;; Yes, mark local state "modified" to ensure - ;; force-gcontext-changes will occur. - 0 - ;; No, mark local state "unmodified" - 1)) - - (with-buffer-request (display *x-creategc*) - (resource-id gcontextid) - (drawable drawable) - (progn (do* ((i 0 (index+ i 1)) - (bit 1 (the xgcmask (ash bit 1))) - (nbyte 16) - (mask 0) - (local (svref local-state i) (svref local-state i))) - ((index>= i *gcontext-fast-change-length*) - (card29-put 12 mask) - (card16-put 2 (index-ash nbyte -2)) - (index-incf (buffer-boffset display) nbyte)) - (declare (type array-index i nbyte) - (type xgcmask bit) - (type gcmask mask) - (type (or null card32) local)) - (unless (eql local (the (or null card32) (svref server-state i))) - (setf (svref server-state i) local) - (card32-put nbyte local) - (setq mask (the gcmask (logior mask bit))) - (index-incf nbyte 4))))) - - ;; Initialize extensions - (do ((extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1))) - ((endp extensions)) - (declare (type list extensions) - (type array-index i)) - (setf (svref server-state i) - (setf (svref local-state i) - (gcontext-extension-default (car extensions))))) - - ;; Set extension values - (do* ((option-list options (cddr option-list)) - (option (car option-list) (car option-list)) - (extension)) - ((endp option-list)) - (declare (type list option-list)) - (cond ((getf *gcontext-indexes* option)) ; Gcontext field - ((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter - ((setq extension (find option *gcontext-extensions* - :key #'gcontext-extension-name)) - (funcall (gcontext-extension-set-function extension) - gcontext (second option-list))) - (t (x-type-error option 'gcontext-key)))) - gcontext)) - -(defun copy-gcontext-components (src dst &rest keys) - (declare (type gcontext src dst) - (dynamic-extent keys)) - ;; you might ask why this isn't just a bunch of - ;; (setf (gcontext-<mumble> dst) (gcontext-<mumble> src)) - ;; the answer is that you can do that yourself if you want, what we are - ;; providing here is access to the protocol request, which will generally - ;; be more efficient (particularly for things like clip and dash lists). - (when keys - (let ((display (gcontext-display src)) - (mask 0)) - (declare (type xgcmask mask)) - (with-display (display) - (force-gcontext-changes-internal src) - (force-gcontext-changes-internal dst) - - ;; collect entire mask and handle extensions - (dolist (key keys) - (let ((i (getf *gcontext-indexes* key))) - (declare (type (or null array-index) i)) - (if i - (setq mask (the xgcmask (logior mask - (the xgcmask (svref *gcontext-masks* i))))) - (multiple-value-bind (extension index) - (find key *gcontext-extensions* :key #'gcontext-extension-name) - (if extension - (funcall (gcontext-extension-copy-function extension) - src dst (svref (gcontext-local-state src) - (index+ index *gcontext-data-length*))) - (x-type-error key 'gcontext-key)))))) - - (when (plusp mask) - (do ((src-server-state (gcontext-server-state src)) - (dst-server-state (gcontext-server-state dst)) - (dst-local-state (gcontext-local-state dst)) - (bit mask (the xgcmask (ash bit -1))) - (i 0 (index+ i 1))) - ((zerop bit) - (incf-internal-timestamp dst-server-state) - (setf (gcontext-internal-timestamp dst-local-state) 0)) - (declare (type gcontext-state src-server-state dst-server-state dst-local-state) - (type xgcmask bit) - (type array-index i)) - (when (oddp bit) - (setf (svref dst-local-state i) - (setf (svref dst-server-state i) (svref src-server-state i))))) - (with-buffer-request (display *x-copygc*) - (gcontext src dst) - (card29 (xgcmask->gcmask mask)))))))) - -(defun copy-gcontext (src dst) - (declare (type gcontext src dst)) - ;; Copies all components. - (apply #'copy-gcontext-components src dst *gcontext-components*) - (do ((extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1))) - ((endp extensions)) - (funcall (gcontext-extension-copy-function (car extensions)) - src dst (svref (gcontext-local-state src) i)))) - -(defun free-gcontext (gcontext) - (declare (type gcontext gcontext)) - (let ((display (gcontext-display gcontext))) - (with-buffer-request (display *x-freegc*) - (gcontext gcontext)) - (deallocate-resource-id display (gcontext-id gcontext) 'gcontext) - (deallocate-gcontext-state (gcontext-server-state gcontext)) - (deallocate-gcontext-state (gcontext-local-state gcontext)) - nil)) - -(defmacro define-gcontext-accessor (name &key default set-function copy-function) - ;; This will define a new gcontext accessor called NAME. - ;; Defines the gcontext-NAME accessor function and its defsetf. - ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when - ;; gcontext-cache-p is true. The NAME keyword will be allowed in - ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS. - ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE) - ;; from create-gcontext, and force-gcontext-changes. - ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value) - ;; from copy-gcontext and copy-gcontext-components. - ;; The copy-function defaults to: - ;; (lambda (ignore dst-gc value) - ;; (if value - ;; (,set-function dst-gc value) - ;; (error "Can't copy unknown GContext component ~a" ',name))) - (declare (type symbol name) - (type t default) - (type symbol set-function) ;; required - (type symbol copy-function)) - (let* ((gc-name (intern (concatenate 'string - (string 'gcontext-) - (string name)))) ;; in current package - (key-name (kintern name)) - (setfer (xintern "Set-" gc-name)) - (internal-set-function (xintern "Internal-Set-" gc-name)) - (internal-copy-function (xintern "Internal-Copy-" gc-name)) - (internal-state-index (xintern "Internal-" gc-name "-State-Index"))) - (unless copy-function - (setq copy-function - `(lambda (src-gc dst-gc value) - (declare (ignore src-gc)) - (if value - (,set-function dst-gc value) - (error "Can't copy unknown GContext component ~a" ',name))))) - `(progn - (eval-when (compile load eval) - (defparameter ,internal-state-index - (add-gcontext-extension ',key-name ,default ',internal-set-function - ',internal-copy-function)) - ) ;; end eval-when - (defun ,gc-name (gcontext) - (svref (gcontext-local-state gcontext) ,internal-state-index)) - (defun ,setfer (gcontext new-value) - (let ((local-state (gcontext-local-state gcontext))) - (setf (gcontext-internal-timestamp local-state) 0) - (setf (svref local-state ,internal-state-index) new-value))) - (defsetf ,gc-name ,setfer) - (defun ,internal-set-function (gcontext new-value) - (,set-function gcontext new-value) - (setf (svref (gcontext-server-state gcontext) ,internal-state-index) - (setf (svref (gcontext-local-state gcontext) ,internal-state-index) - new-value))) - (defun ,internal-copy-function (src-gc dst-gc new-value) - (,copy-function src-gc dst-gc new-value) - (setf (svref (gcontext-local-state dst-gc) ,internal-state-index) - (setf (svref (gcontext-server-state dst-gc) ,internal-state-index) - new-value))) - ',name))) - -;; GContext extension fields are treated in much the same way as normal GContext -;; components. The current value is stored in a slot of the gcontext-local-state, -;; and the value known to the server is in a slot of the gcontext-server-state. -;; The slot-number is defined by its position in the *gcontext-extensions* list. -;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is -;; the extension component name) reflects this position. The position within -;; *gcontext-extensions* and the value of the special value are determined at -;; LOAD time to facilitate merging of seperately compiled extension files. - -(defun add-gcontext-extension (name default-value set-function copy-function) - (declare (type symbol name) - (type t default-value) - (type (function (gcontext t) t) set-function) - (type (function (gcontext gcontext t) t) copy-function)) - (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name) - (prog1 (length *gcontext-extensions*) - (push nil *gcontext-extensions*))))) - (setf (nth number *gcontext-extensions*) - (make-gcontext-extension :name name - :default default-value - :set-function set-function - :copy-function copy-function)) - (+ number *gcontext-data-length*))) diff --git a/clx/generalock.lisp b/clx/generalock.lisp deleted file mode 100644 index cbf95a38a5e5502053b658d8db6c6421455394ea..0000000000000000000000000000000000000000 --- a/clx/generalock.lisp +++ /dev/null @@ -1,72 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*- - -;;; Copyright (C) 1990 Symbolics, Inc. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Symbolics, Inc. provides this software "as is" without -;;; express or implied warranty. - -(defflavor xlib::clx-lock () (simple-recursive-normal-lock) - (:init-keywords :flavor)) - -(defwhopper (lock-internal xlib::clx-lock) (lock-argument) - (catch 'timeout - (continue-whopper lock-argument))) - -(defmethod (lock-block-internal xlib::clx-lock) (lock-argument) - (declare (dbg:locking-function describe-process-lock-for-debugger self)) - (when (null waiter-queue) - (setf waiter-queue (make-scheduler-queue :name name)) - (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name))) - (let ((process (lock-argument-process lock-argument))) - (unwind-protect - (progn - (lock-map-over-conflicting-owners - self lock-argument - #'(lambda (other-lock-arg) - (add-promotion process lock-argument - (lock-argument-process other-lock-arg) other-lock-arg))) - (unless (timer-pending-p timer) - (when (and (safe-to-use-timers %real-current-process) - (not dbg:*debugger-might-have-system-problems*)) - (reset-timer-relative-timer-units timer *lock-timer-interval*))) - (assert (store-conditional (locf latch) process nil)) - (sys:with-aborts-enabled (lock-latch) - (let ((timeout (lock-argument-getf lock-argument :timeout nil))) - (cond ((null timeout) - (promotion-block waiter-queue name #'lock-lockable self lock-argument)) - ((and (plusp timeout) - (using-resource (timer process-block-timers) - ;; Yeah, we know about the internal representation - ;; of timers here. - (setf (car (timer-args timer)) %real-current-process) - (with-scheduler-locked - (reset-timer-relative timer timeout) - (flet ((lock-lockable-or-timeout (timer lock lock-argument) - (or (not (timer-pending-p timer)) - (lock-lockable lock lock-argument)))) - (let ((priority (process-process-priority *current-process*))) - (if (ldb-test %%scheduler-priority-preemption-field priority) - (promotion-block waiter-queue name - #'lock-lockable-or-timeout - timer self lock-argument) - ;; Change to preemptive priority so that when - ;; unlock-internal wakes us up so we can have the lock, - ;; we will really wake up right away - (with-process-priority - (dpb 1 %%scheduler-priority-preemption-field - priority) - (promotion-block waiter-queue name - #'lock-lockable-or-timeout - timer self lock-argument))))) - (lock-lockable self lock-argument))))) - (t (throw 'timeout nil)))))) - (unless (store-conditional (locf latch) nil process) - (lock-latch-wait-internal self)) - (remove-promotions process lock-argument)))) - -(compile-flavor-methods xlib::clx-lock) diff --git a/clx/graphics.lisp b/clx/graphics.lisp deleted file mode 100644 index 6e99140912e1a7262af8face09552b1ad47349d7..0000000000000000000000000000000000000000 --- a/clx/graphics.lisp +++ /dev/null @@ -1,447 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; CLX drawing requests - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defvar *inhibit-appending* nil) - -(defun draw-point (drawable gcontext x y) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y)) - (let ((display (drawable-display drawable))) - (declare (type display display)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length *requestsize*) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) *x-polypoint*) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (data 0) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y)) - (setf (display-boffset display) (index+ buffer-boffset 4))) - ;; New Request - (progn - (put-items (4) - (code *x-polypoint*) - (data 0) ;; Relative-p false - (length 4) - (drawable drawable) - (gcontext gcontext) - (int16 x y)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 16))))))) - (display-invoke-after-function display))) - - -(defun draw-points (drawable gcontext points &optional relative-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type boolean relative-p)) - (with-buffer-request ((drawable-display drawable) *x-polypoint* :gc-force gcontext) - ((data boolean) relative-p) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points))) - -(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x1 y1 x2 y2) - (type boolean relative-p)) - (let ((display (drawable-display drawable))) - (declare (type display display)) - (when relative-p - (incf x2 x1) - (incf y2 y1)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length *requestsize*) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) *x-polysegment*) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x1 y1 x2 y2)) - (setf (display-boffset display) (index+ buffer-boffset 8))) - ;; New Request - (progn - (put-items (4) - (code *x-polysegment*) - (length 5) - (drawable drawable) - (gcontext gcontext) - (int16 x1 y1 x2 y2)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 20))))))) - (display-invoke-after-function display))) - -(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type boolean relative-p fill-p) - (type (member :complex :non-convex :convex) shape)) - (if fill-p - (fill-polygon drawable gcontext points relative-p shape) - (with-buffer-request ((drawable-display drawable) *x-polyline* :gc-force gcontext) - ((data boolean) relative-p) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) points)))) - -;; Internal function called from DRAW-LINES -(defun fill-polygon (drawable gcontext points relative-p shape) - ;; This is clever about appending to previous requests. Should it be? - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type boolean relative-p) - (type (member :complex :non-convex :convex) shape)) - (with-buffer-request ((drawable-display drawable) *x-fillpoly* :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((member8 :complex :non-convex :convex) shape) - (boolean relative-p) - ((sequence :format int16) points))) - -(defun draw-segments (drawable gcontext segments) - (declare (type drawable drawable) - (type gcontext gcontext) - ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2))) - (type sequence segments)) - (with-buffer-request ((drawable-display drawable) *x-polysegment* :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) segments))) - -(defun draw-rectangle (drawable gcontext x y width height &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type boolean fill-p)) - (let ((display (drawable-display drawable)) - (request (if fill-p *x-polyfillrectangle* *x-polyrectangle*))) - (declare (type display display) - (type card16 request)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length *requestsize*) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) request) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y) - (card16 width height)) - (setf (display-boffset display) (index+ buffer-boffset 8))) - ;; New Request - (progn - (put-items (4) - (code request) - (length 5) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card16 width height)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 20))))))) - (display-invoke-after-function display))) - -(defun draw-rectangles (drawable gcontext rectangles &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - ;; (repeat-seq (integer x) (integer y) (integer width) (integer height))) - (type sequence rectangles) - (type boolean fill-p)) - (with-buffer-request ((drawable-display drawable) - (if fill-p *x-polyfillrectangle* *x-polyrectangle*) - :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - ((sequence :format int16) rectangles))) - -(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p) - ;; Should be clever about appending to existing buffered protocol request. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type angle angle1 angle2) - (type boolean fill-p)) - (let ((display (drawable-display drawable)) - (request (if fill-p *x-polyfillarc* *x-polyarc*))) - (declare (type display display) - (type card16 request)) - (with-display (display) - (force-gcontext-changes-internal gcontext) - (with-buffer-output (display :length *requestsize*) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) request) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y) - (card16 width height) - (angle angle1 angle2)) - (setf (display-boffset display) (index+ buffer-boffset 12))) - ;; New Request - (progn - (put-items (4) - (code request) - (length 6) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card16 width height) - (angle angle1 angle2)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 24))))))) - (display-invoke-after-function display))) - -(defun draw-arcs-list (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type list arcs) - (type boolean fill-p)) - (let* ((display (drawable-display drawable)) - (limit (index- (buffer-size display) 12)) - (length (length arcs)) - (request (if fill-p *x-polyfillarc* *x-polyarc*))) - (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (progn - (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) - (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data - (do ((arc arcs)) - ((endp arc) - (setf (buffer-boffset display) buffer-boffset)) - ;; Make sure there's room - (when (index>= buffer-boffset limit) - (setf (buffer-boffset display) buffer-boffset) - (buffer-flush display) - (set-buffer-offset (buffer-boffset display))) - (int16-put 0 (pop arc)) - (int16-put 2 (pop arc)) - (card16-put 4 (pop arc)) - (card16-put 6 (pop arc)) - (angle-put 8 (pop arc)) - (angle-put 10 (pop arc)) - (set-buffer-offset (index+ buffer-boffset 12))))))) - -(defun draw-arcs-vector (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type vector arcs) - (type boolean fill-p)) - (let* ((display (drawable-display drawable)) - (limit (index- (buffer-size display) 12)) - (length (length arcs)) - (request (if fill-p *x-polyfillarc* *x-polyarc*))) - (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (progn - (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) - (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data - (do ((n 0 (index+ n 6)) - (length (length arcs))) - ((index>= n length) - (setf (buffer-boffset display) buffer-boffset)) - ;; Make sure there's room - (when (index>= buffer-boffset limit) - (setf (buffer-boffset display) buffer-boffset) - (buffer-flush display) - (set-buffer-offset (buffer-boffset display))) - (int16-put 0 (aref arcs (index+ n 0))) - (int16-put 2 (aref arcs (index+ n 1))) - (card16-put 4 (aref arcs (index+ n 2))) - (card16-put 6 (aref arcs (index+ n 3))) - (angle-put 8 (aref arcs (index+ n 4))) - (angle-put 10 (aref arcs (index+ n 5))) - (set-buffer-offset (index+ buffer-boffset 12))))))) - -(defun draw-arcs (drawable gcontext arcs &optional fill-p) - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence arcs) - (type boolean fill-p)) - (etypecase arcs - (list (draw-arcs-list drawable gcontext arcs fill-p)) - (vector (draw-arcs-vector drawable gcontext arcs fill-p)))) - -;; The following image routines are bare minimum. It may be useful to define -;; some form of "image" object to hide representation details and format -;; conversions. It also may be useful to provide stream-oriented interfaces -;; for reading and writing the data. - -(defun put-raw-image (drawable gcontext data &key - (start 0) - (depth (required-arg depth)) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (left-pad 0) - (format (required-arg format))) - ;; Data must be a sequence of 8-bit quantities, already in the appropriate format - ;; for transmission; the caller is responsible for all byte and bit swapping and - ;; compaction. Start is the starting index in data; the end is computed from the - ;; other arguments. - (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence data) ; Sequence of integers - (type array-index start) - (type card8 depth left-pad) ;; required - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (member :bitmap :xy-pixmap :z-pixmap) format)) - (with-buffer-request ((drawable-display drawable) *x-putimage* :gc-force gcontext) - ((data (member :bitmap :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (gcontext gcontext) - (card16 width height) - (int16 x y) - (card8 left-pad depth) - (pad16 nil) - ((sequence :format card8 :start start) data))) - -(defun get-raw-image (drawable &key - data - (start 0) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (plane-mask #xffffffff) - (format (required-arg format)) - (result-type '(vector card8))) - ;; If data is given, it is modified in place (and returned), otherwise a new sequence - ;; is created and returned, with a size computed from the other arguments and the - ;; returned depth. The sequence is filled with 8-bit quantities, in transmission - ;; format; the caller is responsible for any byte and bit swapping and compaction - ;; required for further local use. - (declare (type drawable drawable) - (type (or null sequence) data) ;; sequence of integers - (type int16 x y) ;; required - (type card16 width height) ;; required - (type array-index start) - (type pixel plane-mask) - (type (member :xy-pixmap :z-pixmap) format)) - (declare (clx-values (clx-sequence integer) depth visual-info)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32)) - (((data (member error :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (int16 x y) - (card16 width height) - (card32 plane-mask)) - (let ((depth (card8-get 1)) - (length (* 4 (card32-get 4))) - (visual (resource-id-get 8))) - (values (sequence-get :result-type result-type :format card8 - :length length :start start :data data - :index *replysize*) - depth - (visual-info display visual)))))) diff --git a/clx/image.lisp b/clx/image.lisp deleted file mode 100644 index be8099688a6acab9a8838c08abd67c05be0444f9..0000000000000000000000000000000000000000 --- a/clx/image.lisp +++ /dev/null @@ -1,2666 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; CLX Image functions - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defmacro with-image-data-buffer ((buffer size) &body body) - (declare (indentation 0 4 1 1)) - `(let ((.reply-buffer. (allocate-reply-buffer ,size))) - (declare (type reply-buffer .reply-buffer.)) - (unwind-protect - (let ((,buffer (reply-ibuf8 .reply-buffer.))) - (declare (type buffer-bytes ,buffer)) - (with-vector (,buffer buffer-bytes) - ,@body)) - (deallocate-reply-buffer .reply-buffer.)))) - -(def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil)) - ;; Public structure - (width 0 :type card16 :read-only t) - (height 0 :type card16 :read-only t) - (depth 1 :type card8 :read-only t) - (plist nil :type list)) - -;; Image-Plist accessors: -(defmacro image-name (image) `(getf (image-plist ,image) :name)) -(defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot)) -(defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot)) -(defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask)) -(defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask)) -(defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask)) - -(defun print-image (image stream depth) - (declare (type image image) - (ignore depth)) - (print-unreadable-object (image stream :type t) - (when (image-name image) - (write-string (string (image-name image)) stream) - (write-string " " stream)) - (prin1 (image-width image) stream) - (write-string "x" stream) - (prin1 (image-height image) stream) - (write-string "x" stream) - (prin1 (image-depth image) stream))) - -(defconstant *empty-data-x* '#.(make-sequence '(array card8 (*)) 0)) - -(defconstant *empty-data-z* - '#.(make-array '(0 0) :element-type 'pixarray-1-element-type)) - -(def-clx-class (image-x (:include image) (:copier nil) - (:print-function print-image)) - ;; Use this format for shoveling image data - ;; Private structure. Accessors for these NOT exported. - (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) - (bytes-per-line 0 :type card16) - (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (bit-lsb-first-p *image-bit-lsb-first-p* :type boolean) ; Bit order - (byte-lsb-first-p *image-byte-lsb-first-p* :type boolean) ; Byte order - (data *empty-data-x* :type (array card8 (*))) ; row-major - (unit *image-unit* :type (member 8 16 32)) ; Bitmap unit - (pad *image-pad* :type (member 8 16 32)) ; Scanline pad - (left-pad 0 :type card8)) ; Left pad - -(def-clx-class (image-xy (:include image) (:copier nil) - (:print-function print-image)) - ;; Public structure - ;; Use this format for image processing - (bitmap-list nil :type list)) ;; list of bitmaps - -(def-clx-class (image-z (:include image) (:copier nil) - (:print-function print-image)) - ;; Public structure - ;; Use this format for image processing - (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (pixarray *empty-data-z* :type pixarray)) - -(defun create-image (&key width height depth - (data (required-arg data)) - plist name x-hot y-hot - red-mask blue-mask green-mask - bits-per-pixel format bytes-per-line - (byte-lsb-first-p - #+clx-little-endian t - #-clx-little-endian nil) - (bit-lsb-first-p - #+clx-little-endian t - #-clx-little-endian nil) - unit pad left-pad) - ;; Returns an image-x image-xy or image-z structure, depending on the - ;; type of the :DATA parameter. - (declare - (type (or null card16) width height) ; Required - (type (or null card8) depth) ; Defualts to 1 - (type (or buffer-bytes ; Returns image-x - list ; Returns image-xy - pixarray) data) ; Returns image-z - (type list plist) - (type (or null stringable) name) - (type (or null card16) x-hot y-hot) - (type (or null pixel) red-mask blue-mask green-mask) - (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) - - ;; The following parameters are ignored for image-xy and image-z: - (type (or null (member :bitmap :xy-pixmap :z-pixmap)) - format) ; defaults to :z-pixmap - (type (or null card16) bytes-per-line) - (type boolean byte-lsb-first-p bit-lsb-first-p) - (type (or null (member 8 16 32)) unit pad) - (type (or null card8) left-pad)) - (declare (clx-values image)) - (let ((image - (etypecase data - (buffer-bytes ; image-x - (let ((data data)) - (declare (type buffer-bytes data)) - (unless depth (setq depth (or bits-per-pixel 1))) - (unless format - (setq format (if (= depth 1) :xy-pixmap :z-pixmap))) - (unless bits-per-pixel - (setq bits-per-pixel - (cond ((eq format :xy-pixmap) 1) - ((index> depth 24) 32) - ((index> depth 16) 24) - ((index> depth 8) 16) - ((index> depth 4) 8) - ((index> depth 1) 4) - (t 1)))) - (unless width (required-arg width)) - (unless height (required-arg height)) - (unless bytes-per-line - (let* ((pad (or pad 8)) - (bits-per-line (index* width bits-per-pixel)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad))) - (declare (type array-index pad bits-per-line - padded-bits-per-line)) - (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) - (unless unit (setq unit *image-unit*)) - (unless pad - (setq pad - (dolist (pad '(32 16 8)) - (when (and (index<= pad *image-pad*) - (zerop - (index-mod - (index* bytes-per-line 8) pad))) - (return pad))))) - (unless left-pad (setq left-pad 0)) - (make-image-x - :width width :height height :depth depth :plist plist - :format format :data data - :bits-per-pixel bits-per-pixel - :bytes-per-line bytes-per-line - :byte-lsb-first-p byte-lsb-first-p - :bit-lsb-first-p bit-lsb-first-p - :unit unit :pad pad :left-pad left-pad))) - (list ; image-xy - (let ((data data)) - (declare (type list data)) - (unless depth (setq depth (length data))) - (when data - (unless width (setq width (array-dimension (car data) 1))) - (unless height (setq height (array-dimension (car data) 0)))) - (make-image-xy - :width width :height height :plist plist :depth depth - :bitmap-list data))) - (pixarray ; image-z - (let ((data data)) - (declare (type pixarray data)) - (unless width (setq width (array-dimension data 1))) - (unless height (setq height (array-dimension data 0))) - (unless bits-per-pixel - (setq bits-per-pixel - (etypecase data - (pixarray-32 32) - (pixarray-24 24) - (pixarray-16 16) - (pixarray-8 8) - (pixarray-4 4) - (pixarray-1 1))))) - (unless depth (setq depth bits-per-pixel)) - (make-image-z - :width width :height height :depth depth :plist plist - :bits-per-pixel bits-per-pixel :pixarray data))))) - (declare (type image image)) - (when name (setf (image-name image) name)) - (when x-hot (setf (image-x-hot image) x-hot)) - (when y-hot (setf (image-y-hot image) y-hot)) - (when red-mask (setf (image-red-mask image) red-mask)) - (when blue-mask (setf (image-blue-mask image) blue-mask)) - (when green-mask (setf (image-green-mask image) green-mask)) - image)) - -;;;----------------------------------------------------------------------------- -;;; Swapping stuff - -(defun image-noswap - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (if (index= srcinc destinc) - (buffer-replace - dest src destoff - (index+ destoff (index* srcinc (index1- height)) srclen) - srcoff) - (do* ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc)) - (destend (index+ deststart srclen) (index+ deststart srclen))) - ((index-zerop h)) - (declare (type array-index srcstart deststart destend) - (type card16 h)) - (buffer-replace dest src deststart destend srcstart)))) - -(defun image-swap-two-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 2) 2)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 2) - (if lsb-first-p - (setf (aref dest (index1+ (index+ deststart length))) - (the card8 (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index1+ (index+ srcstart length))))))) - (do ((i length (index- i 2)) - (srcidx srcstart (index+ srcidx 2)) - (destidx deststart (index+ destidx 2))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-three-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 3) 3)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 3) - (when (index= (index- srclen length) 2) - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 1))))) - (if lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 2)))))) - (do ((i length (index- i 3)) - (srcidx srcstart (index+ srcidx 3)) - (destidx deststart (index+ destidx 3))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-four-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 3)) - (the card8 (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 3)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 3)) - (the card8 (aref src srcidx)))))))) - -(defun image-swap-words - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 3)) - (the card8 (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index+ srcidx 3)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src srcidx))) - (setf (aref dest (index+ destidx 3)) - (the card8 (aref src (index1+ srcidx))))))))) - -(defun image-swap-nibbles - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 - (let ((byte (aref src srcidx))) - (declare (type card8 byte)) - (dpb (the card4 (ldb (byte 4 0) byte)) - (byte 4 4) - (the card4 (ldb (byte 4 4) byte))))))))))) - -(defun image-swap-nibbles-left - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index= i 1) - (setf (aref dest destidx) - (the card8 - (let ((byte1 (aref src srcidx))) - (declare (type card8 byte1)) - (dpb (the card4 (ldb (byte 4 0) byte1)) - (byte 4 4) - 0))))) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 - (let ((byte1 (aref src srcidx)) - (byte2 (aref src (index1+ srcidx)))) - (declare (type card8 byte1 byte2)) - (dpb (the card4 (ldb (byte 4 0) byte1)) - (byte 4 4) - (the card4 (ldb (byte 4 4) byte2))))))))))) - -(defconstant - *image-byte-reverse* - '#.(coerce - '#( - 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 - 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 - 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 - 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 - 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 - 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 - 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 - 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 - 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 - 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 - 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 - 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 - 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 - 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 - 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 - 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) - '(vector card8))) - -(defun image-swap-bits - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p) - (ignore lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-two-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 2) 2)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 2) - (if lsb-first-p - (setf (aref dest (index1+ (index+ deststart length))) - (br (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (br (aref src (index1+ (index+ srcstart length))))))) - (do ((i length (index- i 2)) - (srcidx srcstart (index+ srcidx 2)) - (destidx deststart (index+ destidx 2))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index1+ srcidx)))) - (setf (aref dest (index1+ destidx)) - (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-four-bytes - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length)) - (br (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 1)) - (br (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 2)) - (br (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 3)) - (br (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index+ srcidx 3)))) - (setf (aref dest (index1+ destidx)) - (br (aref src (index+ srcidx 2)))) - (setf (aref dest (index+ destidx 2)) - (br (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 3)) - (br (aref src srcidx))))))))))) - -(defun image-swap-bits-and-words - (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) - (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type boolean lsb-first-p)) - #.(declare-buffun) - (with-vector (src buffer-bytes) - (with-vector (dest buffer-bytes) - (let ((byte-reverse *image-byte-reverse*)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length 1)) - (br (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length)) - (br (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 3)) - (br (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (br (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (br (aref src (index+ srcidx 3)))) - (setf (aref dest (index+ destidx 2)) - (br (aref src srcidx))) - (setf (aref dest (index+ destidx 3)) - (br (aref src (index1+ srcidx)))))))))))) - -;;; The following table gives the bit ordering within bytes (when accessed -;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to -;;; 31, where bit 0 should be leftmost on the display. For a given byte -;;; labelled A-B, A is for the most significant bit of the byte, and B is -;;; for the least significant bit. -;;; -;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant -;;; -;;; -;;; format ordering -;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 -;;; -;;; -;;; The following table gives the required conversion between any two -;;; formats. It is based strictly on the table above. If you believe one, -;;; you should believe the other. -;;; -;;; legend: -;;; n no changes -;;; s reverse 8-bit units within 16-bit units -;;; l reverse 8-bit units within 32-bit units -;;; w reverse 16-bit units within 32-bit units -;;; r reverse bits within 8-bit units -;;; sr s+R -;;; lr l+R -;;; wr w+R - -(defconstant - *image-swap-function* - '#.(make-array - '(12 12) :initial-contents - (let ((n 'image-noswap) - (s 'image-swap-two-bytes) - (l 'image-swap-four-bytes) - (w 'image-swap-words) - (r 'image-swap-bits) - (sr 'image-swap-bits-and-two-bytes) - (lr 'image-swap-bits-and-four-bytes) - (wr 'image-swap-bits-and-words)) - (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# - (list #| 1Mm |# n n n r sr lr n s l r r r ) - (list #| 2Mm |# n n n r sr lr n s l r r r ) - (list #| 4Mm |# n n n r sr lr n s l r r r ) - (list #| 1Ml |# r r r n s l r sr lr n n n ) - (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) - (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) - (list #| 1Lm |# n n n r sr lr n s l r r r ) - (list #| 2Lm |# s s s sr r wr s n w sr sr sr) - (list #| 4Lm |# l l l lr wr r l w n lr lr lr) - (list #| 1Ll |# r r r n s l r sr lr n n n ) - (list #| 2Ll |# r r r n s l r sr lr n n n ) - (list #| 4Ll |# r r r n s l r sr lr n n n ))))) - -;;; Of course, the table above is a lie. We also need to factor in the -;;; order of the source data to cope with swapping half of a unit at the -;;; end of a scanline, since we are trying to avoid de-ref'ing off the -;;; end of the source. -;;; -;;; Defines whether the first half of a unit has the first half of the data - -(defconstant - *image-swap-lsb-first-p* - '#.(make-array - 12 :initial-contents - (list t #| 1mm |# - t #| 2mm |# - t #| 4mm |# - t #| 1ml |# - nil #| 2ml |# - nil #| 4ml |# - t #| 1lm |# - nil #| 2lm |# - nil #| 4lm |# - t #| 1ll |# - t #| 2ll |# - t #| 4ll |# - ))) - -(defun image-swap-function - (bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p) - (clx-values function lsb-first-p)) - (cond ((index= bits-per-pixel 1) - (let ((from-index - (index+ - (ecase from-bitmap-unit (32 2) (16 1) (8 0)) - (if from-bit-lsb-first-p 3 0) - (if from-byte-lsb-first-p 6 0)))) - (values - (aref *image-swap-function* from-index - (index+ - (ecase to-bitmap-unit (32 2) (16 1) (8 0)) - (if to-bit-lsb-first-p 3 0) - (if to-byte-lsb-first-p 6 0))) - (aref *image-swap-lsb-first-p* from-index)))) - (t - (values - (if (if (index= bits-per-pixel 4) - (eq from-bit-lsb-first-p to-bit-lsb-first-p) - (eq from-byte-lsb-first-p to-byte-lsb-first-p)) - 'image-noswap - (ecase bits-per-pixel - (4 'image-swap-nibbles) - (8 'image-noswap) - (16 'image-swap-two-bytes) - (24 'image-swap-three-bytes) - (32 'image-swap-four-bytes))) - from-byte-lsb-first-p)))) - - -;;;----------------------------------------------------------------------------- -;;; GET-IMAGE - -(defun read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (index-mod (index- x) 8)) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (index- width left-bits right-bits)) - (middle-bytes (index-floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y - left-bits right-bits middle-bits middle-bytes)) - (cond ((index< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x left-bits)) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref array y (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref array y (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref array y (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref array y (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref array y (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref array y (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref array y (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x left-bits)) - (declare (type card8 byte) - (type array-index x)) - (setf (aref array y (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref array y (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref array y (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref array y (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref array y (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref array y (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref array y (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x left-bits (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (index+ left-bits middle-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref array y (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref array y (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref array y (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref array y (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref array y (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref array y (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref array y (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref array y (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref array y (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref array y (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref array y (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) - -(defun read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (index-mod (index- x) 2)) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x left-nibbles (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) - -(defun read-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - x) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start width)) - (i start (index1+ i)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (the card8 (aref buffer-bbuf i))))))) - -(defun read-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)))))))) - -(defun read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) - -(defun read-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 4)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)) - (aref buffer-bbuf (index+ i 3)))))))) - -(defun read-pixarray-internal - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel read-pixarray-function - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type function read-pixarray-function) - (type (member 8 16 32) from-unit to-unit) - (type boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (if (eq image-swap-function 'image-noswap) - (funcall - read-pixarray-function - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (funcall - (symbol-function image-swap-function) bbuf buf - (index+ boffset (index* y padded-bytes-per-line)) 0 - (index-ceiling (index* (index+ x width) bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line height - image-swap-lsb-first-p) - (funcall - read-pixarray-function - buf 0 pixarray x 0 width height padded-bytes-per-line - bits-per-pixel))))) - -(defun read-pixarray - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (fast-read-pixarray - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel - (ecase bits-per-pixel - ( 1 #'read-pixarray-1 ) - ( 4 #'read-pixarray-4 ) - ( 8 #'read-pixarray-8 ) - (16 #'read-pixarray-16) - (24 #'read-pixarray-24) - (32 #'read-pixarray-32)) - unit byte-lsb-first-p bit-lsb-first-p - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*))) - -(defun read-xy-format-image-x - (buffer-bbuf index length data width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p pad) - (declare (type buffer-bytes buffer-bbuf) - (type card16 width height) - (type array-index index length padded-bytes-per-line - padded-bytes-per-plane) - (type image-depth depth) - (type (member 8 16 32) unit pad) - (type boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-x)) - (assert (index<= (index* depth padded-bytes-per-plane) length)) - (let* ((bytes-per-line (index-ceiling width 8)) - (data-length (index* padded-bytes-per-plane depth))) - (declare (type array-index bytes-per-line data-length)) - (cond (data - (check-type data buffer-bytes) - (assert (index>= (length data) data-length))) - (t - (setq data (make-array data-length :element-type 'card8)))) - (do ((plane 0 (index1+ plane))) - ((index>= plane depth)) - (declare (type image-depth plane)) - (image-noswap - buffer-bbuf data - (index+ index (index* plane padded-bytes-per-plane)) - (index* plane padded-bytes-per-plane) - bytes-per-line padded-bytes-per-line padded-bytes-per-line - height byte-lsb-first-p)) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel 1 :format :xy-pixmap - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun read-z-format-image-x - (buffer-bbuf index length data width height depth - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type card16 width height) - (type array-index index length padded-bytes-per-line) - (type image-depth depth) - (type (member 8 16 32) unit pad) - (type boolean byte-lsb-first-p bit-lsb-first-p) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (clx-values image-x)) - (assert (index<= (index* height padded-bytes-per-line) length)) - (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8)) - (data-length (index* padded-bytes-per-line height))) - (declare (type array-index bytes-per-line data-length)) - (cond (data - (check-type data buffer-bytes) - (assert (index>= (length data) data-length))) - (t - (setq data (make-array data-length :element-type 'card8)))) - (image-noswap - buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line - padded-bytes-per-line height byte-lsb-first-p) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel bits-per-pixel :format :z-pixmap - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun read-image-xy (bbuf index length data x y width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type card16 x y width height) - (type array-index index length padded-bytes-per-line - padded-bytes-per-plane) - (type image-depth depth) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-xy)) - (check-type data list) - (multiple-value-bind (dimensions element-type) - (if data - (values (array-dimensions (first data)) - (array-element-type (first data))) - (values (list height - (index* (index-ceiling width *image-pad*) *image-pad*)) - 'pixarray-1-element-type)) - (do* ((arrays data) - (result nil) - (limit (index+ length index)) - (plane 0 (1+ plane)) - (index index (index+ index padded-bytes-per-plane))) - ((or (>= plane depth) - (index> (index+ index padded-bytes-per-plane) limit)) - (setq data (nreverse result) depth (length data))) - (declare (type array-index limit index) - (type image-depth plane) - (type list arrays result)) - (let ((array (or (pop arrays) - (make-array dimensions :element-type element-type)))) - (declare (type pixarray-1 array)) - (push array result) - (read-pixarray - bbuf index array x y width height padded-bytes-per-line 1 - unit byte-lsb-first-p bit-lsb-first-p))) - (create-image - :width width :height height :depth depth :data data))) - -(defun read-image-z (bbuf index length data x y width height depth - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type card16 x y width height) - (type array-index index length padded-bytes-per-line) - (type image-depth depth) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-z)) - (assert (index<= (index* (index+ y height) padded-bytes-per-line) length)) - (let* ((image-bits-per-line (index* width bits-per-pixel)) - (image-pixels-per-line - (index-ceiling - (index* (index-ceiling image-bits-per-line *image-pad*) - *image-pad*) - bits-per-pixel))) - (declare (type array-index image-bits-per-line image-pixels-per-line)) - (unless data - (setq data - (make-array - (list height image-pixels-per-line) - :element-type (ecase bits-per-pixel - (1 'pixarray-1-element-type) - (4 'pixarray-4-element-type) - (8 'pixarray-8-element-type) - (16 'pixarray-16-element-type) - (24 'pixarray-24-element-type) - (32 'pixarray-32-element-type))))) - (read-pixarray - bbuf index data x y width height padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (create-image - :width width :height height :depth depth :data data - :bits-per-pixel bits-per-pixel))) - -(defun get-image (drawable &key - data - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - plane-mask format result-type) - (declare (type drawable drawable) - (type (or buffer-bytes list pixarray) data) - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (or null pixel) plane-mask) - (type (or null (member :xy-pixmap :z-pixmap)) format) - (type (or null (member image-xy image-x image-z)) result-type) - (clx-values image visual-info)) - (unless result-type - (setq result-type (ecase format - (:xy-pixmap 'image-xy) - (:z-pixmap 'image-z) - ((nil) 'image-x)))) - (unless format - (setq format (case result-type - (image-xy :xy-pixmap) - ((image-z image-x) :z-pixmap)))) - (unless (ecase result-type - (image-xy (eq format :xy-pixmap)) - (image-z (eq format :z-pixmap)) - (image-x t)) - (error "Result-type ~s is incompatable with format ~s" - result-type format)) - (unless plane-mask (setq plane-mask #xffffffff)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32)) - (((data (member error :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (int16 x y) - (card16 width height) - (card32 plane-mask)) - (let* ((depth (card8-get 1)) - (length (index* 4 (card32-get 4))) - (visual-info (visual-info display (resource-id-get 8))) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (declare (type image-depth depth) - (type array-index length) - (type (or null visual-info) visual-info) - (type bitmap-format bitmap-format) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (multiple-value-bind (pad bits-per-pixel) - (ecase format - (:xy-pixmap - (values (bitmap-format-pad bitmap-format) 1)) - (:z-pixmap - (if (= depth 1) - (values (bitmap-format-pad bitmap-format) 1) - (let ((pixmap-format - (find depth (display-pixmap-formats display) - :key #'pixmap-format-depth))) - (declare (type pixmap-format pixmap-format)) - (values (pixmap-format-scanline-pad pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format)))))) - (declare (type (member 8 16 32) pad) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((bits-per-line (index* bits-per-pixel width)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line - (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane - (index* padded-bytes-per-line height)) - (image - (ecase result-type - (image-x - (ecase format - (:xy-pixmap - (read-xy-format-image-x - buffer-bbuf *replysize* length data - width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p - pad)) - (:z-pixmap - (read-z-format-image-x - buffer-bbuf *replysize* length data - width height depth - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p - pad bits-per-pixel)))) - (image-xy - (read-image-xy - buffer-bbuf *replysize* length data - 0 0 width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p)) - (image-z - (read-image-z - buffer-bbuf *replysize* length data - 0 0 width height depth padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p))))) - (declare (type image image) - (type array-index bits-per-line - padded-bits-per-line padded-bytes-per-line)) - (when visual-info - (unless (zerop (visual-info-red-mask visual-info)) - (setf (image-red-mask image) - (visual-info-red-mask visual-info))) - (unless (zerop (visual-info-green-mask visual-info)) - (setf (image-green-mask image) - (visual-info-green-mask visual-info))) - (unless (zerop (visual-info-blue-mask visual-info)) - (setf (image-blue-mask image) - (visual-info-blue-mask visual-info)))) - (values image visual-info))))))) - - -;;;----------------------------------------------------------------------------- -;;; PUT-IMAGE - -(defun write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x start-x (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (index+ start-x middle-bits))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (if (index> right-bits 1) - (aref array y (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref array y (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref array y (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref array y (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref array y (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref array y (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (aref array y (index+ x 1)) - (aref array y (index+ x 2)) - (aref array y (index+ x 3)) - (aref array y (index+ x 4)) - (aref array y (index+ x 5)) - (aref array y (index+ x 6)) - (aref array y (index+ x 7)))))))) - -(defun write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x start-x (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (aref array y (index+ x 1)))))))) - -(defun write-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start width)) - (i start (index1+ i)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref buffer-bbuf i) (the card8 (aref array y x))))))) - -(defun write-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-16-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 16)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 16))))))) - -(defun write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) - -(defun write-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) - (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) - #.(declare-buffun) - (with-vector (buffer-bbuf buffer-bytes) - (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y start)) - (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-32-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 32)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 32)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 32)) - (setf (aref buffer-bbuf (index+ i 3)) - (write-image-load-byte 24 pixel 32))))))) - -(defun write-pixarray-internal - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel write-pixarray-function - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type function write-pixarray-function) - (type (member 8 16 32) from-unit to-unit) - (type boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type boolean image-swap-lsb-first-p)) - (if (eq image-swap-function 'image-noswap) - (funcall - write-pixarray-function - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (funcall - write-pixarray-function - buf 0 pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (funcall - (symbol-function image-swap-function) buf bbuf 0 boffset - (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line height - image-swap-lsb-first-p))))) - -(defun write-pixarray - (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (unless (fast-write-pixarray - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel - (ecase bits-per-pixel - ( 1 #'write-pixarray-1 ) - ( 4 #'write-pixarray-4 ) - ( 8 #'write-pixarray-8 ) - (16 #'write-pixarray-16) - (24 #'write-pixarray-24) - (32 #'write-pixarray-32)) - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p* - unit byte-lsb-first-p bit-lsb-first-p))) - -(defun write-xy-format-image-x-data - (data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes data obuf) - (type array-index data-start obuf-start - from-padded-bytes-per-line to-padded-bytes-per-line) - (type card16 x y width height) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (assert (index-zerop (index-mod x 8))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - 1 - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type boolean image-swap-lsb-first-p)) - (let ((x-mod-unit (index-mod x from-bitmap-unit))) - (declare (type card16 x-mod-unit)) - (if (and (index-plusp x-mod-unit) - (not (eq from-byte-lsb-first-p from-bit-lsb-first-p))) - (let* ((temp-width (index+ width x-mod-unit)) - (temp-bytes-per-line (index-ceiling temp-width 8)) - (temp-padded-bits-per-line - (index* (index-ceiling temp-width from-bitmap-unit) - from-bitmap-unit)) - (temp-padded-bytes-per-line - (index-ceiling temp-padded-bits-per-line 8))) - (declare (type card16 temp-width temp-bytes-per-line - temp-padded-bits-per-line temp-padded-bytes-per-line)) - (with-image-data-buffer - (buf (index* height temp-padded-bytes-per-line)) - (funcall - (symbol-function image-swap-function) data buf - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor (index- x x-mod-unit) 8)) - 0 temp-bytes-per-line from-padded-bytes-per-line - temp-padded-bytes-per-line height image-swap-lsb-first-p) - (write-xy-format-image-x-data - buf obuf 0 obuf-start x-mod-unit 0 width height - temp-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))) - (funcall - (symbol-function image-swap-function) data obuf - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor x 8)) - obuf-start (index-ceiling width 8) from-padded-bytes-per-line - to-padded-bytes-per-line height image-swap-lsb-first-p))))) - -(defun write-xy-format-image-x - (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-x image) - (type int16 src-x src-y) - (type card16 width height) - (type array-index padded-bytes-per-line) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (dotimes (plane (image-depth image)) - (let ((data-start - (index* (index* plane (image-height image)) - (image-x-bytes-per-line image))) - (src-y src-y) - (height height)) - (declare (type int16 src-y) - (type card16 height)) - (loop - (when (index-zerop height) (return)) - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-xy-format-image-x-data - (image-x-data image) (buffer-obuf8 display) - data-start (buffer-boffset display) - src-x src-y width nlines - (image-x-bytes-per-line image) padded-bytes-per-line - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))))) - -(defun write-z-format-image-x-data - (data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type buffer-bytes data obuf) - (type array-index data-start obuf-start - from-padded-bytes-per-line to-padded-bytes-per-line) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) - (if (index= bits-per-pixel 1) - (write-xy-format-image-x-data - data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (let ((srcoff - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor (index* x bits-per-pixel) 8))) - (srclen (index-ceiling (index* width bits-per-pixel) 8))) - (declare (type array-index srcoff srclen)) - (if (and (index= bits-per-pixel 4) (index-oddp x)) - (with-image-data-buffer (buf (index* height to-padded-bytes-per-line)) - (image-swap-nibbles-left - data buf srcoff 0 srclen - from-padded-bytes-per-line to-padded-bytes-per-line height nil) - (write-z-format-image-x-data - buf obuf 0 obuf-start 0 0 width height - to-padded-bytes-per-line to-padded-bytes-per-line - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type boolean image-swap-lsb-first-p)) - (funcall - (symbol-function image-swap-function) data obuf srcoff obuf-start - srclen from-padded-bytes-per-line to-padded-bytes-per-line height - image-swap-lsb-first-p)))))) - -(defun write-z-format-image-x (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-x image) - (type int16 src-x src-y) - (type card16 width height) - (type array-index padded-bytes-per-line) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (loop - (when (index-zerop height) (return)) - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-z-format-image-x-data - (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display) - src-x src-y width nlines - (image-x-bytes-per-line image) padded-bytes-per-line - (image-x-bits-per-pixel image) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))) - -(defun write-image-xy (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-xy image) - (type array-index padded-bytes-per-line) - (type int16 src-x src-y) - (type card16 width height) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (dolist (bitmap (image-xy-bitmap-list image)) - (declare (type pixarray-1 bitmap)) - (let ((src-y src-y) - (height height)) - (declare (type int16 src-y) - (type card16 height)) - (loop - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-pixarray - (buffer-obuf8 display) (buffer-boffset display) - bitmap src-x src-y width nlines - padded-bytes-per-line 1 - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))))) - -(defun write-image-z (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type display display) - (type image-z image) - (type array-index padded-bytes-per-line) - (type int16 src-x src-y) - (type card16 width height) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (loop - (let ((bits-per-pixel (image-z-bits-per-pixel image)) - (nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type (member 1 4 8 16 24 32) bits-per-pixel) - (type array-index nlines)) - (when (index-plusp nlines) - (write-pixarray - (buffer-obuf8 display) (buffer-boffset display) - (image-z-pixarray image) src-x src-y width nlines - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))) - -;;; Note: The only difference between a format of :bitmap and :xy-pixmap -;;; of depth 1 is that when sending a :bitmap format the foreground -;;; and background in the gcontext are used. - -(defun put-image (drawable gcontext image &key - (src-x 0) (src-y 0) ;Position within image - (x (required-arg x)) ;Position within drawable - (y (required-arg y)) - width height - bitmap-p) - ;; Copy an image into a drawable. - ;; WIDTH and HEIGHT default from IMAGE. - ;; When BITMAP-P, force format to be :bitmap when depth=1. - ;; This causes gcontext to supply foreground & background pixels. - (declare (type drawable drawable) - (type gcontext gcontext) - (type image image) - (type int16 x y) ;; required - (type int16 src-x src-y) - (type (or null card16) width height) - (type boolean bitmap-p)) - (let* ((format - (etypecase image - (image-x (image-x-format (the image-x image))) - (image-xy :xy-pixmap) - (image-z :z-pixmap))) - (src-x - (if (image-x-p image) - (index+ src-x (image-x-left-pad (the image-x image))) - src-x)) - (image-width (image-width image)) - (image-height (image-height image)) - (width (min (or width image-width) (index- image-width src-x))) - (height (min (or height image-height) (index- image-height src-y))) - (depth (image-depth image)) - (display (drawable-display drawable)) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (declare (type (member :bitmap :xy-pixmap :z-pixmap) format) - (type card16 src-x image-width image-height width height) - (type image-depth depth) - (type display display) - (type bitmap-format bitmap-format) - (type (member 8 16 32) unit) - (type boolean byte-lsb-first-p bit-lsb-first-p)) - (when (and bitmap-p (not (index= depth 1))) - (error "Bitmaps must have depth 1")) - (unless (index<= 0 src-x (index1- (image-width image))) - (error "src-x not inside image")) - (unless (index<= 0 src-y (index1- (image-height image))) - (error "src-y not inside image")) - (when (and (index> width 0) (index> height 0)) - (multiple-value-bind (pad bits-per-pixel) - (ecase format - ((:bitmap :xy-pixmap) - (values (bitmap-format-pad bitmap-format) 1)) - (:z-pixmap - (if (= depth 1) - (values (bitmap-format-pad bitmap-format) 1) - (let ((pixmap-format - (find depth (display-pixmap-formats display) - :key #'pixmap-format-depth))) - (declare (type (or null pixmap-format) pixmap-format)) - (if (null pixmap-format) - (error "The depth of the image ~s does not match any server pixmap format." image)) - (if (not (= (etypecase image - (image-z (image-z-bits-per-pixel image)) - (image-x (image-x-bits-per-pixel image))) - (pixmap-format-bits-per-pixel pixmap-format))) - ;; We could try to use the "/* XXX slow, but works */" - ;; code in XPutImage from X11R4 here. However, that - ;; would require considerable support code - ;; (see XImUtil.c, etc). - (error "The bits-per-pixel of the image ~s does not match any server pixmap format." image)) - (values (pixmap-format-scanline-pad pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format)))))) - (declare (type (member 8 16 32) pad) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((left-pad - (if (or (eq format :xy-pixmap) (= depth 1)) - (index-mod src-x (index-min pad *image-pad*)) - 0)) - (left-padded-src-x (index- src-x left-pad)) - (left-padded-width (index+ width left-pad)) - (bits-per-line (index* left-padded-width bits-per-pixel)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (request-bytes-per-line - (ecase format - ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth)) - (:z-pixmap padded-bytes-per-line))) - (max-bytes-per-request - (index* (index- (display-max-request-length display) 6) 4)) - (max-request-height - (floor max-bytes-per-request request-bytes-per-line))) - (declare (type card8 left-pad) - (type int16 left-padded-src-x) - (type card16 left-padded-width) - (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line request-bytes-per-line - max-bytes-per-request max-request-height)) - ;; Be sure that a scanline can fit in a request - (when (index-zerop max-request-height) - (error "Can't even fit one image scanline in a request")) - ;; Be sure a scanline can fit in a buffer - (buffer-ensure-size display padded-bytes-per-line) - ;; Send the image in multiple requests to avoid exceeding the - ;; request limit - (do* ((request-src-y src-y (index+ request-src-y request-height)) - (request-y y (index+ request-y request-height)) - (height-remaining - height (index- height-remaining request-height)) - (request-height - (index-min height-remaining max-request-height) - (index-min height-remaining max-request-height))) - ((index<= height-remaining 0)) - (declare (type array-index request-src-y height-remaining - request-height)) - (let* ((request-bytes (index* request-bytes-per-line request-height)) - (request-words (index-ceiling request-bytes 4)) - (request-length (index+ request-words 6))) - (declare (type array-index request-bytes) - (type card16 request-words request-length)) - (with-buffer-request (display *x-putimage* :gc-force gcontext) - ((data (member :bitmap :xy-pixmap :z-pixmap)) - (cond ((or (eq format :bitmap) bitmap-p) :bitmap) - ((plusp left-pad) :xy-pixmap) - (t format))) - (drawable drawable) - (gcontext gcontext) - (card16 width request-height) - (int16 x request-y) - (card8 left-pad depth) - (pad16 nil) - (progn - (length-put 2 request-length) - (setf (buffer-boffset display) (advance-buffer-offset 24)) - (etypecase image - (image-x - (ecase (image-x-format (the image-x image)) - ((:bitmap :xy-pixmap) - (write-xy-format-image-x - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)) - (:z-pixmap - (write-z-format-image-x - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)))) - (image-xy - (write-image-xy - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)) - (image-z - (write-image-z - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p))) - ;; Be sure the request is padded to a multiple of 4 bytes - (buffer-pad-request display (index- (index* request-words 4) request-bytes)) - ))))))))) - -;;;----------------------------------------------------------------------------- -;;; COPY-IMAGE - -(defun xy-format-image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-x (index+ x (image-x-left-pad image))) - (left-pad (index-mod padded-x 8)) - (x (index- padded-x left-pad)) - (unit (image-x-unit image)) - (byte-lsb-first-p (image-x-byte-lsb-first-p image)) - (bit-lsb-first-p (image-x-bit-lsb-first-p image)) - (pad (image-x-pad image)) - (padded-width - (index* (index-ceiling (index+ width left-pad) pad) pad)) - (padded-bytes-per-line (index-ceiling padded-width 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (length (index* padded-bytes-per-plane (image-depth image))) - (obuf (make-array length :element-type 'card8))) - (declare (type card16 x) - (type card8 left-pad) - (type (member 8 16 32) unit pad) - (type array-index padded-width padded-bytes-per-line - padded-bytes-per-plane length) - (type buffer-bytes obuf)) - (dotimes (plane (image-depth image)) - (let ((data-start - (index* (image-x-bytes-per-line image) - (image-height image) - plane)) - (obuf-start - (index* padded-bytes-per-plane - plane))) - (declare (type array-index data-start obuf-start)) - (write-xy-format-image-x-data - (image-x-data image) obuf data-start obuf-start - x y width height - (image-x-bytes-per-line image) padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p - unit byte-lsb-first-p bit-lsb-first-p))) - (create-image - :width width :height height :depth (image-depth image) - :data obuf :format (image-x-format image) :bits-per-pixel 1 - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad :left-pad left-pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun z-format-image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-x (index+ x (image-x-left-pad image))) - (left-pad - (if (index= (image-depth image) 1) - (index-mod padded-x 8) - 0)) - (x (index- padded-x left-pad)) - (bits-per-pixel (image-x-bits-per-pixel image)) - (unit (image-x-unit image)) - (byte-lsb-first-p (image-x-byte-lsb-first-p image)) - (bit-lsb-first-p (image-x-bit-lsb-first-p image)) - (pad (image-x-pad image)) - (bits-per-line (index* (index+ width left-pad) bits-per-pixel)) - (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (length (index* padded-bytes-per-plane (image-depth image))) - (obuf (make-array length :element-type 'card8))) - (declare (type card16 x) - (type card8 left-pad) - (type (member 8 16 32) unit pad) - (type array-index bits-per-pixel padded-bytes-per-line - padded-bytes-per-plane length) - (type buffer-bytes obuf)) - (write-z-format-image-x-data - (image-x-data image) obuf 0 0 - x y width height - (image-x-bytes-per-line image) padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - unit byte-lsb-first-p bit-lsb-first-p) - (create-image - :width width :height height :depth (image-depth image) - :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel - :bytes-per-line padded-bytes-per-line - :unit unit :pad pad :left-pad left-pad - :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) - -(defun image-x->image-x (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) - (ecase (image-x-format image) - ((:bitmap :xy-pixmap) - (xy-format-image-x->image-x image x y width height)) - (:z-pixmap - (z-format-image-x->image-x image x y width height)))) - -(defun image-x->image-xy (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-xy)) - (unless (or (eq (image-x-format image) :bitmap) - (eq (image-x-format image) :xy-pixmap) - (and (eq (image-x-format image) :z-pixmap) - (index= (image-depth image) 1))) - (error "Format conversion from ~S to ~S not supported" - (image-x-format image) :xy-pixmap)) - (read-image-xy - (image-x-data image) 0 (length (image-x-data image)) nil - (index+ x (image-x-left-pad image)) y width height - (image-depth image) (image-x-bytes-per-line image) - (index* (image-x-bytes-per-line image) (image-height image)) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image))) - -(defun image-x->image-z (image x y width height) - (declare (type image-x image) - (type card16 x y width height) - (clx-values image-z)) - (unless (or (eq (image-x-format image) :z-pixmap) - (eq (image-x-format image) :bitmap) - (and (eq (image-x-format image) :xy-pixmap) - (index= (image-depth image) 1))) - (error "Format conversion from ~S to ~S not supported" - (image-x-format image) :z-pixmap)) - (read-image-z - (image-x-data image) 0 (length (image-x-data image)) nil - (index+ x (image-x-left-pad image)) y width height - (image-depth image) (image-x-bytes-per-line image) - (image-x-bits-per-pixel image) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image))) - -(defun copy-pixarray (array x y width height bits-per-pixel) - (declare (type pixarray array) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((bits-per-line (index* bits-per-pixel width)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line *image-pad*) *image-pad*)) - (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) - (copy (make-array (list height padded-width) - :element-type (array-element-type array)))) - (declare (type array-index bits-per-line padded-bits-per-line padded-width) - (type pixarray copy)) - #.(declare-buffun) - (unless (fast-copy-pixarray array copy x y width height bits-per-pixel) - (macrolet - ((copy (array-type element-type) - `(let ((array array) - (copy copy)) - (declare (type ,array-type array copy)) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-x 0 (index1+ dst-x)) - (src-x x (index1+ src-x))) - ((index>= dst-x width)) - (declare (type card16 dst-x src-x)) - (setf (aref copy dst-y dst-x) - (the ,element-type - (aref array src-y src-x)))))))) - (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))))) - copy)) - -(defun image-xy->image-x (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((padded-bits-per-line - (index* (index-ceiling width *image-pad*) *image-pad*)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (bytes-total (index* padded-bytes-per-plane (image-depth image))) - (data (make-array bytes-total :element-type 'card8))) - (declare (type array-index padded-bits-per-line padded-bytes-per-line - padded-bytes-per-plane bytes-total) - (type buffer-bytes data)) - (let ((index 0)) - (declare (type array-index index)) - (dolist (bitmap (image-xy-bitmap-list image)) - (declare (type pixarray-1 bitmap)) - (write-pixarray - data index bitmap x y width height padded-bytes-per-line 1 - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*) - (index-incf index padded-bytes-per-plane))) - (create-image - :width width :height height :depth (image-depth image) - :data data :format :xy-pixmap :bits-per-pixel 1 - :bytes-per-line padded-bytes-per-line - :unit *image-unit* :pad *image-pad* - :byte-lsb-first-p *image-byte-lsb-first-p* - :bit-lsb-first-p *image-bit-lsb-first-p*))) - -(defun image-xy->image-xy (image x y width height) - (declare (type image-xy image) - (type card16 x y width height) - (clx-values image-xy)) - (create-image - :width width :height height :depth (image-depth image) - :data (mapcar - #'(lambda (array) - (declare (type pixarray-1 array)) - (copy-pixarray array x y width height 1)) - (image-xy-bitmap-list image)))) - -(defun image-xy->image-z (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (ignore image x y width height)) - (error "Format conversion from ~S to ~S not supported" - :xy-pixmap :z-pixmap)) - -(defun image-z->image-x (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (clx-values image-x)) - (let* ((bits-per-line (index* width (image-z-bits-per-pixel image))) - (padded-bits-per-line - (index* (index-ceiling bits-per-line *image-pad*) *image-pad*)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (bytes-total - (index* padded-bytes-per-line height (image-depth image))) - (data (make-array bytes-total :element-type 'card8)) - (bits-per-pixel (image-z-bits-per-pixel image))) - (declare (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line bytes-total) - (type buffer-bytes data) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (write-pixarray - data 0 (image-z-pixarray image) x y width height padded-bytes-per-line - (image-z-bits-per-pixel image) - *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*) - (create-image - :width width :height height :depth (image-depth image) - :data data :format :z-pixmap - :bits-per-pixel bits-per-pixel - :bytes-per-line padded-bytes-per-line - :unit *image-unit* :pad *image-pad* - :byte-lsb-first-p *image-byte-lsb-first-p* - :bit-lsb-first-p *image-bit-lsb-first-p*))) - -(defun image-z->image-xy (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (ignore image x y width height)) - (error "Format conversion from ~S to ~S not supported" - :z-pixmap :xy-pixmap)) - -(defun image-z->image-z (image x y width height) - (declare (type image-z image) - (type card16 x y width height) - (clx-values image-z)) - (create-image - :width width :height height :depth (image-depth image) - :data (copy-pixarray - (image-z-pixarray image) x y width height - (image-z-bits-per-pixel image)))) - -(defun copy-image (image &key (x 0) (y 0) width height result-type) - ;; Copy with optional sub-imaging and format conversion. - ;; result-type defaults to (type-of image) - (declare (type image image) - (type card16 x y) - (type (or null card16) width height) ;; Default from image - (type (or null (member image-x image-xy image-z)) result-type)) - (declare (clx-values image)) - (let* ((image-width (image-width image)) - (image-height (image-height image)) - (width (or width image-width)) - (height (or height image-height))) - (declare (type card16 image-width image-height width height)) - (unless (index<= 0 x (index1- image-width)) (error "x not inside image")) - (unless (index<= 0 y (index1- image-height)) (error "y not inside image")) - (setq width (index-min width (index-max (index- image-width x) 0))) - (setq height (index-min height (index-max (index- image-height y) 0))) - (let ((copy - (etypecase image - (image-x - (ecase result-type - ((nil image-x) (image-x->image-x image x y width height)) - (image-xy (image-x->image-xy image x y width height)) - (image-z (image-x->image-z image x y width height)))) - (image-xy - (ecase result-type - (image-x (image-xy->image-x image x y width height)) - ((nil image-xy) (image-xy->image-xy image x y width height)) - (image-z (image-xy->image-z image x y width height)))) - (image-z - (ecase result-type - (image-x (image-z->image-x image x y width height)) - (image-xy (image-z->image-xy image x y width height)) - ((nil image-z) (image-z->image-z image x y width height))))))) - (declare (type image copy)) - (setf (image-plist copy) (copy-list (image-plist image))) - (when (and (image-x-hot image) (not (index-zerop x))) - (setf (image-x-hot copy) (index- (image-x-hot image) x))) - (when (and (image-y-hot image) (not (index-zerop y))) - (setf (image-y-hot copy) (index- (image-y-hot image) y))) - copy))) - - -;;;----------------------------------------------------------------------------- -;;; Image I/O functions - - -(defun read-bitmap-file (pathname) - ;; Creates an image from a C include file in standard X11 format - (declare (type (or pathname string stream) pathname)) - (declare (clx-values image)) - (with-open-file (fstream pathname :direction :input) - (let ((line "") - (properties nil) - (name nil) - (name-end nil)) - (declare (type string line) - (type stringable name) - (type list properties)) - ;; Get properties - (loop - (setq line (read-line fstream)) - (unless (char= (aref line 0) #\#) (return)) - (flet ((read-keyword (line start end) - (kintern - (substitute - #\- #\_ - (#-excl string-upcase - #+excl correct-case - (subseq line start end)) - :test #'char=)))) - (when (null name) - (setq name-end (position #\_ line :test #'char= :from-end t) - name (read-keyword line 8 name-end)) - (unless (eq name :image) - (setf (getf properties :name) name))) - (let* ((ind-start (index1+ name-end)) - (ind-end (position #\Space line :test #'char= - :start ind-start)) - (ind (read-keyword line ind-start ind-end)) - (val-start (index1+ ind-end)) - (val (parse-integer line :start val-start))) - (setf (getf properties ind) val)))) - ;; Calculate sizes - (multiple-value-bind (width height depth left-pad) - (flet ((extract-property (ind &rest default) - (prog1 (apply #'getf properties ind default) - (remf properties ind)))) - (values (extract-property :width) - (extract-property :height) - (extract-property :depth 1) - (extract-property :left-pad 0))) - (declare (type (or null card16) width height) - (type image-depth depth) - (type card8 left-pad)) - (unless (and width height) (error "Not a BITMAP file")) - (let* ((bits-per-pixel - (cond ((index> depth 24) 32) - ((index> depth 16) 24) - ((index> depth 8) 16) - ((index> depth 4) 8) - ((index> depth 1) 4) - (t 1))) - (bits-per-line (index* width bits-per-pixel)) - (bytes-per-line (index-ceiling bits-per-line 8)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line 32) 32)) - (padded-bytes-per-line - (index-ceiling padded-bits-per-line 8)) - (data (make-array (* padded-bytes-per-line height) - :element-type 'card8)) - (line-base 0) - (byte 0)) - (declare (type array-index bits-per-line bytes-per-line - padded-bits-per-line padded-bytes-per-line - line-base byte) - (type buffer-bytes data)) - (with-vector (data buffer-bytes) - (flet ((parse-hex (char) - (second - (assoc char - '((#\0 0) (#\1 1) (#\2 2) (#\3 3) - (#\4 4) (#\5 5) (#\6 6) (#\7 7) - (#\8 8) (#\9 9) (#\a 10) (#\b 11) - (#\c 12) (#\d 13) (#\e 14) (#\f 15)) - :test #'char-equal)))) - (declare (inline parse-hex)) - ;; Read data - ;; Note: using read-line instead of read-char would be 20% faster, - ;; but would cons a lot of garbage... - (dotimes (i height) - (dotimes (j bytes-per-line) - (loop (when (eql (read-char fstream) #\x) (return))) - (setf (aref data (index+ line-base byte)) - (index+ (index-ash (parse-hex (read-char fstream)) 4) - (parse-hex (read-char fstream)))) - (incf byte)) - (setq byte 0 - line-base (index+ line-base padded-bytes-per-line))))) - ;; Compensate for left-pad in width and x-hot - (index-decf width left-pad) - (when (getf properties :x-hot) - (index-decf (getf properties :x-hot) left-pad)) - (create-image - :width width :height height - :depth depth :bits-per-pixel bits-per-pixel - :data data :plist properties :format :z-pixmap - :bytes-per-line padded-bytes-per-line - :unit 32 :pad 32 :left-pad left-pad - :byte-lsb-first-p t :bit-lsb-first-p t)))))) - -(defun write-bitmap-file (pathname image &optional name) - ;; Writes an image to a C include file in standard X11 format - ;; NAME argument used for variable prefixes. Defaults to "image" - (declare (type (or pathname string stream) pathname) - (type image image) - (type (or null stringable) name)) - (unless (typep image 'image-x) - (setq image (copy-image image :result-type 'image-x))) - (let* ((plist (image-plist image)) - (name (or name (image-name image) 'image)) - (left-pad (image-x-left-pad image)) - (width (index+ (image-width image) left-pad)) - (height (image-height image)) - (depth - (if (eq (image-x-format image) :z-pixmap) - (image-depth image) - 1)) - (bits-per-pixel (image-x-bits-per-pixel image)) - (bits-per-line (index* width bits-per-pixel)) - (bytes-per-line (index-ceiling bits-per-line 8)) - (last (index* bytes-per-line height)) - (count 0)) - (declare (type list plist) - (type stringable name) - (type card8 left-pad) - (type card16 width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type image-depth depth) - (type array-index bits-per-line bytes-per-line count last)) - ;; Move x-hot by left-pad, if there is an x-hot, so image readers that - ;; don't know about left pad get the hot spot in the right place. We have - ;; already increased width by left-pad. - (when (getf plist :x-hot) - (setq plist (copy-list plist)) - (index-incf (getf plist :x-hot) left-pad)) - (with-image-data-buffer (data last) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) 32 t t) - (declare (type symbol image-swap-function) - (type boolean image-swap-lsb-first-p)) - (funcall - (symbol-function image-swap-function) (image-x-data image) - data 0 0 bytes-per-line (image-x-bytes-per-line image) - bytes-per-line height image-swap-lsb-first-p)) - (with-vector (data buffer-bytes) - (setq name (string-downcase (string name))) - (with-open-file (fstream pathname :direction :output) - (format fstream "#define ~a_width ~d~%" name width) - (format fstream "#define ~a_height ~d~%" name height) - (unless (= depth 1) - (format fstream "#define ~a_depth ~d~%" name depth)) - (unless (zerop left-pad) - (format fstream "#define ~a_left_pad ~d~%" name left-pad)) - (do ((prop plist (cddr prop))) - ((endp prop)) - (when (and (not (member (car prop) '(:width :height))) - (numberp (cadr prop))) - (format fstream "#define ~a_~a ~d~%" - name - (substitute - #\_ #\- (string-downcase (string (car prop))) - :test #'char=) - (cadr prop)))) - (format fstream "static char ~a_bits[] = {" name) - (dotimes (i height) - (dotimes (j bytes-per-line) - (when (zerop (index-mod count 15)) - (terpri fstream) - (write-char #\space fstream)) - (write-string "0x" fstream) - ;; Faster than (format fstream "0x~2,'0x," byte) - (let ((byte (aref data count)) - (translate "0123456789abcdef")) - (declare (type card8 byte)) - (write-char (char translate (ldb (byte 4 4) byte)) fstream) - (write-char (char translate (ldb (byte 4 0) byte)) fstream)) - (index-incf count) - (unless (index= count last) - (write-char #\, fstream)))) - (format fstream "};~%" fstream)))))) - -(defun bitmap-image (&optional plist &rest patterns) - ;; Create an image containg pattern - ;; PATTERNS are bit-vector constants (e.g. #*10101) - ;; If the first parameter is a list, its used as the image property-list. - (declare (type (or list bit-vector) plist) - (type list patterns)) ;; list of bitvector - (declare (clx-values image)) - (unless (listp plist) - (push plist patterns) - (setq plist nil)) - (let* ((width (length (first patterns))) - (height (length patterns)) - (bitarray (make-array (list height width) :element-type 'bit)) - (row 0)) - (declare (type card16 width height row) - (type pixarray-1 bitarray)) - (dolist (pattern patterns) - (declare (type simple-bit-vector pattern)) - (dotimes (col width) - (declare (type card16 col)) - (setf (aref bitarray row col) (the bit (aref pattern col)))) - (incf row)) - (create-image :width width :height height :plist plist :data bitarray))) - -(defun image-pixmap (drawable image &key gcontext width height depth) - ;; Create a pixmap containing IMAGE. Size defaults from the image. - ;; DEPTH is the pixmap depth. - ;; GCONTEXT is used for putting the image into the pixmap. - ;; If none is supplied, then one is created, used then freed. - (declare (type drawable drawable) - (type image image) - (type (or null gcontext) gcontext) - (type (or null card16) width height) - (type (or null card8) depth)) - (declare (clx-values pixmap)) - (let* ((image-width (image-width image)) - (image-height (image-height image)) - (image-depth (image-depth image)) - (width (or width image-width)) - (height (or height image-height)) - (depth (or depth image-depth)) - (pixmap (create-pixmap :drawable drawable - :width width - :height height - :depth depth)) - (gc (or gcontext (create-gcontext - :drawable pixmap - :foreground 1 - :background 0)))) - (unless (= depth image-depth) - (if (= image-depth 1) - (unless gcontext (xlib::required-arg gcontext)) - (error "Pixmap depth ~d incompatable with image depth ~d" - depth image-depth))) - (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) gcontext)) - ;; Tile when image-width is less than the pixmap width, or - ;; the image-height is less than the pixmap height. - ;; ??? Would it be better to create a temporary pixmap and - ;; ??? let the server do the tileing? - (do ((x image-width (+ x image-width))) - ((>= x width)) - (copy-area pixmap gc 0 0 image-width image-height pixmap x 0) - (incf image-width image-width)) - (do ((y image-height (+ y image-height))) - ((>= y height)) - (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y) - (incf image-height image-height)) - (unless gcontext (free-gcontext gc)) - pixmap)) - diff --git a/clx/input.lisp b/clx/input.lisp deleted file mode 100644 index ecf33ee29aa9288da5676052438d3b0d6c181c4f..0000000000000000000000000000000000000000 --- a/clx/input.lisp +++ /dev/null @@ -1,1887 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; -;;; Change history: -;;; -;;; Date Author Description -;;; ------------------------------------------------------------------------------------- -;;; 12/10/87 LGO Created - -(in-package :xlib) - -;; Event Resource -(defvar *event-free-list* nil) ;; List of unused (processed) events - -(eval-when (eval compile load) -(defconstant *max-events* 64) ;; Maximum number of events supported (the X11 alpha release only has 34) -(defvar *event-key-vector* (make-array *max-events* :initial-element nil) - "Vector of event keys - See define-event") -) -(defvar *event-macro-vector* (make-array *max-events* :initial-element nil) - "Vector of event handler functions - See declare-event") -(defvar *event-handler-vector* (make-array *max-events* :initial-element nil) - "Vector of event handler functions - See declare-event") -(defvar *event-send-vector* (make-array *max-events* :initial-element nil) - "Vector of event sending functions - See declare-event") - -(defun allocate-event () - (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer) - (make-reply-buffer *replysize*))) - -(defun deallocate-event (reply-buffer) - (declare (type reply-buffer reply-buffer)) - (setf (reply-size reply-buffer) *replysize*) - (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer)) - -;; Extensions are handled as follows: -;; DEFINITION: Use DEFINE-EXTENSION -;; -;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension. -;; This looks up the code on the display-extension-alist. -;; -;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE -;; at LOAD time to define an internal event-code number -;; (stored in the 'event-code property of the event-name) -;; used to index the following vectors: -;; *event-key-vector* Used for getting the event-key -;; *event-macro-vector* Used for getting the event-parameter getting macros -;; -;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert -;; a server event-code into an internal event-code used to index the following -;; vectors: -;; *event-handler-vector* Used for getting the event-handler function -;; *event-send-vector* Used for getting the event-sending function -;; -;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert -;; internal event-codes to external (server) codes. -;; -;; ERRORS: Use DEFINE-ERROR to define new error decodings. -;; - - -;; Any event-code greater than 34 is for an extension -(defparameter *first-extension-event-code* 35) - -(defvar *extensions* nil) ;; alist of (extension-name-symbol events errors) - -(defmacro define-extension (name &key events errors) - ;; Define extension NAME with EVENTS and ERRORS. - ;; Note: The case of NAME is important. - ;; To define the request, Use: - ;; (with-buffer-request (display (extension-opcode ,name)) ,@body) - ;; See the REQUESTS file for lots of examples. - ;; To define event handlers, use declare-event. - ;; To define error handlers, use declare-error and define-condition. - (declare (type stringable name) - (type list events errors)) - (let ((name-symbol (kintern name)) ;; Intern name in the keyword package - (event-list (mapcar #'canonicalize-event-name events))) - `(eval-when (compile load eval) - (setq *extensions* (cons (list ',name-symbol ',event-list ',errors) - (delete ',name-symbol *extensions* :key #'car)))))) - -(eval-when (compile eval load) -(defun canonicalize-event-name (event) - ;; Returns the event name keyword given an event name stringable - (declare (type stringable event)) - (declare (clx-values event-key)) - (kintern event)) -) ;; end eval-when - -(eval-when (compile eval load) -(defun allocate-extension-event-code (name) - ;; Allocate an event-code for an extension - ;; This is executed at COMPILE and LOAD time from DECLARE-EVENT. - ;; The event-code is used at compile-time by macros to index the following vectors: - ;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector* - (let ((event-code (get name 'event-code))) - (declare (type (or null card8) event-code)) - (unless event-code - ;; First ensure the name is for a declared extension - (unless (dolist (extension *extensions*) - (when (member name (second extension)) - (return t))) - (x-type-error name 'event-key)) - (setq event-code (position nil *event-key-vector* - :start *first-extension-event-code*)) - (setf (svref *event-key-vector* event-code) name) - (setf (get name 'event-code) event-code)) - event-code)) -) ;; end eval-when - -(defun get-internal-event-code (display code) - ;; Given an X11 event-code, return the internal event-code. - ;; The internal event-code is used for indexing into the following vectors: - ;; *event-key-vector* *event-handler-vector* *event-send-vector* - ;; Returns NIL when the event-code is for an extension that isn't handled. - (declare (type display display) - (type card8 code)) - (declare (clx-values (or null card8))) - (setq code (logand #x7f code)) - (if (< code *first-extension-event-code*) - code - (let* ((code-offset (- code *first-extension-event-code*)) - (event-extensions (display-event-extensions display)) - (code (if (< code-offset (length event-extensions)) - (aref event-extensions code-offset) - 0))) - (declare (type card8 code-offset code)) - (when (zerop code) - (x-cerror "Ignore the event" - 'unimplemented-event :event-code code :display display)) - code))) - -(defun get-external-event-code (display event) - ;; Given an X11 event name, return the event-code - (declare (type display display) - (type event-key event)) - (declare (clx-values card8)) - (let ((code (get-event-code event))) - (declare (type (or null card8) code)) - (when (>= code *first-extension-event-code*) - (setq code (+ *first-extension-event-code* - (or (position code (display-event-extensions display)) - (x-error 'undefined-event :display display :event-name event))))) - code)) - -(defmacro extension-opcode (display name) - ;; Returns the major opcode for extension NAME. - ;; This is a macro to enable NAME to be interned for fast run-time - ;; retrieval. - ;; Note: The case of NAME is important. - (let ((name-symbol (kintern name))) ;; Intern name in the keyword package - `(or (second (assoc ',name-symbol (display-extension-alist ,display))) - (x-error 'absent-extension :name ',name-symbol :display ,display)))) - -(defun initialize-extensions (display) - ;; Initialize extensions for DISPLAY - (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0)) - (extension-alist nil)) - (declare (type vector event-extensions) - (type list extension-alist)) - (dolist (extension *extensions*) - (let ((name (first extension)) - (events (second extension))) - (declare (type keyword name) - (type list events)) - (multiple-value-bind (major-opcode first-event first-error) - (query-extension display name) - (declare (type (or null card8) major-opcode first-event first-error)) - (when (and major-opcode (plusp major-opcode)) - (push (list name major-opcode first-event first-error) - extension-alist) - (when (plusp first-event) ;; When there are extension events - ;; Grow extension vector when needed - (let ((max-event (- (+ first-event (length events)) - *first-extension-event-code*))) - (declare (type card8 max-event)) - (when (>= max-event (length event-extensions)) - (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8 - :initial-element 0))) - (declare (type vector new-extensions)) - (replace new-extensions event-extensions) - (setq event-extensions new-extensions)))) - (dolist (event events) - (declare (type symbol event)) - (setf (aref event-extensions (- first-event *first-extension-event-code*)) - (get-event-code event)) - (incf first-event))))))) - (setf (display-event-extensions display) event-extensions) - (setf (display-extension-alist display) extension-alist))) - -;; -;; Reply handlers -;; - -(defvar *pending-command-free-list* nil) - -(defun start-pending-command (display) - (declare (type display display)) - (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list* - pending-command-next pending-command) - (make-pending-command)))) - (declare (type pending-command pending-command)) - (setf (pending-command-reply-buffer pending-command) nil) - (setf (pending-command-process pending-command) (current-process)) - (setf (pending-command-sequence pending-command) - (ldb (byte 16 0) (1+ (buffer-request-number display)))) - ;; Add the pending command to the end of the threaded list of pending - ;; commands for the display. - (with-event-queue-internal (display) - (threaded-nconc pending-command (display-pending-commands display) - pending-command-next pending-command)) - pending-command)) - -(defun stop-pending-command (display pending-command) - (declare (type display display) - (type pending-command pending-command)) - (with-event-queue-internal (display) - ;; Remove the pending command from the threaded list of pending commands - ;; for the display. - (threaded-delete pending-command (display-pending-commands display) - pending-command-next pending-command) - ;; Deallocate any reply buffers in this pending command - (loop - (let ((reply-buffer - (threaded-pop (pending-command-reply-buffer pending-command) - reply-next reply-buffer))) - (declare (type (or null reply-buffer) reply-buffer)) - (if reply-buffer - (deallocate-reply-buffer reply-buffer) - (return nil))))) - ;; Clear pointers to help the Garbage Collector - (setf (pending-command-process pending-command) nil) - ;; Deallocate this pending-command - (threaded-atomic-push pending-command *pending-command-free-list* - pending-command-next pending-command) - nil) - -;;; - -(defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil)) - -(defun allocate-reply-buffer (size) - (declare (type array-index size)) - (if (index<= size *replysize*) - (allocate-event) - (let ((index (integer-length (index1- size)))) - (declare (type array-index index)) - (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index) - reply-next reply-buffer) - (make-reply-buffer (index-ash 1 index)))))) - -(defun deallocate-reply-buffer (reply-buffer) - (declare (type reply-buffer reply-buffer)) - (let ((size (reply-size reply-buffer))) - (declare (type array-index size)) - (if (index<= size *replysize*) - (deallocate-event reply-buffer) - (let ((index (integer-length (index1- size)))) - (declare (type array-index index)) - (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index) - reply-next reply-buffer))))) - -;;; - -(defun read-error-input (display sequence reply-buffer token) - (declare (type display display) - (type reply-buffer reply-buffer) - (type card16 sequence)) - (tagbody - start - (with-event-queue-internal (display) - (let ((command - ;; Find any pending command with this sequence number. - (threaded-dolist (pending-command (display-pending-commands display) - pending-command-next pending-command) - (when (= (pending-command-sequence pending-command) sequence) - (return pending-command))))) - (declare (type (or null pending-command) command)) - (cond ((not (null command)) - ;; Give this reply to the pending command - (threaded-nconc reply-buffer (pending-command-reply-buffer command) - reply-next reply-buffer) - (process-wakeup (pending-command-process command))) - ((member :immediately (display-report-asynchronous-errors display)) - ;; No pending command and we should report the error immediately - (go report-error)) - (t - ;; No pending command found, count this as an asynchronous error - (threaded-nconc reply-buffer (display-asynchronous-errors display) - reply-next reply-buffer))))) - (return-from read-error-input nil) - report-error - (note-input-complete display token) - (apply #'report-error display - (prog1 (make-error display reply-buffer t) - (deallocate-event reply-buffer))))) - -(defun read-reply-input (display sequence length reply-buffer) - (declare (type display display) - (type (or null reply-buffer) reply-buffer) - (type card16 sequence) - (type array-index length)) - (unwind-protect - (progn - (when (index< *replysize* length) - (let ((repbuf nil)) - (declare (type (or null reply-buffer) repbuf)) - (unwind-protect - (progn - (setq repbuf (allocate-reply-buffer length)) - (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer) - 0 *replysize*) - (deallocate-event (shiftf reply-buffer repbuf nil))) - (when repbuf - (deallocate-reply-buffer repbuf)))) - (when (buffer-input display (reply-ibuf8 reply-buffer) *replysize* length) - (return-from read-reply-input t)) - (setf (reply-data-size reply-buffer) length)) - (with-event-queue-internal (display) - ;; Find any pending command with this sequence number. - (let ((command - (threaded-dolist (pending-command (display-pending-commands display) - pending-command-next pending-command) - (when (= (pending-command-sequence pending-command) sequence) - (return pending-command))))) - (declare (type (or null pending-command) command)) - (when command - ;; Give this reply to the pending command - (threaded-nconc (shiftf reply-buffer nil) - (pending-command-reply-buffer command) - reply-next reply-buffer) - (process-wakeup (pending-command-process command))))) - nil) - (when reply-buffer - (deallocate-reply-buffer reply-buffer)))) - -(defun read-event-input (display code reply-buffer) - (declare (type display display) - (type card8 code) - (type reply-buffer reply-buffer)) - ;; Push the event in the input buffer on the display's event queue - (setf (event-code reply-buffer) - (get-internal-event-code display code)) - (enqueue-event reply-buffer display) - nil) - -(defun note-input-complete (display token) - (declare (type display display)) - (when (eq (display-input-in-progress display) token) - ;; Indicate that input is no longer in progress - (setf (display-input-in-progress display) nil) - ;; Let the event process get the first chance to do input - (let ((process (display-event-process display))) - (when (not (null process)) - (process-wakeup process))) - ;; Then give processes waiting for command responses a chance - (unless (display-input-in-progress display) - (with-event-queue-internal (display) - (threaded-dolist (command (display-pending-commands display) - pending-command-next pending-command) - (process-wakeup (pending-command-process command))))))) - -(defun read-input (display timeout force-output-p predicate &rest predicate-args) - (declare (type display display) - (type (or null number) timeout) - (type boolean force-output-p) - (dynamic-extent predicate-args)) - (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) - (let ((reply-buffer nil) - (token (or (current-process) (cons nil nil)))) - (declare (type (or null reply-buffer) reply-buffer)) - (unwind-protect - (tagbody - loop - (when (display-dead display) - (x-error 'closed-display :display display)) - (when (apply predicate predicate-args) - (return-from read-input nil)) - ;; Check and see if we have to force output - (when (and force-output-p - (or (and (not (eq (display-input-in-progress display) token)) - (not (conditional-store - (display-input-in-progress display) nil token))) - (null (buffer-listen display)))) - (go force-output)) - ;; Ensure that ony one process is reading input. - (unless (or (eq (display-input-in-progress display) token) - (conditional-store (display-input-in-progress display) nil token)) - (if (eql timeout 0) - (return-from read-input :timeout) - (apply #'process-block "CLX Input Lock" - #'(lambda (display predicate &rest predicate-args) - (declare (type display display) - (dynamic-extent predicate-args) - (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) - (or (apply predicate predicate-args) - (null (display-input-in-progress display)) - (not (null (display-dead display))))) - display predicate predicate-args)) - (go loop)) - ;; Now start gobbling. - (setq reply-buffer (allocate-event)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (let ((type 0)) - (declare (type card8 type)) - ;; Wait for input before we disallow aborts. - (unless (eql timeout 0) - (let ((eof-p (buffer-input-wait display timeout))) - (when eof-p (return-from read-input eof-p)))) - (without-aborts - (let ((eof-p (buffer-input display buffer-bbuf 0 *replysize* - (if force-output-p 0 timeout)))) - (when eof-p - (when (eq eof-p :timeout) - (if force-output-p - (go force-output) - (return-from read-input :timeout))) - (setf (display-dead display) t) - (return-from read-input eof-p))) - (setf (reply-data-size reply-buffer) *replysize*) - (when (= (the card8 (setq type (read-card8 0))) 1) - ;; Normal replies can be longer than *replysize*, so we - ;; have to handle them while aborts are still disallowed. - (let ((value - (read-reply-input - display (read-card16 2) - (index+ *replysize* (index* (read-card32 4) 4)) - (shiftf reply-buffer nil)))) - (when value - (return-from read-input value)) - (go loop)))) - (if (zerop type) - (read-error-input - display (read-card16 2) (shiftf reply-buffer nil) token) - (read-event-input - display (read-card8 0) (shiftf reply-buffer nil))))) - (go loop) - force-output - (note-input-complete display token) - (display-force-output display) - (setq force-output-p nil) - (go loop)) - (when (not (null reply-buffer)) - (deallocate-reply-buffer reply-buffer)) - (note-input-complete display token)))) - -(defun report-asynchronous-errors (display mode) - (when (and (display-asynchronous-errors display) - (member mode (display-report-asynchronous-errors display))) - (let ((aborted t)) - (unwind-protect - (loop - (let ((error - (with-event-queue-internal (display) - (threaded-pop (display-asynchronous-errors display) - reply-next reply-buffer)))) - (declare (type (or null reply-buffer) error)) - (if error - (apply #'report-error display - (prog1 (make-error display error t) - (deallocate-event error))) - (return (setq aborted nil))))) - ;; If we get aborted out of this, deallocate all outstanding asynchronous - ;; errors. - (when aborted - (with-event-queue-internal (display) - (loop - (let ((reply-buffer - (threaded-pop (display-asynchronous-errors display) - reply-next reply-buffer))) - (declare (type (or null reply-buffer) reply-buffer)) - (if reply-buffer - (deallocate-event reply-buffer) - (return nil)))))))))) - -(defun wait-for-event (display timeout force-output-p) - (declare (type display display) - (type (or null number) timeout) - (type boolean force-output-p)) - (let ((event-process-p (not (eql timeout 0)))) - (declare (type boolean event-process-p)) - (unwind-protect - (loop - (when event-process-p - (conditional-store (display-event-process display) nil (current-process))) - (let ((eof (read-input - display timeout force-output-p - #'(lambda (display) - (declare (type display display)) - (or (not (null (display-new-events display))) - (and (display-asynchronous-errors display) - (member :before-event-handling - (display-report-asynchronous-errors display)) - t))) - display))) - (when eof (return eof))) - ;; Report asynchronous errors here if the user wants us to. - (when event-process-p - (report-asynchronous-errors display :before-event-handling)) - (when (not (null (display-new-events display))) - (return nil))) - (when (and event-process-p - (eq (display-event-process display) (current-process))) - (setf (display-event-process display) nil))))) - -(defun read-reply (display pending-command) - (declare (type display display) - (type pending-command pending-command)) - (loop - (when (read-input display nil nil - #'(lambda (pending-command) - (declare (type pending-command pending-command)) - (not (null (pending-command-reply-buffer pending-command)))) - pending-command) - (x-error 'closed-display :display display)) - (let ((reply-buffer - (with-event-queue-internal (display) - (threaded-pop (pending-command-reply-buffer pending-command) - reply-next reply-buffer)))) - (declare (type reply-buffer reply-buffer)) - ;; Check for error. - (with-buffer-input (reply-buffer) - (ecase (read-card8 0) - (0 (apply #'report-error display - (prog1 (make-error display reply-buffer nil) - (deallocate-reply-buffer reply-buffer)))) - (1 (return reply-buffer))))))) - -;;; - -(defun event-listen (display &optional (timeout 0)) - (declare (type display display) - (type (or null number) timeout) - (clx-values number-of-events-queued eof-or-timeout)) - ;; Returns the number of events queued locally, if any, else nil. Hangs - ;; waiting for events, forever if timeout is nil, else for the specified - ;; number of seconds. - (let* ((current-event-symbol (car (display-current-event-symbol display))) - (current-event (and (boundp current-event-symbol) - (symbol-value current-event-symbol))) - (queue (if current-event - (reply-next (the reply-buffer current-event)) - (display-event-queue-head display)))) - (declare (type symbol current-event-symbol) - (type (or null reply-buffer) current-event queue)) - (if queue - (values - (with-event-queue-internal (display :timeout timeout) - (threaded-length queue reply-next reply-buffer)) - nil) - (with-event-queue (display :timeout timeout :inline t) - (let ((eof-or-timeout (wait-for-event display timeout nil))) - (if eof-or-timeout - (values nil eof-or-timeout) - (values - (with-event-queue-internal (display :timeout timeout) - (threaded-length (display-new-events display) - reply-next reply-buffer)) - nil))))))) - -(defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys) - ;; The event is put at the head of the queue if append-p is nil, else the tail. - ;; Additional arguments depend on event-key, and are as specified above with - ;; declare-event, except that both resource-ids and resource objects are accepted - ;; in the event components. - (declare (type display display) - (type event-key event-key) - (type boolean append-p send-event-p) - (dynamic-extent args)) - (unless (get event-key 'event-code) - (x-type-error event-key 'event-key)) - (let* ((event (allocate-event)) - (buffer (reply-ibuf8 event)) - (event-code (get event-key 'event-code))) - (declare (type reply-buffer event) - (type buffer-bytes buffer) - (type (or null card8) event-code)) - (unless event-code (x-type-error event-key 'event-key)) - (setf (event-code event) event-code) - (with-display (display) - (apply (svref *event-send-vector* event-code) display args) - (buffer-replace buffer - (display-obuf8 display) - 0 - *replysize* - (index+ 12 (buffer-boffset display))) - (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code) - (aref buffer 2) 0 - (aref buffer 3) 0)) - (with-event-queue (display) - (if append-p - (enqueue-event event display) - (with-event-queue-internal (display) - (threaded-requeue event - (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer)))))) - -(defun enqueue-event (new-event display) - (declare (type reply-buffer new-event) - (type display display)) - ;; Place EVENT at the end of the event queue for DISPLAY - (let* ((event-code (event-code new-event)) - (event-key (and (index< event-code (length *event-key-vector*)) - (svref *event-key-vector* event-code)))) - (declare (type array-index event-code) - (type (or null keyword) event-key)) - (if (null event-key) - (unwind-protect - (cerror "Ignore this event" "No handler for ~s event" event-key) - (deallocate-event new-event)) - (with-event-queue-internal (display) - (threaded-enqueue new-event - (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer) - (unless (display-new-events display) - (setf (display-new-events display) new-event)))))) - - -(defmacro define-event (name code) - `(eval-when (eval compile load) - (setf (svref *event-key-vector* ,code) ',name) - (setf (get ',name 'event-code) ,code))) - -;; Event names. Used in "type" field in XEvent structures. Not to be -;; confused with event masks above. They start from 2 because 0 and 1 -;; are reserved in the protocol for errors and replies. */ - -(define-event :key-press 2) -(define-event :key-release 3) -(define-event :button-press 4) -(define-event :button-release 5) -(define-event :motion-notify 6) -(define-event :enter-notify 7) -(define-event :leave-notify 8) -(define-event :focus-in 9) -(define-event :focus-out 10) -(define-event :keymap-notify 11) -(define-event :exposure 12) -(define-event :graphics-exposure 13) -(define-event :no-exposure 14) -(define-event :visibility-notify 15) -(define-event :create-notify 16) -(define-event :destroy-notify 17) -(define-event :unmap-notify 18) -(define-event :map-notify 19) -(define-event :map-request 20) -(define-event :reparent-notify 21) -(define-event :configure-notify 22) -(define-event :configure-request 23) -(define-event :gravity-notify 24) -(define-event :resize-request 25) -(define-event :circulate-notify 26) -(define-event :circulate-request 27) -(define-event :property-notify 28) -(define-event :selection-clear 29) -(define-event :selection-request 30) -(define-event :selection-notify 31) -(define-event :colormap-notify 32) -(define-event :client-message 33) -(define-event :mapping-notify 34) - - -(defmacro declare-event (event-codes &body declares &environment env) - ;; Used to indicate the keyword arguments for handler functions in - ;; process-event and event-case. - ;; Generates the functions used in SEND-EVENT. - ;; A compiler warning is printed when all of EVENT-CODES are not - ;; defined by a preceding DEFINE-EXTENSION. - ;; The body is a list of declarations, each of which has the form: - ;; (type . items) Where type is a data-type, and items is a list of - ;; symbol names. The item order corresponds to the order of fields - ;; in the event sent by the server. An item may be a list of items. - ;; In this case, each item is aliased to the same event field. - ;; This is used to give all events an EVENT-WINDOW item. - ;; See the INPUT file for lots of examples. - (declare (type (or keyword list) event-codes) - (type (alist (field-type symbol) (field-names list)) - declares)) - (when (atom event-codes) (setq event-codes (list event-codes))) - (setq event-codes (mapcar #'canonicalize-event-name event-codes)) - (let* ((keywords nil) - (name (first event-codes)) - (get-macro (xintern name '-event-get-macro)) - (get-function (xintern name '-event-get)) - (put-function (xintern name '-event-put))) - (multiple-value-bind (get-code get-index get-sizes) - (get-put-items - 2 declares nil - #'(lambda (type index item args) - (flet ((event-get (type index item args) - (unless (member type '(pad8 pad16)) - `(,(kintern item) - (,(getify type) ,index ,@args))))) - (if (atom item) - (event-get type index item args) - (mapcan #'(lambda (item) - (event-get type index item args)) - item))))) - (declare (ignore get-index)) - (multiple-value-bind (put-code put-index put-sizes) - (get-put-items - 2 declares t - #'(lambda (type index item args) - (unless (member type '(pad8 pad16)) - (if (atom item) - (progn - (push item keywords) - `((,(putify type) ,index ,item ,@args))) - (let ((names (mapcar #'(lambda (name) (kintern name)) - item))) - (setq keywords (append item keywords)) - `((,(putify type) ,index - (check-consistency ',names ,@item) ,@args))))))) - (declare (ignore put-index)) - `(within-definition (,name declare-event) - (defun ,get-macro (display event-key variable) - ;; Note: we take pains to macroexpand the get-code here to enable application - ;; code to be compiled without having the CLX macros file loaded. - `(let ((%buffer ,display)) - (declare (ignorable %buffer)) - ,(getf `(:display (the display ,display) - :event-key (the keyword ,event-key) - :event-code (the card8 (logand #x7f (read-card8 0))) - :send-event-p (the boolean (logbitp 7 (read-card8 0))) - ,@',(mapcar #'(lambda (form) - (clx-macroexpand form env)) - get-code)) - variable))) - - (defun ,get-function (display event handler) - (declare (type display display) - (type reply-buffer event)) - (declare (type function handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg handler)) - (reading-event (event :display display :sizes (8 16 ,@get-sizes)) - (funcall handler - :display display - :event-key (svref *event-key-vector* (event-code event)) - :event-code (logand #x7f (card8-get 0)) - :send-event-p (logbitp 7 (card8-get 0)) - ,@get-code))) - - (defun ,put-function (display &key ,@(setq keywords (nreverse keywords)) - &allow-other-keys) - (declare (type display display)) - ,(when (member 'sequence keywords) - `(unless sequence (setq sequence (display-request-number display)))) - (with-buffer-output (display :sizes ,put-sizes - :index (index+ (buffer-boffset display) 12)) - ,@put-code)) - - ,@(mapcar #'(lambda (name) - (allocate-extension-event-code name) - `(let ((event-code (or (get ',name 'event-code) - (allocate-extension-event-code ',name)))) - (setf (svref *event-macro-vector* event-code) - (function ,get-macro)) - (setf (svref *event-handler-vector* event-code) - (function ,get-function)) - (setf (svref *event-send-vector* event-code) - (function ,put-function)))) - event-codes) - ',name))))) - -(defun check-consistency (names &rest args) - ;; Ensure all args are nil or have the same value. - ;; Returns the consistent non-nil value. - (let ((value (car args))) - (dolist (arg (cdr args)) - (if value - (when (and arg (not (eq arg value))) - (x-error 'inconsistent-parameters - :parameters (mapcan #'list names args))) - (setq value arg))) - value)) - -(declare-event (:key-press :key-release :button-press :button-release) - ;; for key-press and key-release, code is the keycode - ;; for button-press and button-release, code is the button number - (data code) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - (boolean same-screen-p) - ) - -(declare-event :motion-notify - ((data boolean) hint-p) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - (boolean same-screen-p)) - -(declare-event (:enter-notify :leave-notify) - ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind) - (card16 sequence) - ((or null card32) time) - (window root (window event-window)) - ((or null window) child) - (int16 root-x root-y x y) - (card16 state) - ((member8 :normal :grab :ungrab) mode) - ((bit 0) focus-p) - ((bit 1) same-screen-p)) - -(declare-event (:focus-in :focus-out) - ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual - :pointer :pointer-root :none)) - kind) - (card16 sequence) - (window (window event-window)) - ((member8 :normal :while-grabbed :grab :ungrab) mode)) - -(declare-event :keymap-notify - ((bit-vector256 0) keymap)) - -(declare-event :exposure - (card16 sequence) - (window (window event-window)) - (card16 x y width height count)) - -(declare-event :graphics-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card16 x y width height) - (card16 minor) ;; Minor opcode - (card16 count) - (card8 major)) - -(declare-event :no-exposure - (card16 sequence) - (drawable (drawable event-window)) - (card16 minor) - (card8 major)) - -(declare-event :visibility-notify - (card16 sequence) - (window (window event-window)) - ((member8 :unobscured :partially-obscured :fully-obscured) state)) - -(declare-event :create-notify - (card16 sequence) - (window (parent event-window) window) - (int16 x y) - (card16 width height border-width) - (boolean override-redirect-p)) - -(declare-event :destroy-notify - (card16 sequence) - (window event-window window)) - -(declare-event :unmap-notify - (card16 sequence) - (window event-window window) - (boolean configure-p)) - -(declare-event :map-notify - (card16 sequence) - (window event-window window) - (boolean override-redirect-p)) - -(declare-event :map-request - (card16 sequence) - (window (parent event-window) window)) - -(declare-event :reparent-notify - (card16 sequence) - (window event-window window parent) - (int16 x y) - (boolean override-redirect-p)) - -(declare-event :configure-notify - (card16 sequence) - (window event-window window) - ((or null window) above-sibling) - (int16 x y) - (card16 width height border-width) - (boolean override-redirect-p)) - -(declare-event :configure-request - ((data (member :above :below :top-if :bottom-if :opposite)) stack-mode) - (card16 sequence) - (window (parent event-window) window) - ((or null window) above-sibling) - (int16 x y) - (card16 width height border-width value-mask)) - -(declare-event :gravity-notify - (card16 sequence) - (window event-window window) - (int16 x y)) - -(declare-event :resize-request - (card16 sequence) - (window (window event-window)) - (card16 width height)) - -(declare-event :circulate-notify - (card16 sequence) - (window event-window window parent) - ((member16 :top :bottom) place)) - -(declare-event :circulate-request - (card16 sequence) - (window (parent event-window) window) - (pad16 1 2) - ((member16 :top :bottom) place)) - -(declare-event :property-notify - (card16 sequence) - (window (window event-window)) - (keyword atom) ;; keyword - ((or null card32) time) - ((member16 :new-value :deleted) state)) - -(declare-event :selection-clear - (card16 sequence) - ((or null card32) time) - (window (window event-window)) - (keyword selection) ;; keyword - ) - -(declare-event :selection-request - (card16 sequence) - ((or null card32) time) - (window (window event-window) requestor) - (keyword selection target) - ((or null keyword) property) - ) - -(declare-event :selection-notify - (card16 sequence) - ((or null card32) time) - (window (window event-window)) - (keyword selection target) - ((or null keyword) property) - ) - -(declare-event :colormap-notify - (card16 sequence) - (window (window event-window)) - ((or null colormap) colormap) - (boolean new-p installed-p)) - -(declare-event :client-message - (data format) - (card16 sequence) - (window (window event-window)) - (keyword type) - ((client-message-sequence format) data)) - -(declare-event :mapping-notify - (card16 sequence) - ((member8 :modifier :keyboard :pointer) request) - (card8 start) ;; first key-code - (card8 count)) - - -;; -;; EVENT-LOOP -;; - -(defun event-loop-setup (display) - (declare (type display display) - (clx-values progv-vars progv-vals - current-event-symbol current-event-discarded-p-symbol)) - (let* ((progv-vars (display-current-event-symbol display)) - (current-event-symbol (first progv-vars)) - (current-event-discarded-p-symbol (second progv-vars))) - (declare (type list progv-vars) - (type symbol current-event-symbol current-event-discarded-p-symbol)) - (values - progv-vars - (list (if (boundp current-event-symbol) - ;; The current event is already bound, so bind it to the next - ;; event. - (let ((event (symbol-value current-event-symbol))) - (declare (type (or null reply-buffer) event)) - (and event (reply-next (the reply-buffer event)))) - ;; The current event isn't bound, so bind it to the head of the - ;; event queue. - (display-event-queue-head display)) - nil) - current-event-symbol - current-event-discarded-p-symbol))) - -(defun event-loop-step-before (display timeout force-output-p current-event-symbol) - (declare (type display display) - (type (or null number) timeout) - (type boolean force-output-p) - (type symbol current-event-symbol) - (clx-values event eof-or-timeout)) - (unless (symbol-value current-event-symbol) - (let ((eof-or-timeout (wait-for-event display timeout force-output-p))) - (when eof-or-timeout - (return-from event-loop-step-before (values nil eof-or-timeout)))) - (setf (symbol-value current-event-symbol) (display-new-events display))) - (let ((event (symbol-value current-event-symbol))) - (declare (type reply-buffer event)) - (with-event-queue-internal (display) - (when (eq event (display-new-events display)) - (setf (display-new-events display) (reply-next event)))) - (values event nil))) - -(defun dequeue-event (display event) - (declare (type display display) - (type reply-buffer event) - (clx-values next)) - ;; Remove the current event from the event queue - (with-event-queue-internal (display) - (let ((next (reply-next event)) - (head (display-event-queue-head display))) - (declare (type (or null reply-buffer) next head)) - (when (eq event (display-new-events display)) - (setf (display-new-events display) next)) - (cond ((eq event head) - (threaded-dequeue (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer)) - ((null head) - (setq next nil)) - (t - (do* ((previous head current) - (current (reply-next previous) (reply-next previous))) - ((or (null current) (eq event current)) - (when (eq event current) - (when (eq current (display-event-queue-tail display)) - (setf (display-event-queue-tail display) previous)) - (setf (reply-next previous) next))) - (declare (type reply-buffer previous) - (type (or null reply-buffer) current))))) - next))) - -(defun event-loop-step-after - (display event discard-p current-event-symbol current-event-discarded-p-symbol - &optional aborted) - (declare (type display display) - (type reply-buffer event) - (type boolean discard-p aborted) - (type symbol current-event-symbol current-event-discarded-p-symbol)) - (when (and discard-p - (not aborted) - (not (symbol-value current-event-discarded-p-symbol))) - (discard-current-event display)) - (let ((next (reply-next event))) - (declare (type (or null reply-buffer) next)) - (when (symbol-value current-event-discarded-p-symbol) - (setf (symbol-value current-event-discarded-p-symbol) nil) - (setq next (dequeue-event display event)) - (deallocate-event event)) - (setf (symbol-value current-event-symbol) next))) - -(defmacro event-loop ((display event timeout force-output-p discard-p) &body body) - ;; Bind EVENT to the events for DISPLAY. - ;; This is the "GUTS" of process-event and event-case. - `(let ((.display. ,display) - (.timeout. ,timeout) - (.force-output-p. ,force-output-p) - (.discard-p. ,discard-p)) - (declare (type display .display.) - (type (or null number) .timeout.) - (type boolean .force-output-p. .discard-p.)) - (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.))) - (multiple-value-bind (.progv-vars. .progv-vals. - .current-event-symbol. .current-event-discarded-p-symbol.) - (event-loop-setup .display.) - (declare (type list .progv-vars. .progv-vals.) - (type symbol .current-event-symbol. .current-event-discarded-p-symbol.)) - (progv .progv-vars. .progv-vals. - (loop - (multiple-value-bind (.event. .eof-or-timeout.) - (event-loop-step-before - .display. .timeout. .force-output-p. - .current-event-symbol.) - (declare (type (or null reply-buffer) .event.)) - (when (null .event.) (return (values nil .eof-or-timeout.))) - (let ((.aborted. t)) - (unwind-protect - (progn - (let ((,event .event.)) - (declare (type reply-buffer ,event)) - ,@body) - (setq .aborted. nil)) - (event-loop-step-after - .display. .event. .discard-p. - .current-event-symbol. .current-event-discarded-p-symbol. - .aborted.)))))))))) - -(defun discard-current-event (display) - ;; Discard the current event for DISPLAY. - ;; Returns NIL when the event queue is empty, else T. - ;; To ensure events aren't ignored, application code should only call - ;; this when throwing out of event-case or process-next-event, or from - ;; inside even-case, event-cond or process-event when :peek-p is T and - ;; :discard-p is NIL. - (declare (type display display) - (clx-values boolean)) - (let* ((symbols (display-current-event-symbol display)) - (event - (let ((current-event-symbol (first symbols))) - (declare (type symbol current-event-symbol)) - (when (boundp current-event-symbol) - (symbol-value current-event-symbol))))) - (declare (type list symbols) - (type (or null reply-buffer) event)) - (unless (null event) - ;; Set the discarded-p flag - (let ((current-event-discarded-p-symbol (second symbols))) - (declare (type symbol current-event-discarded-p-symbol)) - (when (boundp current-event-discarded-p-symbol) - (setf (symbol-value current-event-discarded-p-symbol) t))) - ;; Return whether the event queue is empty - (not (null (reply-next (the reply-buffer event))))))) - -;; -;; PROCESS-EVENT -;; -(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t)) - ;; If force-output-p is true, first invokes display-force-output. Invokes handler - ;; on each queued event until handler returns non-nil, and that returned object is - ;; then returned by process-event. If peek-p is true, then the event is not - ;; removed from the queue. If discard-p is true, then events for which handler - ;; returns nil are removed from the queue, otherwise they are left in place. Hangs - ;; until non-nil is generated for some event, or for the specified timeout (in - ;; seconds, if given); however, it is acceptable for an implementation to wait only - ;; once on network data, and therefore timeout prematurely. Returns nil on - ;; timeout. If handler is a sequence, it is expected to contain handler functions - ;; specific to each event class; the event code is used to index the sequence, - ;; fetching the appropriate handler. Handler is called with raw resource-ids, not - ;; with resource objects. The arguments to the handler are described using declare-event. - ;; - ;; T for peek-p means the event (for which the handler returns non-nil) is not removed - ;; from the queue (it is left in place), NIL means the event is removed. - - (declare (type display display) - (type (or null number) timeout) - (type boolean peek-p discard-p force-output-p)) - (declare (type t handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera handler)) - (event-loop (display event timeout force-output-p discard-p) - (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT - (event-decoder (and (index< event-code (length *event-handler-vector*)) - (svref *event-handler-vector* event-code)))) - (declare (type array-index event-code) - (type (or null function) event-decoder)) - (if event-decoder - (let ((event-handler (if (functionp handler) - handler - (and (type? handler 'sequence) - (< event-code (length handler)) - (elt handler event-code))))) - (if event-handler - (let ((result (funcall event-decoder display event event-handler))) - (when result - (unless peek-p - (discard-current-event display)) - (return result))) - (cerror "Ignore this event" - "No handler for ~s event" - (svref *event-key-vector* event-code)))) - (cerror "Ignore this event" - "Server Error: event with unknown event code ~d received." - event-code))))) - -(defun make-event-handlers (&key (type 'array) default) - (declare (type t type) ;Sequence type specifier - (type function default) - (clx-values sequence)) ;Default handler for initial content - ;; Makes a handler sequence suitable for process-event - (make-sequence type *max-events* :initial-element default)) - -(defun event-handler (handlers event-key) - (declare (type sequence handlers) - (type event-key event-key) - (clx-values function)) - ;; Accessor for a handler sequence - (elt handlers (position event-key *event-key-vector* :test #'eq))) - -(defun set-event-handler (handlers event-key handler) - (declare (type sequence handlers) - (type event-key event-key) - (type function handler) - (clx-values handler)) - (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler)) - -(defsetf event-handler set-event-handler) - -;; -;; EVENT-CASE -;; - -(defmacro event-case ((&rest args) &body clauses) - ;; If force-output-p is true, first invokes display-force-output. Executes the - ;; matching clause for each queued event until a clause returns non-nil, and that - ;; returned object is then returned by event-case. If peek-p is true, then the - ;; event is not removed from the queue. If discard-p is true, then events for - ;; which the clause returns nil are removed from the queue, otherwise they are left - ;; in place. Hangs until non-nil is generated for some event, or for the specified - ;; timeout (in seconds, if given); however, it is acceptable for an implementation - ;; to wait only once on network data, and therefore timeout prematurely. Returns - ;; nil on timeout. In each clause, event-or-events is an event-key or a list of - ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise - ;; (but only in the last clause). The keys are not evaluated, and it is an error - ;; for the same key to appear in more than one clause. Args is the list of event - ;; components of interest; corresponding values (if any) are bound to variables - ;; with these names (i.e., the args are variable names, not keywords, the keywords - ;; are derived from the variable names). An arg can also be a (keyword var) form, - ;; as for keyword args in a lambda lists. If no t/otherwise clause appears, it is - ;; equivalent to having one that returns nil. - (declare (arglist (display &key timeout peek-p discard-p (force-output-p t)) - (event-or-events ((&rest args) |...|) &body body) |...|)) - ;; Event-case is just event-cond with the whole body in the test-form - `(event-cond ,args - ,@(mapcar - #'(lambda (clause) - `(,(car clause) ,(cadr clause) (progn ,@(cddr clause)))) - clauses))) - -;; -;; EVENT-COND -;; - -(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) - &body clauses) - ;; The clauses of event-cond are of the form: - ;; (event-or-events binding-list test-form . body-forms) - ;; - ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they - ;; need not be typed as keywords) or the symbol t - ;; or otherwise (but only in the last clause). If - ;; no t/otherwise clause appears, it is equivalent - ;; to having one that returns nil. The keys are - ;; not evaluated, and it is an error for the same - ;; key to appear in more than one clause. - ;; - ;; BINDING-LIST The list of event components of interest. - ;; corresponding values (if any) are bound to - ;; variables with these names (i.e., the binding-list - ;; has variable names, not keywords, the keywords are - ;; derived from the variable names). An arg can also - ;; be a (keyword var) form, as for keyword args in a - ;; lambda list. - ;; - ;; The matching TEST-FORM for each queued event is executed until a - ;; clause's test-form returns non-nil. Then the BODY-FORMS are - ;; evaluated, returning the (possibly multiple) values of the last - ;; form from event-cond. If there are no body-forms then, if the - ;; test-form is non-nil, the value of the test-form is returned as a - ;; single value. - ;; - ;; Options: - ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no - ;; input is pending. - ;; - ;; PEEK-P When true, then the event is not removed from the queue. - ;; - ;; DISCARD-P When true, then events for which the clause returns nil - ;; are removed from the queue, otherwise they are left in place. - ;; - ;; TIMEOUT If NIL, hang until non-nil is generated for some event's - ;; test-form. Otherwise return NIL after TIMEOUT seconds have - ;; elapsed. - ;; - (declare (arglist (display &key timeout peek-p discard-p force-output-p) - (event-or-events (&rest args) test-form &body body) |...|)) - (let ((event (gensym)) - (disp (gensym)) - (peek (gensym))) - `(let ((,disp ,display) - (,peek ,peek-p)) - (declare (type display ,disp)) - (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p) - (event-dispatch (,disp ,event ,peek) ,@clauses))))) - -(defun get-event-code (event) - ;; Returns the event code given an event-key - (declare (type event-key event)) - (declare (clx-values card8)) - (or (get event 'event-code) - (x-type-error event 'event-key))) - -(defun universal-event-get-macro (display event-key variable) - (getf - `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code - (the card8 (logand 127 (read-card8 0))) :send-event-p - (the boolean (logbitp 7 (read-card8 0)))) - variable)) - -(defmacro event-dispatch ((display event peek-p) &body clauses) - ;; Helper macro for event-case - ;; CLAUSES are of the form: - ;; (event-or-events binding-list test-form . body-forms) - (let ((event-key (gensym)) - (all-events (make-array *max-events* :element-type 'bit :initial-element 0))) - `(reading-event (,event) - (let ((,event-key (svref *event-key-vector* (event-code ,event)))) - (case ,event-key - ,@(mapcar - #'(lambda (clause) ; Translate event-cond clause to case clause - (let* ((events (first clause)) - (arglist (second clause)) - (test-form (third clause)) - (body-forms (cdddr clause))) - (flet ((event-clause (display peek-p first-form rest-of-forms) - (if rest-of-forms - `(when ,first-form - (unless ,peek-p (discard-current-event ,display)) - (return (progn ,@rest-of-forms))) - ;; No body forms, return the result of the test form - (let ((result (gensym))) - `(let ((,result ,first-form)) - (when ,result - (unless ,peek-p (discard-current-event ,display)) - (return ,result))))))) - - (if (member events '(otherwise t)) - ;; code for OTHERWISE clause. - ;; Find all events NOT used by other clauses - (let ((keys (do ((i 0 (1+ i)) - (key nil) - (result nil)) - ((>= i *max-events*) result) - (setq key (svref *event-key-vector* i)) - (when (and key (zerop (aref all-events i))) - (push key result))))) - `(otherwise - (binding-event-values - (,display ,event-key ,(or keys :universal) ,@arglist) - ,(event-clause display peek-p test-form body-forms)))) - - ;; Code for normal clauses - (let (true-events) ;; canonicalize event-names - (if (consp events) - (progn - (setq true-events (mapcar #'canonicalize-event-name events)) - (dolist (event true-events) - (setf (aref all-events (get-event-code event)) 1))) - (setf true-events (canonicalize-event-name events) - (aref all-events (get-event-code true-events)) 1)) - `(,true-events - (binding-event-values - (,display ,event-key ,true-events ,@arglist) - ,(event-clause display peek-p test-form body-forms)))))))) - clauses)))))) - -(defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body) - ;; Execute BODY with the variables in VALUE-LIST bound to components of the - ;; EVENT-KEYS events. - (unless (consp event-keys) (setq event-keys (list event-keys))) - (flet ((var-key (var) (kintern (if (consp var) (first var) var))) - (var-symbol (var) (if (consp var) (second var) var))) - ;; VARS is an alist of: - ;; (component-key ((event-key event-key ...) . extraction-code) - ;; ((event-key event-key ...) . extraction-code) ...) - ;; There should probably be accessor macros for this, instead of things like cdadr. - (let ((vars (mapcar #'list value-list)) - (multiple-p nil)) - ;; Fill in the VARS alist with event-keys and extraction-code - (do ((keys event-keys (cdr keys)) - (temp nil)) - ((endp keys)) - (let* ((key (car keys)) - (binder (case key - (:universal #'universal-event-get-macro) - (otherwise (svref *event-macro-vector* (get-event-code key)))))) - (dolist (var vars) - (let ((code (funcall binder display event-key (var-key (car var))))) - (unless code (warn "~a isn't a component of the ~s event" - (var-key (car var)) key)) - (if (setq temp (member code (cdr var) :key #'cdr :test #'equal)) - (push key (caar temp)) - (push `((,key) . ,code) (cdr var))))))) - ;; Bind all the values - `(let ,(mapcar #'(lambda (var) - (if (cddr var) ;; if more than one binding form - (progn (setq multiple-p t) - (var-symbol (car var))) - (list (var-symbol (car var)) (cdadr var)))) - vars) - ;; When some values come from different places, generate code to set them - ,(when multiple-p - `(case ,event-key - ,@(do ((keys event-keys (cdr keys)) - (clauses nil) ;; alist of (event-keys bindings) - (clause nil nil) - (temp)) - ((endp keys) - (dolist (clause clauses) - (unless (cdar clause) ;; Atomize single element lists - (setf (car clause) (caar clause)))) - clauses) - ;; Gather up all the bindings associated with (car keys) - (dolist (var vars) - (when (cddr var) ;; when more than one binding form - (dolist (events (cdr var)) - (when (member (car keys) (car events)) - ;; Optimize for event-window being the same as some other binding - (if (setq temp (member (cdr events) clause - :key #'caddr - :test #'equal)) - (setq clause - (nconc clause `((setq ,(car var) ,(second (car temp)))))) - (push `(setq ,(car var) ,(cdr events)) clause)))))) - ;; Merge bindings for (car keys) with other bindings - (when clause - (if (setq temp (member clause clauses :key #'cdr :test #'equal)) - (push (car keys) (caar temp)) - (push `((,(car keys)) . ,clause) clauses)))))) - ,@body)))) - - -;;;----------------------------------------------------------------------------- -;;; Error Handling -;;;----------------------------------------------------------------------------- - -(eval-when (eval compile load) -(defparameter - *xerror-vector* - '#(unknown-error - request-error ; 1 bad request code - value-error ; 2 integer parameter out of range - window-error ; 3 parameter not a Window - pixmap-error ; 4 parameter not a Pixmap - atom-error ; 5 parameter not an Atom - cursor-error ; 6 parameter not a Cursor - font-error ; 7 parameter not a Font - match-error ; 8 parameter mismatch - drawable-error ; 9 parameter not a Pixmap or Window - access-error ; 10 attempt to access private resource" - alloc-error ; 11 insufficient resources - colormap-error ; 12 no such colormap - gcontext-error ; 13 parameter not a GContext - id-choice-error ; 14 invalid resource ID for this connection - name-error ; 15 font or color name does not exist - length-error ; 16 request length incorrect; - ; internal Xlib error - implementation-error ; 17 server is defective - )) -) - -(defun make-error (display event asynchronous) - (declare (type display display) - (type reply-buffer event) - (type boolean asynchronous)) - (reading-event (event) - (let* ((error-code (read-card8 1)) - (error-key (get-error-key display error-code)) - (error-decode-function (get error-key 'error-decode-function)) - (params (funcall error-decode-function display event))) - (list* error-code error-key - :asynchronous asynchronous :current-sequence (display-request-number display) - params)))) - -(defun report-error (display error-code error-key &rest params) - (declare (type display display) - (dynamic-extent params)) - ;; All errors (synchronous and asynchronous) are processed by calling - ;; an error handler in the display. The handler is called with the display - ;; as the first argument and the error-key as its second argument. If handler is - ;; an array it is expected to contain handler functions specific to - ;; each error; the error code is used to index the array, fetching the - ;; appropriate handler. Any results returned by the handler are ignored;; - ;; it is assumed the handler either takes care of the error completely, - ;; or else signals. For all core errors, additional keyword/value argument - ;; pairs are: - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; :current-sequence integer - ;; :asynchronous (member t nil) - ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window - ;; errors another pair is: - ;; :resource-id integer - ;; For :atom errors, another pair is: - ;; :atom-id integer - ;; For :value errors, another pair is: - ;; :value integer - (let* ((handler (display-error-handler display)) - (handler-function - (if (type? handler 'sequence) - (elt handler error-code) - handler))) - (apply handler-function display error-key params))) - -(defun request-name (code &optional display) - (if (< code (length *request-names*)) - (svref *request-names* code) - (dolist (extension (and display (display-extension-alist display)) "unknown") - (when (= code (second extension)) - (return (first extension)))))) - -#-(or clx-ansi-common-lisp excl lcl3.0 CMU) -(define-condition request-error (x-error) - ((display :reader request-error-display) - (error-key :reader request-error-error-key) - (major :reader request-error-major) - (minor :reader request-error-minor) - (sequence :reader request-error-sequence) - (current-sequence :reader request-error-current-sequence) - (asynchronous :reader request-error-asynchronous)) - (:report report-request-error)) - -(defun report-request-error (condition stream) - (let ((error-key (request-error-error-key condition)) - (asynchronous (request-error-asynchronous condition)) - (major (request-error-major condition)) - (minor (request-error-minor condition)) - (sequence (request-error-sequence condition)) - (current-sequence (request-error-current-sequence condition))) - (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]" - asynchronous error-key (= sequence current-sequence) - sequence current-sequence major minor - (request-name major (request-error-display condition))))) - -;; Since the :report arg is evaluated as (function report-request-error) the -;; define-condition must come after the function definition. -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) -(define-condition request-error (x-error) - ((display :reader request-error-display :initarg :display) - (error-key :reader request-error-error-key :initarg :error-key) - (major :reader request-error-major :initarg :major) - (minor :reader request-error-minor :initarg :minor) - (sequence :reader request-error-sequence :initarg :sequence) - (current-sequence :reader request-error-current-sequence :initarg :current-sequence) - (asynchronous :reader request-error-asynchronous :initarg :asynchronous)) - (:report report-request-error)) - -(define-condition resource-error (request-error) - ((resource-id :reader resource-error-resource-id :initarg :resource-id)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " ID #x~x" (resource-error-resource-id condition))))) - -(define-condition unknown-error (request-error) - ((error-code :reader unknown-error-error-code :initarg :error-code)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Error Code ~d." (unknown-error-error-code condition))))) - -(define-condition access-error (request-error) ()) - -(define-condition alloc-error (request-error) ()) - -(define-condition atom-error (request-error) - ((atom-id :reader atom-error-atom-id :initarg :atom-id)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Atom-ID #x~x" (atom-error-atom-id condition))))) - -(define-condition colormap-error (resource-error) ()) - -(define-condition cursor-error (resource-error) ()) - -(define-condition drawable-error (resource-error) ()) - -(define-condition font-error (resource-error) ()) - -(define-condition gcontext-error (resource-error) ()) - -(define-condition id-choice-error (resource-error) ()) - -(define-condition illegal-request-error (request-error) ()) - -(define-condition length-error (request-error) ()) - -(define-condition match-error (request-error) ()) - -(define-condition name-error (request-error) ()) - -(define-condition pixmap-error (resource-error) ()) - -(define-condition value-error (request-error) - ((value :reader value-error-value :initarg :value)) - (:report - (lambda (condition stream) - (report-request-error condition stream) - (format stream " Value ~d." (value-error-value condition))))) - -(define-condition window-error (resource-error)()) - -(define-condition implementation-error (request-error) ()) - -;;----------------------------------------------------------------------------- -;; Internal error conditions signaled by CLX - -(define-condition x-type-error (type-error x-error) - ((type-string :reader x-type-error-type-string :initarg :type-string)) - (:report - (lambda (condition stream) - (format stream "~s isn't a ~a" - (type-error-datum condition) - (or (x-type-error-type-string condition) - (type-error-expected-type condition)))))) - -(define-condition closed-display (x-error) - ((display :reader closed-display-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Attempt to use closed display ~s" - (closed-display-display condition))))) - -(define-condition lookup-error (x-error) - ((id :reader lookup-error-id :initarg :id) - (display :reader lookup-error-display :initarg :display) - (type :reader lookup-error-type :initarg :type) - (object :reader lookup-error-object :initarg :object)) - (:report - (lambda (condition stream) - (format stream "ID ~d from display ~s should have been a ~s, but was ~s" - (lookup-error-id condition) - (lookup-error-display condition) - (lookup-error-type condition) - (lookup-error-object condition))))) - -(define-condition connection-failure (x-error) - ((major-version :reader connection-failure-major-version :initarg :major-version) - (minor-version :reader connection-failure-minor-version :initarg :minor-version) - (host :reader connection-failure-host :initarg :host) - (display :reader connection-failure-display :initarg :display) - (reason :reader connection-failure-reason :initarg :reason)) - (:report - (lambda (condition stream) - (format stream "Connection failure to X~d.~d server ~a display ~d: ~a" - (connection-failure-major-version condition) - (connection-failure-minor-version condition) - (connection-failure-host condition) - (connection-failure-display condition) - (connection-failure-reason condition))))) - -(define-condition reply-length-error (x-error) - ((reply-length :reader reply-length-error-reply-length :initarg :reply-length) - (expected-length :reader reply-length-error-expected-length :initarg :expected-length) - (display :reader reply-length-error-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Reply length was ~d when ~d words were expected for display ~s" - (reply-length-error-reply-length condition) - (reply-length-error-expected-length condition) - (reply-length-error-display condition))))) - -(define-condition reply-timeout (x-error) - ((timeout :reader reply-timeout-timeout :initarg :timeout) - (display :reader reply-timeout-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Timeout after waiting ~d seconds for a reply for display ~s" - (reply-timeout-timeout condition) - (reply-timeout-display condition))))) - -(define-condition sequence-error (x-error) - ((display :reader sequence-error-display :initarg :display) - (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence) - (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence)) - (:report - (lambda (condition stream) - (format stream "Reply out of sequence for display ~s.~% Expected ~d, Got ~d" - (sequence-error-display condition) - (sequence-error-req-sequence condition) - (sequence-error-msg-sequence condition))))) - -(define-condition unexpected-reply (x-error) - ((display :reader unexpected-reply-display :initarg :display) - (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence) - (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence) - (length :reader unexpected-reply-length :initarg :length)) - (:report - (lambda (condition stream) - (format stream "Display ~s received a server reply when none was expected.~@ - Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes." - (unexpected-reply-display condition) - (unexpected-reply-req-sequence condition) - (unexpected-reply-msg-sequence condition) - (unexpected-reply-length condition))))) - -(define-condition missing-parameter (x-error) - ((parameter :reader missing-parameter-parameter :initarg :parameter)) - (:report - (lambda (condition stream) - (let ((parm (missing-parameter-parameter condition))) - (if (consp parm) - (format stream "One or more of the required parameters ~a is missing." - parm) - (format stream "Required parameter ~a is missing or null." parm)))))) - -;; This can be signalled anywhere a pseudo font access fails. -(define-condition invalid-font (x-error) - ((font :reader invalid-font-font :initarg :font)) - (:report - (lambda (condition stream) - (format stream "Can't access font ~s" (invalid-font-font condition))))) - -(define-condition device-busy (x-error) - ((display :reader device-busy-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Device busy for display ~s" - (device-busy-display condition))))) - -(define-condition unimplemented-event (x-error) - ((display :reader unimplemented-event-display :initarg :display) - (event-code :reader unimplemented-event-event-code :initarg :event-code)) - (:report - (lambda (condition stream) - (format stream "Event code ~d not implemented for display ~s" - (unimplemented-event-event-code condition) - (unimplemented-event-display condition))))) - -(define-condition undefined-event (x-error) - ((display :reader undefined-event-display :initarg :display) - (event-name :reader undefined-event-event-name :initarg :event-name)) - (:report - (lambda (condition stream) - (format stream "Event code ~d undefined for display ~s" - (undefined-event-event-name condition) - (undefined-event-display condition))))) - -(define-condition absent-extension (x-error) - ((name :reader absent-extension-name :initarg :name) - (display :reader absent-extension-display :initarg :display)) - (:report - (lambda (condition stream) - (format stream "Extension ~a isn't defined for display ~s" - (absent-extension-name condition) - (absent-extension-display condition))))) - -(define-condition inconsistent-parameters (x-error) - ((parameters :reader inconsistent-parameters-parameters :initarg :parameters)) - (:report - (lambda (condition stream) - (format stream "inconsistent-parameters:~{ ~s~}" - (inconsistent-parameters-parameters condition))))) - -(defun get-error-key (display error-code) - (declare (type display display) - (type array-index error-code)) - ;; Return the error-key associated with error-code - (if (< error-code (length *xerror-vector*)) - (svref *xerror-vector* error-code) - ;; Search the extensions for the error - (dolist (entry (display-extension-alist display) 'unknown-error) - (let* ((event-name (first entry)) - (first-error (fourth entry)) - (errors (third (assoc event-name *extensions*)))) - (declare (type keyword event-name) - (type array-index first-error) - (type list errors)) - (when (and errors - (index<= first-error error-code - (index+ first-error (index- (length errors) 1)))) - (return (nth (index- error-code first-error) errors))))))) - -(defmacro define-error (error-key function) - ;; Associate a function with ERROR-KEY which will be called with - ;; parameters DISPLAY and REPLY-BUFFER and - ;; returns a plist of keyword/value pairs which will be passed on - ;; to the error handler. A compiler warning is printed when - ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION. - ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type - ;; macros for getting error fields. See DECODE-CORE-ERROR for - ;; an example. - (declare (type symbol error-key) - (type function function)) - ;; First ensure the name is for a declared extension - (unless (or (find error-key *xerror-vector*) - (dolist (extension *extensions*) - (when (member error-key (third extension)) - (return t)))) - (x-type-error error-key 'error-key)) - `(setf (get ',error-key 'error-decode-function) (function ,function))) - -;; All core errors use this, so we make it available to extensions. -(defun decode-core-error (display event &optional arg) - ;; All core errors have the following keyword/argument pairs: - ;; :major integer - ;; :minor integer - ;; :sequence integer - ;; In addition, many have an additional argument that comes from the - ;; same place in the event, but is named differently. When the ARG - ;; argument is specified, the keyword ARG with card32 value starting - ;; at byte 4 of the event is returned with the other keyword/argument - ;; pairs. - (declare (type display display) - (type reply-buffer event) - (type (or null keyword) arg)) - (declare (clx-values keyword/arg-plist)) - display - (reading-event (event) - (let* ((sequence (read-card16 2)) - (minor-code (read-card16 8)) - (major-code (read-card8 10)) - (result (list :major major-code - :minor minor-code - :sequence sequence))) - (when arg - (setq result (list* arg (read-card32 4) result))) - result))) - -(defun decode-resource-error (display event) - (decode-core-error display event :resource-id)) - -(define-error unknown-error - (lambda (display event) - (list* :error-code (aref (reply-ibuf8 event) 1) - (decode-core-error display event)))) - -(define-error request-error decode-core-error) ; 1 bad request code - -(define-error value-error ; 2 integer parameter out of range - (lambda (display event) - (decode-core-error display event :value))) - -(define-error window-error decode-resource-error) ; 3 parameter not a Window - -(define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap - -(define-error atom-error ; 5 parameter not an Atom - (lambda (display event) - (decode-core-error display event :atom-id))) - -(define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor - -(define-error font-error decode-resource-error) ; 7 parameter not a Font - -(define-error match-error decode-core-error) ; 8 parameter mismatch - -(define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window - -(define-error access-error decode-core-error) ; 10 attempt to access private resource" - -(define-error alloc-error decode-core-error) ; 11 insufficient resources - -(define-error colormap-error decode-resource-error) ; 12 no such colormap - -(define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext - -(define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection - -(define-error name-error decode-core-error) ; 15 font or color name does not exist - -(define-error length-error decode-core-error) ; 16 request length incorrect; - ; internal Xlib error - -(define-error implementation-error decode-core-error) ; 17 server is defective diff --git a/clx/keysyms.lisp b/clx/keysyms.lisp deleted file mode 100644 index 96d160b83c02959d110d5c747a114646226801ce..0000000000000000000000000000000000000000 --- a/clx/keysyms.lisp +++ /dev/null @@ -1,408 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- - -;;; Define lisp character to keysym mappings - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255)) -(define-keysym-set :latin-2 (keysym 1 0) (keysym 1 255)) -(define-keysym-set :latin-3 (keysym 2 0) (keysym 2 255)) -(define-keysym-set :latin-4 (keysym 3 0) (keysym 3 255)) -(define-keysym-set :kana (keysym 4 0) (keysym 4 255)) -(define-keysym-set :arabic (keysym 5 0) (keysym 5 255)) -(define-keysym-set :cryllic (keysym 6 0) (keysym 6 255)) -(define-keysym-set :greek (keysym 7 0) (keysym 7 255)) -(define-keysym-set :tech (keysym 8 0) (keysym 8 255)) -(define-keysym-set :special (keysym 9 0) (keysym 9 255)) -(define-keysym-set :publish (keysym 10 0) (keysym 10 255)) -(define-keysym-set :apl (keysym 11 0) (keysym 11 255)) -(define-keysym-set :hebrew (keysym 12 0) (keysym 12 255)) -(define-keysym-set :keyboard (keysym 255 0) (keysym 255 255)) - -(define-keysym :character-set-switch character-set-switch-keysym) -(define-keysym :left-shift left-shift-keysym) -(define-keysym :right-shift right-shift-keysym) -(define-keysym :left-control left-control-keysym) -(define-keysym :right-control right-control-keysym) -(define-keysym :caps-lock caps-lock-keysym) -(define-keysym :shift-lock shift-lock-keysym) -(define-keysym :left-meta left-meta-keysym) -(define-keysym :right-meta right-meta-keysym) -(define-keysym :left-alt left-alt-keysym) -(define-keysym :right-alt right-alt-keysym) -(define-keysym :left-super left-super-keysym) -(define-keysym :right-super right-super-keysym) -(define-keysym :left-hyper left-hyper-keysym) -(define-keysym :right-hyper right-hyper-keysym) - -(define-keysym #\space 032) -(define-keysym #\! 033) -(define-keysym #\" 034) -(define-keysym #\# 035) -(define-keysym #\$ 036) -(define-keysym #\% 037) -(define-keysym #\& 038) -(define-keysym #\' 039) -(define-keysym #\( 040) -(define-keysym #\) 041) -(define-keysym #\* 042) -(define-keysym #\+ 043) -(define-keysym #\, 044) -(define-keysym #\- 045) -(define-keysym #\. 046) -(define-keysym #\/ 047) -(define-keysym #\0 048) -(define-keysym #\1 049) -(define-keysym #\2 050) -(define-keysym #\3 051) -(define-keysym #\4 052) -(define-keysym #\5 053) -(define-keysym #\6 054) -(define-keysym #\7 055) -(define-keysym #\8 056) -(define-keysym #\9 057) -(define-keysym #\: 058) -(define-keysym #\; 059) -(define-keysym #\< 060) -(define-keysym #\= 061) -(define-keysym #\> 062) -(define-keysym #\? 063) -(define-keysym #\@ 064) -(define-keysym #\A 065 :lowercase 097) -(define-keysym #\B 066 :lowercase 098) -(define-keysym #\C 067 :lowercase 099) -(define-keysym #\D 068 :lowercase 100) -(define-keysym #\E 069 :lowercase 101) -(define-keysym #\F 070 :lowercase 102) -(define-keysym #\G 071 :lowercase 103) -(define-keysym #\H 072 :lowercase 104) -(define-keysym #\I 073 :lowercase 105) -(define-keysym #\J 074 :lowercase 106) -(define-keysym #\K 075 :lowercase 107) -(define-keysym #\L 076 :lowercase 108) -(define-keysym #\M 077 :lowercase 109) -(define-keysym #\N 078 :lowercase 110) -(define-keysym #\O 079 :lowercase 111) -(define-keysym #\P 080 :lowercase 112) -(define-keysym #\Q 081 :lowercase 113) -(define-keysym #\R 082 :lowercase 114) -(define-keysym #\S 083 :lowercase 115) -(define-keysym #\T 084 :lowercase 116) -(define-keysym #\U 085 :lowercase 117) -(define-keysym #\V 086 :lowercase 118) -(define-keysym #\W 087 :lowercase 119) -(define-keysym #\X 088 :lowercase 120) -(define-keysym #\Y 089 :lowercase 121) -(define-keysym #\Z 090 :lowercase 122) -(define-keysym #\[ 091) -(define-keysym #\\ 092) -(define-keysym #\] 093) -(define-keysym #\^ 094) -(define-keysym #\_ 095) -(define-keysym #\` 096) -(define-keysym #\a 097) -(define-keysym #\b 098) -(define-keysym #\c 099) -(define-keysym #\d 100) -(define-keysym #\e 101) -(define-keysym #\f 102) -(define-keysym #\g 103) -(define-keysym #\h 104) -(define-keysym #\i 105) -(define-keysym #\j 106) -(define-keysym #\k 107) -(define-keysym #\l 108) -(define-keysym #\m 109) -(define-keysym #\n 110) -(define-keysym #\o 111) -(define-keysym #\p 112) -(define-keysym #\q 113) -(define-keysym #\r 114) -(define-keysym #\s 115) -(define-keysym #\t 116) -(define-keysym #\u 117) -(define-keysym #\v 118) -(define-keysym #\w 119) -(define-keysym #\x 120) -(define-keysym #\y 121) -(define-keysym #\z 122) -(define-keysym #\{ 123) -(define-keysym #\| 124) -(define-keysym #\} 125) -(define-keysym #\~ 126) - -(progn ;; Semi-standard characters - (define-keysym #\rubout (keysym 255 255)) ; :tty - (define-keysym #\tab (keysym 255 009)) ; :tty - (define-keysym #\linefeed (keysym 255 010)) ; :tty - (define-keysym #\page (keysym 009 227)) ; :special - (define-keysym #\return (keysym 255 013)) ; :tty - (define-keysym #\backspace (keysym 255 008)) ; :tty - ) - -#+(or lispm excl) -(progn ;; Nonstandard characters - (define-keysym #\escape (keysym 255 027)) ; :tty - ) - -#+ti -(progn - (define-keysym #\Inverted-exclamation-mark 161) - (define-keysym #\american-cent-sign 162) - (define-keysym #\british-pound-sign 163) - (define-keysym #\Currency-sign 164) - (define-keysym #\Japanese-yen-sign 165) - (define-keysym #\Yen 165) - (define-keysym #\Broken-bar 166) - (define-keysym #\Section-symbol 167) - (define-keysym #\Section 167) - (define-keysym #\Diaresis 168) - (define-keysym #\Umlaut 168) - (define-keysym #\Copyright-sign 169) - (define-keysym #\Copyright 169) - (define-keysym #\Feminine-ordinal-indicator 170) - (define-keysym #\Angle-quotation-left 171) - (define-keysym #\Soft-hyphen 173) - (define-keysym #\Shy 173) - (define-keysym #\Registered-trademark 174) - (define-keysym #\Macron 175) - (define-keysym #\Degree-sign 176) - (define-keysym #\Ring 176) - (define-keysym #\Plus-minus-sign 177) - (define-keysym #\Superscript-2 178) - (define-keysym #\Superscript-3 179) - (define-keysym #\Acute-accent 180) - (define-keysym #\Greek-mu 181) - (define-keysym #\Paragraph-symbol 182) - (define-keysym #\Paragraph 182) - (define-keysym #\Pilcrow-sign 182) - (define-keysym #\Middle-dot 183) - (define-keysym #\Cedilla 184) - (define-keysym #\Superscript-1 185) - (define-keysym #\Masculine-ordinal-indicator 186) - (define-keysym #\Angle-quotation-right 187) - (define-keysym #\Fraction-1/4 188) - (define-keysym #\One-quarter 188) - (define-keysym #\Fraction-1/2 189) - (define-keysym #\One-half 189) - (define-keysym #\Fraction-3/4 190) - (define-keysym #\Three-quarters 190) - (define-keysym #\Inverted-question-mark 191) - (define-keysym #\Multiplication-sign 215) - (define-keysym #\Eszet 223) - (define-keysym #\Division-sign 247) -) - -#+ti -(progn ;; There are no 7-bit ascii representations for the following - ;; European characters, so use int-char to create them to ensure - ;; nothing is lost while sending files through the mail. - (define-keysym (int-char 192) 192 :lowercase 224) - (define-keysym (int-char 193) 193 :lowercase 225) - (define-keysym (int-char 194) 194 :lowercase 226) - (define-keysym (int-char 195) 195 :lowercase 227) - (define-keysym (int-char 196) 196 :lowercase 228) - (define-keysym (int-char 197) 197 :lowercase 229) - (define-keysym (int-char 198) 198 :lowercase 230) - (define-keysym (int-char 199) 199 :lowercase 231) - (define-keysym (int-char 200) 200 :lowercase 232) - (define-keysym (int-char 201) 201 :lowercase 233) - (define-keysym (int-char 202) 202 :lowercase 234) - (define-keysym (int-char 203) 203 :lowercase 235) - (define-keysym (int-char 204) 204 :lowercase 236) - (define-keysym (int-char 205) 205 :lowercase 237) - (define-keysym (int-char 206) 206 :lowercase 238) - (define-keysym (int-char 207) 207 :lowercase 239) - (define-keysym (int-char 208) 208 :lowercase 240) - (define-keysym (int-char 209) 209 :lowercase 241) - (define-keysym (int-char 210) 210 :lowercase 242) - (define-keysym (int-char 211) 211 :lowercase 243) - (define-keysym (int-char 212) 212 :lowercase 244) - (define-keysym (int-char 213) 213 :lowercase 245) - (define-keysym (int-char 214) 214 :lowercase 246) - (define-keysym (int-char 215) 215) - (define-keysym (int-char 216) 216 :lowercase 248) - (define-keysym (int-char 217) 217 :lowercase 249) - (define-keysym (int-char 218) 218 :lowercase 250) - (define-keysym (int-char 219) 219 :lowercase 251) - (define-keysym (int-char 220) 220 :lowercase 252) - (define-keysym (int-char 221) 221 :lowercase 253) - (define-keysym (int-char 222) 222 :lowercase 254) - (define-keysym (int-char 223) 223) - (define-keysym (int-char 224) 224) - (define-keysym (int-char 225) 225) - (define-keysym (int-char 226) 226) - (define-keysym (int-char 227) 227) - (define-keysym (int-char 228) 228) - (define-keysym (int-char 229) 229) - (define-keysym (int-char 230) 230) - (define-keysym (int-char 231) 231) - (define-keysym (int-char 232) 232) - (define-keysym (int-char 233) 233) - (define-keysym (int-char 234) 234) - (define-keysym (int-char 235) 235) - (define-keysym (int-char 236) 236) - (define-keysym (int-char 237) 237) - (define-keysym (int-char 238) 238) - (define-keysym (int-char 239) 239) - (define-keysym (int-char 240) 240) - (define-keysym (int-char 241) 241) - (define-keysym (int-char 242) 242) - (define-keysym (int-char 243) 243) - (define-keysym (int-char 244) 244) - (define-keysym (int-char 245) 245) - (define-keysym (int-char 246) 246) - (define-keysym (int-char 247) 247) - (define-keysym (int-char 248) 248) - (define-keysym (int-char 249) 249) - (define-keysym (int-char 250) 250) - (define-keysym (int-char 251) 251) - (define-keysym (int-char 252) 252) - (define-keysym (int-char 253) 253) - (define-keysym (int-char 254) 254) - (define-keysym (int-char 255) 255) - ) - -#+lispm ;; Nonstandard characters -(progn - (define-keysym #\center-dot (keysym 183)) ; :latin-1 - (define-keysym #\down-arrow (keysym 008 254)) ; :technical - (define-keysym #\alpha (keysym 007 225)) ; :greek - (define-keysym #\beta (keysym 007 226)) ; :greek - (define-keysym #\and-sign (keysym 008 222)) ; :technical - (define-keysym #\not-sign (keysym 172)) ; :latin-1 - (define-keysym #\epsilon (keysym 007 229)) ; :greek - (define-keysym #\pi (keysym 007 240)) ; :greek - (define-keysym #\lambda (keysym 007 235)) ; :greek - (define-keysym #\gamma (keysym 007 227)) ; :greek - (define-keysym #\delta (keysym 007 228)) ; :greek - (define-keysym #\up-arrow (keysym 008 252)) ; :technical - (define-keysym #\plus-minus (keysym 177)) ; :latin-1 - (define-keysym #\infinity (keysym 008 194)) ; :technical - (define-keysym #\partial-delta (keysym 008 239)) ; :technical - (define-keysym #\left-horseshoe (keysym 011 218)) ; :apl - (define-keysym #\right-horseshoe (keysym 011 216)) ; :apl - (define-keysym #\up-horseshoe (keysym 011 195)) ; :apl - (define-keysym #\down-horseshoe (keysym 011 214)) ; :apl - (define-keysym #\double-arrow (keysym 008 205)) ; :technical - (define-keysym #\left-arrow (keysym 008 251)) ; :technical - (define-keysym #\right-arrow (keysym 008 253)) ; :technical - (define-keysym #\not-equals (keysym 008 189)) ; :technical - (define-keysym #\less-or-equal (keysym 008 188)) ; :technical - (define-keysym #\greater-or-equal (keysym 008 190)) ; :technical - (define-keysym #\equivalence (keysym 008 207)) ; :technical - (define-keysym #\or-sign (keysym 008 223)) ; :technical - (define-keysym #\integral (keysym 008 191)) ; :technical -;; break isn't null -;; (define-keysym #\null (keysym 255 107)) ; :function - (define-keysym #\clear-input (keysym 255 011)) ; :tty - (define-keysym #\help (keysym 255 106)) ; :function - (define-keysym #\refresh (keysym 255 097)) ; :function - (define-keysym #\abort (keysym 255 105)) ; :function - (define-keysym #\resume (keysym 255 098)) ; :function - (define-keysym #\end (keysym 255 087)) ; :cursor -;;#\universal-quantifier -;;#\existential-quantifier -;;#\circle-plus -;;#\circle-cross same as #\circle-x - ) - -#+genera -(progn -;;#\network -;;#\symbol-help - (define-keysym #\lozenge (keysym 009 224)) ; :special - (define-keysym #\suspend (keysym 255 019)) ; :tty - (define-keysym #\function (keysym 255 032)) ; :function - (define-keysym #\square (keysym 010 231)) ; :publishing - (define-keysym #\circle (keysym 010 230)) ; :publishing - (define-keysym #\triangle (keysym 010 232)) ; :publishing - (define-keysym #\scroll (keysym 255 086)) ; :cursor - (define-keysym #\select (keysym 255 096)) ; :function - (define-keysym #\complete (keysym 255 104)) ; :function - ) - -#+ti -(progn - (define-keysym #\terminal (keysym 255 032)) ; :function - (define-keysym #\system (keysym 255 096)) ; :function - (define-keysym #\center-arrow (keysym 255 80)) - (define-keysym #\left-arrow (keysym 255 081)) ; :cursor - (define-keysym #\up-arrow (keysym 255 082)) ; :cursor - (define-keysym #\right-arrow (keysym 255 083)) ; :cursor - (define-keysym #\down-arrow (keysym 255 084)) ; :cursor - (define-keysym #\end (keysym 255 087)) ; :cursor - (define-keysym #\undo (keysym 255 101)) ; :function - (define-keysym #\break (keysym 255 107)) - (define-keysym #\keypad-space (keysym 255 128)) ; :keypad - (define-keysym #\keypad-tab (keysym 255 137)) ; :keypad - (define-keysym #\keypad-enter (keysym 255 141)) ; :keypad - (define-keysym #\f1 (keysym 255 145)) ; :keypad - (define-keysym #\f2 (keysym 255 146)) ; :keypad - (define-keysym #\f3 (keysym 255 147)) ; :keypad - (define-keysym #\f4 (keysym 255 148)) ; :keypad - (define-keysym #\f1 (keysym 255 190)) ; :keypad - (define-keysym #\f2 (keysym 255 191)) ; :keypad - (define-keysym #\f3 (keysym 255 192)) ; :keypad - (define-keysym #\f4 (keysym 255 193)) ; :keypad - (define-keysym #\keypad-plus (keysym 255 171)) ; :keypad - (define-keysym #\keypad-comma (keysym 255 172)) ; :keypad - (define-keysym #\keypad-minus (keysym 255 173)) ; :keypad - (define-keysym #\keypad-period (keysym 255 174)) ; :keypad - (define-keysym #\keypad-0 (keysym 255 176)) ; :keypad - (define-keysym #\keypad-1 (keysym 255 177)) ; :keypad - (define-keysym #\keypad-2 (keysym 255 178)) ; :keypad - (define-keysym #\keypad-3 (keysym 255 179)) ; :keypad - (define-keysym #\keypad-4 (keysym 255 180)) ; :keypad - (define-keysym #\keypad-5 (keysym 255 181)) ; :keypad - (define-keysym #\keypad-6 (keysym 255 182)) ; :keypad - (define-keysym #\keypad-7 (keysym 255 183)) ; :keypad - (define-keysym #\keypad-8 (keysym 255 184)) ; :keypad - (define-keysym #\keypad-9 (keysym 255 185)) ; :keypad - (define-keysym #\keypad-equal (keysym 255 189)) ; :keypad - (define-keysym #\f1 (keysym 255 192)) ; :function - (define-keysym #\f2 (keysym 255 193)) ; :function - (define-keysym #\f3 (keysym 255 194)) ; :function - (define-keysym #\f4 (keysym 255 195)) ; :function - (define-keysym #\network (keysym 255 214)) - (define-keysym #\status (keysym 255 215)) - (define-keysym #\clear-screen (keysym 255 217)) - (define-keysym #\left (keysym 255 218)) - (define-keysym #\middle (keysym 255 219)) - (define-keysym #\right (keysym 255 220)) - (define-keysym #\resume (keysym 255 221)) - (define-keysym #\vt (keysym 009 233)) ; :special ;; same as #\delete - ) - -#+ti -(progn ;; Explorer specific characters - (define-keysym #\Call (keysym 131)) ; :latin-1 - (define-keysym #\Macro (keysym 133)) ; :latin-1 - (define-keysym #\Quote (keysym 142)) ; :latin-1 - (define-keysym #\Hold-output (keysym 143)) ; :latin-1 - (define-keysym #\Stop-output (keysym 144)) ; :latin-1 - (define-keysym #\Center (keysym 156)) ; :latin-1 - (define-keysym #\no-break-space (keysym 160)) ; :latin-1 - - (define-keysym #\circle-plus (keysym 13)) ; :latin-1 - (define-keysym #\universal-quantifier (keysym 20)) ; :latin-1 - (define-keysym #\existential-quantifier (keysym 21)) ; :latin-1 - (define-keysym #\circle-cross (keysym 22)) ; :latin-1 - ) - diff --git a/clx/macros.lisp b/clx/macros.lisp deleted file mode 100644 index faf64da7b7ab8e48903ec11bd2442e821574aa4c..0000000000000000000000000000000000000000 --- a/clx/macros.lisp +++ /dev/null @@ -1,1090 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -;;; CLX basicly implements a very low overhead remote procedure call -;;; to the server. This file contains macros which generate the code -;;; for both the client AND the server, given a specification of the -;;; interface. This was done to eliminate errors that may occur because -;;; the client and server code get/put bytes in different places, and -;;; it makes it easier to extend the protocol. - -;;; This is built on top of BUFFER - -(in-package :xlib) - -;;; This variable is used by the required-arg macro just to satisfy compilers. -(defvar *required-arg-dummy*) - -;;; An error signalling macro use to specify that keyword arguments are required. -(defmacro required-arg (name) - `(progn (x-error 'missing-parameter :parameter ',name) - *required-arg-dummy*)) - -(defmacro lround (index) - ;; Round up to the next 32 bit boundary - `(the array-index (logand (index+ ,index 3) -4))) - -(defmacro wround (index) - ;; Round up to the next 16 bit boundary - `(the array-index (logand (index+ ,index 1) -2))) - -;; -;; Data-type accessor functions -;; -;; These functions translate between lisp data-types and the byte, -;; half-word or word that gets transmitted across the client/server -;; connection - -(defun index-increment (type) - ;; Given a type, return its field width in bytes - (let* ((name (if (consp type) (car type) type)) - (increment (get name 'byte-width :not-found))) - (when (eq increment :not-found) - ;; Check for TYPE in a different package - (when (not (eq (symbol-package name) *xlib-package*)) - (setq name (xintern name)) - (setq increment (get name 'byte-width :not-found))) - (when (eq increment :not-found) - (error "~s isn't a known field accessor" name))) - increment)) - -(eval-when (eval compile load) -(defun getify (name) - (xintern name '-get)) - -(defun putify (name &optional predicate-p) - (xintern name '-put (if predicate-p '-predicating ""))) - - ;; Use &body so zmacs indents properly -(defmacro define-accessor (name (width) &body get-put-macros) - ;; The first body form defines the get macro - ;; The second body form defines the put macro - ;; The third body form is optional, and defines a put macro that does - ;; type checking and does a put when ok, else NIL when the type is incorrect. - ;; If no third body form is present, then these macros assume that - ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated. - ;; these predicating puts are used by the OR accessor. - (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro)) - (when (cdddr get-put-macros) - (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros))) - (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name))) - (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name)))) - `(within-definition (,name define-accessor) - (setf (get ',name 'byte-width) ,(and width (floor width 8))) - (defmacro ,(getify name) ,(car get-macro) - ,@(cdr get-macro)) - (defmacro ,(putify name) ,(car put-macro) - ,@(cdr put-macro)) - ,@(when *type-check?* - (let ((predicating-put (third get-put-macros))) - (when predicating-put - `((setf (get ',name 'predicating-put) t) - (defmacro ,(putify name t) ,(car predicating-put) - ,@(cdr predicating-put))))))))) -) ;; End eval-when - -(define-accessor card32 (32) - ((index) `(read-card32 ,index)) - ((index thing) `(write-card32 ,index ,thing))) - -(define-accessor card29 (32) - ((index) `(read-card29 ,index)) - ((index thing) `(write-card29 ,index ,thing))) - -(define-accessor card16 (16) - ((index) `(read-card16 ,index)) - ((index thing) `(write-card16 ,index ,thing))) - -(define-accessor card8 (8) - ((index) `(read-card8 ,index)) - ((index thing) `(write-card8 ,index ,thing))) - -(define-accessor integer (32) - ((index) `(read-int32 ,index)) - ((index thing) `(write-int32 ,index ,thing))) - -(define-accessor int16 (16) - ((index) `(read-int16 ,index)) - ((index thing) `(write-int16 ,index ,thing))) - -(define-accessor rgb-val (16) - ;; Used for color's - ((index) `(card16->rgb-val (read-card16 ,index))) - ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing)))) - -(define-accessor angle (16) - ;; Used for drawing arcs - ((index) `(int16->radians (read-int16 ,index))) - ((index thing) `(write-int16 ,index (radians->int16 ,thing)))) - -(define-accessor bit (0) - ;; Like BOOLEAN, but tests bits - ;; only used by declare-event (:enter-notify :leave-notify) - ((index bit) - `(logbitp ,bit (read-card8 ,index))) - ((index thing bit) - (if (zerop bit) - `(write-card8 ,index (if ,thing 1 0)) - `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index)))))) - -(define-accessor boolean (8) - ((index) - `(plusp (read-card8 ,index))) - ((index thing) `(write-card8 ,index (if ,thing 1 0)))) - -(define-accessor drawable (32) - ((index &optional (buffer '%buffer)) - `(lookup-drawable ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (drawable-id ,thing)))) - -(define-accessor window (32) - ((index &optional (buffer '%buffer)) - `(lookup-window ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (window-id ,thing)))) - -(define-accessor pixmap (32) - ((index &optional (buffer '%buffer)) - `(lookup-pixmap ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (pixmap-id ,thing)))) - -(define-accessor gcontext (32) - ((index &optional (buffer '%buffer)) - `(lookup-gcontext ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (gcontext-id ,thing)))) - -(define-accessor cursor (32) - ((index &optional (buffer '%buffer)) - `(lookup-cursor ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (cursor-id ,thing)))) - -(define-accessor colormap (32) - ((index &optional (buffer '%buffer)) - `(lookup-colormap ,buffer (read-card29 ,index))) - ((index thing) `(write-card29 ,index (colormap-id ,thing)))) - -(define-accessor font (32) - ((index &optional (buffer '%buffer)) - `(lookup-font ,buffer (read-card29 ,index))) - ;; The FONT-ID accessor may make a OpenFont request. Since we don't support recursive - ;; with-buffer-request, issue a compile time error, rather than barf at run-time. - ((index thing) - (declare (ignore index thing)) - (error "FONT-ID must be called OUTSIDE with-buffer-request. Use RESOURCE-ID instead."))) - -;; Needed to get and put xatom's in events -(define-accessor keyword (32) - ((index &optional (buffer '%buffer)) - `(atom-name ,buffer (read-card29 ,index))) - ((index thing &key (buffer '%buffer)) - `(write-card29 ,index (or (atom-id ,thing ,buffer) - (error "CLX implementation error in KEYWORD-PUT"))))) - -(define-accessor resource-id (32) - ((index) `(read-card29 ,index)) - ((index thing) `(write-card29 ,index ,thing))) - -(define-accessor resource-id-or-nil (32) - ((index) (let ((id (gensym))) - `(let ((,id (read-card29 ,index))) - (and (plusp ,id) ,id)))) - ((index thing) `(write-card29 ,index (or ,thing 0)))) - -(defmacro char-info-get (index) - `(make-char-info - :left-bearing (int16-get ,index) - :right-bearing (int16-get ,(+ index 2)) - :width (int16-get ,(+ index 4)) - :ascent (int16-get ,(+ index 6)) - :descent (int16-get ,(+ index 8)) - :attributes (card16-get ,(+ index 10)))) - -(define-accessor member8 (8) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card8 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value (integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card8 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (let ((value (gensym))) - `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card8 ,index ,value)))))) - -(define-accessor member16 (16) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card16 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value (integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card16 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (let ((value (gensym))) - `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card16 ,index ,value)))))) - -(define-accessor member (32) - ((index &rest keywords) - (let ((value (gensym))) - `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value (integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) - ((index thing &rest keywords) - `(write-card29 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - ((index thing &rest keywords) - (if (cdr keywords) ;; IF more than one - (let ((value (gensym))) - `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card29 ,index ,value)))) - `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0))))) - -(deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list))) - -(define-accessor member-vector (32) - ((index membership-vector) - `(member-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor member16-vector (16) - ((index membership-vector) - `(member16-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor member8-vector (8) - ((index membership-vector) - `(member8-get ,index ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) - ((index thing membership-vector) - `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) - -(define-accessor boole-constant (32) - ;; this isn't member-vector because we need eql instead of eq - ((index) - (let ((value (gensym))) - `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length *boole-vector*))) ,value)) - (type-check ,value (integer 0 (,(length *boole-vector*)))) - (svref *boole-vector* ,value)))) - ((index thing) - `(write-card29 ,index (position ,thing (the simple-vector *boole-vector*)))) - ((index thing) - (let ((value (gensym))) - `(let ((,value (position ,thing (the simple-vector *boole-vector*)))) - (and ,value (write-card29 ,index ,value)))))) - -(define-accessor null (32) - ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index))) - ((index value) (declare (ignore value)) `(write-card32 ,index 0))) - -(define-accessor pad8 (8) - ((index) (declare (ignore index)) nil) - ((index value) (declare (ignore index value)) nil)) - -(define-accessor pad16 (16) - ((index) (declare (ignore index)) nil) - ((index value) (declare (ignore index value)) nil)) - -(define-accessor bit-vector256 (256) - ;; used for key-maps - ;; REAL-INDEX parameter provided so the default index can be over-ridden. - ;; This is needed for the :keymap-notify event where the keymap overlaps - ;; the window id. - ((index &optional (real-index index) data) - `(read-bitvector256 buffer-bbuf ,real-index ,data)) - ((index map &optional (real-index index) (buffer '%buffer)) - `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map))) - -(define-accessor string (nil) - ((length index &key reply-buffer) - `(read-sequence-char - ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index)) - ((index string &key buffer (start 0) end header-length appending) - (unless buffer (setq buffer '%buffer)) - (unless header-length (setq header-length (lround index))) - (let* ((real-end (if appending (or end `(length ,string)) (gensym))) - (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length) - ,string ,start ,real-end))) - (if appending - form - `(let ((,real-end ,(or end `(length ,string)))) - (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4)) - ,form))))) - -(define-accessor sequence (nil) - ((&key length (format 'card32) result-type transform reply-buffer data index start) - `(,(ecase format - (card8 'read-sequence-card8) - (int8 'read-sequence-int8) - (card16 'read-sequence-card16) - (int16 'read-sequence-int16) - (card32 'read-sequence-card32) - (int32 'read-sequence-int32)) - ,(or reply-buffer '%reply-buffer) - ,result-type ,length ,transform ,data - ,@(when (or start index) `(,(or start 0))) - ,@(when index `(,index)))) - ((index data &key (format 'card32) (start 0) end transform buffer appending) - (unless buffer (setq buffer '%buffer)) - (let* ((real-end (if appending (or end `(length ,data)) (gensym))) - (writer (xintern 'write-sequence- format)) - (form `(,writer ,buffer (index+ buffer-boffset ,(lround index)) - ,data ,start ,real-end ,transform))) - (flet ((maker (size) - (if appending - form - (let ((idx `(index- ,real-end ,start))) - (unless (= size 1) - (setq idx `(index-ceiling ,idx ,size))) - `(let ((,real-end ,(or end `(length ,data)))) - (write-card16 2 (index+ ,idx ,(index-ceiling index 4))) - ,form))))) - (ecase format - ((card8 int8) - (maker 4)) - ((card16 int16 char2b) - (maker 2)) - ((card32 int32) - (maker 1))))))) - -(defmacro client-message-event-get-sequence () - '(let* ((format (read-card8 1)) - (sequence (make-array (ceiling 160 format) - :element-type `(unsigned-byte ,format)))) - (declare (type (member 8 16 32) format)) - (do ((i 12) - (j 0 (index1+ j))) - ((>= i 32)) - (case format - (8 (setf (aref sequence j) (read-card8 i)) - (index-incf i)) - (16 (setf (aref sequence j) (read-card16 i)) - (index-incf i 2)) - (32 (setf (aref sequence j) (read-card32 i)) - (index-incf i 4)))) - sequence)) - -(defmacro client-message-event-put-sequence (format sequence) - `(ecase ,format - (8 (sequence-put 12 ,sequence - :format card8 - :end (min (length ,sequence) 20) - :appending t)) - (16 (sequence-put 12 ,sequence - :format card16 - :end (min (length ,sequence) 10) - :appending t)) - (32 (sequence-put 12 ,sequence - :format card32 - :end (min (length ,sequence) 5) - :appending t)))) - -;; Used only in declare-event -(define-accessor client-message-sequence (160) - ((index format) (declare (ignore index format)) `(client-message-event-get-sequence)) - ((index value format) (declare (ignore index)) - `(client-message-event-put-sequence ,format ,value))) - - -;;; -;;; Compound accessors -;;; Accessors that take other accessors as parameters -;;; -(define-accessor code (0) - ((index) (declare (ignore index)) '(read-card8 0)) - ((index value) (declare (ignore index)) `(write-card8 0 ,value)) - ((index value) (declare (ignore index)) `(write-card8 0 ,value))) - -(define-accessor length (0) - ((index) (declare (ignore index)) '(read-card16 2)) - ((index value) (declare (ignore index)) `(write-card16 2 ,value)) - ((index value) (declare (ignore index)) `(write-card16 2 ,value))) - -(deftype data () 'card8) - -(define-accessor data (0) - ;; Put data in byte 1 of the reqeust - ((index &optional stuff) (declare (ignore index)) - (if stuff - (if (consp stuff) - `(,(getify (car stuff)) 1 ,@(cdr stuff)) - `(,(getify stuff) 1)) - `(read-card8 1))) - ((index thing &optional stuff) - (if stuff - (if (consp stuff) - `(macrolet ((write-card32 (index value) index value)) - (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) - `(,(putify stuff) 1 ,thing)) - `(write-card8 1 ,thing))) - ((index thing &optional stuff) - (if stuff - `(and (type? ,thing ',stuff) - ,(if (consp stuff) - `(macrolet ((write-card32 (index value) index value)) - (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) - `(,(putify stuff) 1 ,thing))) - `(and (type? ,thing 'card8) (write-card8 1 ,thing))))) - -;; Macroexpand the result of OR-GET to allow the macros file to not be loaded -;; when using event-case. This is pretty gross. - -(defmacro or-expand (&rest forms &environment environment) - `(cond ,@(mapcar #'(lambda (forms) - (mapcar #'(lambda (form) - (clx-macroexpand form environment)) - forms)) - forms))) - -;; -;; the OR type -;; -(define-accessor or (32) - ;; Select from among several types (usually NULL and something else) - ((index &rest type-list &environment environment) - (do ((types type-list (cdr types)) - (value (gensym)) - (result)) - ((endp types) - `(let ((,value (read-card32 ,index))) - (macrolet ((read-card32 (index) index ',value) - (read-card29 (index) index ',value)) - ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment)))) - (let ((item (car types)) - (args nil)) - (when (consp item) - (setq args (cdr item) - item (car item))) - (if (eq item 'null) ;; Special case for NULL - (push `((zerop ,value) nil) result) - (push - `((,(getify item) ,index ,@args)) - result))))) - - ((index value &rest type-list) - (do ((types type-list (cdr types)) - (result)) - ((endp types) - `(cond ,@(nreverse result) - ,@(when *type-check?* - `((t (x-type-error ,value '(or ,@type-list))))))) - (let* ((type (car types)) - (type-name type) - (args nil)) - (when (consp type) - (setq args (cdr type) - type-name (car type))) - (push - `(,@(cond ((get type-name 'predicating-put) nil) - ((or *type-check?* (cdr types)) `((type? ,value ',type))) - (t '(t))) - (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args)) - result))))) - -;; -;; the MASK type... -;; is used to specify a subset of a collection of "optional" arguments. -;; A mask type consists of a 32 bit mask word followed by a word for each one-bit -;; in the mask. The MASK type is ALWAYS the LAST item in a request. -;; -(setf (get 'mask 'byte-width) nil) - -(defun mask-get (index type-values body-function) - (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) - ;; This is a function, because it must return more than one form (called by get-put-items) - ;; Functions that use this must have a binding for %MASK - (let* ((bit 0) - (result - (mapcar - #'(lambda (form) - (if (atom form) - form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs - (prog1 - `(when (logbitp ,bit %mask) - ;; Execute form when bit is set - ,form) - (incf bit)))) - (get-put-items - (+ index 4) type-values nil - #'(lambda (type index item args) - (declare (ignore index)) - (funcall body-function type '(* (incf %index) 4) item args)))))) - ;; First form must load %MASK - `(,@(when (atom (car result)) - (list (pop result))) - (progn (setq %mask (read-card32 ,index)) - (setq %index ,(ceiling index 4)) - ,(car result)) - ,@(cdr result)))) - -;; MASK-PUT - -(defun mask-put (index type-values body-function) - (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) - ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES - ;; A 32 bit value follows for each non-nil value. - `((let ((%mask 0) - (%index ,index)) - ,@(let ((bit 1)) - (get-put-items - index type-values t - #'(lambda (type index item args) - (declare (ignore index)) - (if (or (symbolp item) (constantp item)) - `((unless (null ,item) - (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) - ,@(funcall body-function type - `(index-incf %index 4) item args))) - `((let ((.item. ,item)) - (unless (null .item.) - (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) - ,@(funcall body-function type - `(index-incf %index 4) '.item. args)))))))) - (write-card32 ,index %mask) - (write-card16 2 (index-ceiling (index-incf %index 4) 4)) - (incf (buffer-boffset %buffer) %index)))) - -(define-accessor progn (nil) - ;; Catch-all for inserting random code - ;; Note that code using this is then responsible for setting the request length - ((index statement) (declare (ignore index)) statement) - ((index statement) (declare (ignore index)) statement)) - - -; -; Wrapper macros, for use around the above -; -(defmacro type-check (value type) - value type - (when *type-check?* - `(unless (type? ,value ,type) - (x-type-error ,value ,type)))) - -(defmacro check-put (index value type &rest args &environment env) - (let* ((var (if (or (symbolp value) (constantp value)) value '.value.)) - (body - (if (or (null (macroexpand `(type-check ,var ',type) env)) - (member type '(or progn pad8 pad16)) - (constantp value)) - `(,(putify type) ,index ,var ,@args) - ;; Do type checking - (if (get type 'predicating-put) - `(or (,(putify type t) ,index ,var ,@args) - (x-type-error ,var ',(if args `(,type ,@args) type))) - `(if (type? ,var ',type) - (,(putify type) ,index ,var ,@args) - (x-type-error ,var ',(if args `(,type ,@args) type))))))) - (if (eq var value) - body - `(let ((,var ,value)) - ,body)))) - -(defun get-put-items (index type-args putp &optional body-function) - (declare (type (or null function) body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) - ;; Given a lists of the form (type item item ... item) - ;; Calls body-function with four arguments, a function name, - ;; index, item name, and optional arguments. - ;; The results are appended together and retured. - (unless body-function - (setq body-function - #'(lambda (type index item args) - `((check-put ,index ,item ,type ,@args))))) - (do* ((items type-args (cdr items)) - (type (caar items) (caar items)) - (args nil nil) - (result nil) - (sizes nil)) - ((endp items) (values result index sizes)) - (when (consp type) - (setq args (cdr type) - type (car type))) - (cond ((member type '(return buffer))) - ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values - (setq result - (append result (if putp - (mask-put index (cdar items) body-function) - (mask-get index (cdar items) body-function))) - index nil)) - (t (do* ((item (cdar items) (cdr item)) - (increment (index-increment type))) - ((endp item)) - (when (constantp index) - (case increment ;Round up index when needed - (2 (setq index (wround index))) - (4 (setq index (lround index))))) - (setq result - (append result (funcall body-function type index (car item) args))) - (when (constantp index) - ;; Variable length requests have null length increment. - ;; Variable length requests set the request size - ;; & maintain buffer pointers - (if (null increment) - (setq index nil) - (progn - (incf index increment) - (when (and increment (zerop increment)) (setq increment 1)) - (pushnew (* increment 8) sizes))))))))) - -(defmacro with-buffer-request-internal - ((buffer opcode &key length sizes &allow-other-keys) - &body type-args) - (multiple-value-bind (code index item-sizes) - (get-put-items 4 type-args t) - (let ((length (if length `(index+ ,length *requestsize*) '*requestsize*)) - (sizes (remove-duplicates (append '(8 16) item-sizes sizes)))) - `(with-buffer-output (,buffer :length ,length :sizes ,sizes) - (setf (buffer-last-request ,buffer) buffer-boffset) - (write-card8 0 ,opcode) ;; Stick in the opcode - ,@code - ,@(when index - (setq index (lround index)) - `((write-card16 2 ,(ceiling index 4)) - (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index)))) - (buffer-new-request-number ,buffer))))) - -(defmacro with-buffer-request - ((buffer opcode &rest options &key inline gc-force &allow-other-keys) - &body type-args &environment env) - (if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.request-body. (.display.) - (declare (type display .display.)) - (with-buffer-request-internal (.display. ,opcode ,@options) - ,@type-args))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.request-body.)) - (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) - 'with-buffer-request-function-nolock - 'with-buffer-request-function) - ,buffer ,gc-force #'.request-body.)) - `(let ((.display. ,buffer)) - (declare (type display .display.)) - (with-buffer (.display.) - ,@(when gc-force `((force-gcontext-changes-internal ,gc-force))) - (multiple-value-prog1 - (without-aborts - (with-buffer-request-internal (.display. ,opcode ,@options) - ,@type-args)) - (display-invoke-after-function .display.)))))) - -(defmacro with-buffer-request-and-reply - ((buffer opcode reply-size &key sizes multiple-reply inline) - type-args &body reply-forms &environment env) - (declare (indentation 0 4 1 4 2 1)) - (let* ((inner-reply-body - `(with-buffer-input (.reply-buffer. :display .display. - ,@(and sizes (list :sizes sizes))) - nil ,@reply-forms)) - (reply-body - (if (or (not (symbolp reply-size)) (constantp reply-size)) - inner-reply-body - `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.)))) - (declare (type array-index ,reply-size)) - ,inner-reply-body)))) - (if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.request-body. (.display.) - (declare (type display .display.)) - (with-buffer-request-internal (.display. ,opcode) - ,@type-args)) - (.reply-body. (.display. .reply-buffer.) - (declare (type display .display.) - (type reply-buffer .reply-buffer.)) - (progn .display. .reply-buffer. nil) - ,reply-body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.request-body. #'.reply-body.)) - (with-buffer-request-and-reply-function - ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) - `(let ((.display. ,buffer) - (.pending-command. nil) - (.reply-buffer. nil)) - (declare (type display .display.) - (type (or null pending-command) .pending-command.) - (type (or null reply-buffer) .reply-buffer.)) - (unwind-protect - (progn - (with-buffer (.display.) - (setq .pending-command. (start-pending-command .display.)) - (without-aborts - (with-buffer-request-internal (.display. ,opcode) - ,@type-args)) - (buffer-force-output .display.) - (display-invoke-after-function .display.)) - ,@(if multiple-reply - `((loop - (setq .reply-buffer. (read-reply .display. .pending-command.)) - (when ,reply-body (return nil)) - (deallocate-reply-buffer (shiftf .reply-buffer. nil)))) - `((setq .reply-buffer. (read-reply .display. .pending-command.)) - ,reply-body))) - (when .reply-buffer. - (deallocate-reply-buffer .reply-buffer.)) - (when .pending-command. - (stop-pending-command .display. .pending-command.))))))) - -(defmacro compare-request ((index) &body body) - `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index))) - (write-int32 (index item) `(= ,item (read-int32 ,index))) - (write-card29 (index item) `(= ,item (read-card29 ,index))) - (write-int29 (index item) `(= ,item (read-int29 ,index))) - (write-card16 (index item) `(= ,item (read-card16 ,index))) - (write-int16 (index item) `(= ,item (read-int16 ,index))) - (write-card8 (index item) `(= ,item (read-card8 ,index))) - (write-int8 (index item) `(= ,item (read-int8 ,index)))) - (macrolet ((type-check (value type) value type nil)) - (and ,@(get-put-items index body t))))) - -(defmacro put-items ((index) &body body) - `(progn ,@(get-put-items index body t))) - -(defmacro decode-type (type value) - ;; Given an integer and type, return the value - (let ((args nil)) - (when (consp type) - (setq args (cdr type) - type (car type))) - `(macrolet ((read-card29 (value) value) - (read-card32 (value) value) - (read-int32 (value) `(card32->int32 ,value)) - (read-card16 (value) value) - (read-int16 (value) `(card16->int16 ,value)) - (read-card8 (value) value) - (read-int8 (value) `(int8->card8 ,value))) - (,(getify type) ,value ,@args)))) - -(defmacro encode-type (type value) - ;; Given a value and type, return an integer - ;; When check-p, do type checking on value - (let ((args nil)) - (when (consp type) - (setq args (cdr type) - type (car type))) - `(macrolet ((write-card29 (index value) index value) - (write-card32 (index value) index value) - (write-int32 (index value) index `(int32->card32 ,value)) - (write-card16 (index value) index value) - (write-int16 (index value) index `(int16->card16 ,value)) - (write-card8 (index value) index value) - (write-int8 (index value) index `(int8->card8 ,value))) - (check-put 0 ,value ,type ,@args)))) - -(defmacro set-decode-type (type accessor value) - `(setf ,accessor (encode-type ,type ,value))) -(defsetf decode-type set-decode-type) - - -;;; -;;; Request codes -;;; - -(defconstant *x-createwindow* 1) -(defconstant *x-changewindowattributes* 2) -(defconstant *x-getwindowattributes* 3) -(defconstant *x-destroywindow* 4) -(defconstant *x-destroysubwindows* 5) -(defconstant *x-changesaveset* 6) -(defconstant *x-reparentwindow* 7) -(defconstant *x-mapwindow* 8) -(defconstant *x-mapsubwindows* 9) -(defconstant *x-unmapwindow* 10) -(defconstant *x-unmapsubwindows* 11) -(defconstant *x-configurewindow* 12) -(defconstant *x-circulatewindow* 13) -(defconstant *x-getgeometry* 14) -(defconstant *x-querytree* 15) -(defconstant *x-internatom* 16) -(defconstant *x-getatomname* 17) -(defconstant *x-changeproperty* 18) -(defconstant *x-deleteproperty* 19) -(defconstant *x-getproperty* 20) -(defconstant *x-listproperties* 21) -(defconstant *x-setselectionowner* 22) -(defconstant *x-getselectionowner* 23) -(defconstant *x-convertselection* 24) -(defconstant *x-sendevent* 25) -(defconstant *x-grabpointer* 26) -(defconstant *x-ungrabpointer* 27) -(defconstant *x-grabbutton* 28) -(defconstant *x-ungrabbutton* 29) -(defconstant *x-changeactivepointergrab* 30) -(defconstant *x-grabkeyboard* 31) -(defconstant *x-ungrabkeyboard* 32) -(defconstant *x-grabkey* 33) -(defconstant *x-ungrabkey* 34) -(defconstant *x-allowevents* 35) -(defconstant *x-grabserver* 36) -(defconstant *x-ungrabserver* 37) -(defconstant *x-querypointer* 38) -(defconstant *x-getmotionevents* 39) -(defconstant *x-translatecoords* 40) -(defconstant *x-warppointer* 41) -(defconstant *x-setinputfocus* 42) -(defconstant *x-getinputfocus* 43) -(defconstant *x-querykeymap* 44) -(defconstant *x-openfont* 45) -(defconstant *x-closefont* 46) -(defconstant *x-queryfont* 47) -(defconstant *x-querytextextents* 48) -(defconstant *x-listfonts* 49) -(defconstant *x-listfontswithinfo* 50) -(defconstant *x-setfontpath* 51) -(defconstant *x-getfontpath* 52) -(defconstant *x-createpixmap* 53) -(defconstant *x-freepixmap* 54) -(defconstant *x-creategc* 55) -(defconstant *x-changegc* 56) -(defconstant *x-copygc* 57) -(defconstant *x-setdashes* 58) -(defconstant *x-setcliprectangles* 59) -(defconstant *x-freegc* 60) -(defconstant *x-cleartobackground* 61) -(defconstant *x-copyarea* 62) -(defconstant *x-copyplane* 63) -(defconstant *x-polypoint* 64) -(defconstant *x-polyline* 65) -(defconstant *x-polysegment* 66) -(defconstant *x-polyrectangle* 67) -(defconstant *x-polyarc* 68) -(defconstant *x-fillpoly* 69) -(defconstant *x-polyfillrectangle* 70) -(defconstant *x-polyfillarc* 71) -(defconstant *x-putimage* 72) -(defconstant *x-getimage* 73) -(defconstant *x-polytext8* 74) -(defconstant *x-polytext16* 75) -(defconstant *x-imagetext8* 76) -(defconstant *x-imagetext16* 77) -(defconstant *x-createcolormap* 78) -(defconstant *x-freecolormap* 79) -(defconstant *x-copycolormapandfree* 80) -(defconstant *x-installcolormap* 81) -(defconstant *x-uninstallcolormap* 82) -(defconstant *x-listinstalledcolormaps* 83) -(defconstant *x-alloccolor* 84) -(defconstant *x-allocnamedcolor* 85) -(defconstant *x-alloccolorcells* 86) -(defconstant *x-alloccolorplanes* 87) -(defconstant *x-freecolors* 88) -(defconstant *x-storecolors* 89) -(defconstant *x-storenamedcolor* 90) -(defconstant *x-querycolors* 91) -(defconstant *x-lookupcolor* 92) -(defconstant *x-createcursor* 93) -(defconstant *x-createglyphcursor* 94) -(defconstant *x-freecursor* 95) -(defconstant *x-recolorcursor* 96) -(defconstant *x-querybestsize* 97) -(defconstant *x-queryextension* 98) -(defconstant *x-listextensions* 99) -(defconstant *x-setkeyboardmapping* 100) -(defconstant *x-getkeyboardmapping* 101) -(defconstant *x-changekeyboardcontrol* 102) -(defconstant *x-getkeyboardcontrol* 103) -(defconstant *x-bell* 104) -(defconstant *x-changepointercontrol* 105) -(defconstant *x-getpointercontrol* 106) -(defconstant *x-setscreensaver* 107) -(defconstant *x-getscreensaver* 108) -(defconstant *x-changehosts* 109) -(defconstant *x-listhosts* 110) -(defconstant *x-changeaccesscontrol* 111) -(defconstant *x-changeclosedownmode* 112) -(defconstant *x-killclient* 113) -(defconstant *x-rotateproperties* 114) -(defconstant *x-forcescreensaver* 115) -(defconstant *x-setpointermapping* 116) -(defconstant *x-getpointermapping* 117) -(defconstant *x-setmodifiermapping* 118) -(defconstant *x-getmodifiermapping* 119) -(defconstant *x-nooperation* 127) - -;;; Some macros for threaded lists - -(defmacro threaded-atomic-push (item list next type) - (let ((x (gensym)) - (y (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x)) - (loop - (let ((,y ,list)) - (declare (type (or null ,type) ,y) - (optimize (speed 3) (safety 0))) - (setf (,next ,x) ,y) - (when (conditional-store ,list ,y ,x) - (return ,x))))))) - -(defmacro threaded-atomic-pop (list next type) - (let ((y (gensym))) - `(loop - (let ((,y ,list)) - (declare (type (or null ,type) ,y) - (optimize (speed 3) (safety 0))) - (if (null ,y) - (return nil) - (when (conditional-store ,list ,y (,next (the ,type ,y))) - (setf (,next (the ,type ,y)) nil) - (return ,y))))))) - -(defmacro threaded-nconc (item list next type) - (let ((first (gensym)) - (x (gensym)) - (y (gensym)) - (z (gensym))) - `(let ((,z ,item) - (,first ,list)) - (declare (type ,type ,z) - (type (or null ,type) ,first) - (optimize (speed 3) (safety 0))) - (if (null ,first) - (setf ,list ,z) - (do* ((,x ,first ,y) - (,y (,next ,x) (,next ,x))) - ((null ,y) - (setf (,next ,x) ,z) - ,first) - (declare (type ,type ,x) - (type (or null ,type) ,y))))))) - -(defmacro threaded-push (item list next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) - (shiftf (,next ,x) ,list ,x) - ,x))) - -(defmacro threaded-pop (list next type) - (let ((x (gensym))) - `(let ((,x ,list)) - (declare (type (or null ,type) ,x) - (optimize (speed 3) (safety 0))) - (when ,x - (shiftf ,list (,next (the ,type ,x)) nil)) - ,x))) - -(defmacro threaded-enqueue (item head tail next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) - (if (null ,tail) - (threaded-nconc ,x ,head ,next ,type) - (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type)) - (setf ,tail ,x)))) - -(defmacro threaded-dequeue (head tail next type) - (let ((x (gensym))) - `(let ((,x ,head)) - (declare (type (or null ,type) ,x) - (optimize (speed 3) (safety 0))) - (when ,x - (when (eq ,x ,tail) - (setf ,tail (,next (the ,type ,x)))) - (setf ,head (,next (the ,type ,x)))) - ,x))) - -(defmacro threaded-requeue (item head tail next type) - (let ((x (gensym))) - `(let ((,x ,item)) - (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) - (if (null ,tail) - (setf ,tail (setf ,head ,x)) - (shiftf (,next ,x) ,head ,x)) - ,x))) - -(defmacro threaded-dolist ((variable list next type) &body body) - `(block nil - (do* ((,variable ,list (,next (the ,type ,variable)))) - ((null ,variable)) - (declare (type (or null ,type) ,variable)) - ,@body))) - -(defmacro threaded-delete (item list next type) - (let ((x (gensym)) - (y (gensym)) - (z (gensym)) - (first (gensym))) - `(let ((,x ,item) - (,first ,list)) - (declare (type ,type ,x) - (type (or null ,type) ,first) - (optimize (speed 3) (safety 0))) - (when ,first - (if (eq ,first ,x) - (setf ,first (setf ,list (,next ,x))) - (do* ((,y ,first ,z) - (,z (,next ,y) (,next ,y))) - ((or (null ,z) (eq ,z ,x)) - (when (eq ,z ,x) - (setf (,next ,y) (,next ,x)))) - (declare (type ,type ,y)) - (declare (type (or null ,type) ,z))))) - (setf (,next ,x) nil) - ,first))) - -(defmacro threaded-length (list next type) - (let ((x (gensym)) - (count (gensym))) - `(do ((,x ,list (,next (the ,type ,x))) - (,count 0 (index1+ ,count))) - ((null ,x) - ,count) - (declare (type (or null ,type) ,x) - (type array-index ,count) - (optimize (speed 3) (safety 0)))))) - diff --git a/clx/manager.lisp b/clx/manager.lisp deleted file mode 100644 index 5366cd18ee3e8541138932dc2858e42f7e6a244f..0000000000000000000000000000000000000000 --- a/clx/manager.lisp +++ /dev/null @@ -1,789 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;;; Window Manager Property functions - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defun wm-name (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char)) - -(defsetf wm-name (window) (name) - `(set-string-property ,window :WM_NAME ,name)) - -(defun set-string-property (window property string) - (declare (type window window) - (type keyword property) - (type stringable string)) - (change-property window property (string string) :STRING 8 :transform #'char->card8) - string) - -(defun wm-icon-name (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_ICON_NAME :type :STRING - :result-type 'string :transform #'card8->char)) - -(defsetf wm-icon-name (window) (name) - `(set-string-property ,window :WM_ICON_NAME ,name)) - -(defun wm-client-machine (window) - (declare (type window window)) - (declare (clx-values string)) - (get-property window :WM_CLIENT_MACHINE :type :STRING - :result-type 'string :transform #'card8->char)) - -(defsetf wm-client-machine (window) (name) - `(set-string-property ,window :WM_CLIENT_MACHINE ,name)) - -(defun get-wm-class (window) - (declare (type window window)) - (declare (clx-values (or null name-string) (or null class-string))) - (let ((value (get-property window :WM_CLASS :type :STRING :result-type '(vector card8)))) - (declare (type (or null (vector card8)) value)) - (when value - (let* ((name-len (position 0 (the (vector card8) value))) - (name (subseq (the (vector card8) value) 0 name-len)) - (class (subseq (the (vector card8) value) (1+ name-len) (1- (length value))))) - (values (and (plusp (length name)) (map 'string #'card8->char name)) - (and (plusp (length class)) (map 'string #'card8->char class))))))) - -(defun set-wm-class (window resource-name resource-class) - (declare (type window window) - (type (or null stringable) resource-name resource-class)) - (change-property window :WM_CLASS - (concatenate '(vector card8) - (map '(vector card8) #'char->card8 - (string (or resource-name ""))) - #(0) - (map '(vector card8) #'char->card8 - (string (or resource-class ""))) - #(0)) - :string 8) - (values)) - -(defun wm-command (window) - ;; Returns a list whose car is the command and - ;; whose cdr is the list of arguments - (declare (type window window)) - (declare (clx-values list)) - (do* ((command-string (get-property window :WM_COMMAND :type :STRING - :result-type '(vector card8))) - (command nil) - (start 0 (1+ end)) - (end 0) - (len (length command-string))) - ((>= start len) (nreverse command)) - (setq end (position 0 command-string :start start)) - (push (map 'string #'card8->char (subseq command-string start end)) - command))) - -(defsetf wm-command set-wm-command) -(defun set-wm-command (window command) - ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or - ;; equivalent), with elements of command separated by NULL characters. This - ;; enables - ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) - ;; to recover a lisp command. - (declare (type window window) - (type list command)) - (change-property window :WM_COMMAND - (apply #'concatenate '(vector card8) - (mapcan #'(lambda (c) - (list (map '(vector card8) #'char->card8 - (with-output-to-string (stream) - (with-standard-io-syntax - (prin1 c stream)))) - #(0))) - command)) - :string 8) - command) - -;;----------------------------------------------------------------------------- -;; WM_HINTS - -(def-clx-class (wm-hints) - (input nil :type (or null (member :off :on))) - (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive))) - (icon-pixmap nil :type (or null pixmap)) - (icon-window nil :type (or null window)) - (icon-x nil :type (or null card16)) - (icon-y nil :type (or null card16)) - (icon-mask nil :type (or null pixmap)) - (window-group nil :type (or null resource-id)) - (flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field - ;; may be extended in the future - ) - -(defun wm-hints (window) - (declare (type window window)) - (declare (clx-values wm-hints)) - (let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector))) - (when prop - (decode-wm-hints prop (window-display window))))) - -(defsetf wm-hints set-wm-hints) -(defun set-wm-hints (window wm-hints) - (declare (type window window) - (type wm-hints wm-hints)) - (declare (clx-values wm-hints)) - (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32) - wm-hints) - -(defun decode-wm-hints (vector display) - (declare (type (simple-vector 9) vector) - (type display display)) - (declare (clx-values wm-hints)) - (let ((input-hint 0) - (state-hint 1) - (icon-pixmap-hint 2) - (icon-window-hint 3) - (icon-position-hint 4) - (icon-mask-hint 5) - (window-group-hint 6)) - (let ((flags (aref vector 0)) - (hints (make-wm-hints)) - (%buffer display)) - (declare (type card32 flags) - (type wm-hints hints) - (type display %buffer)) - (setf (wm-hints-flags hints) flags) - (when (logbitp input-hint flags) - (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1)))) - (when (logbitp state-hint flags) - (setf (wm-hints-initial-state hints) - (decode-type (member :dont-care :normal :zoom :iconic :inactive) - (aref vector 2)))) - (when (logbitp icon-pixmap-hint flags) - (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) - (when (logbitp icon-window-hint flags) - (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) - (when (logbitp icon-position-hint flags) - (setf (wm-hints-icon-x hints) (aref vector 5) - (wm-hints-icon-y hints) (aref vector 6))) - (when (logbitp icon-mask-hint flags) - (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) - (when (and (logbitp window-group-hint flags) (> (length vector) 7)) - (setf (wm-hints-window-group hints) (aref vector 8))) - hints))) - - -(defun encode-wm-hints (wm-hints) - (declare (type wm-hints wm-hints)) - (declare (clx-values simple-vector)) - (let ((input-hint #b1) - (state-hint #b10) - (icon-pixmap-hint #b100) - (icon-window-hint #b1000) - (icon-position-hint #b10000) - (icon-mask-hint #b100000) - (window-group-hint #b1000000) - (mask #b1111111) - ) - (let ((vector (make-array 9 :initial-element 0)) - (flags 0)) - (declare (type (simple-vector 9) vector) - (type card16 flags)) - (when (wm-hints-input wm-hints) - (setf flags input-hint - (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) - (when (wm-hints-initial-state wm-hints) - (setf flags (logior flags state-hint) - (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) - (wm-hints-initial-state wm-hints)))) - (when (wm-hints-icon-pixmap wm-hints) - (setf flags (logior flags icon-pixmap-hint) - (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) - (when (wm-hints-icon-window wm-hints) - (setf flags (logior flags icon-window-hint) - (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) - (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints)) - (setf flags (logior flags icon-position-hint) - (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) - (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) - (when (wm-hints-icon-mask wm-hints) - (setf flags (logior flags icon-mask-hint) - (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) - (when (wm-hints-window-group wm-hints) - (setf flags (logior flags window-group-hint) - (aref vector 8) (wm-hints-window-group wm-hints))) - (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask))) - vector))) - -;;----------------------------------------------------------------------------- -;; WM_SIZE_HINTS - -(def-clx-class (wm-size-hints) - (user-specified-position-p nil :type boolean) ;; True when user specified x y - (user-specified-size-p nil :type boolean) ;; True when user specified width height - (x nil :type (or null int16)) ;; Obsolete - (y nil :type (or null int16)) ;; Obsolete - (width nil :type (or null card16)) ;; Obsolete - (height nil :type (or null card16)) ;; Obsolete - (min-width nil :type (or null card16)) - (min-height nil :type (or null card16)) - (max-width nil :type (or null card16)) - (max-height nil :type (or null card16)) - (width-inc nil :type (or null card16)) - (height-inc nil :type (or null card16)) - (min-aspect nil :type (or null number)) - (max-aspect nil :type (or null number)) - (base-width nil :type (or null card16)) - (base-height nil :type (or null card16)) - (win-gravity nil :type (or null win-gravity)) - (program-specified-position-p nil :type boolean) ;; True when program specified x y - (program-specified-size-p nil :type boolean) ;; True when program specified width height - ) - - -(defun wm-normal-hints (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) - -(defsetf wm-normal-hints set-wm-normal-hints) -(defun set-wm-normal-hints (window hints) - (declare (type window window) - (type wm-size-hints hints)) - (declare (clx-values wm-size-hints)) - (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) - hints) - -;;; OBSOLETE -(defun wm-zoom-hints (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) - -;;; OBSOLETE -(defsetf wm-zoom-hints set-wm-zoom-hints) -;;; OBSOLETE -(defun set-wm-zoom-hints (window hints) - (declare (type window window) - (type wm-size-hints hints)) - (declare (clx-values wm-size-hints)) - (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) - hints) - -(defun decode-wm-size-hints (vector) - (declare (type (or null (simple-vector *)) vector)) - (declare (clx-values (or null wm-size-hints))) - (when vector - (let ((flags (aref vector 0)) - (hints (make-wm-size-hints))) - (declare (type card16 flags) - (type wm-size-hints hints)) - (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags)) - (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags)) - (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags)) - (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags)) - (when (logbitp 4 flags) - (setf (wm-size-hints-min-width hints) (aref vector 5) - (wm-size-hints-min-height hints) (aref vector 6))) - (when (logbitp 5 flags) - (setf (wm-size-hints-max-width hints) (aref vector 7) - (wm-size-hints-max-height hints) (aref vector 8))) - (when (logbitp 6 flags) - (setf (wm-size-hints-width-inc hints) (aref vector 9) - (wm-size-hints-height-inc hints) (aref vector 10))) - (when (logbitp 7 flags) - (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12)) - (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14)))) - (when (> (length vector) 15) - ;; This test is for backwards compatibility since old Xlib programs - ;; can set a size-hints structure that is too small. See ICCCM. - (when (logbitp 8 flags) - (setf (wm-size-hints-base-width hints) (aref vector 15) - (wm-size-hints-base-height hints) (aref vector 16))) - (when (logbitp 9 flags) - (setf (wm-size-hints-win-gravity hints) - (decode-type (member-vector *win-gravity-vector*) (aref vector 17))))) - ;; Obsolete fields - (when (or (logbitp 0 flags) (logbitp 2 flags)) - (setf (wm-size-hints-x hints) (aref vector 1) - (wm-size-hints-y hints) (aref vector 2))) - (when (or (logbitp 1 flags) (logbitp 3 flags)) - (setf (wm-size-hints-width hints) (aref vector 3) - (wm-size-hints-height hints) (aref vector 4))) - hints))) - -(defun encode-wm-size-hints (hints) - (declare (type wm-size-hints hints)) - (declare (clx-values simple-vector)) - (let ((vector (make-array 18 :initial-element 0)) - (flags 0)) - (declare (type (simple-vector 18) vector) - (type card16 flags)) - (when (wm-size-hints-user-specified-position-p hints) - (setf (ldb (byte 1 0) flags) 1)) - (when (wm-size-hints-user-specified-size-p hints) - (setf (ldb (byte 1 1) flags) 1)) - (when (wm-size-hints-program-specified-position-p hints) - (setf (ldb (byte 1 2) flags) 1)) - (when (wm-size-hints-program-specified-size-p hints) - (setf (ldb (byte 1 3) flags) 1)) - (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints)) - (setf (ldb (byte 1 4) flags) 1 - (aref vector 5) (wm-size-hints-min-width hints) - (aref vector 6) (wm-size-hints-min-height hints))) - (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints)) - (setf (ldb (byte 1 5) flags) 1 - (aref vector 7) (wm-size-hints-max-width hints) - (aref vector 8) (wm-size-hints-max-height hints))) - (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints)) - (setf (ldb (byte 1 6) flags) 1 - (aref vector 9) (wm-size-hints-width-inc hints) - (aref vector 10) (wm-size-hints-height-inc hints))) - (let ((min-aspect (wm-size-hints-min-aspect hints)) - (max-aspect (wm-size-hints-max-aspect hints))) - (when (and min-aspect max-aspect) - (setf (ldb (byte 1 7) flags) 1 - min-aspect (rationalize min-aspect) - max-aspect (rationalize max-aspect) - (aref vector 11) (numerator min-aspect) - (aref vector 12) (denominator min-aspect) - (aref vector 13) (numerator max-aspect) - (aref vector 14) (denominator max-aspect)))) - (when (and (wm-size-hints-base-width hints) - (wm-size-hints-base-height hints)) - (setf (ldb (byte 1 8) flags) 1 - (aref vector 15) (wm-size-hints-base-width hints) - (aref vector 16) (wm-size-hints-base-height hints))) - (when (wm-size-hints-win-gravity hints) - (setf (ldb (byte 1 9) flags) 1 - (aref vector 17) (encode-type - (member-vector *win-gravity-vector*) - (wm-size-hints-win-gravity hints)))) - ;; Obsolete fields - (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) - (unless (wm-size-hints-user-specified-position-p hints) - (setf (ldb (byte 1 2) flags) 1)) - (setf (aref vector 1) (wm-size-hints-x hints) - (aref vector 2) (wm-size-hints-y hints))) - (when (and (wm-size-hints-width hints) (wm-size-hints-height hints)) - (unless (wm-size-hints-user-specified-size-p hints) - (setf (ldb (byte 1 3) flags) 1)) - (setf (aref vector 3) (wm-size-hints-width hints) - (aref vector 4) (wm-size-hints-height hints))) - (setf (aref vector 0) flags) - vector)) - -;;----------------------------------------------------------------------------- -;; Icon_Size - -;; Use the same intermediate structure as WM_SIZE_HINTS - -(defun icon-sizes (window) - (declare (type window window)) - (declare (clx-values wm-size-hints)) - (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector))) - (declare (type (or null (simple-vector 6)) vector)) - (when vector - (make-wm-size-hints - :min-width (aref vector 0) - :min-height (aref vector 1) - :max-width (aref vector 2) - :max-height (aref vector 3) - :width-inc (aref vector 4) - :height-inc (aref vector 5))))) - -(defsetf icon-sizes set-icon-sizes) -(defun set-icon-sizes (window wm-size-hints) - (declare (type window window) - (type wm-size-hints wm-size-hints)) - (let ((vector (vector (wm-size-hints-min-width wm-size-hints) - (wm-size-hints-min-height wm-size-hints) - (wm-size-hints-max-width wm-size-hints) - (wm-size-hints-max-height wm-size-hints) - (wm-size-hints-width-inc wm-size-hints) - (wm-size-hints-height-inc wm-size-hints)))) - (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32) - wm-size-hints)) - -;;----------------------------------------------------------------------------- -;; WM-Protocols - -(defun wm-protocols (window) - (map 'list #'(lambda (id) (atom-name (window-display window) id)) - (get-property window :WM_PROTOCOLS :type :ATOM))) - -(defsetf wm-protocols set-wm-protocols) -(defun set-wm-protocols (window protocols) - (change-property window :WM_PROTOCOLS - (map 'list #'(lambda (atom) (intern-atom (window-display window) atom)) - protocols) - :ATOM 32) - protocols) - -;;----------------------------------------------------------------------------- -;; WM-Colormap-windows - -(defun wm-colormap-windows (window) - (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW - :transform #'(lambda (id) - (lookup-window (window-display window) id))))) - -(defsetf wm-colormap-windows set-wm-colormap-windows) -(defun set-wm-colormap-windows (window colormap-windows) - (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32 - :transform #'window-id) - colormap-windows) - -;;----------------------------------------------------------------------------- -;; Transient-For - -(defun transient-for (window) - (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list))) - (and prop (lookup-window (window-display window) (car prop))))) - -(defsetf transient-for set-transient-for) -(defun set-transient-for (window transient) - (declare (type window window transient)) - (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32) - transient) - -;;----------------------------------------------------------------------------- -;; Set-WM-Properties - -(defun set-wm-properties (window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints zoom-hints - ;; the following are used for wm-normal-hints - (user-specified-position-p nil usppp) - (user-specified-size-p nil usspp) - (program-specified-position-p nil psppp) - (program-specified-size-p nil psspp) - x y width height min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group) - ;; Set properties for WINDOW. - (declare (arglist window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints - ;; the following are used for wm-normal-hints - user-specified-position-p user-specified-size-p - program-specified-position-p program-specified-size-p - min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group)) - (declare (type window window) - (type (or null stringable) name icon-name resource-name resource-class client-machine) - (type (or null list) command) - (type (or null wm-hints) hints) - (type (or null wm-size-hints) normal-hints zoom-hints) - (type boolean user-specified-position-p user-specified-size-p) - (type boolean program-specified-position-p program-specified-size-p) - (type (or null int16) x y) - (type (or null card16) width height min-width min-height max-width max-height width-inc height-inc base-width base-height) - (type (or null win-gravity) win-gravity) - (type (or null number) min-aspect max-aspect) - (type (or null (member :off :on)) input) - (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state) - (type (or null pixmap) icon-pixmap icon-mask) - (type (or null window) icon-window) - (type (or null card16) icon-x icon-y) - (type (or null resource-id) window-group) - (dynamic-extent options)) - (when name (setf (wm-name window) name)) - (when icon-name (setf (wm-icon-name window) icon-name)) - (when client-machine (setf (wm-client-machine window) client-machine)) - (when (or resource-name resource-class) - (set-wm-class window resource-name resource-class)) - (when command (setf (wm-command window) command)) - ;; WM-HINTS - (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window - :icon-x :icon-y :icon-mask :window-group)) - (when (getf options arg) (return t))) - (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints)))) - (when input (setf (wm-hints-input wm-hints) input)) - (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) - (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) - (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) - (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) - (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) - (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) - (when window-group (setf (wm-hints-window-group wm-hints) window-group)) - (setf (wm-hints window) wm-hints)) - (when hints (setf (wm-hints window) hints))) - ;; WM-NORMAL-HINTS - (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height - :width-inc :height-inc :min-aspect :max-aspect - :user-specified-position-p :user-specified-size-p - :program-specified-position-p :program-specified-size-p - :base-width :base-height :win-gravity)) - (when (getf options arg) (return t))) - (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints)))) - (when x (setf (wm-size-hints-x size) x)) - (when y (setf (wm-size-hints-y size) y)) - (when width (setf (wm-size-hints-width size) width)) - (when height (setf (wm-size-hints-height size) height)) - (when min-width (setf (wm-size-hints-min-width size) min-width)) - (when min-height (setf (wm-size-hints-min-height size) min-height)) - (when max-width (setf (wm-size-hints-max-width size) max-width)) - (when max-height (setf (wm-size-hints-max-height size) max-height)) - (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) - (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) - (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) - (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) - (when base-width (setf (wm-size-hints-base-width size) base-width)) - (when base-height (setf (wm-size-hints-base-height size) base-height)) - (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) - (when usppp - (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p)) - (when usspp - (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p)) - (when psppp - (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p)) - (when psspp - (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p)) - (setf (wm-normal-hints window) size)) - (when normal-hints (setf (wm-normal-hints window) normal-hints))) - (when zoom-hints (setf (wm-zoom-hints window) zoom-hints)) - ) - -;;; OBSOLETE -(defun set-standard-properties (window &rest options) - (declare (dynamic-extent options)) - (apply #'set-wm-properties window options)) - -;;----------------------------------------------------------------------------- -;; WM Control - -(defun iconify-window (window screen) - (declare (type window window) - (type screen screen)) - (let ((root (screen-root screen))) - (declare (type window root)) - (send-event root :client-message '(:substructure-redirect :substructure-notify) - :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) - -(defun withdraw-window (window screen) - (declare (type window window) - (type screen screen)) - (unmap-window window) - (let ((root (screen-root screen))) - (declare (type window root)) - (send-event root :unmap-notify '(:substructure-redirect :substructure-notify) - :window window :event-window root :configure-p nil))) - - -;;----------------------------------------------------------------------------- -;; Colormaps - -(def-clx-class (standard-colormap (:copier nil) (:predicate nil)) - (colormap nil :type (or null colormap)) - (base-pixel 0 :type pixel) - (max-color nil :type (or null color)) - (mult-color nil :type (or null color)) - (visual nil :type (or null visual-info)) - (kill nil :type (or (member nil :release-by-freeing-colormap) - drawable gcontext cursor colormap font))) - -(defun rgb-colormaps (window property) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) - (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) - (declare (type (or null simple-vector) prop)) - (when prop - (list (make-standard-colormap - :colormap (lookup-colormap (window-display window) (aref prop 0)) - :base-pixel (aref prop 7) - :max-color (make-color :red (card16->rgb-val (aref prop 1)) - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - :mult-color (make-color :red (card16->rgb-val (aref prop 2)) - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))) - :visual (and (<= 9 (length prop)) - (visual-info (window-display window) (aref prop 8))) - :kill (and (<= 10 (length prop)) - (let ((killid (aref prop 9))) - (if (= killid 1) - :release-by-freeing-colormap - (lookup-resource-id (window-display window) killid))))))))) - -(defsetf rgb-colormaps set-rgb-colormaps) -(defun set-rgb-colormaps (window property maps) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type list maps)) - (let ((prop (make-array (* 10 (length maps)) :element-type 'card32)) - (index -1)) - (dolist (map maps) - (setf (aref prop (incf index)) - (encode-type colormap (standard-colormap-colormap map))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) - (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) - (setf (aref prop (incf index)) - (standard-colormap-base-pixel map)) - (setf (aref prop (incf index)) - (visual-info-id (standard-colormap-visual map))) - (setf (aref prop (incf index)) - (let ((kill (standard-colormap-kill map))) - (etypecase kill - (symbol - (ecase kill - ((nil) 0) - ((:release-by-freeing-colormap) 1))) - (drawable (drawable-id kill)) - (gcontext (gcontext-id kill)) - (cursor (cursor-id kill)) - (colormap (colormap-id kill)) - (font (font-id kill)))))) - (change-property window property prop :RGB_COLOR_MAP 32))) - -;;; OBSOLETE -(defun get-standard-colormap (window property) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) - (declare (clx-values colormap base-pixel max-color mult-color)) - (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) - (declare (type (or null simple-vector) prop)) - (when prop - (values (lookup-colormap (window-display window) (aref prop 0)) - (aref prop 7) ;Base Pixel - (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))))))) - -;;; OBSOLETE -(defun set-standard-colormap (window property colormap base-pixel max-color mult-color) - (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type colormap colormap) - (type pixel base-pixel) - (type color max-color mult-color)) - (let ((prop (vector (encode-type colormap colormap) - (encode-type rgb-val (color-red max-color)) - (encode-type rgb-val (color-red mult-color)) - (encode-type rgb-val (color-green max-color)) - (encode-type rgb-val (color-green mult-color)) - (encode-type rgb-val (color-blue max-color)) - (encode-type rgb-val (color-blue mult-color)) - base-pixel))) - (change-property window property prop :RGB_COLOR_MAP 32))) - -;;----------------------------------------------------------------------------- -;; Cut-Buffers - -(defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string) - (transform #'card8->char) (start 0) end) - ;; Return the contents of cut-buffer BUFFER - (declare (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type array-index start) - (type (or null array-index) end) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) - (declare (clx-values sequence type format bytes-after)) - (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) - (get-property root property :type type :result-type result-type - :start start :end end :transform transform))) - -;; Implement the following: -;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8) -;; (transform #'char->card8) (start 0) end) (data) -;; In order to avoid having to pass positional parameters to set-cut-buffer, -;; We've got to do the following. WHAT A PAIN... -#-clx-ansi-common-lisp -(define-setf-method cut-buffer (display &rest option-list) - (declare (dynamic-extent option-list)) - (do* ((options (copy-list option-list)) - (option options (cddr option)) - (store (gensym)) - (dtemp (gensym)) - (temps (list dtemp)) - (values (list display))) - ((endp option) - (values (nreverse temps) - (nreverse values) - (list store) - `(set-cut-buffer ,store ,dtemp ,@options) - `(cut-buffer ,@options))) - (unless (member (car option) '(:buffer :type :format :start :end :transform)) - (error "Keyword arg ~s isn't recognized" (car option))) - (let ((x (gensym))) - (push x temps) - (push (cadr option) values) - (setf (cadr option) x)))) - -(defun - #+clx-ansi-common-lisp (setf cut-buffer) - #-clx-ansi-common-lisp set-cut-buffer - (data display &key (buffer 0) (type :STRING) (format 8) - (start 0) end (transform #'char->card8)) - (declare (type sequence data) - (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type (member 8 16 32) format) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (integer) t)) transform)) - (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) - (change-property root property data type format :transform transform :start start :end end) - data)) - -(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t)) - ;; Positive rotates left, negative rotates right (opposite of actual protocol request). - ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors. - (declare (type display display) - (type int16 delta) - (type boolean careful-p)) - (let* ((root (screen-root (first (display-roots display)))) - (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 - :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) - (when careful-p - (let ((props (list-properties root))) - (dotimes (i 8) - (unless (member (aref buffers i) props) - (setf (cut-buffer display :buffer i) ""))))) - (rotate-properties root buffers delta))) - diff --git a/clx/ms-patch.uu b/clx/ms-patch.uu deleted file mode 100644 index b84726c5ca763f5ef80b9d49dfdfa2934faa6490..0000000000000000000000000000000000000000 --- a/clx/ms-patch.uu +++ /dev/null @@ -1,57 +0,0 @@ -begin 666 make-sequence-patch.lbin -M1D%33"!&24Q%.@I&05-,('9E<G-I;VX@,"XP,#4@*&]F(#@V,3$Q,BDL($Q/ -M5U1!1R V.# P,"X*1DE,12!)1#H@(B]M;V1S+W!A=&-H97,O8G5G+3(S-C@N -M;&)I;B([('9E<G-I;VX@3D5715-4.PIA=71H;W(@<F]G97([(&-R96%T960@ -M.#<P.#(V(#$W.C(T.C W+@I4:&ES(&9I;&4@:7,@=&AE(&]U='!U="!O9B!T -M:&4@3%5#240L($E.0RX@0V]M;6]N($QI<W @0V]M<&EL97(N"DEN=&5R;F%L -M(&9A<VP@<F5L96%S92!D871E($IU;F4@,C4L(#$Y.#8N"E-/55)#15,Z"B(O -M;6]D<R]P871C:&5S+V)U9RTR,S8X+FQI<W B.R!V97)S:6]N($Y%5T535#L* -M875T:&]R(')O9V5R.R!W<FET=&5N(#@W,#@R-B Q-SHR,SHU,BX*1DQ/050@ -M4$%204U%5$524SH@4F%D:7@Z(#(@4')E8VES:6]N<SH@," P(# @." R,R Q -M-C @," P(# @," P(# *1D5!5%5215,Z( I"24Y!4ED@1$%402!&3TQ,3U=3 -M.@H]* I)3BU004-+04=% 2@%3%5#240Z3"@A5D%,241!5$4M4T51545.0T4M -M4D5354Q4+5194$534$5#.Q@\_0*'#$8 F<0#$8 6<()&P XTZJ 4O#"!N -M__0B;0 18 0B:0 #( D" '# 6<$)$Q@"+'I =FYB1)N<IG$"U( 0J -M;O_\3^[_^"973M-/[O_PL>T %682+6T &0 $*F[__$_N__@F5T[3L>T '6<& -ML>T (682+6T )0 $*F[__$_N__@F5T[3L>T *682+6T +0 $*F[__$_N__@F -M5T[3(&[_]+G(9PX@" ( <, !9@ #^B!N__0O* '0J<O#B\-2'H &B\( -M? $D;0 Q*FH $]S\_^0@;0 !3N@ !4Y>)&T -;7N_^QF &X("[_Z R -M#&<L0J<O#B\-2'H ("\M #DO+O_T? (D;0 ]*FH $]S\_^ @;0 !3N@ !4Y> -M6(\@;O_T(F@ R1M $&UZ0 '9P @B!N__0B: #(FD R1M $&UZ0 '9RQ" -MIR\.+PU(>@ @+RT .2\N__1\ B1M #TJ:@ 3W/S_X"!M %.Z %3EY8CR)N -M__0B:0 #(&D !R)N__0B:0 #(FD R\I <B;O_T(FD R-N_^0 !R)N__0B -M:0 #(FD R-( =/[O_H0J<O#B\-2'H +"!N__0B: #(FD R\I <O+O_P -M? (D;0!%*FH $]S\_^ @;0 !3N@ !4Y>(&[_Y")M $E@!")I ,@"0( <, -M !9P0O#& (L>D !V;F+PE/[O_@N>[_X&<"8%P@;O_DN<AG$" ( @ !PP -M %G!"\,8!(D;0 UM>@ !R1,9P0D; W+PJY[O_<9P)@*D*G+PXO#4AZ " O -M+0 Y+R[_]'P")&T /2IJ !/<_/_4(&T 4[H 5.7D_N_^0@;O_T(F@ R)I -M ,C;O_D <M2 $*F[__$_N__@F5T[3)&T 3;7N_^QF>B N_^@,@ 1F -M$BUM $T !"IN__Q/[O_X)E=.TR N_^@,@ AG*@R #&<B+6[_]/_P -M+6T .?_T? (D;0 ]*FH $R!M %/[O_P3N@ !2!N__0B: #(&D !RU(__1\ -M 21M %$J:@ 3(&T 4_N__1.Z %(&[_[+'M %5G!K'M %EF7B N_^@,@ -M QG+$*G+PXO#4AZ " O+0 Y+R[_]'P")&T /2IJ !/<_/_@(&T 4[H 5. -M7EB/(&[_]")H ,@:0 '+4C_]'P!)&T 42IJ !,@;0 !3^[_]$[H 4O+0!) -M(&[_[")N_^1@!")I ,@"0( <, !9P0D3& (L>D !V;F)$FYRF< (0@ -M+O_H#( (9RQ"IR\.+PU(>@ @+RT .2\N__1\ B1M #TJ:@ 3W/S_W"!M -M %.Z %3EY8CR!N_^RQ[0 59A(M;0 9 0J;O_\3^[_^"973M.Q[0 =9Q:Q -M[0 A9Q M2 $*F[__$_N__@F5T[3+6T )0 $*F[__$_N__@F5T[33^[_Z+GN -M__!G F X0J<O#B\-2'H '"\N__1\ 21M %TJ:@ 3W/S_X"!M %.Z %3EXM -M7__T+6P -__P3^[_\& ^XHM;O_T__ M;0 Y__1\ B1M #TJ:@ 3(&T 4_N -M__!.Z %N>[_\&<"8#1"IR\.+PU(>@ <+R[_]'P!)&T 72IJ !/<_/_H(&T -M 4[H 5.7BU?__0M; W__!@ /LL+6[_]/_P+6T .?_T? (D;0 ]*FH $R!M -M %/[O_P3N@ !?X"!20N* A465!%4U!%0R@))D]05$E/3D%,* M.3U)-04Q) -M6D5$4#A,* 1,25-4* 1.54Q,3"@&5D5#5$]23 $U#"@-4TE-4$Q%+59%0U1/ -M4DPH#5-)35!,12U35%))3D=,*!)324U03$4M,4))5"U614-43U(H$E-)35!, -M12TR0DE4+59%0U1/4B@24TE-4$Q%+31"250M5D5#5$]2*!)324U03$4M.$)) -M5"U614-43U(H$U-)35!,12TQ-D))5"U614-43U(H$U-)35!,12TS,D))5"U6 -M14-43U(H&5-)35!,12U324=.140M.$))5"U614-43U(H&E-)35!,12U324=. -M140M,39"250M5D5#5$]2*!I324U03$4M4TE'3D5$+3,R0DE4+59%0U1/4B@: -M4TE-4$Q%+5-)3D=,12U&3$]!5"U614-43U),* 935%))3D?^"TPH"D))5"U6 -M14-43U),*!%324U03$4M0DE4+59%0U1/4OX,* A315%514Y#12Y,* )/4OX& -M_@@H"TQ)4U0M3$5.1U1(_AHB.7Y3(&ES(&%N(&EN=F%L:60@;W(@=6YR97-O -M;'9A8FQE(')E<W5L="!S97%U96YC92!T>7!E<W!E8R@%15)23U+^!OX".07^ -M"/X6_A?^&/X)_@@H'5-)35!,12U614-43U(M5%E012U&4D]-+45465!%* 5! -M4E)!62@,4TE-4$Q%+4%24D%9* Y.3U)-04Q)6D4M5%E014$*14Y$($]&($9! -(4TP@1$%400I- - -end diff --git a/clx/package.lisp b/clx/package.lisp deleted file mode 100644 index cdfd8b166d745c078bbdfc376ca458633018dbde..0000000000000000000000000000000000000000 --- a/clx/package.lisp +++ /dev/null @@ -1,385 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; -*- - -;;; Copyright 1990 Massachusetts Institute of Technology, Cambridge, -;;; Massachusetts. All Rights Reserved. -;;; -;;; Permission to use, copy, modify, and distribute this software and its -;;; documentation for any purpose and without fee is hereby granted, provided -;;; that the above copyright notice appear in all copies and that both that -;;; copyright notice and this permission notice appear in supporting -;;; documentation, and that the name MIT not be used in advertising or -;;; publicity pertaining to distribution of the software without specific, -;;; written prior permission. - -;;; The CLtL way - -#-clx-ansi-common-lisp -(lisp:in-package :xlib :use '(:lisp)) - -#+(and (or kcl ibcl) (not clx-ansi-common-lisp)) -(shadow - '( - rational - )) - -#+(and CMU (not clx-ansi-common-lisp)) -(shadow '(define-condition)) - -#+(and lispm (not clx-ansi-common-lisp)) -(import - '( - sys:arglist - sys:with-stack-list - sys:with-stack-list* - )) - -#+(and Genera (not clx-ansi-common-lisp)) -(import - '( - future-common-lisp:print-unreadable-object - future-common-lisp:with-standard-io-syntax - zwei:indentation - )) - -#+(and lcl3.0 (not clx-ansi-common-lisp)) -(import - '( - lcl:arglist - lcl:dynamic-extent - lcl:type-error - lucid::type-error-datum - lucid::type-error-expected-type - )) - -#+(and excl (not clx-ansi-common-lisp)) -(import - '( - excl::arglist - excl::dynamic-extent - excl::type-error - excl::type-error-datum - excl::type-error-expected-type - )) - -#+(and allegro (not clx-ansi-common-lisp)) -(import - '( - excl::without-interrupts - )) - -#-clx-ansi-common-lisp -(export - '( - *version* access-control access-error access-hosts - activate-screen-saver add-access-host add-resource add-to-save-set - alist alloc-color alloc-color-cells alloc-color-planes alloc-error - allow-events angle arc-seq array-index atom-error atom-name - bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p - bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image - boole-constant boolean card16 card29 card32 card8 - card8->char change-active-pointer-grab change-keyboard-control - change-keyboard-mapping change-pointer-control change-property - char->card8 char-ascent char-attributes char-descent - char-left-bearing char-right-bearing char-width character->keysyms - character-in-map-p circulate-window-down circulate-window-up clear-area - close-display close-down-mode close-font closed-display color - color-blue color-green color-p color-red color-rgb colormap - colormap-display colormap-equal colormap-error colormap-id colormap-p - colormap-plist colormap-visual-info connection-failure convert-selection - copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components - copy-image copy-plane create-colormap create-cursor - create-gcontext create-glyph-cursor create-image create-pixmap - create-window cursor cursor-display cursor-equal cursor-error - cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error - default-error-handler default-keysym-index default-keysym-translate - define-error define-extension define-gcontext-accessor - define-keysym define-keysym-set delete-property delete-resource - destroy-subwindows destroy-window device-busy device-event-mask - device-event-mask-class discard-current-event discard-font-info display - display-after-function display-authorization-data display-authorization-name - display-bitmap-format display-byte-order display-default-screen - display-display display-error-handler display-finish-output - display-force-output display-host display-image-lsb-first-p - display-invoke-after-function display-keycode-range display-max-keycode - display-max-request-length display-min-keycode display-motion-buffer-size - display-nscreens display-p display-pixmap-formats display-plist - display-protocol-major-version display-protocol-minor-version - display-protocol-version display-release-number - display-report-asynchronous-errors display-resource-id-base - display-resource-id-mask display-roots display-vendor - display-vendor-name display-xdefaults display-xid draw-arc - draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph - draw-image-glyphs draw-line draw-lines draw-point draw-points - draw-rectangle draw-rectangles draw-segments drawable - drawable-border-width drawable-depth drawable-display drawable-equal - drawable-error drawable-height drawable-id drawable-p - drawable-plist drawable-root drawable-width drawable-x drawable-y - error-key event-case event-cond event-handler event-key - event-listen event-mask event-mask-class extension-opcode - find-atom font font-all-chars-exist-p font-ascent - font-default-char font-descent font-direction font-display - font-equal font-error font-id font-max-byte1 font-max-byte2 - font-max-char font-min-byte1 font-min-byte2 font-min-char - font-name font-p font-path font-plist font-properties - font-property fontable force-gcontext-changes free-colormap - free-colors free-cursor free-gcontext free-pixmap gcontext - gcontext-arc-mode gcontext-background - gcontext-cache-p gcontext-cap-style - gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x - gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display - gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule - gcontext-fill-style gcontext-font gcontext-foreground gcontext-function - gcontext-id gcontext-join-style gcontext-key gcontext-line-style - gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist - gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x - gcontext-ts-y get-external-event-code get-image get-property - get-raw-image get-resource get-search-resource get-search-table - get-standard-colormap get-wm-class global-pointer-position grab-button - grab-key grab-keyboard grab-pointer grab-server grab-status - icon-sizes iconify-window id-choice-error illegal-request-error - image image-blue-mask image-depth image-green-mask image-height - image-name image-pixmap image-plist image-red-mask image-width - image-x image-x-hot image-x-p image-xy image-xy-bitmap-list - image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p - image-z-pixarray implementation-error input-focus install-colormap - installed-colormaps int16 int32 int8 intern-atom invalid-font - keyboard-control keyboard-mapping keycode->character keycode->keysym - keysym keysym->character keysym->keycodes keysym-in-map-p - keysym-set kill-client kill-temporary-clients length-error - list-extensions list-font-names list-fonts list-properties - lookup-color lookup-error make-color make-event-handlers - make-event-keys make-event-mask make-resource-database make-state-keys - make-state-mask make-wm-hints make-wm-size-hints map-resource - map-subwindows map-window mapping-notify mask16 mask32 - match-error max-char-ascent max-char-attributes max-char-descent - max-char-left-bearing max-char-right-bearing max-char-width - merge-resources min-char-ascent min-char-attributes min-char-descent - min-char-left-bearing min-char-right-bearing min-char-width - missing-parameter modifier-key modifier-mapping modifier-mask - motion-events name-error no-operation open-display open-font - pixarray pixel pixmap pixmap-display pixmap-equal - pixmap-error pixmap-format pixmap-format-bits-per-pixel - pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad - pixmap-id pixmap-p pixmap-plist point-seq pointer-control - pointer-event-mask pointer-event-mask-class pointer-mapping - pointer-position process-event put-image put-raw-image - query-best-cursor query-best-stipple query-best-tile query-colors - query-extension query-keymap query-pointer query-tree queue-event - read-bitmap-file read-resources recolor-cursor rect-seq - remove-access-host remove-from-save-set reparent-window repeat-seq - reply-length-error reply-timeout request-error reset-screen-saver - resource-database resource-database-timestamp resource-error - resource-id resource-key rgb-colormaps rgb-val root-resources - rotate-cut-buffers rotate-properties screen screen-backing-stores - screen-black-pixel screen-default-colormap screen-depths - screen-event-mask-at-open screen-height screen-height-in-millimeters - screen-max-installed-maps screen-min-installed-maps screen-p - screen-plist screen-root screen-root-depth screen-root-visual - screen-root-visual-info screen-save-unders-p screen-saver - screen-white-pixel screen-width screen-width-in-millimeters seg-seq - selection-owner send-event sequence-error set-access-control - set-close-down-mode set-input-focus set-modifier-mapping - set-pointer-mapping set-screen-saver set-selection-owner - set-standard-colormap set-standard-properties set-wm-class - set-wm-properties set-wm-resources state-keysym-p state-mask-key - store-color store-colors stringable text-extents text-width - timestamp transient-for translate-coordinates translate-default - translation-function type-error undefine-keysym unexpected-reply - ungrab-button ungrab-key ungrab-keyboard ungrab-pointer - ungrab-server uninstall-colormap unknown-error unmap-subwindows - unmap-window value-error visual-info visual-info-bits-per-rgb - visual-info-blue-mask visual-info-class visual-info-colormap-entries - visual-info-display visual-info-green-mask visual-info-id visual-info-p - visual-info-plist visual-info-red-mask warp-pointer - warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside - win-gravity window window-all-event-masks window-background - window-backing-pixel window-backing-planes window-backing-store - window-bit-gravity window-border window-class window-colormap - window-colormap-installed-p window-cursor window-display - window-do-not-propagate-mask window-equal window-error - window-event-mask window-gravity window-id window-map-state - window-override-redirect window-p window-plist window-priority - window-save-under window-visual window-visual-info with-display - with-event-queue with-gcontext with-server-grabbed with-state - withdraw-window wm-client-machine wm-colormap-windows wm-command - wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap - wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y - wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group - wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources - wm-size-hints wm-size-hints-base-height wm-size-hints-base-width - wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect - wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect - wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p - wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p - wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity - wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file - write-resources xatom - )) - - -;;; The ANSI Common Lisp way - -#+(and Genera clx-ansi-common-lisp) -(eval-when (:compile-toplevel :load-toplevel :execute) - (setf *readtable* si:*ansi-common-lisp-readtable*)) - -#+clx-ansi-common-lisp -(common-lisp:in-package :common-lisp-user) - -#+clx-ansi-common-lisp -(defpackage xlib - (:use common-lisp) - (:size 3000) - #+(or kcl ibcl) (:shadow rational) - #+allegro (:use cltl1) - #+allegro (:import-from excl without-interrupts) - #+excl (:import-from excl arglist) - #+Genera (:import-from zwei indentation) - #+lcl3.0 (:import-from lcl arglist) - #+lispm (:import-from lisp char-bit) - #+lispm (:import-from sys arglist with-stack-list with-stack-list*) - (:export - *version* access-control access-error access-hosts - activate-screen-saver add-access-host add-resource add-to-save-set - alist alloc-color alloc-color-cells alloc-color-planes alloc-error - allow-events angle arc-seq array-index atom-error atom-name - bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p - bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image - boole-constant boolean card16 card29 card32 card8 - card8->char change-active-pointer-grab change-keyboard-control - change-keyboard-mapping change-pointer-control change-property - char->card8 char-ascent char-attributes char-descent - char-left-bearing char-right-bearing char-width character->keysyms - character-in-map-p circulate-window-down circulate-window-up clear-area - close-display close-down-mode close-font closed-display color - color-blue color-green color-p color-red color-rgb colormap - colormap-display colormap-equal colormap-error colormap-id colormap-p - colormap-plist colormap-visual-info connection-failure convert-selection - copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components - copy-image copy-plane create-colormap create-cursor - create-gcontext create-glyph-cursor create-image create-pixmap - create-window cursor cursor-display cursor-equal cursor-error - cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error - default-error-handler default-keysym-index default-keysym-translate - define-error define-extension define-gcontext-accessor - define-keysym define-keysym-set delete-property delete-resource - destroy-subwindows destroy-window device-busy device-event-mask - device-event-mask-class discard-current-event discard-font-info display - display-after-function display-authorization-data display-authorization-name - display-bitmap-format display-byte-order display-default-screen - display-display display-error-handler display-finish-output - display-force-output display-host display-image-lsb-first-p - display-invoke-after-function display-keycode-range display-max-keycode - display-max-request-length display-min-keycode display-motion-buffer-size - display-nscreens display-p display-pixmap-formats display-plist - display-protocol-major-version display-protocol-minor-version - display-protocol-version display-release-number - display-report-asynchronous-errors display-resource-id-base - display-resource-id-mask display-roots display-vendor - display-vendor-name display-xdefaults display-xid draw-arc - draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph - draw-image-glyphs draw-line draw-lines draw-point draw-points - draw-rectangle draw-rectangles draw-segments drawable - drawable-border-width drawable-depth drawable-display drawable-equal - drawable-error drawable-height drawable-id drawable-p - drawable-plist drawable-root drawable-width drawable-x drawable-y - error-key event-case event-cond event-handler event-key - event-listen event-mask event-mask-class extension-opcode - find-atom font font-all-chars-exist-p font-ascent - font-default-char font-descent font-direction font-display - font-equal font-error font-id font-max-byte1 font-max-byte2 - font-max-char font-min-byte1 font-min-byte2 font-min-char - font-name font-p font-path font-plist font-properties - font-property fontable force-gcontext-changes free-colormap - free-colors free-cursor free-gcontext free-pixmap gcontext - gcontext-arc-mode gcontext-background - gcontext-cache-p gcontext-cap-style - gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x - gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display - gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule - gcontext-fill-style gcontext-font gcontext-foreground gcontext-function - gcontext-id gcontext-join-style gcontext-key gcontext-line-style - gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist - gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x - gcontext-ts-y get-external-event-code get-image get-property - get-raw-image get-resource get-search-resource get-search-table - get-standard-colormap get-wm-class global-pointer-position grab-button - grab-key grab-keyboard grab-pointer grab-server grab-status - icon-sizes iconify-window id-choice-error illegal-request-error - image image-blue-mask image-depth image-green-mask image-height - image-name image-pixmap image-plist image-red-mask image-width - image-x image-x-hot image-x-p image-xy image-xy-bitmap-list - image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p - image-z-pixarray implementation-error input-focus install-colormap - installed-colormaps int16 int32 int8 intern-atom invalid-font - keyboard-control keyboard-mapping keycode->character keycode->keysym - keysym keysym->character keysym->keycodes keysym-in-map-p - keysym-set kill-client kill-temporary-clients length-error - list-extensions list-font-names list-fonts list-properties - lookup-color lookup-error make-color make-event-handlers - make-event-keys make-event-mask make-resource-database make-state-keys - make-state-mask make-wm-hints make-wm-size-hints map-resource - map-subwindows map-window mapping-notify mask16 mask32 - match-error max-char-ascent max-char-attributes max-char-descent - max-char-left-bearing max-char-right-bearing max-char-width - merge-resources min-char-ascent min-char-attributes min-char-descent - min-char-left-bearing min-char-right-bearing min-char-width - missing-parameter modifier-key modifier-mapping modifier-mask - motion-events name-error no-operation open-display open-font - pixarray pixel pixmap pixmap-display pixmap-equal - pixmap-error pixmap-format pixmap-format-bits-per-pixel - pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad - pixmap-id pixmap-p pixmap-plist point-seq pointer-control - pointer-event-mask pointer-event-mask-class pointer-mapping - pointer-position process-event put-image put-raw-image - query-best-cursor query-best-stipple query-best-tile query-colors - query-extension query-keymap query-pointer query-tree queue-event - read-bitmap-file read-resources recolor-cursor rect-seq - remove-access-host remove-from-save-set reparent-window repeat-seq - reply-length-error reply-timeout request-error reset-screen-saver - resource-database resource-database-timestamp resource-error - resource-id resource-key rgb-colormaps rgb-val root-resources - rotate-cut-buffers rotate-properties screen screen-backing-stores - screen-black-pixel screen-default-colormap screen-depths - screen-event-mask-at-open screen-height screen-height-in-millimeters - screen-max-installed-maps screen-min-installed-maps screen-p - screen-plist screen-root screen-root-depth screen-root-visual - screen-root-visual-info screen-save-unders-p screen-saver - screen-white-pixel screen-width screen-width-in-millimeters seg-seq - selection-owner send-event sequence-error set-access-control - set-close-down-mode set-input-focus set-modifier-mapping - set-pointer-mapping set-screen-saver set-selection-owner - set-standard-colormap set-standard-properties set-wm-class - set-wm-properties set-wm-resources state-keysym-p state-mask-key - store-color store-colors stringable text-extents text-width - timestamp transient-for translate-coordinates translate-default - translation-function undefine-keysym unexpected-reply - ungrab-button ungrab-key ungrab-keyboard ungrab-pointer - ungrab-server uninstall-colormap unknown-error unmap-subwindows - unmap-window value-error visual-info visual-info-bits-per-rgb - visual-info-blue-mask visual-info-class visual-info-colormap-entries - visual-info-display visual-info-green-mask visual-info-id visual-info-p - visual-info-plist visual-info-red-mask warp-pointer - warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside - win-gravity window window-all-event-masks window-background - window-backing-pixel window-backing-planes window-backing-store - window-bit-gravity window-border window-class window-colormap - window-colormap-installed-p window-cursor window-display - window-do-not-propagate-mask window-equal window-error - window-event-mask window-gravity window-id window-map-state - window-override-redirect window-p window-plist window-priority - window-save-under window-visual window-visual-info with-display - with-event-queue with-gcontext with-server-grabbed with-state - withdraw-window wm-client-machine wm-colormap-windows wm-command - wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap - wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y - wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group - wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources - wm-size-hints wm-size-hints-base-height wm-size-hints-base-width - wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect - wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect - wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p - wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p - wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity - wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file - write-resources xatom)) diff --git a/clx/provide.lisp b/clx/provide.lisp deleted file mode 100644 index bf6f3c7a4e0dd3da20eae4ccf8c358d2bb5750fe..0000000000000000000000000000000000000000 --- a/clx/provide.lisp +++ /dev/null @@ -1,56 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; Package: USER; -*- - -;;;; Module definition for CLX - -;;; This file is a Common Lisp Module description, but you will have to edit -;;; it to meet the needs of your site. - -;;; Ideally, this file (or a file that loads this file) should be -;;; located in the system directory that REQUIRE searches. Thus a user -;;; would say -;;; (require :clx) -;;; to load CLX. If there is no such registry, then the user must -;;; put in a site specific -;;; (require :clx <pathname-of-this-file>) -;;; - -#-clx-ansi-common-lisp -(in-package :user) - -#+clx-ansi-common-lisp -(in-package :common-lisp-user) - -#-clx-ansi-common-lisp -(provide :clx) - -(defvar *clx-source-pathname* - (pathname "/src/local/clx/*.l")) - -(defvar *clx-binary-pathname* - (let ((lisp - (or #+lucid "lucid" - #+akcl "akcl" - #+kcl "kcl" - #+ibcl "ibcl" - (error "Can't provide CLX for this lisp."))) - (architecture - (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" - #+(or sun4 sparc) "sparc" - #+(and hp (or mc68000 mc68020)) "hp9000s300" - #+vax "vax" - #+prime "prime" - #+sunrise "sunrise" - #+ibm-rt-pc "ibm-rt-pc" - #+mips "mips" - #+prism "prism" - (error "Can't provide CLX for this architecture.")))) - (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) - -(defvar *compile-clx* - nil) - -(load (merge-pathnames "defsystem" *clx-source-pathname*)) - -(if *compile-clx* - (compile-clx *clx-source-pathname* *clx-binary-pathname*) - (load-clx *clx-binary-pathname*)) diff --git a/clx/requests.lisp b/clx/requests.lisp deleted file mode 100644 index d91ea8f0bb8ba00626ce54925cd3226d6be085c3..0000000000000000000000000000000000000000 --- a/clx/requests.lisp +++ /dev/null @@ -1,1491 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defun create-window (&key - window - (parent (required-arg parent)) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (depth 0) (border-width 0) - (class :copy) (visual :copy) - background border - bit-gravity gravity - backing-store backing-planes backing-pixel save-under - event-mask do-not-propagate-mask override-redirect - colormap cursor) - ;; Display is obtained from parent. Only non-nil attributes are passed on in - ;; the request: the function makes no assumptions about what the actual protocol - ;; defaults are. Width and height are the inside size, excluding border. - (declare (type (or null window) window) - (type window parent) ; required - (type int16 x y) ;required - (type card16 width height) ;required - (type card16 depth border-width) - (type (member :copy :input-output :input-only) class) - (type (or (member :copy) visual-info resource-id) visual) - (type (or null (member :none :parent-relative) pixel pixmap) background) - (type (or null (member :copy) pixel pixmap) border) - (type (or null bit-gravity) bit-gravity) - (type (or null win-gravity) gravity) - (type (or null (member :not-useful :when-mapped :always)) backing-store) - (type (or null pixel) backing-planes backing-pixel) - (type (or null event-mask) event-mask) - (type (or null device-event-mask) do-not-propagate-mask) - (type (or null (member :on :off)) save-under override-redirect) - (type (or null (member :copy) colormap) colormap) - (type (or null (member :none) cursor) cursor)) - (declare (clx-values window)) - (let* ((display (window-display parent)) - (window (or window (make-window :display display))) - (wid (allocate-resource-id display window 'window)) - back-pixmap back-pixel - border-pixmap border-pixel) - (declare (type display display) - (type window window) - (type resource-id wid) - (type (or null resource-id) back-pixmap border-pixmap) - (type (or null pixel) back-pixel border-pixel)) - (setf (window-id window) wid) - (case background - ((nil) nil) - (:none (setq back-pixmap 0)) - (:parent-relative (setq back-pixmap 1)) - (otherwise - (if (type? background 'pixmap) - (setq back-pixmap (pixmap-id background)) - (if (integerp background) - (setq back-pixel background) - (x-type-error background - '(or null (member :none :parent-relative) integer pixmap)))))) - (case border - ((nil) nil) - (:copy (setq border-pixmap 0)) - (otherwise - (if (type? border 'pixmap) - (setq border-pixmap (pixmap-id border)) - (if (integerp border) - (setq border-pixel border) - (x-type-error border '(or null (member :copy) integer pixmap)))))) - (when event-mask - (setq event-mask (encode-event-mask event-mask))) - (when do-not-propagate-mask - (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask))) - - ;Make the request - (with-buffer-request (display *x-createwindow*) - (data depth) - (resource-id wid) - (window parent) - (int16 x y) - (card16 width height border-width) - ((member16 :copy :input-output :input-only) class) - (resource-id (cond ((eq visual :copy) - 0) - ((typep visual 'resource-id) - visual) - (t - (visual-info-id visual)))) - (mask (card32 back-pixmap back-pixel border-pixmap border-pixel) - ((member-vector *bit-gravity-vector*) bit-gravity) - ((member-vector *win-gravity-vector*) gravity) - ((member :not-useful :when-mapped :always) backing-store) - (card32 backing-planes backing-pixel) - ((member :off :on) override-redirect save-under) - (card32 event-mask do-not-propagate-mask) - ((or (member :copy) colormap) colormap) - ((or (member :none) cursor) cursor))) - window)) - -(defun destroy-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) *x-destroywindow*) - (window window))) - -(defun destroy-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) *x-destroysubwindows*) - (window window))) - -(defun add-to-save-set (window) - (declare (type window window)) - (with-buffer-request ((window-display window) *x-changesaveset*) - (data 0) - (window window))) - -(defun remove-from-save-set (window) - (declare (type window window)) - (with-buffer-request ((window-display window) *x-changesaveset*) - (data 1) - (window window))) - -(defun reparent-window (window parent x y) - (declare (type window window parent) - (type int16 x y)) - (with-buffer-request ((window-display window) *x-reparentwindow*) - (window window parent) - (int16 x y))) - -(defun map-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) *x-mapwindow*) - (window window))) - -(defun map-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) *x-mapsubwindows*) - (window window))) - -(defun unmap-window (window) - (declare (type window window)) - (with-buffer-request ((window-display window) *x-unmapwindow*) - (window window))) - -(defun unmap-subwindows (window) - (declare (type window window)) - (with-buffer-request ((window-display window) *x-unmapsubwindows*) - (window window))) - -(defun circulate-window-up (window) - (declare (type window window)) - (with-buffer-request ((window-display window) *x-circulatewindow*) - (data 0) - (window window))) - -(defun circulate-window-down (window) - (declare (type window window)) - (with-buffer-request ((window-display window) *x-circulatewindow*) - (data 1) - (window window))) - -(defun query-tree (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;;type specifier - (declare (clx-values (clx-sequence window) parent root)) - (let ((display (window-display window))) - (multiple-value-bind (root parent sequence) - (with-buffer-request-and-reply (display *x-querytree* nil :sizes (8 16 32)) - ((window window)) - (values - (window-get 8) - (resource-id-get 12) - (sequence-get :length (card16-get 16) :result-type result-type - :index *replysize*))) - ;; Parent is NIL for root window - (setq parent (and (plusp parent) (lookup-window display parent))) - (dotimes (i (length sequence)) ; Convert ID's to window's - (setf (elt sequence i) (lookup-window display (elt sequence i)))) - (values sequence parent root)))) - -;; Although atom-ids are not visible in the normal user interface, atom-ids might -;; appear in window properties and other user data, so conversion hooks are needed. - -(defun intern-atom (display name) - (declare (type display display) - (type xatom name)) - (declare (clx-values resource-id)) - (let ((name (if (or (null name) (keywordp name)) - name - (kintern (string name))))) - (declare (type symbol name)) - (or (atom-id name display) - (let ((string (symbol-name name))) - (declare (type string string)) - (multiple-value-bind (id) - (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32) - ((data 0) - (card16 (length string)) - (pad16 nil) - (string string)) - (values - (resource-id-get 8))) - (declare (type resource-id id)) - (setf (atom-id name display) id) - id))))) - -(defun find-atom (display name) - ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True - (declare (type display display) - (type xatom name)) - (declare (clx-values (or null resource-id))) - (let ((name (if (or (null name) (keywordp name)) - name - (kintern (string name))))) - (declare (type symbol name)) - (or (atom-id name display) - (let ((string (symbol-name name))) - (declare (type string string)) - (multiple-value-bind (id) - (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32) - ((data 1) - (card16 (length string)) - (pad16 nil) - (string string)) - (values - (or-get 8 null resource-id))) - (declare (type (or null resource-id) id)) - (when id - (setf (atom-id name display) id)) - id))))) - -(defun atom-name (display atom-id) - (declare (type display display) - (type resource-id atom-id)) - (declare (clx-values keyword)) - (if (zerop atom-id) - nil - (or (id-atom atom-id display) - (let ((keyword - (kintern - (with-buffer-request-and-reply - (display *x-getatomname* nil :sizes (16)) - ((resource-id atom-id)) - (values - (string-get (card16-get 8) *replysize*)))))) - (declare (type keyword keyword)) - (setf (atom-id keyword display) atom-id) - keyword)))) - -;;; For binary compatibility with older code -(defun lookup-xatom (display atom-id) - (declare (type display display) - (type resource-id atom-id)) - (atom-name display atom-id)) - -(defun change-property (window property data type format - &key (mode :replace) (start 0) end transform) - ; Start and end affect sub-sequence extracted from data. - ; Transform is applied to each extracted element. - (declare (type window window) - (type xatom property type) - (type (member 8 16 32) format) - (type sequence data) - (type (member :replace :prepend :append) mode) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (t) integer)) transform)) - (unless end (setq end (length data))) - (let* ((display (window-display window)) - (length (index- end start)) - (property-id (intern-atom display property)) - (type-id (intern-atom display type))) - (declare (type display display) - (type array-index length) - (type resource-id property-id type-id)) - (with-buffer-request (display *x-changeproperty*) - ((data (member :replace :prepend :append)) mode) - (window window) - (resource-id property-id type-id) - (card8 format) - (card32 length) - (progn - (ecase format - (8 (sequence-put 24 data :format card8 - :start start :end end :transform transform)) - (16 (sequence-put 24 data :format card16 - :start start :end end :transform transform)) - (32 (sequence-put 24 data :format card32 - :start start :end end :transform transform))))))) - -(defun delete-property (window property) - (declare (type window window) - (type xatom property)) - (let* ((display (window-display window)) - (property-id (intern-atom display property))) - (declare (type display display) - (type resource-id property-id)) - (with-buffer-request (display *x-deleteproperty*) - (window window) - (resource-id property-id)))) - -(defun get-property (window property - &key type (start 0) end delete-p (result-type 'list) transform) - ;; Transform is applied to each integer retrieved. - (declare (type window window) - (type xatom property) - (type (or null xatom) type) - (type array-index start) - (type (or null array-index) end) - (type boolean delete-p) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) - (declare (clx-values data (or null type) format bytes-after)) - (let* ((display (window-display window)) - (property-id (intern-atom display property)) - (type-id (and type (intern-atom display type)))) - (declare (type display display) - (type resource-id property-id) - (type (or null resource-id) type-id)) - (multiple-value-bind (reply-format reply-type bytes-after data) - (with-buffer-request-and-reply (display *x-getproperty* nil :sizes (8 32)) - (((data boolean) delete-p) - (window window) - (resource-id property-id) - ((or null resource-id) type-id) - (card32 start) - (card32 (index- (or end 64000) start))) - (let ((reply-format (card8-get 1)) - (reply-type (card32-get 8)) - (bytes-after (card32-get 12)) - (nitems (card32-get 16))) - (values - reply-format - reply-type - bytes-after - (and (plusp nitems) - (ecase reply-format - (0 nil) ;; (make-sequence result-type 0) ;; Property not found. - (8 (sequence-get :result-type result-type :format card8 - :length nitems :transform transform - :index *replysize*)) - (16 (sequence-get :result-type result-type :format card16 - :length nitems :transform transform - :index *replysize*)) - (32 (sequence-get :result-type result-type :format card32 - :length nitems :transform transform - :index *replysize*))))))) - (values data - (and (plusp reply-type) (atom-name display reply-type)) - reply-format - bytes-after)))) - -(defun rotate-properties (window properties &optional (delta 1)) - ;; Positive rotates left, negative rotates right (opposite of actual protocol request). - (declare (type window window) - (type sequence properties) ;; sequence of xatom - (type int16 delta)) - (let* ((display (window-display window)) - (length (length properties)) - (sequence (make-array length))) - (declare (type display display) - (type array-index length)) - (with-vector (sequence vector) - ;; Atoms must be interned before the RotateProperties request - ;; is started to allow InternAtom requests to be made. - (dotimes (i length) - (setf (aref sequence i) (intern-atom display (elt properties i)))) - (with-buffer-request (display *x-rotateproperties*) - (window window) - (card16 length) - (int16 (- delta)) - ((sequence :end length) sequence)))) - nil) - -(defun list-properties (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;; a sequence type - (declare (clx-values (clx-sequence keyword))) - (let ((display (window-display window))) - (multiple-value-bind (seq) - (with-buffer-request-and-reply (display *x-listproperties* nil :sizes 16) - ((window window)) - (values - (sequence-get :result-type result-type :length (card16-get 8) - :index *replysize*))) - ;; lookup the atoms in the sequence - (if (listp seq) - (do ((elt seq (cdr elt))) - ((endp elt) seq) - (setf (car elt) (atom-name display (car elt)))) - (dotimes (i (length seq) seq) - (setf (aref seq i) (atom-name display (aref seq i)))))))) - -(defun selection-owner (display selection) - (declare (type display display) - (type xatom selection)) - (declare (clx-values (or null window))) - (let ((selection-id (intern-atom display selection))) - (declare (type resource-id selection-id)) - (multiple-value-bind (window) - (with-buffer-request-and-reply (display *x-getselectionowner* 12 :sizes 32) - ((resource-id selection-id)) - (values - (resource-id-or-nil-get 8))) - (and window (lookup-window display window))))) - -(defun set-selection-owner (display selection owner &optional time) - (declare (type display display) - (type xatom selection) - (type (or null window) owner) - (type timestamp time)) - (let ((selection-id (intern-atom display selection))) - (declare (type resource-id selection-id)) - (with-buffer-request (display *x-setselectionowner*) - ((or null window) owner) - (resource-id selection-id) - ((or null card32) time)) - owner)) - -(defsetf selection-owner (display selection &optional time) (owner) - ;; A bit strange, but retains setf form. - `(set-selection-owner ,display ,selection ,owner ,time)) - -(defun convert-selection (selection type requestor &optional property time) - (declare (type xatom selection type) - (type window requestor) - (type (or null xatom) property) - (type timestamp time)) - (let* ((display (window-display requestor)) - (selection-id (intern-atom display selection)) - (type-id (intern-atom display type)) - (property-id (and property (intern-atom display property)))) - (declare (type display display) - (type resource-id selection-id type-id) - (type (or null resource-id) property-id)) - (with-buffer-request (display *x-convertselection*) - (window requestor) - (resource-id selection-id type-id) - ((or null resource-id) property-id) - ((or null card32) time)))) - -(defun send-event (window event-key event-mask &rest args - &key propagate-p display &allow-other-keys) - ;; Additional arguments depend on event-key, and are as specified further below - ;; with declare-event, except that both resource-ids and resource objects are - ;; accepted in the event components. The display argument is only required if the - ;; window is :pointer-window or :input-focus. - (declare (type (or window (member :pointer-window :input-focus)) window) - (type event-key event-key) - (type (or null event-mask) event-mask) - (type boolean propagate-p) - (type (or null display) display) - (dynamic-extent args)) - (unless event-mask (setq event-mask 0)) - (unless display (setq display (window-display window))) - (let ((internal-event-code (get-event-code event-key)) - (external-event-code (get-external-event-code display event-key))) - (declare (type card8 internal-event-code external-event-code)) - ;; Ensure keyword atom-id's are cached - (dolist (arg (cdr (assoc event-key '((:property-notify :atom) - (:selection-clear :selection) - (:selection-request :selection :target :property) - (:selection-notify :selection :target :property) - (:client-message :type)) - :test #'eq))) - (let ((keyword (getf args arg))) - (intern-atom display keyword))) - ;; Make the sendevent request - (with-buffer-request (display *x-sendevent*) - ((data boolean) propagate-p) - (length 11) ;; 3 word request + 8 words for event = 11 - ((or (member :pointer-window :input-focus) window) window) - (card32 (encode-event-mask event-mask)) - (card8 external-event-code) - (progn - (apply (svref *event-send-vector* internal-event-code) display args) - (setf (buffer-boffset display) (index+ buffer-boffset 44)))))) - -(defun grab-pointer (window event-mask - &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) - (declare (type window window) - (type pointer-event-mask event-mask) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor) - (type timestamp time)) - (declare (clx-values grab-status)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display *x-grabpointer* nil :sizes 8) - (((data boolean) owner-p) - (window window) - (card16 (encode-pointer-event-mask event-mask)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)) - ((or null window) confine-to) - ((or null cursor) cursor) - ((or null card32) time)) - (values - (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) - -(defun ungrab-pointer (display &key time) - (declare (type timestamp time)) - (with-buffer-request (display *x-ungrabpointer*) - ((or null card32) time))) - -(defun grab-button (window button event-mask - &key (modifiers 0) - owner-p sync-pointer-p sync-keyboard-p confine-to cursor) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers) - (type pointer-event-mask event-mask) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor)) - (with-buffer-request ((window-display window) *x-grabbutton*) - ((data boolean) owner-p) - (window window) - (card16 (encode-pointer-event-mask event-mask)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)) - ((or null window) confine-to) - ((or null cursor) cursor) - (card8 (if (eq button :any) 0 button)) - (pad8 1) - (card16 (encode-modifier-mask modifiers)))) - -(defun ungrab-button (window button &key (modifiers 0)) - (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) *x-ungrabbutton*) - (data (if (eq button :any) 0 button)) - (window window) - (card16 (encode-modifier-mask modifiers)))) - -(defun change-active-pointer-grab (display event-mask &optional cursor time) - (declare (type display display) - (type pointer-event-mask event-mask) - (type (or null cursor) cursor) - (type timestamp time)) - (with-buffer-request (display *x-changeactivepointergrab*) - ((or null cursor) cursor) - ((or null card32) time) - (card16 (encode-pointer-event-mask event-mask)))) - -(defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time) - (declare (type window window) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type timestamp time)) - (declare (clx-values grab-status)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display *x-grabkeyboard* nil :sizes 8) - (((data boolean) owner-p) - (window window) - ((or null card32) time) - (boolean (not sync-pointer-p) (not sync-keyboard-p))) - (values - (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) - -(defun ungrab-keyboard (display &key time) - (declare (type display display) - (type timestamp time)) - (with-buffer-request (display *x-ungrabkeyboard*) - ((or null card32) time))) - -(defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) - (declare (type window window) - (type boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or (member :any) card8) key) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) *x-grabkey*) - ((data boolean) owner-p) - (window window) - (card16 (encode-modifier-mask modifiers)) - (card8 (if (eq key :any) 0 key)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)))) - -(defun ungrab-key (window key &key (modifiers 0)) - (declare (type window window) - (type (or (member :any) card8) key) - (type modifier-mask modifiers)) - (with-buffer-request ((window-display window) *x-ungrabkey*) - (data (if (eq key :any) 0 key)) - (window window) - (card16 (encode-modifier-mask modifiers)))) - -(defun allow-events (display mode &optional time) - (declare (type display display) - (type (member :async-pointer :sync-pointer :replay-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both) - mode) - (type timestamp time)) - (with-buffer-request (display *x-allowevents*) - ((data (member :async-pointer :sync-pointer :replay-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both)) - mode) - ((or null card32) time))) - -(defun grab-server (display) - (declare (type display display)) - (with-buffer-request (display *x-grabserver*))) - -(defun ungrab-server (display) - (with-buffer-request (display *x-ungrabserver*))) - -(defmacro with-server-grabbed ((display) &body body) - ;; The body is not surrounded by a with-display. - (let ((disp (if (symbolp display) display (gensym)))) - `(let ((,disp ,display)) - (declare (type display ,disp)) - (unwind-protect - (progn - (grab-server ,disp) - ,@body) - (ungrab-server ,disp))))) - -(defun query-pointer (window) - (declare (type window window)) - (declare (clx-values x y same-screen-p child mask root-x root-y root)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display *x-querypointer* 26 :sizes (8 16 32)) - ((window window)) - (values - (int16-get 20) - (int16-get 22) - (boolean-get 1) - (or-get 12 null window) - (card16-get 24) - (int16-get 16) - (int16-get 18) - (window-get 8))))) - -(defun pointer-position (window) - (declare (type window window)) - (declare (clx-values x y same-screen-p)) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display *x-querypointer* 24 :sizes (8 16)) - ((window window)) - (values - (int16-get 20) - (int16-get 22) - (boolean-get 1))))) - -(defun global-pointer-position (display) - (declare (type display display)) - (declare (clx-values root-x root-y root)) - (with-buffer-request-and-reply (display *x-querypointer* 20 :sizes (16 32)) - ((window (screen-root (first (display-roots display))))) - (values - (int16-get 16) - (int16-get 18) - (window-get 8)))) - -(defun motion-events (window &key start stop (result-type 'list)) - (declare (type window window) - (type timestamp start stop) - (type t result-type)) ;; a type specifier - (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time)))) - (let ((display (window-display window))) - (with-buffer-request-and-reply (display *x-getmotionevents* nil :sizes 32) - ((window window) - ((or null card32) start stop)) - (values - (sequence-get :result-type result-type :length (index* (card32-get 8) 3) - :index *replysize*))))) - -(defun translate-coordinates (src src-x src-y dst) - ;; Returns NIL when not on the same screen - (declare (type window src) - (type int16 src-x src-y) - (type window dst)) - (declare (clx-values dst-x dst-y child)) - (let ((display (window-display src))) - (with-buffer-request-and-reply (display *x-translatecoords* 16 :sizes (8 16 32)) - ((window src dst) - (int16 src-x src-y)) - (and (boolean-get 1) - (values - (int16-get 12) - (int16-get 14) - (or-get 8 null window)))))) - -(defun warp-pointer (dst dst-x dst-y) - (declare (type window dst) - (type int16 dst-x dst-y)) - (with-buffer-request ((window-display dst) *x-warppointer*) - (resource-id 0) ;; None - (window dst) - (int16 0 0) - (card16 0 0) - (int16 dst-x dst-y))) - -(defun warp-pointer-relative (display x-off y-off) - (declare (type display display) - (type int16 x-off y-off)) - (with-buffer-request (display *x-warppointer*) - (resource-id 0) ;; None - (resource-id 0) ;; None - (int16 0 0) - (card16 0 0) - (int16 x-off y-off))) - -(defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. - ;; A null src-width or src-height translates into a zero value in the protocol request. - (declare (type window dst src) - (type int16 dst-x dst-y src-x src-y) - (type (or null card16) src-width src-height)) - (unless (or (eql src-width 0) (eql src-height 0)) - (with-buffer-request ((window-display dst) *x-warppointer*) - (window src dst) - (int16 src-x src-y) - (card16 (or src-width 0) (or src-height 0)) - (int16 dst-x dst-y)))) - -(defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y - &optional src-width src-height) - ;; Passing in a zero src-width or src-height is a no-op. - ;; A null src-width or src-height translates into a zero value in the protocol request. - (declare (type window src) - (type int16 x-off y-off src-x src-y) - (type (or null card16) src-width src-height)) - (unless (or (eql src-width 0) (eql src-height 0)) - (with-buffer-request ((window-display src) *x-warppointer*) - (window src) - (resource-id 0) ;; None - (int16 src-x src-y) - (card16 (or src-width 0) (or src-height 0)) - (int16 x-off y-off)))) - -(defun set-input-focus (display focus revert-to &optional time) - (declare (type display display) - (type (or (member :none :pointer-root) window) focus) - (type (member :none :pointer-root :parent) revert-to) - (type timestamp time)) - (with-buffer-request (display *x-setinputfocus*) - ((data (member :none :pointer-root :parent)) revert-to) - ((or window (member :none :pointer-root)) focus) - ((or null card32) time))) - -(defun input-focus (display) - (declare (type display display)) - (declare (clx-values focus revert-to)) - (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32)) - () - (values - (or-get 8 (member :none :pointer-root) window) - (member8-get 1 :none :pointer-root :parent)))) - -(defun query-keymap (display &optional bit-vector) - (declare (type display display) - (type (or null (bit-vector 256)) bit-vector)) - (declare (clx-values (bit-vector 256))) - (with-buffer-request-and-reply (display *x-querykeymap* 40 :sizes 8) - () - (values - (bit-vector256-get 8 8 bit-vector)))) - -(defun create-pixmap (&key - pixmap - (width (required-arg width)) - (height (required-arg height)) - (depth (required-arg depth)) - (drawable (required-arg drawable))) - (declare (type (or null pixmap) pixmap) - (type card8 depth) ;; required - (type card16 width height) ;; required - (type drawable drawable)) ;; required - (declare (clx-values pixmap)) - (let* ((display (drawable-display drawable)) - (pixmap (or pixmap (make-pixmap :display display))) - (pid (allocate-resource-id display pixmap 'pixmap))) - (setf (pixmap-id pixmap) pid) - (with-buffer-request (display *x-createpixmap*) - (data depth) - (resource-id pid) - (drawable drawable) - (card16 width height)) - pixmap)) - -(defun free-pixmap (pixmap) - (declare (type pixmap pixmap)) - (let ((display (pixmap-display pixmap))) - (with-buffer-request (display *x-freepixmap*) - (pixmap pixmap)) - (deallocate-resource-id display (pixmap-id pixmap) 'pixmap))) - -(defun clear-area (window &key (x 0) (y 0) width height exposures-p) - ;; Passing in a zero width or height is a no-op. - ;; A null width or height translates into a zero value in the protocol request. - (declare (type window window) - (type int16 x y) - (type (or null card16) width height) - (type boolean exposures-p)) - (unless (or (eql width 0) (eql height 0)) - (with-buffer-request ((window-display window) *x-cleartobackground*) - ((data boolean) exposures-p) - (window window) - (int16 x y) - (card16 (or width 0) (or height 0))))) - -(defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height)) - (with-buffer-request ((drawable-display src) *x-copyarea* :gc-force gcontext) - (drawable src dst) - (gcontext gcontext) - (int16 src-x src-y dst-x dst-y) - (card16 width height))) - -(defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y) - (declare (type drawable src dst) - (type gcontext gcontext) - (type pixel plane) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height)) - (with-buffer-request ((drawable-display src) *x-copyplane* :gc-force gcontext) - (drawable src dst) - (gcontext gcontext) - (int16 src-x src-y dst-x dst-y) - (card16 width height) - (card32 plane))) - -(defun create-colormap (visual-info window &optional alloc-p) - (declare (type (or visual-info resource-id) visual-info) - (type window window) - (type boolean alloc-p)) - (declare (clx-values colormap)) - (let ((display (window-display window))) - (when (typep visual-info 'resource-id) - (setf visual-info (visual-info display visual-info))) - (let* ((colormap (make-colormap :display display :visual-info visual-info)) - (id (allocate-resource-id display colormap 'colormap))) - (setf (colormap-id colormap) id) - (with-buffer-request (display *x-createcolormap*) - ((data boolean) alloc-p) - (card29 id) - (window window) - (card29 (visual-info-id visual-info))) - colormap))) - -(defun free-colormap (colormap) - (declare (type colormap colormap)) - (let ((display (colormap-display colormap))) - (with-buffer-request (display *x-freecolormap*) - (colormap colormap)) - (deallocate-resource-id display (colormap-id colormap) 'colormap))) - -(defun copy-colormap-and-free (colormap) - (declare (type colormap colormap)) - (declare (clx-values colormap)) - (let* ((display (colormap-display colormap)) - (new-colormap (make-colormap :display display - :visual-info (colormap-visual-info colormap))) - (id (allocate-resource-id display new-colormap 'colormap))) - (setf (colormap-id new-colormap) id) - (with-buffer-request (display *x-copycolormapandfree*) - (resource-id id) - (colormap colormap)) - new-colormap)) - -(defun install-colormap (colormap) - (declare (type colormap colormap)) - (with-buffer-request ((colormap-display colormap) *x-installcolormap*) - (colormap colormap))) - -(defun uninstall-colormap (colormap) - (declare (type colormap colormap)) - (with-buffer-request ((colormap-display colormap) *x-uninstallcolormap*) - (colormap colormap))) - -(defun installed-colormaps (window &key (result-type 'list)) - (declare (type window window) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence colormap))) - (let ((display (window-display window))) - (flet ((get-colormap (id) - (lookup-colormap display id))) - (with-buffer-request-and-reply (display *x-listinstalledcolormaps* nil :sizes 16) - ((window window)) - (values - (sequence-get :result-type result-type :length (card16-get 8) - :transform #'get-colormap :index *replysize*)))))) - -(defun alloc-color (colormap color) - (declare (type colormap colormap) - (type (or stringable color) color)) - (declare (clx-values pixel screen-color exact-color)) - (let ((display (colormap-display colormap))) - (etypecase color - (color - (with-buffer-request-and-reply (display *x-alloccolor* 20 :sizes (16 32)) - ((colormap colormap) - (rgb-val (color-red color) - (color-green color) - (color-blue color)) - (pad16 nil)) - (values - (card32-get 16) - (make-color :red (rgb-val-get 8) - :green (rgb-val-get 10) - :blue (rgb-val-get 12)) - color))) - (stringable - (let* ((string (string color)) - (length (length string))) - (with-buffer-request-and-reply (display *x-allocnamedcolor* 24 :sizes (16 32)) - ((colormap colormap) - (card16 length) - (pad16 nil) - (string string)) - (values - (card32-get 8) - (make-color :red (rgb-val-get 18) - :green (rgb-val-get 20) - :blue (rgb-val-get 22)) - (make-color :red (rgb-val-get 12) - :green (rgb-val-get 14) - :blue (rgb-val-get 16))))))))) - -(defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors planes) - (type boolean contiguous-p) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence pixel) (clx-sequence mask))) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display *x-alloccolorcells* nil :sizes 16) - (((data boolean) contiguous-p) - (colormap colormap) - (card16 colors planes)) - (let ((pixel-length (card16-get 8)) - (mask-length (card16-get 10))) - (values - (sequence-get :result-type result-type :length pixel-length :index *replysize*) - (sequence-get :result-type result-type :length mask-length - :index (index+ *replysize* (index* pixel-length 4)))))))) - -(defun alloc-color-planes (colormap colors - &key (reds 0) (greens 0) (blues 0) - contiguous-p (result-type 'list)) - (declare (type colormap colormap) - (type card16 colors reds greens blues) - (type boolean contiguous-p) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask)) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display *x-alloccolorplanes* nil :sizes (16 32)) - (((data boolean) contiguous-p) - (colormap colormap) - (card16 colors reds greens blues)) - (let ((red-mask (card32-get 12)) - (green-mask (card32-get 16)) - (blue-mask (card32-get 20))) - (values - (sequence-get :result-type result-type :length (card16-get 8) :index *replysize*) - red-mask green-mask blue-mask))))) - -(defun free-colors (colormap pixels &optional (plane-mask 0)) - (declare (type colormap colormap) - (type sequence pixels) ;; Sequence of integers - (type pixel plane-mask)) - (with-buffer-request ((colormap-display colormap) *x-freecolors*) - (colormap colormap) - (card32 plane-mask) - (sequence pixels))) - -(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t)) - (declare (type colormap colormap) - (type pixel pixel) - (type (or stringable color) spec) - (type boolean red-p green-p blue-p)) - (let ((display (colormap-display colormap)) - (flags 0)) - (declare (type display display) - (type card8 flags)) - (when red-p (setq flags 1)) - (when green-p (incf flags 2)) - (when blue-p (incf flags 4)) - (etypecase spec - (color - (with-buffer-request (display *x-storecolors*) - (colormap colormap) - (card32 pixel) - (rgb-val (color-red spec) - (color-green spec) - (color-blue spec)) - (card8 flags) - (pad8 nil))) - (stringable - (let* ((string (string spec)) - (length (length string))) - (with-buffer-request (display *x-storenamedcolor*) - ((data card8) flags) - (colormap colormap) - (card32 pixel) - (card16 length) - (pad16 nil) - (string string))))))) - -(defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t)) - ;; If stringables are specified for colors, it is unspecified whether all - ;; stringables are first resolved and then a single StoreColors protocol request is - ;; issued, or whether multiple StoreColors protocol requests are issued. - (declare (type colormap colormap) - (type sequence specs) - (type boolean red-p green-p blue-p)) - (etypecase specs - (list - (do ((spec specs (cddr spec))) - ((endp spec)) - (store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p))) - (vector - (do ((i 0 (+ i 2)) - (len (length specs))) - ((>= i len)) - (store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p))))) - -(defun query-colors (colormap pixels &key (result-type 'list)) - (declare (type colormap colormap) - (type sequence pixels) ;; sequence of integer - (type t result-type)) ;; a type specifier - (declare (clx-values (clx-sequence color))) - (let ((display (colormap-display colormap))) - (with-buffer-request-and-reply (display *x-querycolors* nil :sizes (8 16)) - ((colormap colormap) - (sequence pixels)) - (let ((sequence (make-sequence result-type (card16-get 8)))) - (advance-buffer-offset *replysize*) - (dotimes (i (length sequence) sequence) - (setf (elt sequence i) - (make-color :red (rgb-val-get 0) - :green (rgb-val-get 2) - :blue (rgb-val-get 4))) - (advance-buffer-offset 8)))))) - -(defun lookup-color (colormap name) - (declare (type colormap colormap) - (type stringable name)) - (declare (clx-values screen-color true-color)) - (let* ((display (colormap-display colormap)) - (string (string name)) - (length (length string))) - (with-buffer-request-and-reply (display *x-lookupcolor* 20 :sizes 16) - ((colormap colormap) - (card16 length) - (pad16 nil) - (string string)) - (values - (make-color :red (rgb-val-get 14) - :green (rgb-val-get 16) - :blue (rgb-val-get 18)) - (make-color :red (rgb-val-get 8) - :green (rgb-val-get 10) - :blue (rgb-val-get 12)))))) - -(defun create-cursor (&key - (source (required-arg source)) - mask - (x (required-arg x)) - (y (required-arg y)) - (foreground (required-arg foreground)) - (background (required-arg background))) - (declare (type pixmap source) ;; required - (type (or null pixmap) mask) - (type card16 x y) ;; required - (type (or null color) foreground background)) ;; required - (declare (clx-values cursor)) - (let* ((display (pixmap-display source)) - (cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor))) - (setf (cursor-id cursor) cid) - (with-buffer-request (display *x-createcursor*) - (resource-id cid) - (pixmap source) - ((or null pixmap) mask) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background)) - (card16 x y)) - cursor)) - -(defun create-glyph-cursor (&key - (source-font (required-arg source-font)) - (source-char (required-arg source-char)) - mask-font - mask-char - (foreground (required-arg foreground)) - (background (required-arg background))) - (declare (type font source-font) ;; Required - (type card16 source-char) ;; Required - (type (or null font) mask-font) - (type (or null card16) mask-char) - (type color foreground background)) ;; required - (declare (clx-values cursor)) - (let* ((display (font-display source-font)) - (cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor)) - (source-font-id (font-id source-font)) - (mask-font-id (if mask-font (font-id mask-font) 0))) - (setf (cursor-id cursor) cid) - (unless mask-char (setq mask-char 0)) - (with-buffer-request (display *x-createglyphcursor*) - (resource-id cid source-font-id mask-font-id) - (card16 source-char) - (card16 mask-char) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background))) - cursor)) - -(defun free-cursor (cursor) - (declare (type cursor cursor)) - (let ((display (cursor-display cursor))) - (with-buffer-request (display *x-freecursor*) - (cursor cursor)) - (deallocate-resource-id display (cursor-id cursor) 'cursor))) - -(defun recolor-cursor (cursor foreground background) - (declare (type cursor cursor) - (type color foreground background)) - (with-buffer-request ((cursor-display cursor) *x-recolorcursor*) - (cursor cursor) - (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) - (rgb-val (color-red background) - (color-green background) - (color-blue background)) - )) - -(defun query-best-cursor (width height drawable) - (declare (type card16 width height) - (type (or drawable display) drawable)) - (declare (clx-values width height)) - ;; Drawable can be a display for compatibility. - (multiple-value-bind (display drawable) - (if (type? drawable 'drawable) - (values (drawable-display drawable) drawable) - (values drawable (screen-root (display-default-screen drawable)))) - (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16) - ((data 0) - (window drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-best-tile (width height drawable) - (declare (type card16 width height) - (type drawable drawable)) - (declare (clx-values width height)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16) - ((data 1) - (drawable drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-best-stipple (width height drawable) - (declare (type card16 width height) - (type drawable drawable)) - (declare (clx-values width height)) - (let ((display (drawable-display drawable))) - (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16) - ((data 2) - (drawable drawable) - (card16 width height)) - (values - (card16-get 8) - (card16-get 10))))) - -(defun query-extension (display name) - (declare (type display display) - (type stringable name)) - (declare (clx-values major-opcode first-event first-error)) - (let ((string (string name))) - (with-buffer-request-and-reply (display *x-queryextension* 12 :sizes 8) - ((card16 (length string)) - (pad16 nil) - (string string)) - (and (boolean-get 8) ;; If present - (values - (card8-get 9) - (card8-get 10) - (card8-get 11)))))) - -(defun list-extensions (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence string))) - (with-buffer-request-and-reply (display *x-listextensions* size :sizes 8) - () - (values - (read-sequence-string - buffer-bbuf (index- size *replysize*) (card8-get 1) result-type *replysize*)))) - -(defun change-keyboard-control (display &key key-click-percent - bell-percent bell-pitch bell-duration - led led-mode key auto-repeat-mode) - (declare (type display display) - (type (or null (member :default) int16) key-click-percent - bell-percent bell-pitch bell-duration) - (type (or null card8) led key) - (type (or null (member :on :off)) led-mode) - (type (or null (member :on :off :default)) auto-repeat-mode)) - (when (eq key-click-percent :default) (setq key-click-percent -1)) - (when (eq bell-percent :default) (setq bell-percent -1)) - (when (eq bell-pitch :default) (setq bell-pitch -1)) - (when (eq bell-duration :default) (setq bell-duration -1)) - (with-buffer-request (display *x-changekeyboardcontrol* :sizes (32)) - (mask - (integer key-click-percent bell-percent bell-pitch bell-duration) - (card32 led) - ((member :off :on) led-mode) - (card32 key) - ((member :off :on :default) auto-repeat-mode)))) - -(defun keyboard-control (display) - (declare (type display display)) - (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration - led-mask global-auto-repeat auto-repeats)) - (with-buffer-request-and-reply (display *x-getkeyboardcontrol* 32 :sizes (8 16 32)) - () - (values - (card8-get 12) - (card8-get 13) - (card16-get 14) - (card16-get 16) - (card32-get 8) - (member8-get 1 :off :on) - (bit-vector256-get 32)))) - -;; The base volume should -;; be considered to be the "desired" volume in the normal case; that is, a -;; typical application should call XBell with 0 as the percent. Rather -;; than using a simple sum, the percent argument is instead used as the -;; percentage of the remaining range to alter the base volume by. That is, -;; the actual volume is: -;; if percent>=0: base - [(base * percent) / 100] + percent -;; if percent<0: base + [(base * percent) / 100] - -(defun bell (display &optional (percent-from-normal 0)) - ;; It is assumed that an eventual audio extension to X will provide more complete control. - (declare (type display display) - (type int8 percent-from-normal)) - (with-buffer-request (display *x-bell*) - (data (int8->card8 percent-from-normal)))) - -(defun pointer-mapping (display &key (result-type 'list)) - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values sequence)) ;; Sequence of card - (with-buffer-request-and-reply (display *x-getpointermapping* nil :sizes 8) - () - (values - (sequence-get :length (card8-get 1) :result-type result-type :format card8 - :index *replysize*)))) - -(defun set-pointer-mapping (display map) - ;; Can signal device-busy. - (declare (type display display) - (type sequence map)) ;; Sequence of card8 - (when (with-buffer-request-and-reply (display *x-setpointermapping* 2 :sizes 8) - ((data (length map)) - ((sequence :format card8) map)) - (values - (boolean-get 1))) - (x-error 'device-busy :display display)) - map) - -(defsetf pointer-mapping set-pointer-mapping) - -(defun change-pointer-control (display &key acceleration threshold) - ;; Acceleration is rationalized if necessary. - (declare (type display display) - (type (or null (member :default) number) acceleration) - (type (or null (member :default) integer) threshold)) - (flet ((rationalize16 (number) - ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers - (declare (type number number)) - (declare (clx-values numerator denominator)) - (do* ((rational (rationalize number)) - (numerator (numerator rational) (ash numerator -1)) - (denominator (denominator rational) (ash denominator -1))) - ((or (= numerator 1) - (and (< (abs numerator) #x8000) - (< denominator #x8000))) - (values - numerator (min denominator #x7fff)))))) - (declare (inline rationalize16)) - (let ((acceleration-p 1) - (threshold-p 1) - (numerator 0) - (denominator 1)) - (declare (type card8 acceleration-p threshold-p) - (type int16 numerator denominator)) - (cond ((eq acceleration :default) (setq numerator -1)) - (acceleration (multiple-value-setq (numerator denominator) - (rationalize16 acceleration))) - (t (setq acceleration-p 0))) - (cond ((eq threshold :default) (setq threshold -1)) - ((null threshold) (setq threshold -1 - threshold-p 0))) - (with-buffer-request (display *x-changepointercontrol*) - (int16 numerator denominator threshold) - (card8 acceleration-p threshold-p))))) - -(defun pointer-control (display) - (declare (type display display)) - (declare (clx-values acceleration threshold)) - (with-buffer-request-and-reply (display *x-getpointercontrol* 16 :sizes 16) - () - (values - (/ (card16-get 8) (card16-get 10)) ; Should we float this? - (card16-get 12)))) - -(defun set-screen-saver (display timeout interval blanking exposures) - ;; Timeout and interval are in seconds, will be rounded to minutes. - (declare (type display display) - (type (or (member :default) int16) timeout interval) - (type (member :on :off :default :yes :no) blanking exposures)) - (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off))) - (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off))) - (when (eq timeout :default) (setq timeout -1)) - (when (eq interval :default) (setq interval -1)) - (with-buffer-request (display *x-setscreensaver*) - (int16 timeout interval) - ((member8 :on :off :default) blanking exposures))) - -(defun screen-saver (display) - ;; Returns timeout and interval in seconds. - (declare (type display display)) - (declare (clx-values timeout interval blanking exposures)) - (with-buffer-request-and-reply (display *x-getscreensaver* 14 :sizes (8 16)) - () - (values - (card16-get 8) - (card16-get 10) - (member8-get 12 :on :off :default) - (member8-get 13 :on :off :default)))) - -(defun activate-screen-saver (display) - (declare (type display display)) - (with-buffer-request (display *x-forcescreensaver*) - (data 1))) - -(defun reset-screen-saver (display) - (declare (type display display)) - (with-buffer-request (display *x-forcescreensaver*) - (data 0))) - -(defun add-access-host (display host &optional (family :internet)) - ;; A string must be acceptable as a host, but otherwise the possible types for - ;; host are not constrained, and will likely be very system dependent. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (change-access-host display host family nil)) - -(defun remove-access-host (display host &optional (family :internet)) - ;; A string must be acceptable as a host, but otherwise the possible types for - ;; host are not constrained, and will likely be very system dependent. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (change-access-host display host family t)) - -(defun change-access-host (display host family remove-p) - (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) - (unless (consp host) - (setq host (host-address host family))) - (let ((family (car host)) - (address (cdr host))) - (with-buffer-request (display *x-changehosts*) - ((data boolean) remove-p) - (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family)) - (card16 (length address)) - ((sequence :format card8) address)))) - -(defun access-hosts (display &optional (result-type 'list)) - ;; The type of host objects returned is not constrained, except that the hosts must - ;; be acceptable to add-access-host and remove-access-host. - ;; This implementation uses a list whose car is the family keyword - ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. - (declare (type display display) - (type t result-type)) ;; CL type - (declare (clx-values (clx-sequence host) enabled-p)) - (with-buffer-request-and-reply (display *x-listhosts* nil :sizes (8 16)) - () - (let* ((enabled-p (boolean-get 1)) - (nhosts (card16-get 8)) - (sequence (make-sequence result-type nhosts))) - (advance-buffer-offset *replysize*) - (dotimes (i nhosts) - (let ((family (card8-get 0)) - (len (card16-get 2))) - (setf (elt sequence i) - (cons (if (< family 3) - (svref '#(:internet :decnet :chaos) family) - family) - (sequence-get :length len :format card8 :result-type 'list - :index (+ buffer-boffset 4)))) - (advance-buffer-offset (+ 4 (* 4 (ceiling len 4)))))) - (values - sequence - enabled-p)))) - -(defun access-control (display) - (declare (type display display)) - (declare (clx-values boolean)) ;; True when access-control is ENABLED - (with-buffer-request-and-reply (display *x-listhosts* 2 :sizes 8) - () - (boolean-get 1))) - -(defun set-access-control (display enabled-p) - (declare (type display display) - (type boolean enabled-p)) - (with-buffer-request (display *x-changeaccesscontrol*) - ((data boolean) enabled-p)) - enabled-p) - -(defsetf access-control set-access-control) - -(defun close-down-mode (display) - ;; setf'able - ;; Cached locally in display object. - (declare (type display display)) - (declare (clx-values (member :destroy :retain-permanent :retain-temporary nil))) - (display-close-down-mode display)) - -(defun set-close-down-mode (display mode) - ;; Cached locally in display object. - (declare (type display display) - (type (member :destroy :retain-permanent :retain-temporary) mode)) - (setf (display-close-down-mode display) mode) - (with-buffer-request (display *x-changeclosedownmode* :sizes (32)) - ((data (member :destroy :retain-permanent :retain-temporary)) mode)) - mode) - -(defsetf close-down-mode set-close-down-mode) - -(defun kill-client (display resource-id) - (declare (type display display) - (type resource-id resource-id)) - (with-buffer-request (display *x-killclient*) - (resource-id resource-id))) - -(defun kill-temporary-clients (display) - (declare (type display display)) - (with-buffer-request (display *x-killclient*) - (resource-id 0))) - -(defun no-operation (display) - (declare (type display display)) - (with-buffer-request (display *x-nooperation*))) diff --git a/clx/resource.lisp b/clx/resource.lisp deleted file mode 100644 index 3e7b74aab7e7e11278b8c158d9feceb9cdcd6894..0000000000000000000000000000000000000000 --- a/clx/resource.lisp +++ /dev/null @@ -1,696 +0,0 @@ -;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- - -;; RESOURCE - Lisp version of XLIB's Xrm resource manager - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;; The C version of this uses a 64 entry hash table at each entry. -;; Small hash tables lose in Lisp, so we do linear searches on lists. - -(defstruct (resource-database (:copier nil) (:predicate nil) - (:print-function print-resource-database) - (:constructor make-resource-database-internal) - #+explorer (:callable-constructors nil) - ) - (name nil :type stringable :read-only t) - (value nil) - (tight nil :type list) ;; List of resource-database - (loose nil :type list) ;; List of resource-database - ) - -(defun print-resource-database (database stream depth) - (declare (type resource-database database) - (ignore depth)) - (print-unreadable-object (database stream :type t) - (write-string (string (resource-database-name database)) stream) - (when (resource-database-value database) - (write-string " " stream) - (prin1 (resource-database-value database) stream)))) - -;; The value slot of the top-level resource-database structure is used for a -;; time-stamp. - -(defun make-resource-database () - ;; Make a resource-database with initial timestamp of 0 - (make-resource-database-internal :name "Top-Level" :value 0)) - -(defun resource-database-timestamp (database) - (declare (type resource-database database)) - (resource-database-value database)) - -(defun incf-resource-database-timestamp (database) - ;; Increment the timestamp - (declare (type resource-database database)) - (let ((timestamp (resource-database-value database))) - (setf (resource-database-value database) - (if (= timestamp most-positive-fixnum) - most-negative-fixnum - (1+ timestamp))))) - -;; DEBUG FUNCTION (not exported) -(defun print-db (entry &optional (level 0) type) - ;; Debug function to print a resource database - (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]" - level - (resource-database-name entry) - (eq type 'loose) - (resource-database-value entry)) - (when (resource-database-tight entry) - (dolist (tight (resource-database-tight entry)) - (print-db tight (+ 2 level) 'tight))) - (when (resource-database-loose entry) - (dolist (loose (resource-database-loose entry)) - (print-db loose (+ 2 level) 'loose)))) - -;; DEBUG FUNCTION -#+comment -(defun print-search-table (table) - (terpri) - (dolist (dbase-list table) - (format t "~%~s" dbase-list) - (dolist (db dbase-list) - (print-db db) - (dolist (dblist table) - (unless (eq dblist dbase-list) - (when (member db dblist) - (format t " duplicate at ~s" db)))) - ))) - -;; -;; If this is true, resource symbols will be compared in a case-insensitive -;; manner, and converting a resource string to a keyword will uppercaseify it. -;; -(defparameter *uppercase-resource-symbols* nil) - -(defun resource-key (stringable) - ;; Ensure STRINGABLE is a keyword. - (declare (type stringable stringable)) - (etypecase stringable - (symbol - (if (keywordp (the symbol stringable)) - stringable - (kintern (symbol-name (the symbol stringable))))) - (string - (if *uppercase-resource-symbols* - (setq stringable (#-allegro string-upcase #+allegro correct-case - (the string stringable)))) - (kintern (the string stringable))))) - -(defun stringable-equal (a b) - ;; Compare two stringables. - ;; Ignore case when comparing to a symbol. - (declare (type stringable a b)) - (declare (clx-values boolean)) - (etypecase a - (string - (etypecase b - (string - (string= (the string a) (the string b))) - (symbol - (if *uppercase-resource-symbols* - (string-equal (the string a) - (the string (symbol-name (the symbol b)))) - (string= (the string a) - (the string (symbol-name (the symbol b)))))))) - (symbol - (etypecase b - (string - (if *uppercase-resource-symbols* - (string-equal (the string (symbol-name (the symbol a))) - (the string b)) - (string= (the string (symbol-name (the symbol a))) - (the string b)))) - (symbol - (string= (the string (symbol-name (the symbol a))) - (the string (symbol-name (the symbol b))))))))) - - -;;;----------------------------------------------------------------------------- -;;; Add/delete resource - -(defun add-resource (database name-list value) - ;; name-list is a list of either strings or symbols. If a symbol, - ;; case-insensitive comparisons will be used, if a string, - ;; case-sensitive comparisons will be used. The symbol '* or - ;; string "*" are used as wildcards, matching anything or nothing. - (declare (type resource-database database) - (type (clx-list stringable) name-list) - (type t value)) - (unless value (error "Null resource values are ignored")) - (incf-resource-database-timestamp database) - (do* ((list name-list (cdr list)) - (name (car list) (car list)) - (node database) - (loose-p nil)) - ((endp list) - (setf (resource-database-value node) value)) - ;; Key is the first name that isn't * - (if (stringable-equal name "*") - (setq loose-p t) - ;; find the entry associated with name - (progn - (do ((entry (if loose-p - (resource-database-loose node) - (resource-database-tight node)) - (cdr entry))) - ((endp entry) - ;; Entry not found - create a new one - (setq entry (make-resource-database-internal :name name)) - (if loose-p - (push entry (resource-database-loose node)) - (push entry (resource-database-tight node))) - (setq node entry)) - (when (stringable-equal name (resource-database-name (car entry))) - ;; Found entry - use it - (return (setq node (car entry))))) - (setq loose-p nil))))) - - -(defun delete-resource (database name-list) - (declare (type resource-database database) - (type list name-list)) - (incf-resource-database-timestamp database) - (delete-resource-internal database name-list)) - -(defun delete-resource-internal (database name-list) - (declare (type resource-database database) - (type (clx-list stringable) name-list)) - (do* ((list name-list (cdr list)) - (string (car list) (car list)) - (node database) - (loose-p nil)) - ((endp list) nil) - ;; Key is the first name that isn't * - (if (stringable-equal string "*") - (setq loose-p t) - ;; find the entry associated with name - (progn - (do* ((first-entry (if loose-p - (resource-database-loose node) - (resource-database-tight node))) - (entry-list first-entry (cdr entry-list)) - (entry (car entry-list) (car entry-list))) - ((endp entry-list) - ;; Entry not found - exit - (return-from delete-resource-internal nil)) - (when (stringable-equal string (resource-database-name entry)) - (when (cdr list) (delete-resource-internal entry (cdr list))) - (when (and (null (resource-database-loose entry)) - (null (resource-database-tight entry))) - (if loose-p - (setf (resource-database-loose node) - (delete entry (resource-database-loose node) - :test #'eq :count 1)) - (setf (resource-database-tight node) - (delete entry (resource-database-tight node) - :test #'eq :count 1)))) - (return-from delete-resource-internal t))) - (setq loose-p nil))))) - -;;;----------------------------------------------------------------------------- -;;; Get Resource - -(defun get-resource (database value-name value-class full-name full-class) - ;; Return the value of the resource in DATABASE whose partial name - ;; most closely matches (append full-name (list value-name)) and - ;; (append full-class (list value-class)). - (declare (type resource-database database) - (type stringable value-name value-class) - (type (clx-list stringable) full-name full-class)) - (declare (clx-values value)) - (let ((names (append full-name (list value-name))) - (classes (append full-class (list value-class)))) - (let* ((result (get-entry (resource-database-tight database) - (resource-database-loose database) - names classes))) - (when result - (resource-database-value result))))) - -(defun get-entry-lookup (table name names classes) - (declare (type list table names classes) - (symbol name)) - (dolist (entry table) - (declare (type resource-database entry)) - (when (stringable-equal name (resource-database-name entry)) - (if (null (cdr names)) - (return entry) - (let ((result (get-entry (resource-database-tight entry) - (resource-database-loose entry) - (cdr names) (cdr classes)))) - (declare (type (or null resource-database) result)) - (when result - (return result) - )))))) - -(defun get-entry (tight loose names classes &aux result) - (declare (type list tight loose names classes)) - (let ((name (car names)) - (class (car classes))) - (declare (type symbol name class)) - (cond ((and tight - (get-entry-lookup tight name names classes))) - ((and loose - (get-entry-lookup loose name names classes))) - ((and tight - (not (stringable-equal name class)) - (get-entry-lookup tight class names classes))) - ((and loose - (not (stringable-equal name class)) - (get-entry-lookup loose class names classes))) - (loose - (loop - (pop names) (pop classes) - (unless (and names classes) (return nil)) - (setq name (car names) - class (car classes)) - (when (setq result (get-entry-lookup loose name names classes)) - (return result)) - (when (and (not (stringable-equal name class)) - (setq result - (get-entry-lookup loose class names classes))) - (return result)) - ))))) - - -;;;----------------------------------------------------------------------------- -;;; Get-resource with search-table - -(defun get-search-resource (table name class) - ;; (get-search-resource (get-search-table database full-name full-class) - ;; value-name value-class) - ;; is equivalent to - ;; (get-resource database value-name value-class full-name full-class) - ;; But since most of the work is done by get-search-table, - ;; get-search-resource is MUCH faster when getting several resources with - ;; the same full-name/full-class - (declare (type list table) - (type stringable name class)) - (let ((do-class (and class (not (stringable-equal name class))))) - (dolist (dbase-list table) - (declare (type list dbase-list)) - (dolist (dbase dbase-list) - (declare (type resource-database dbase)) - (when (stringable-equal name (resource-database-name dbase)) - (return-from get-search-resource - (resource-database-value dbase)))) - (when do-class - (dolist (dbase dbase-list) - (declare (type resource-database dbase)) - (when (stringable-equal class (resource-database-name dbase)) - (return-from get-search-resource - (resource-database-value dbase)))))))) - -(defvar *get-table-result*) - -(defun get-search-table (database full-name full-class) - ;; Return a search table for use with get-search-resource. - (declare (type resource-database database) - (type (clx-list stringable) full-name full-class)) - (declare (clx-values value)) - (let* ((tight (resource-database-tight database)) - (loose (resource-database-loose database)) - (result (cons nil nil)) - (*get-table-result* result)) - (declare (type list tight loose) - (type cons result)) - (when (or tight loose) - (when full-name - (get-tables tight loose full-name full-class)) - - ;; Pick up bindings of the form (* name). These are the elements of - ;; top-level loose without further tight/loose databases. - ;; - ;; (Hack: these bindings belong in ANY search table, so recomputing them - ;; is a drag. True fix involves redesigning entire lookup - ;; data-structure/algorithm.) - ;; - (let ((universal-bindings - (remove nil loose :test-not #'eq - :key #'(lambda (database) - (or (resource-database-tight database) - (resource-database-loose database)))))) - (when universal-bindings - (setf (cdr *get-table-result*) (list universal-bindings))))) - (cdr result))) - -(defun get-tables-lookup (dbase name names classes) - (declare (type list dbase names classes) - (type symbol name)) - (declare (optimize speed)) - (dolist (entry dbase) - (declare (type resource-database entry)) - (when (stringable-equal name (resource-database-name entry)) - (let ((tight (resource-database-tight entry)) - (loose (resource-database-loose entry))) - (declare (type list tight loose)) - (when (or tight loose) - (if (cdr names) - (get-tables tight loose (cdr names) (cdr classes)) - (when tight - (let ((result *get-table-result*)) - ;; Put tight at end of *get-table-result* - (setf (cdr result) - (setq *get-table-result* (cons tight nil)))))) - (when loose - (let ((result *get-table-result*)) - ;; Put loose at end of *get-table-result* - (setf (cdr result) - (setq *get-table-result* (cons loose nil)))))))))) - -(defun get-tables (tight loose names classes) - (declare (type list tight loose names classes)) - (let ((name (car names)) - (class (car classes))) - (declare (type symbol name class)) - (when tight - (get-tables-lookup tight name names classes)) - (when loose - (get-tables-lookup loose name names classes)) - (when (and tight (not (stringable-equal name class))) - (get-tables-lookup tight class names classes)) - (when (and loose (not (stringable-equal name class))) - (get-tables-lookup loose class names classes)) - (when loose - (loop - (pop names) (pop classes) - (unless (and names classes) (return nil)) - (setq name (car names) - class (car classes)) - (get-tables-lookup loose name names classes) - (unless (stringable-equal name class) - (get-tables-lookup loose class names classes)) - )))) - - -;;;----------------------------------------------------------------------------- -;;; Utility functions - -(defun map-resource (database function &rest args) - ;; Call FUNCTION on each resource in DATABASE. - ;; FUNCTION is called with arguments (name-list value . args) - (declare (type resource-database database) - (type (function (list t &rest t) t) function) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function) - (dynamic-extent args)) - (declare (clx-values nil)) - (labels ((map-resource-internal (database function args name) - (declare (type resource-database database) - (type (function (list t &rest t) t) function) - (type list name) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) - (let ((tight (resource-database-tight database)) - (loose (resource-database-loose database))) - (declare (type list tight loose)) - (dolist (resource tight) - (declare (type resource-database resource)) - (let ((value (resource-database-value resource)) - (name (append - name - (list (resource-database-name resource))))) - (if value - (apply function name value args) - (map-resource-internal resource function args name)))) - (dolist (resource loose) - (declare (type resource-database resource)) - (let ((value (resource-database-value resource)) - (name (append - name - (list "*" (resource-database-name resource))))) - (if value - (apply function name value args) - (map-resource-internal resource function args name))))))) - (map-resource-internal database function args nil))) - -(defun merge-resources (database with-database) - (declare (type resource-database database with-database)) - (declare (clx-values resource-database)) - (map-resource - database - #'(lambda (name value database) - (add-resource database name value)) - with-database) - with-database) - -(defun char-memq (key char) - ;; Used as a test function for POSITION - (declare (type base-char char)) - (member char key)) - -(defmacro resource-with-open-file ((stream pathname &rest options) &body body) - ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the - ;; stream - (let ((abortp (gensym)) - (streamp (gensym))) - `(let* ((,abortp t) - (,streamp (streamp pathname)) - (,stream (if ,streamp pathname (open ,pathname ,@options)))) - (unwind-protect - (multiple-value-prog1 - (progn ,@body) - (setq ,abortp nil)) - (unless ,streamp - (close stream :abort ,abortp)))))) - -(defun read-resources (database pathname &key key test test-not) - ;; Merges resources from a file in standard X11 format with DATABASE. - ;; KEY is a function used for converting value-strings, the default is - ;; identity. TEST and TEST-NOT are predicates used for filtering - ;; which resources to include in the database. They are called with - ;; the name and results of the KEY function. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string) t)) key) - (type (or null (function (list t) boolean)) - test test-not)) - (declare (clx-values resource-database)) - (resource-with-open-file (stream pathname) - (loop - (let ((string (read-line stream nil :eof))) - (declare (type (or string keyword) string)) - (when (eq string :eof) (return database)) - (let* ((end (length string)) - (i (position '(#\tab #\space) string - :test-not #'char-memq :end end)) - (term nil)) - (declare (type array-index end) - (type (or null array-index) i term)) - (when i ;; else blank line - (case (char string i) - (#\! nil) ;; Comment - skip - ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip - (#\# ;; Include - (setq term (position '(#\tab #\space) string :test #'char-memq - :start i :end end)) - (when (string-equal string "#INCLUDE" :start1 i :end1 term) - (let ((path (merge-pathnames - (subseq string (1+ term)) (truename stream)))) - (read-resources database path - :key key :test test :test-not test-not)))) - (otherwise - (multiple-value-bind (name-list value) - (parse-resource string i end) - (when name-list - (when key (setq value (funcall key value))) - (when - (cond (test (funcall test name-list value)) - (test-not (not (funcall test-not name-list value))) - (t t)) - (add-resource database name-list value)))))))))))) - -(defun parse-resource (string &optional (start 0) end) - ;; Parse a resource specfication string into a list of names and a value - ;; string - (declare (type string string) - (type array-index start) - (type (or null array-index) end)) - (declare (clx-values name-list value)) - (do ((i start) - (end (or end (length string))) - (term) - (name-list)) - ((>= i end)) - (declare (type array-index end) - (type (or null array-index) i term)) - (setq term (position '(#\. #\* #\:) string - :test #'char-memq :start i :end end)) - (case (and term (char string term)) - ;; Name seperator - (#\. (when (> term i) - (push (subseq string i term) name-list))) - ;; Wildcard seperator - (#\* (when (> term i) - (push (subseq string i term) name-list)) - (push '* name-list)) - ;; Value separator - (#\: - (push (subseq string i term) name-list) - (return - (values - (nreverse name-list) - (string-trim '(#\tab #\space) (subseq string (1+ term)))))) - (otherwise - (return - (values - (nreverse name-list) - (subseq string i term))))) - (setq i (1+ term)))) - -(defun write-resources (database pathname &key write test test-not) - ;; Write resources to PATHNAME in the standard X11 format. - ;; WRITE is a function used for writing values, the default is #'princ - ;; TEST and TEST-NOT are predicates used for filtering which resources - ;; to include in the database. They are called with the name and value. - (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string stream) t)) write) - (type (or null (function (list t) boolean)) - test test-not)) - (resource-with-open-file (stream pathname :direction :output) - (map-resource - database - #'(lambda (name-list value stream write test test-not) - (when - (cond (test (funcall test name-list value)) - (test-not (not (funcall test-not name-list value))) - (t t)) - (let ((previous (car name-list))) - (princ previous stream) - (dolist (name (cdr name-list)) - (unless (or (stringable-equal name "*") - (stringable-equal previous "*")) - (write-char #\. stream)) - (setq previous name) - (princ name stream))) - (write-string ": " stream) - (funcall write value stream) - (terpri stream))) - stream (or write #'princ) test test-not)) - database) - -(defun wm-resources (database window &key key test test-not) - ;; Takes the resources associated with the RESOURCE_MANAGER property - ;; of WINDOW (if any) and merges them with DATABASE. - ;; KEY is a function used for converting value-strings, the default is - ;; identity. TEST and TEST-NOT are predicates used for filtering - ;; which resources to include in the database. They are called with - ;; the name and results of the KEY function. - (declare (type resource-database database) - (type window window) - (type (or null (function (string) t)) key) - (type (or null (function (list t) boolean)) - test test-not)) - (declare (clx-values resource-database)) - (let ((string (get-property window :RESOURCE_MANAGER :type :STRING - :result-type 'string - :transform #'xlib::card8->char))) - (when string - (with-input-from-string (stream string) - (read-resources database stream - :key key :test test :test-not test-not))))) - -(defun set-wm-resources (database window &key write test test-not) - ;; Sets the resources associated with the RESOURCE_MANAGER property - ;; of WINDOW. - ;; WRITE is a function used for writing values, the default is #'princ - ;; TEST and TEST-NOT are predicates used for filtering which resources - ;; to include in the database. They are called with the name and value. - (declare (type resource-database database) - (type window window) - (type (or null (function (string stream) t)) write) - (type (or null (function (list t) boolean)) - test test-not)) - (xlib::set-string-property - window :RESOURCE_MANAGER - (with-output-to-string (stream) - (write-resources database stream :write write - :test test :test-not test-not)))) - -(defun root-resources (screen &key database key test test-not) - "Returns a resource database containing the contents of the root window - RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, - then its default screen is used. If an existing DATABASE is given, then - resource values are merged with the DATABASE and the modified DATABASE is - returned. - - TEST and TEST-NOT are predicates for selecting which resources are - read. Arguments are a resource name list and a resource value. The KEY - function, if given, is called to convert a resource value string to the - value given to TEST or TEST-NOT." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (string) t)) key) - (type (or null (function (list t) boolean)) test test-not) - (clx-values resource-database)) - (let* ((screen (if (type? screen 'display) - (display-default-screen screen) - screen)) - (window (screen-root screen)) - (database (or database (make-resource-database)))) - (wm-resources database window :key key :test test :test-not test-not) - database)) - -(defun set-root-resources (screen &key test test-not (write #'princ) database) - "Changes the contents of the root window RESOURCE_MANAGER property for the - given SCREEN. If SCREEN is a display, then its default screen is used. - - TEST and TEST-NOT are predicates for selecting which resources from the - DATABASE are written. Arguments are a resource name list and a resource - value. The WRITE function is used to convert a resource value into a - string stored in the property." - - (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (list t) boolean)) test test-not) - (type (or null (function (string stream) t)) write) - (clx-values resource-database)) - (let* ((screen (if (type? screen 'display) - (display-default-screen screen) - screen)) - (window (screen-root screen))) - (set-wm-resources database window - :write write :test test :test-not test-not) - database)) - -(defsetf root-resources set-root-resources) - -(defun initialize-resource-database (display) - ;; This function is (supposed to be) equivalent to the Xlib initialization - ;; code. - (declare (type display display)) - (let ((rdb (make-resource-database)) - (rootwin (screen-root (car (display-roots display))))) - ;; First read the server defaults if present, otherwise from the default - ;; resource file - (if (get-property rootwin :RESOURCE_MANAGER) - (xlib:wm-resources rdb rootwin) - (let ((path (default-resources-pathname))) - (when (and path (probe-file path)) - (read-resources rdb path)))) - ;; Next read from the resources file - (let ((path (resources-pathname))) - (when (and path (probe-file path)) - (read-resources rdb path))) - (setf (display-xdefaults display) rdb))) diff --git a/clx/sockcl.lisp b/clx/sockcl.lisp deleted file mode 100644 index 26c0eda348242d4b888ca3d4efb1e610a922ae8b..0000000000000000000000000000000000000000 --- a/clx/sockcl.lisp +++ /dev/null @@ -1,163 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;;; Server Connection for kcl and ibcl - -;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology -;;; -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. -;;; -;;; Massachussetts Institute of Technology provides this software "as is" -;;; without express or implied warranty. -;;; - -;;; Adapted from code by Roman Budzianowski - Project Athena/MIT - -;;; make-two-way-stream is probably not a reasonable thing to do. -;;; A close on a two way stream probably does not close the substreams. -;;; I presume an :io will not work (maybe because it uses 1 buffer?). -;;; There should be some fast io (writes and reads...). - -;;; Compile this file with compile-file. -;;; Load it with (si:faslink "sockcl.o" "socket.o -lc") - -(in-package :xlib) - -;;; The cmpinclude.h file does not have this type definition from -;;; <kcldistribution>/h/object.h. We include it here so the -;;; compile-file will work without figuring out where the distribution -;;; directory is located. -;;; -(CLINES " -enum smmode { /* stream mode */ - smm_input, /* input */ - smm_output, /* output */ - smm_io, /* input-output */ - smm_probe, /* probe */ - smm_synonym, /* synonym */ - smm_broadcast, /* broadcast */ - smm_concatenated, /* concatenated */ - smm_two_way, /* two way */ - smm_echo, /* echo */ - smm_string_input, /* string input */ - smm_string_output, /* string output */ - smm_user_defined /* for user defined */ -}; -") - -#-akcl -(CLINES " -struct stream { - short t, m; - FILE *sm_fp; /* file pointer */ - object sm_object0; /* some object */ - object sm_object1; /* some object */ - int sm_int0; /* some int */ - int sm_int1; /* some int */ - short sm_mode; /* stream mode */ - /* of enum smmode */ -}; -") - - -;;;; Connect to the server. - -;;; A lisp string is not a reasonable type for C, so copy the characters -;;; out and then call connect_to_server routine defined in socket.o - -(CLINES " -int -konnect_to_server(host,display) - object host; /* host name */ - int display; /* display number */ -{ - int fd; /* file descriptor */ - int i; - char hname[BUFSIZ]; - FILE *fout, *fin; - - if (host->st.st_fillp > BUFSIZ - 1) - too_long_file_name(host); - for (i = 0; i < host->st.st_fillp; i++) - hname[i] = host->st.st_self[i]; - hname[i] = '\\0'; /* doubled backslash for lisp */ - - fd = connect_to_server(hname,display); - - return(fd); -} -") - -(defentry konnect-to-server (object int) (int "konnect_to_server")) - - -;;;; Make a one-way stream from a file descriptor. - -(CLINES " -object -konnect_stream(host,fd,flag,elem) - object host; /* not really used */ - int fd; /* file descriptor */ - int flag; /* 0 input, 1 output */ - object elem; /* 'string-char */ -{ - struct stream *stream; - char *mode; /* file open mode */ - FILE *fp; /* file pointer */ - enum smmode smm; /* lisp mode (a short) */ - vs_mark; - - switch(flag){ - case 0: - smm = smm_input; - mode = \"r\"; - break; - case 1: - smm = smm_output; - mode = \"w\"; - break; - default: - FEerror(\"konnect_stream : wrong mode\"); - } - - fp = fdopen(fd,mode); - - if (fp == NULL) { - stream = Cnil; - vs_push(stream); - } else { - stream = alloc_object(t_stream); - stream->sm_mode = (short)smm; - stream->sm_fp = fp; - stream->sm_object0 = elem; - stream->sm_object1 = host; - stream->sm_int0 = stream->sm.sm_int1 = 0; - vs_push(stream); - setbuf(fp, alloc_contblock(BUFSIZ)); - } - vs_reset; - return(stream); -} -") - -(defentry konnect-stream (object int int object) (object "konnect_stream")) - - -;;;; Open an X stream - -(defun open-socket-stream (host display) - (when (not (and (typep host 'string) ; sanity check the arguments - (typep display 'fixnum))) - (error "Host ~s or display ~s are bad." host display)) - - (let ((fd (konnect-to-server host display))) ; get a file discriptor - (if (< fd 0) - NIL - (let ((stream-in (konnect-stream host fd 0 'string-char)) ; input - (stream-out (konnect-stream host fd 1 'string-char))) ; output - (if (or (null stream-in) (null stream-out)) - (error "Could not make i/o streams for fd ~d." fd)) - (make-two-way-stream stream-in stream-out)) - ))) diff --git a/clx/socket.c b/clx/socket.c deleted file mode 100644 index b2eaf39d535a36267df9efec31d2dc60f1aa9b3e..0000000000000000000000000000000000000000 --- a/clx/socket.c +++ /dev/null @@ -1,153 +0,0 @@ -/* Copyright Massachusetts Institute of Technology 1988 */ -/* - * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived - * systems. VMS and System V should plan to have their own version. - * - * This code was cribbed from lib/X/XConnDis.c. - * Compile using - * % cc -c socket.c -DUNIXCONN - */ - -#include <stdio.h> -#include <X11/Xos.h> -#include <X11/Xproto.h> -#include <errno.h> -#include <netinet/in.h> -#include <sys/ioctl.h> -#include <netdb.h> -#include <sys/socket.h> -#ifndef hpux -#include <netinet/tcp.h> -#endif - -extern int errno; /* Certain (broken) OS's don't have this */ - /* decl in errno.h */ - -#ifdef UNIXCONN -#include <sys/un.h> -#ifndef X_UNIX_PATH -#ifdef hpux -#define X_UNIX_PATH "/usr/spool/sockets/X11/" -#define OLD_UNIX_PATH "/tmp/.X11-unix/X" -#else /* hpux */ -#define X_UNIX_PATH "/tmp/.X11-unix/X" -#endif /* hpux */ -#endif /* X_UNIX_PATH */ -#endif /* UNIXCONN */ - -#ifndef hpux -void bcopy(); -#endif /* hpux */ - -/* - * Attempts to connect to server, given host and display. Returns file - * descriptor (network socket) or 0 if connection fails. - */ - -int connect_to_server (host, display) - char *host; - int display; -{ - struct sockaddr_in inaddr; /* INET socket address. */ - struct sockaddr *addr; /* address to connect to */ - struct hostent *host_ptr; - int addrlen; /* length of address */ -#ifdef UNIXCONN - struct sockaddr_un unaddr; /* UNIX socket address. */ -#endif - extern char *getenv(); - extern struct hostent *gethostbyname(); - int fd; /* Network socket */ - { -#ifdef UNIXCONN - if ((host[0] == '\0') || (strcmp("unix", host) == 0)) { - /* Connect locally using Unix domain. */ - unaddr.sun_family = AF_UNIX; - (void) strcpy(unaddr.sun_path, X_UNIX_PATH); - (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); - addr = (struct sockaddr *) &unaddr; - addrlen = strlen(unaddr.sun_path) + 2; - /* - * Open the network connection. - */ - if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { -#ifdef hpux /* this is disgusting */ /* cribbed from X11R4 xlib source */ - if (errno == ENOENT) { /* No such file or directory */ - (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); - addrlen = strlen(unaddr.sun_path) + 2; - if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0) - return(-1); /* errno set by most recent system call. */ - } else -#endif /* hpux */ - return(-1); /* errno set by system call. */ - } - } else -#endif /* UNIXCONN */ - { - /* Get the statistics on the specified host. */ - if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) - { - if ((host_ptr = gethostbyname(host)) == NULL) - { - /* No such host! */ - errno = EINVAL; - return(-1); - } - /* Check the address type for an internet host. */ - if (host_ptr->h_addrtype != AF_INET) - { - /* Not an Internet host! */ - errno = EPROTOTYPE; - return(-1); - } - /* Set up the socket data. */ - inaddr.sin_family = host_ptr->h_addrtype; -#ifdef hpux - (void) memcpy((char *)&inaddr.sin_addr, - (char *)host_ptr->h_addr, - sizeof(inaddr.sin_addr)); -#else /* hpux */ - (void) bcopy((char *)host_ptr->h_addr, - (char *)&inaddr.sin_addr, - sizeof(inaddr.sin_addr)); -#endif /* hpux */ - } - else - { - inaddr.sin_family = AF_INET; - } - addr = (struct sockaddr *) &inaddr; - addrlen = sizeof (struct sockaddr_in); - inaddr.sin_port = display + X_TCP_PORT; - inaddr.sin_port = htons(inaddr.sin_port); - /* - * Open the network connection. - */ - if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ - return(-1); /* errno set by system call. */} - /* make sure to turn off TCP coalescence */ -#ifdef TCP_NODELAY - { - int mi = 1; - setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); - } -#endif - } - - /* - * Changed 9/89 to retry connection if system call was interrupted. This - * is necessary for multiprocessing implementations that use timers, - * since the timer results in a SIGALRM. -- jdi - */ - while (connect(fd, addr, addrlen) == -1) { - if (errno != EINTR) { - (void) close (fd); - return(-1); /* errno set by system call. */ - } - } - } - /* - * Return the id if the connection succeeded. - */ - return(fd); -} diff --git a/clx/text.lisp b/clx/text.lisp deleted file mode 100644 index f39bfc7d57646761165d2e69ca13ceb36b272148..0000000000000000000000000000000000000000 --- a/clx/text.lisp +++ /dev/null @@ -1,1084 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- - -;;; CLX text keyboard and pointer requests - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -;; Strings are broken up into chunks of this size -(defparameter *max-string-size* 254) - -;; In the functions below, the transform is used to convert an element of the -;; sequence into a font index. The transform is applied to each element of the -;; (sub)sequence, until either the transform returns nil or the end of the -;; (sub)sequence is reached. If transform returns nil for an element, the -;; index of that element in the sequence is returned, otherwise nil is -;; returned. - -(deftype translation-function () - #+explorer t - #-explorer - '(function (sequence array-index array-index (or null font) vector array-index) - (values array-index (or null int16 font) (or null int32)))) - -;; In the functions below, if width is specified, it is assumed to be the pixel -;; width of whatever string of glyphs is actually drawn. Specifying width will -;; allow for appending the output of subsequent calls to the same protocol -;; request, provided gcontext has not been modified in the interim. If width -;; is not specified, appending of subsequent output might not occur. -;; Specifying width is simply a hint, for performance. Note that specifying -;; width may be difficult if transform can return nil. - -(defun translate-default (src src-start src-end font dst dst-start) - ;; dst is guaranteed to have room for (- src-end src-start) integer elements, - ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends - ;; on context. font is the current font, if known. The function should - ;; translate as many elements of src as possible into indexes in the current - ;; font, and store them into dst. - ;; - ;; The first return value should be the src index of the first untranslated - ;; element. If no further elements need to be translated, the second return - ;; value should be nil. If a horizontal motion is required before further - ;; translation, the second return value should be the delta in x coordinate. - ;; If a font change is required for further translation, the second return - ;; value should be the new font. If known, the pixel width of the translated - ;; text can be returned as the third value; this can allow for appending of - ;; subsequent output to the same protocol request, if no overall width has - ;; been specified at the higher level. - ;; (returns values: ending-index - ;; (OR null horizontal-motion font) - ;; (OR null translated-width)) - (declare (type sequence src) - (type array-index src-start src-end dst-start) - (type (or null font) font) - (type vector dst) - (inline graphic-char-p)) - (declare (clx-values integer (or null integer font) (or null integer))) - font ;;not used - (if (stringp src) - (do ((i src-start (index+ i 1)) - (j dst-start (index+ j 1)) - (char)) - ((index>= i src-end) - i) - (declare (type array-index i j)) - (if (graphic-char-p (setq char (char src i))) - (setf (aref dst j) (char->card8 char)) - (return i))) - (do ((i src-start (index+ i 1)) - (j dst-start (index+ j 1)) - (elt)) - ((index>= i src-end) - i) - (declare (type array-index i j)) - (setq elt (elt src i)) - (cond ((and (characterp elt) (graphic-char-p elt)) - (setf (aref dst j) (char->card8 elt))) - ((integerp elt) - (setf (aref dst j) elt)) - (t - (return i)))))) - -;; There is a question below of whether translate should always be required, or -;; if not, what the default should be or where it should come from. For -;; example, the default could be something that expected a string as src and -;; translated the CL standard character set to ASCII indexes, and ignored fonts -;; and bits. Or the default could expect a string but otherwise be "system -;; dependent". Or the default could be something that expected a vector of -;; integers and did no translation. Or the default could come from the -;; gcontext (but what about text-extents and text-width?). - -(defun text-extents (font sequence &key (start 0) end translate) - ;; If multiple fonts are involved, font-ascent and font-descent will be the - ;; maximums. If multiple directions are involved, the direction will be nil. - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values width ascent descent left right - font-ascent font-descent direction - (or null array-index))) - (when (type? font 'gcontext) - (force-gcontext-changes font) - (setq font (gcontext-font font t))) - (check-type font font) - (let* ((left-bearing 0) - (right-bearing 0) - ;; Sum of widths - (width 0) - (ascent 0) - (descent 0) - (overall-ascent (font-ascent font)) - (overall-descent (font-descent font)) - (overall-direction (font-direction font)) - (next-start nil) - (display (font-display font))) - (declare (type int16 ascent descent overall-ascent overall-descent) - (type int32 left-bearing right-bearing width) - (type (or null array-index) next-start) - (type display display)) - (with-display (display) - (do* ((wbuf (display-tbuf16 display)) - (src-end (or end (length sequence))) - (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start *buffer-text16-size*)) - (index-min src-end (index+ src-start *buffer-text16-size*))) - (buf-end 0) - (new-font) - (font-ascent 0) - (font-descent 0) - (font-direction) - (stop-p nil)) - ((or stop-p (index>= src-start src-end)) - (when (index< src-start src-end) - (setq next-start src-start))) - (declare (type buffer-text16 wbuf) - (type array-index src-start src-end end buf-end) - (type int16 font-ascent font-descent) - (type boolean stop-p)) - ;; Translate the text - (multiple-value-setq (buf-end new-font) - (funcall (or translate #'translate-default) - sequence src-start end font wbuf 0)) - (setq buf-end (- buf-end src-start)) - (cond ((null new-font) (setq stop-p t)) - ((integerp new-font) (incf width (the int32 new-font)))) - - (let (w a d l r) - (if (or (font-char-infos-internal font) (font-local-only-p font)) - ;; Calculate text extents locally - (progn - (multiple-value-setq (w a d l r) - (text-extents-local font wbuf 0 buf-end nil)) - (setq font-ascent (the int16 (font-ascent font)) - font-descent (the int16 (font-descent font)) - font-direction (font-direction font))) - ;; Let the server calculate text extents - (multiple-value-setq - (w a d l r font-ascent font-descent font-direction) - (text-extents-server font wbuf 0 buf-end))) - (incf width (the int32 w)) - (cond ((index= src-start start) - (setq left-bearing (the int32 l)) - (setq right-bearing (the int32 r)) - (setq ascent (the int16 a)) - (setq descent (the int16 d))) - (t - (setq left-bearing (the int32 (min left-bearing (the int32 l)))) - (setq right-bearing (the int32 (max right-bearing (the int32 r)))) - (setq ascent (the int16 (max ascent (the int16 a)))) - (setq descent (the int16 (max descent (the int16 d))))))) - - (when (type? new-font 'font) - (setq font new-font)) - - (setq overall-ascent (the int16 (max overall-ascent font-ascent))) - (setq overall-descent (the int16 (max overall-descent font-descent))) - (case overall-direction - (:unknown (setq overall-direction font-direction)) - (:left-to-right (unless (eq font-direction :left-to-right) - (setq overall-direction nil))) - (:right-to-left (unless (eq font-direction :right-to-left) - (setq overall-direction nil)))))) - - (values width - ascent - descent - left-bearing - right-bearing - overall-ascent - overall-descent - overall-direction - next-start))) - -(defun text-width (font sequence &key (start 0) end translate) - ;; Translate will always be called with a 16-bit dst buffer. - (declare (type sequence sequence) - (type (or font gcontext) font) - (type array-index start) - (type (or null array-index) end)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values integer (or null integer))) - (when (type? font 'gcontext) - (force-gcontext-changes font) - (setq font (gcontext-font font t))) - (check-type font font) - (let* ((width 0) - (next-start nil) - (display (font-display font))) - (declare (type int32 width) - (type (or null array-index) next-start) - (type display display)) - (with-display (display) - (do* ((wbuf (display-tbuf16 display)) - (src-end (or end (length sequence))) - (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start *buffer-text16-size*)) - (index-min src-end (index+ src-start *buffer-text16-size*))) - (buf-end 0) - (new-font) - (stop-p nil)) - ((or stop-p (index>= src-start src-end)) - (when (index< src-start src-end) - (setq next-start src-start))) - (declare (type buffer-text16 wbuf) - (type array-index src-start src-end end buf-end) - (type boolean stop-p)) - ;; Translate the text - (multiple-value-setq (buf-end new-font) - (funcall (or translate #'translate-default) - sequence src-start end font wbuf 0)) - (setq buf-end (- buf-end src-start)) - (cond ((null new-font) (setq stop-p t)) - ((integerp new-font) (incf width (the int32 new-font)))) - - (incf width - (if (or (font-char-infos-internal font) (font-local-only-p font)) - (text-extents-local font wbuf 0 buf-end :width-only) - (text-width-server font wbuf 0 buf-end))) - (when (type? new-font 'font) - (setq font new-font)))) - (values width next-start))) - -(defun text-extents-server (font string start end) - (declare (type font font) - (type string string) - (type array-index start end)) - (declare (clx-values width ascent descent left right font-ascent font-descent direction)) - (let ((display (font-display font)) - (length (index- end start)) - (font-id (font-id font))) - (declare (type display display) - (type array-index length) - (type resource-id font-id)) - (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes (8 16 32)) - (((data boolean) (oddp length)) - (length (index+ (index-ceiling length 2) 2)) - (resource-id font-id) - ((sequence :format char2b :start start :end end :appending t) - string)) - (values - (integer-get 16) - (int16-get 12) - (int16-get 14) - (integer-get 20) - (integer-get 24) - (int16-get 8) - (int16-get 10) - (member8-get 1 :left-to-right :right-to-left))))) - -(defun text-width-server (font string start end) - (declare (type (or font gcontext) font) - (type string string) - (type array-index start end)) - (declare (clx-values integer)) - (let ((display (font-display font)) - (length (index- end start)) - (font-id (font-id font))) - (declare (type display display) - (type array-index length) - (type resource-id font-id)) - (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes 32) - (((data boolean) (oddp length)) - (length (index+ (index-ceiling length 2) 2)) - (resource-id font-id) - ((sequence :format char2b :start start :end end :appending t) - string)) - (values (integer-get 16))))) - -(defun text-extents-local (font sequence start end width-only-p) - (declare (type font font) - (type sequence sequence) - (type integer start end) - (type boolean width-only-p)) - (declare (clx-values width ascent descent overall-left overall-right)) - (let* ((char-infos (font-char-infos font)) - (font-info (font-font-info font))) - (declare (type font-info font-info)) - (declare (type (simple-array int16 (*)) char-infos)) - (if (zerop (length char-infos)) - ;; Fixed width font - (let* ((font-width (max-char-width font)) - (font-ascent (max-char-ascent font)) - (font-descent (max-char-descent font)) - (width (* (index- end start) font-width))) - (declare (type int16 font-width font-ascent font-descent) - (type int32 width)) - (if width-only-p - width - (values width - font-ascent - font-descent - (max-char-left-bearing font) - (+ width (- font-width) (max-char-right-bearing font))))) - - ;; Variable-width font - (let* ((first-col (font-info-min-byte2 font-info)) - (num-cols (1+ (- (font-info-max-byte2 font-info) first-col))) - (first-row (font-info-min-byte1 font-info)) - (last-row (font-info-max-byte1 font-info)) - (num-rows (1+ (- last-row first-row)))) - (declare (type card8 first-col first-row last-row) - (type card16 num-cols num-rows)) - (if (or (plusp first-row) (plusp last-row)) - - ;; Matrix (16 bit) font - (macrolet ((char-info-elt (sequence elt) - `(let* ((char (the card16 (elt ,sequence ,elt))) - (row (- (ash char -8) first-row)) - (col (- (logand char #xff) first-col))) - (declare (type card16 char) - (type int16 row col)) - (if (and (< -1 row num-rows) (< -1 col num-cols)) - (index* 6 (index+ (index* row num-cols) col)) - -1)))) - (if width-only-p - (do ((i start (index1+ i)) - (width 0)) - ((index>= i end) width) - (declare (type array-index i) - (type int32 width)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (incf width (the int16 (aref char-infos (index+ 2 n))))))) - ;; extents - (do ((i start (index1+ i)) - (width 0) - (ascent #x-7fff) - (descent #x-7fff) - (left #x7fff) - (right #x-7fff)) - ((index>= i end) - (values width ascent descent left right)) - (declare (type array-index i) - (type int16 ascent descent) - (type int32 width left right)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (setq left (min left (+ width (aref char-infos n)))) - (setq right (max right (+ width (aref char-infos (index1+ n))))) - (incf width (aref char-infos (index+ 2 n))) - (setq ascent (max ascent (aref char-infos (index+ 3 n)))) - (setq descent (max descent (aref char-infos (index+ 4 n))))))))) - - ;; Non-matrix (8 bit) font - ;; The code here is identical to the above, except for the following macro: - (macrolet ((char-info-elt (sequence elt) - `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col))) - (declare (type int16 col)) - (if (< -1 col num-cols) - (index* 6 col) - -1)))) - (if width-only-p - (do ((i start (index1+ i)) - (width 0)) - ((index>= i end) width) - (declare (type array-index i) - (type int32 width)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (incf width (the int16 (aref char-infos (index+ 2 n))))))) - ;; extents - (do ((i start (index1+ i)) - (width 0) - (ascent #x-7fff) - (descent #x-7fff) - (left #x7fff) - (right #x-7fff)) - ((index>= i end) - (values width ascent descent left right)) - (declare (type array-index i) - (type int16 ascent descent) - (type int32 width left right)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (setq left (min left (+ width (aref char-infos n)))) - (setq right (max right (+ width (aref char-infos (index1+ n))))) - (incf width (aref char-infos (index+ 2 n))) - (setq ascent (max ascent (aref char-infos (index+ 3 n)))) - (setq descent (max descent (aref char-infos (index+ 4 n))))) - )))) - ))))) - -;;----------------------------------------------------------------------------- - -;; This controls the element size of the dst buffer given to translate. If -;; :default is specified, the size will be based on the current font, if known, -;; and otherwise 16 will be used. [An alternative would be to pass the buffer -;; size to translate, and allow it to return the desired size if it doesn't -;; like the current size. The problem is that the protocol doesn't allow -;; switching within a single request, so to allow switching would require -;; knowing the width of text, which isn't necessarily known. We could call -;; text-width to compute it, but perhaps that is doing too many favors?] [An -;; additional possibility is to allow an index-size of :two-byte, in which case -;; translate would be given a double-length 8-bit array, and translate would be -;; expected to store first-byte/second-byte instead of 16-bit integers.] - -(deftype index-size () '(member :default 8 16)) - -;; In the functions below, if width is specified, it is assumed to be the total -;; pixel width of whatever string of glyphs is actually drawn. Specifying -;; width will allow for appending the output of subsequent calls to the same -;; protocol request, provided gcontext has not been modified in the interim. -;; If width is not specified, appending of subsequent output might not occur -;; (unless translate returns the width). Specifying width is simply a hint, -;; for performance. - -(defun draw-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values boolean (or null int32))) - (let* ((display (gcontext-display gcontext)) - (result t) - (opcode *x-polytext8*)) - (declare (type display display)) - (let ((vector (allocate-gcontext-state))) - (declare (type gcontext-state vector)) - (setf (aref vector 0) elt) - (multiple-value-bind (new-start new-font translate-width) - (funcall (or translate #'translate-default) - vector 0 1 (gcontext-font gcontext t) vector 1) - ;; Allow translate to set a new font - (when (type? new-font 'font) - (setf (gcontext-font gcontext) new-font) - (multiple-value-setq (new-start new-font translate-width) - (funcall translate vector 0 1 new-font vector 1))) - ;; If new-start is zero, translate refuses to output it - (setq result (index-plusp new-start) - elt (aref vector 1)) - (deallocate-gcontext-state vector) - (when translate-width (setq width translate-width)))) - (when result - (when (eql size 16) - (setq opcode *x-polytext16*) - (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) - (with-buffer-request (display opcode :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card8 1 0) - (card8 (ldb (byte 8 0) elt)) - (card8 (ldb (byte 8 8) elt))) - (values t width)))) - -(defun draw-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values (or null array-index) (or null int32))) - (unless end (setq end (length sequence))) - (ecase size - ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end - (or translate #'translate-default) width)) - (16 (draw-glyphs16 drawable gcontext x y sequence start end - (or translate #'translate-default) width)))) - -(defun draw-glyphs8 (drawable gcontext x y sequence start end translate width) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (clx-values (or null array-index) (or null int32))) - (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (let* ((src-start start) - (src-end (or end (length sequence))) - (next-start nil) - (length (index- src-end src-start)) - (request-length (* length 2)) ; Leave lots of room for font shifts. - (display (gcontext-display gcontext)) - ;; Should metrics-p be T? Don't want to pass a NIL font into translate... - (font (gcontext-font gcontext t))) - (declare (type array-index src-start src-end length) - (type (or null array-index) next-start) - (type display display)) - (with-buffer-request (display *x-polytext8* :gc-force gcontext :length request-length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - (do* ((boffset (index+ buffer-boffset 16)) - (src-chunk 0) - (dst-chunk 0) - (offset 0) - (overall-width 0) - (stop-p nil)) - ((or stop-p (zerop length)) - ;; Ensure terminated with zero bytes - (do ((end (the array-index (lround boffset)))) - ((index>= boffset end)) - (setf (aref buffer-bbuf boffset) 0) - (index-incf boffset)) - (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) - (setf (buffer-boffset display) boffset) - (unless (index-zerop length) (setq next-start src-start)) - (when overall-width (setq width overall-width))) - - (declare (type array-index src-chunk dst-chunk offset) - (type (or null int32) overall-width) - (type boolean stop-p)) - (setq src-chunk (index-min length *max-string-size*)) - (multiple-value-bind (new-start new-font translated-width) - (funcall translate - sequence src-start (index+ src-start src-chunk) - font buffer-bbuf (index+ boffset 2)) - (setq dst-chunk (index- new-start src-start) - length (index- length dst-chunk) - src-start new-start) - (if translated-width - (when overall-width (incf overall-width translated-width)) - (setq overall-width nil)) - (when (index-plusp dst-chunk) - (setf (aref buffer-bbuf boffset) dst-chunk) - (setf (aref buffer-bbuf (index+ boffset 1)) offset) - (incf boffset (index+ dst-chunk 2))) - (setq offset 0) - (cond ((null new-font) - ;; Don't stop if translate copied whole chunk - (unless (index= src-chunk dst-chunk) - (setq stop-p t))) - ((integerp new-font) (setq offset new-font)) - ((type? new-font 'font) - (setq font new-font) - (let ((font-id (font-id font)) - (buffer-boffset boffset)) - (declare (type resource-id font-id) - (type array-index buffer-boffset)) - ;; This changes the gcontext font in the server - ;; Update the gcontext cache (both local and server state) - (let ((local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state local-state server-state)) - (setf (gcontext-internal-font-obj server-state) font - (gcontext-internal-font server-state) font-id) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font - (gcontext-internal-font local-state) font-id))) - (card8-put 0 #xff) - (card8-put 1 (ldb (byte 8 24) font-id)) - (card8-put 2 (ldb (byte 8 16) font-id)) - (card8-put 3 (ldb (byte 8 8) font-id)) - (card8-put 4 (ldb (byte 8 0) font-id))) - (index-incf boffset 5))) - ))))) - (values next-start width))) - -;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer -;; on 16bit boundaries and this function garbles the bytes. -(defun draw-glyphs16 (drawable gcontext x y sequence start end translate width) - ;; First result is new start, if end was not reached. Second result is - ;; overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (clx-values (or null array-index) (or null int32))) - (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (let* ((src-start start) - (src-end (or end (length sequence))) - (next-start nil) - (length (index- src-end src-start)) - (request-length (* length 3)) ; Leave lots of room for font shifts. - (display (gcontext-display gcontext)) - ;; Should metrics-p be T? Don't want to pass a NIL font into translate... - (font (gcontext-font gcontext t)) - (buffer (display-tbuf16 display))) - (declare (type array-index src-start src-end length) - (type (or null array-index) next-start) - (type display display) - (type buffer-text16 buffer)) - (with-buffer-request (display *x-polytext16* :gc-force gcontext :length request-length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - (do* ((boffset (index+ buffer-boffset 16)) - (src-chunk 0) - (dst-chunk 0) - (offset 0) - (overall-width 0) - (stop-p nil)) - ((or stop-p (zerop length)) - ;; Ensure terminated with zero bytes - (do ((end (lround boffset))) - ((index>= boffset end)) - (setf (aref buffer-bbuf boffset) 0) - (index-incf boffset)) - (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) - (setf (buffer-boffset display) boffset) - (unless (zerop length) (setq next-start src-start)) - (when overall-width (setq width overall-width))) - - (declare (type array-index boffset src-chunk dst-chunk offset) - (type (or null int32) overall-width) - (type boolean stop-p)) - (setq src-chunk (index-min length *max-string-size*)) - (multiple-value-bind (new-start new-font translated-width) - (funcall translate - sequence src-start (index+ src-start src-chunk) - font buffer 0) - (setq dst-chunk (index- new-start src-start) - length (index- length dst-chunk) - src-start new-start) - (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk) - (if translated-width - (when overall-width (incf overall-width translated-width)) - (setq overall-width nil)) - (when (index-plusp dst-chunk) - (setf (aref buffer-bbuf boffset) dst-chunk) - (setf (aref buffer-bbuf (index+ boffset 1)) offset) - (index-incf boffset (index+ dst-chunk dst-chunk 2))) - (setq offset 0) - (cond ((null new-font) - ;; Don't stop if translate copied whole chunk - (unless (index= src-chunk dst-chunk) - (setq stop-p t))) - ((integerp new-font) (setq offset new-font)) - ((type? new-font 'font) - (setq font new-font) - (let ((font-id (font-id font)) - (buffer-boffset boffset)) - (declare (type resource-id font-id) - (type array-index buffer-boffset)) - ;; This changes the gcontext font in the SERVER - ;; Update the gcontext cache (both local and server state) - (let ((local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state local-state server-state)) - (setf (gcontext-internal-font-obj server-state) font - (gcontext-internal-font server-state) font-id) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font - (gcontext-internal-font local-state) font-id))) - (card8-put 0 #xff) - (card8-put 1 (ldb (byte 8 24) font-id)) - (card8-put 2 (ldb (byte 8 16) font-id)) - (card8-put 3 (ldb (byte 8 8) font-id)) - (card8-put 4 (ldb (byte 8 0) font-id))) - (index-incf boffset 5))) - ))))) - (values next-start width))) - -(defun draw-image-glyph (drawable gcontext x y elt - &key translate width (size :default)) - ;; Returns true if elt is output, nil if translate refuses to output it. - ;; Second result is overall width, if known. An initial font change is - ;; allowed from translate. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values boolean (or null int32))) - (let* ((display (gcontext-display gcontext)) - (result t) - (opcode *x-imagetext8*)) - (declare (type display display)) - (let ((vector (allocate-gcontext-state))) - (declare (type gcontext-state vector)) - (setf (aref vector 0) elt) - (multiple-value-bind (new-start new-font translate-width) - (funcall (or translate #'translate-default) - vector 0 1 (gcontext-font gcontext t) vector 1) - ;; Allow translate to set a new font - (when (type? new-font 'font) - (setf (gcontext-font gcontext) new-font) - (multiple-value-setq (new-start new-font translate-width) - (funcall translate vector 0 1 new-font vector 1))) - ;; If new-start is zero, translate refuses to output it - (setq result (index-plusp new-start) - elt (aref vector 1)) - (deallocate-gcontext-state vector) - (when translate-width (setq width translate-width)))) - (when result - (when (eql size 16) - (setq opcode *x-imagetext16*) - (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) - (with-buffer-request (display opcode :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (data 1) ;; 1 character - (int16 x y) - (card8 (ldb (byte 8 0) elt)) - (card8 (ldb (byte 8 8) elt))) - (values t width)))) - -(defun draw-image-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type (or null array-index) end) - (type sequence sequence) - (type (or null int32) width) - (type index-size size)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) - (declare (clx-values (or null array-index) (or null int32))) - (setf end (index-min (index+ start 255) (or end (length sequence)))) - (ecase size - ((:default 8) - (draw-image-glyphs8 drawable gcontext x y sequence start end translate width)) - (16 - (draw-image-glyphs16 drawable gcontext x y sequence start end translate width)))) - -(defun draw-image-glyphs8 (drawable gcontext x y sequence start end translate width) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (declare (clx-values (or null array-index) (or null int32))) - (do* ((display (gcontext-display gcontext)) - (length (index- end start)) - ;; Should metrics-p be T? Don't want to pass a NIL font into translate... - (font (gcontext-font gcontext t)) - (font-change nil) - (new-start) (translated-width) (chunk)) - (nil) ;; forever - (declare (type display display) - (type array-index length) - (type (or null array-index) new-start chunk)) - - (when font-change - (setf (gcontext-font gcontext) font)) - (block change-font - (with-buffer-request (display *x-imagetext8* :gc-force gcontext :length length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - ;; Translate the sequence into the buffer - (multiple-value-setq (new-start font translated-width) - (funcall (or translate #'translate-default) sequence start end - font buffer-bbuf (index+ buffer-boffset 16))) - ;; Number of glyphs translated - (setq chunk (index- new-start start)) - ;; Check for initial font change - (when (and (index-zerop chunk) (type? font 'font)) - (setq font-change t) ;; Loop around changing font - (return-from change-font)) - ;; Quit when nothing translated - (when (index-zerop chunk) - (return-from draw-image-glyphs8 new-start)) - ;; Update buffer pointers - (data-put 1 chunk) - (let ((blen (lround (index+ 16 chunk)))) - (length-put 2 (index-ash blen -2)) - (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) - ;; Normal exit - (return-from draw-image-glyphs8 - (values (if (index= chunk length) nil new-start) - (or translated-width width)))))) - -(defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width) - ;; An initial font change is allowed from translate, but any subsequent font - ;; change or horizontal motion will cause termination (because the protocol - ;; doesn't support chaining). [Alternatively, font changes could be accepted - ;; as long as they are accompanied with a width return value, or always - ;; accept font changes and call text-width as required. However, horizontal - ;; motion can't really be accepted, due to semantics.] First result is new - ;; start, if end was not reached. Second result is overall width, if known. - (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) - (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) - (declare (clx-values (or null array-index) (or null int32))) - (do* ((display (gcontext-display gcontext)) - (length (index- end start)) - ;; Should metrics-p be T? Don't want to pass a NIL font into translate... - (font (gcontext-font gcontext t)) - (font-change nil) - (new-start) (translated-width) (chunk) - (buffer (buffer-tbuf16 display))) - (nil) ;; forever - - (declare (type display display) - (type array-index length) - (type (or null array-index) new-start chunk) - (type buffer-text16 buffer)) - (when font-change - (setf (gcontext-font gcontext) font)) - - (block change-font - (with-buffer-request (display *x-imagetext16* :gc-force gcontext :length length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - ;; Translate the sequence into the buffer - (multiple-value-setq (new-start font translated-width) - (funcall (or translate #'translate-default) sequence start end - font buffer 0)) - ;; Number of glyphs translated - (setq chunk (index- new-start start)) - ;; Check for initial font change - (when (and (index-zerop chunk) (type? font 'font)) - (setq font-change t) ;; Loop around changing font - (return-from change-font)) - ;; Quit when nothing translated - (when (index-zerop chunk) - (return-from draw-image-glyphs16 new-start)) - (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk) - ;; Update buffer pointers - (data-put 1 chunk) - (let ((blen (lround (index+ 16 (index-ash chunk 1))))) - (length-put 2 (index-ash blen -2)) - (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) - ;; Normal exit - (return-from draw-image-glyphs16 - (values (if (index= chunk length) nil new-start) - (or translated-width width)))))) - - -;;----------------------------------------------------------------------------- - -(defun display-keycode-range (display) - (declare (type display display)) - (declare (clx-values min max)) - (values (display-min-keycode display) - (display-max-keycode display))) - -;; Should this signal device-busy like the pointer-mapping setf, and return a -;; boolean instead (true for success)? Alternatively, should the -;; pointer-mapping setf be changed to set-pointer-mapping with a (member -;; :success :busy) result? - -(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) - ;; Setf ought to allow multiple values. - (declare (type display display) - (type sequence shift lock control mod1 mod2 mod3 mod4 mod5)) - (declare (clx-values (member :success :busy :failed))) - (let* ((keycodes-per-modifier (index-max (length shift) - (length lock) - (length control) - (length mod1) - (length mod2) - (length mod3) - (length mod4) - (length mod5))) - (data (make-array (index* 8 keycodes-per-modifier) - :element-type 'card8 - :initial-element 0))) - (replace data shift) - (replace data lock :start1 keycodes-per-modifier) - (replace data control :start1 (index* 2 keycodes-per-modifier)) - (replace data mod1 :start1 (index* 3 keycodes-per-modifier)) - (replace data mod2 :start1 (index* 4 keycodes-per-modifier)) - (replace data mod3 :start1 (index* 5 keycodes-per-modifier)) - (replace data mod4 :start1 (index* 6 keycodes-per-modifier)) - (replace data mod5 :start1 (index* 7 keycodes-per-modifier)) - (with-buffer-request-and-reply (display *x-setmodifiermapping* 4 :sizes 8) - ((data keycodes-per-modifier) - ((sequence :format card8) data)) - (values (member8-get 1 :success :busy :failed))))) - -(defun modifier-mapping (display) - ;; each value is a list of integers - (declare (type display display)) - (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5)) - (let ((lists nil)) - (with-buffer-request-and-reply (display *x-getmodifiermapping* nil :sizes 8) - () - (do* ((keycodes-per-modifier (card8-get 1)) - (advance-by *replysize* keycodes-per-modifier) - (keys nil nil) - (i 0 (index+ i 1))) - ((index= i 8)) - (advance-buffer-offset advance-by) - (dotimes (j keycodes-per-modifier) - (let ((key (read-card8 j))) - (unless (zerop key) - (push key keys)))) - (push (nreverse keys) lists))) - (values-list (nreverse lists)))) - -;; Either we will want lots of defconstants for well-known values, or perhaps -;; an integer-to-keyword translation function for well-known values. - -(defun change-keyboard-mapping - (display keysyms &key (start 0) end (first-keycode start)) - ;; start/end give subrange of keysyms - ;; first-keycode is the first-keycode to store at - (declare (type display display) - (type array-index start) - (type card8 first-keycode) - (type (or null array-index) end) - (type (array * (* *)) keysyms)) - (let* ((keycode-end (or end (array-dimension keysyms 0))) - (keysyms-per-keycode (array-dimension keysyms 1)) - (length (index- keycode-end start)) - (size (index* length keysyms-per-keycode)) - (request-length (index+ size 2))) - (declare (type array-index keycode-end keysyms-per-keycode length request-length)) - (with-buffer-request (display *x-setkeyboardmapping* - :length (index-ash request-length 2) - :sizes (32)) - (data length) - (length request-length) - (card8 first-keycode keysyms-per-keycode) - (progn - (do ((limit (index-ash (buffer-size display) -2)) - (w (index+ 2 (index-ash buffer-boffset -2))) - (i start (index+ i 1))) - ((index>= i keycode-end) - (setf (buffer-boffset display) (index-ash w 2))) - (declare (type array-index limit w i)) - (when (index> w limit) - (buffer-flush display) - (setq w (index-ash (buffer-boffset display) -2))) - (do ((j 0 (index+ j 1))) - ((index>= j keysyms-per-keycode)) - (declare (type array-index j)) - (card29-put (index* w 4) (aref keysyms i j)) - (index-incf w))))))) - -(defun keyboard-mapping (display &key first-keycode start end data) - ;; First-keycode specifies which keycode to start at (defaults to min-keycode). - ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode) - ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)). - ;; If DATA is specified, the results are put there. - (declare (type display display) - (type (or null card8) first-keycode) - (type (or null array-index) start end) - (type (or null (array * (* *))) data)) - (declare (clx-values (array * (* *)))) - (unless first-keycode (setq first-keycode (display-min-keycode display))) - (unless start (setq start first-keycode)) - (unless end (setq end (1+ (display-max-keycode display)))) - (with-buffer-request-and-reply (display *x-getkeyboardmapping* nil :sizes (8 32)) - ((card8 first-keycode (index- end start))) - (do* ((keysyms-per-keycode (card8-get 1)) - (bytes-per-keycode (* keysyms-per-keycode 4)) - (advance-by *replysize* bytes-per-keycode) - (keycode-count (floor (card32-get 4) keysyms-per-keycode) - (index- keycode-count 1)) - (result (if (and (arrayp data) - (= (array-rank data) 2) - (>= (array-dimension data 0) (index+ start keycode-count)) - (>= (array-dimension data 1) keysyms-per-keycode)) - data - (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode) - :element-type 'keysym :initial-element 0))) - (i start (1+ i))) - ((zerop keycode-count) (setq data result)) - (advance-buffer-offset advance-by) - (dotimes (j keysyms-per-keycode) - (setf (aref result i j) (card29-get (* j 4)))))) - data) diff --git a/clx/translate.lisp b/clx/translate.lisp deleted file mode 100644 index aa8ff5b2d0b160c1a4160bb3d4c50a36ffa256a0..0000000000000000000000000000000000000000 --- a/clx/translate.lisp +++ /dev/null @@ -1,563 +0,0 @@ -;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- - -;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 -;;; -;;; Copyright (C) 1987 Texas Instruments Incorporated. -;;; -;;; Permission is granted to any individual or institution to use, copy, modify, -;;; and distribute this software, provided that this complete copyright and -;;; permission notice is maintained, intact, in all copies and supporting -;;; documentation. -;;; -;;; Texas Instruments Incorporated provides this software "as is" without -;;; express or implied warranty. -;;; - -(in-package :xlib) - -(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym) - -(defun define-keysym-set (set first-keysym last-keysym) - ;; Define all keysyms from first-keysym up to and including - ;; last-keysym to be in SET (returned from the keysym-set function). - ;; Signals an error if the keysym range overlaps an existing set. - (declare (type keyword set) - (type keysym first-keysym last-keysym)) - (when (> first-keysym last-keysym) - (rotatef first-keysym last-keysym)) - (setq *keysym-sets* (delete set *keysym-sets* :key #'car)) - (dolist (set *keysym-sets*) - (let ((first (second set)) - (last (third set))) - (when (or (<= first first-keysym last) - (<= first last-keysym last)) - (error "Keysym range overlaps existing set ~s" set)))) - (push (list set first-keysym last-keysym) *keysym-sets*) - set) - -(defun keysym-set (keysym) - ;; Return the character code set name of keysym - (declare (type keysym keysym) - (clx-values keyword)) - (dolist (set *keysym-sets*) - (let ((first (second set)) - (last (third set))) - (when (<= first keysym last) - (return (first set)))))) - -(eval-when (compile eval load) ;; Required for Vaxlisp ... -(defmacro keysym (keysym &rest bytes) - ;; Build a keysym. - ;; If KEYSYM is an integer, it is used as the most significant bits of - ;; the keysym, and BYTES are used to specify low order bytes. The last - ;; parameter is always byte4 of the keysym. If KEYSYM is not an - ;; integer, the keysym associated with KEYSYM is returned. - ;; - ;; This is a macro and not a function macro to promote compile-time - ;; lookup. All arguments are evaluated. - (declare (type t keysym) - (type list bytes) - (clx-values keysym)) - (typecase keysym - ((integer 0 *) - (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b)))) - (otherwise - (or (car (character->keysyms keysym)) - (error "~s Isn't the name of a keysym" keysym))))) -) - -(defvar *keysym->character-map* - (make-hash-table :test (keysym->character-map-test) :size 400)) - -;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask) -;; With the following accessor macros. Everything after OBJECT is optional. - -(defmacro keysym-mapping-object (keysym-mapping) - ;; Parameter to translate - `(first ,keysym-mapping)) - -(defmacro keysym-mapping-translate (keysym-mapping) - ;; Function to be called with parameters (display state OBJECT) - ;; when translating KEYSYM and modifiers and mask are satisfied. - `(second ,keysym-mapping)) - -(defmacro keysym-mapping-lowercase (keysym-mapping) - ;; LOWERCASE is used for uppercase alphabetic keysyms. The value - ;; is the associated lowercase keysym. - `(third ,keysym-mapping)) - -(defmacro keysym-mapping-modifiers (keysym-mapping) - ;; MODIFIERS is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying when to use this - ;; keysym-translation. - `(fourth ,keysym-mapping)) - -(defmacro keysym-mapping-mask (keysym-mapping) - ;; MASK is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying which modifiers to look at - ;; (i.e. modifiers not specified are don't-cares) - `(fifth ,keysym-mapping)) - -(defvar *default-keysym-translate-mask* - (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - (logand #xff (lognot (make-state-mask :lock)))) - "Default keysym state mask to use during keysym-translation.") - -(defun define-keysym (object keysym &key lowercase translate modifiers mask display) - ;; Define the translation from keysym/modifiers to a (usually - ;; character) object. ANy previous keysym definition with - ;; KEYSYM and MODIFIERS is deleted before adding the new definition. - ;; - ;; MODIFIERS is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying when to use this - ;; keysym-translation. The default is NIL. - ;; - ;; MASK is either a modifier-mask or list containing intermixed - ;; keysyms and state-mask-keys specifying which modifiers to look at - ;; (i.e. modifiers not specified are don't-cares). - ;; If mask is :MODIFIERS then the mask is the same as the modifiers - ;; (i.e. modifiers not specified by modifiers are don't cares) - ;; The default mask is *default-keysym-translate-mask* - ;; - ;; If DISPLAY is specified, the translation will be local to DISPLAY, - ;; otherwise it will be the default translation for all displays. - ;; - ;; LOWERCASE is used for uppercase alphabetic keysyms. The value - ;; is the associated lowercase keysym. This information is used - ;; by the keysym-both-case-p predicate (for caps-lock computations) - ;; and by the keysym-downcase function. - ;; - ;; TRANSLATE will be called with parameters (display state OBJECT) - ;; when translating KEYSYM and modifiers and mask are satisfied. - ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*)) - ;; (or modifiers 0))) - ;; when mask and modifiers aren't lists of keysyms] - ;; The default is #'default-keysym-translate - ;; - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - mask) - (type (or null display) display) - (type (or null keysym) lowercase) - (type (or null (function (display card16 t) t)) translate)) - (flet ((merge-keysym-mappings (new old) - ;; Merge new keysym-mapping with list of old mappings. - ;; Ensure that the mapping with no modifiers or mask comes first. - (let* ((key (keysym-mapping-modifiers new)) - (merge (delete key old :key #'cadddr :test #'equal))) - (if key - (nconc merge (list new)) - (cons new merge)))) - (mask-check (mask) - (unless (or (numberp mask) - (dolist (element mask t) - (unless (or (find element *state-mask-vector*) - (gethash element *keysym->character-map*)) - (return nil)))) - (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym))))))) - (let ((entry - ;; Create with a single LIST call, to ensure cdr-coding - (cond - (mask - (unless (eq mask :modifiers) - (mask-check mask)) - (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers))) - (error "Mask with no modifiers")) - (list object translate lowercase modifiers mask)) - (modifiers (mask-check modifiers) - (list object translate lowercase modifiers)) - (lowercase (list object translate lowercase)) - (translate (list object translate)) - (t (list object))))) - (if display - (let ((previous (assoc keysym (display-keysym-translation display)))) - (if previous - (setf (cdr previous) (merge-keysym-mappings entry (cdr previous))) - (push (list keysym entry) (display-keysym-translation display)))) - (setf (gethash keysym *keysym->character-map*) - (merge-keysym-mappings entry (gethash keysym *keysym->character-map*))))) - object)) - -(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) - ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS. - ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists. - (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null display) display)) - (flet ((match (key entry) - (let ((object (car key)) - (modifiers (cdr key))) - (or (eql object (keysym-mapping-object entry)) - (equal modifiers (keysym-mapping-modifiers entry)))))) - (let* (entry - (previous (if display - (cdr (setq entry (assoc keysym (display-keysym-translation display)))) - (gethash keysym *keysym->character-map*))) - (key (cons object modifiers))) - (when (and previous (find key previous :test #'match)) - (setq previous (delete key previous :test #'match)) - (if display - (setf (cdr entry) previous) - (setf (gethash keysym *keysym->character-map*) previous)))))) - -(defun keysym-downcase (keysym) - ;; If keysym has a lower-case equivalent, return it, otherwise return keysym. - (declare (type keysym keysym)) - (declare (clx-values keysym)) - (let ((translations (gethash keysym *keysym->character-map*))) - (or (and translations (keysym-mapping-lowercase (first translations))) keysym))) - -(defun keysym-uppercase-alphabetic-p (keysym) - ;; Returns T if keysym is uppercase-alphabetic. - ;; I.E. If it has a lowercase equivalent. - (declare (type keysym keysym)) - (declare (clx-values (or null keysym))) - (let ((translations (gethash keysym *keysym->character-map*))) - (and translations - (keysym-mapping-lowercase (first translations))))) - -(defun character->keysyms (character &optional display) - ;; Given a character, return a list of all matching keysyms. - ;; If DISPLAY is given, translations specific to DISPLAY are used, - ;; otherwise only global translations are used. - ;; Implementation dependent function. - ;; May be slow [i.e. do a linear search over all known keysyms] - (declare (type t character) - (type (or null display) display) - (clx-values (clx-list keysym))) - (let ((result nil)) - (when display - (dolist (mapping (display-keysym-translation display)) - (when (eql character (second mapping)) - (push (first mapping) result)))) - (maphash #'(lambda (keysym mappings) - (dolist (mapping mappings) - (when (eql (keysym-mapping-object mapping) character) - (pushnew keysym result)))) - *keysym->character-map*) - result)) - -(eval-when (compile eval load) ;; Required for Symbolics... -(defconstant character-set-switch-keysym (keysym 255 126)) -(defconstant left-shift-keysym (keysym 255 225)) -(defconstant right-shift-keysym (keysym 255 226)) -(defconstant left-control-keysym (keysym 255 227)) -(defconstant right-control-keysym (keysym 255 228)) -(defconstant caps-lock-keysym (keysym 255 229)) -(defconstant shift-lock-keysym (keysym 255 230)) -(defconstant left-meta-keysym (keysym 255 231)) -(defconstant right-meta-keysym (keysym 255 232)) -(defconstant left-alt-keysym (keysym 255 233)) -(defconstant right-alt-keysym (keysym 255 234)) -(defconstant left-super-keysym (keysym 255 235)) -(defconstant right-super-keysym (keysym 255 236)) -(defconstant left-hyper-keysym (keysym 255 237)) -(defconstant right-hyper-keysym (keysym 255 238)) -) ;; end eval-when - - -;;----------------------------------------------------------------------------- -;; Keysym mapping functions - -(defun display-keyboard-mapping (display) - (declare (type display display)) - (declare (clx-values (simple-array keysym (display-max-keycode keysyms-per-keycode)))) - (or (display-keysym-mapping display) - (setf (display-keysym-mapping display) (keyboard-mapping display)))) - -(defun keycode->keysym (display keycode keysym-index) - (declare (type display display) - (type card8 keycode) - (type card8 keysym-index) - (clx-values keysym)) - (let* ((mapping (display-keyboard-mapping display)) - (keysym (aref mapping keycode keysym-index))) - (declare (type (simple-array keysym (* *)) mapping) - (type keysym keysym)) - ;; The keysym-mapping is brain dammaged. - ;; Mappings for both-case alphabetic characters have the - ;; entry for keysym-index zero set to the uppercase keysym - ;; (this is normally where the lowercase keysym goes), and the - ;; entry for keysym-index one is zero. - (cond ((zerop keysym-index) ; Lowercase alphabetic keysyms - (keysym-downcase keysym)) - ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym - (aref mapping keycode 0)) - (t keysym)))) - -(defun keysym->character (display keysym &optional (state 0)) - ;; Find the character associated with a keysym. - ;; STATE can be used to set character attributes. - ;; Implementation dependent function. - (declare (type display display) - (type keysym keysym) - (type card16 state)) - (declare (clx-values (or null character))) - (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display)))) - (mapping (or ;; Find the matching display mapping - (dolist (mapping display-mappings) - (when (mapping-matches-p display state mapping) - (return mapping))) - ;; Find the matching static mapping - (dolist (mapping (gethash keysym *keysym->character-map*)) - (when (mapping-matches-p display state mapping) - (return mapping)))))) - (when mapping - (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate) - display state (keysym-mapping-object mapping))))) - -(defun mapping-matches-p (display state mapping) - ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY - (declare (type display display) - (type mask16 state) - (type list mapping)) - (declare (clx-values boolean)) - (flet - ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0)) - ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask. - ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified, - ;; otherwise ignore unknown modifiers. - (declare (type list display-mapping) ; Alist of (keysym . mask) - (type (or mask16 list) modifiers) - (type mask16 mask)) - (declare (clx-values (or null mask16))) - (if (numberp modifiers) - modifiers - (dolist (modifier modifiers mask) - (declare (type symbol modifier)) - (let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq))) - (setq mask - (logior mask - (if bit - (ash 1 bit) - (or (cdr (assoc modifier display-mapping)) - ;; bad modifier - (if errorp - (return-from modifiers->mask nil) - 0)))))))))) - - (let* ((display-mapping (get-display-modifier-mapping display)) - (mapping-modifiers (keysym-mapping-modifiers mapping)) - (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t) - (return-from mapping-matches-p nil))) - (mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default. - (if mapping-modifiers ; If no modifiers, match anything. - *default-keysym-translate-mask* - 0))) - (mask (if (eq mapping-mask :modifiers) - modifiers - (modifiers->mask display-mapping mapping-mask nil)))) - (declare (type mask16 modifiers mask)) - (= (logand state mask) modifiers)))) - -(defun default-keysym-index (display keycode state) - ;; Returns a keysym-index for use with keycode->character - (declare (clx-values card8)) - (macrolet ((keystate-p (state keyword) - `(the boolean - (logbitp ,(position keyword *state-mask-vector*) - ,state)))) - (let* ((mapping (display-keyboard-mapping display)) - (keysyms-per-keycode (array-dimension mapping 1)) - (symbolp (and (> keysyms-per-keycode 2) - (state-keysymp display state character-set-switch-keysym))) - (result (if symbolp 2 0))) - (declare (type (simple-array keysym (* *)) mapping) - (type boolean symbolp) - (type card8 keysyms-per-keycode result)) - (when (and (< result keysyms-per-keycode) - (keysym-shift-p display state (keysym-uppercase-alphabetic-p - (aref mapping keycode 0)))) - (incf result)) - result))) - -(defun keysym-shift-p (display state uppercase-alphabetic-p &key - shift-lock-xors - (control-modifiers - '#.(list left-meta-keysym left-super-keysym left-hyper-keysym))) - (declare (type display display) - (type card16 state) - (type boolean uppercase-alphabetic-p) - (type boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same - ;;; as neither if the character is alphabetic. - (declare (clx-values boolean)) - (macrolet ((keystate-p (state keyword) - `(the boolean - (logbitp ,(position keyword *state-mask-vector*) - ,state)))) - (let* ((controlp (or (keystate-p state :control) - (dolist (modifier control-modifiers) - (when (state-keysymp display state modifier) - (return t))))) - (shiftp (keystate-p state :shift)) - (lockp (keystate-p state :lock)) - (alphap (or uppercase-alphabetic-p - (not (state-keysymp display #.(make-state-mask :lock) - caps-lock-keysym))))) - (declare (type boolean controlp shiftp lockp alphap)) - ;; Control keys aren't affected by lock - (unless controlp - ;; Not a control character - check state of lock modifier - (when (and lockp - alphap - (or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors - (setq shiftp (not shiftp)))) - shiftp))) - -;;; default-keysym-index implements the following tables: -;;; -;;; control shift caps-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\8 -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\* -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-8 -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-* -;;; -;;; control shift shift-lock character character -;;; 0 0 0 #\a #\8 -;;; 0 0 1 #\A #\* -;;; 0 1 0 #\A #\* -;;; 0 1 1 #\A #\8 -;;; 1 0 0 #\control-A #\control-8 -;;; 1 0 1 #\control-A #\control-* -;;; 1 1 0 #\control-shift-a #\control-* -;;; 1 1 1 #\control-shift-a #\control-8 - -(defun keycode->character (display keycode state &key keysym-index - (keysym-index-function #'default-keysym-index)) - ;; keysym-index defaults to the result of keysym-index-function which - ;; is called with the following parameters: - ;; (char0 state caps-lock-p keysyms-per-keycode) - ;; where char0 is the "character" object associated with keysym-index 0 and - ;; caps-lock-p is non-nil when the keysym associated with the lock - ;; modifier is for caps-lock. - ;; STATE can also used for setting character attributes. - ;; Implementation dependent function. - (declare (type display display) - (type card8 keycode) - (type card16 state) - (type (or null card8) keysym-index) - (type (or null (function (base-char card16 boolean card8) card8)) - keysym-index-function)) - (declare (clx-values (or null character))) - (let* ((index (or keysym-index - (funcall keysym-index-function display keycode state))) - (keysym (if index (keycode->keysym display keycode index) 0))) - (declare (type (or null card8) index) - (type keysym keysym)) - (when (plusp keysym) - (keysym->character display keysym state)))) - -(defun get-display-modifier-mapping (display) - (labels ((keysym-replace (display modifiers mask &aux result) - (dolist (modifier modifiers result) - (push (cons (keycode->keysym display modifier 0) mask) result)))) - (or (display-modifier-mapping display) - (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5) - (modifier-mapping display) - (setf (display-modifier-mapping display) - (nconc (keysym-replace display shift #.(make-state-mask :shift)) - (keysym-replace display lock #.(make-state-mask :lock)) - (keysym-replace display control #.(make-state-mask :control)) - (keysym-replace display mod1 #.(make-state-mask :mod-1)) - (keysym-replace display mod2 #.(make-state-mask :mod-2)) - (keysym-replace display mod3 #.(make-state-mask :mod-3)) - (keysym-replace display mod4 #.(make-state-mask :mod-4)) - (keysym-replace display mod5 #.(make-state-mask :mod-5)))))))) - -(defun state-keysymp (display state keysym) - ;; Returns T when a modifier key associated with KEYSYM is on in STATE - (declare (type display display) - (type card16 state) - (type keysym keysym)) - (declare (clx-values boolean)) - (let* ((mapping (get-display-modifier-mapping display)) - (mask (assoc keysym mapping))) - (and mask (plusp (logand state (cdr mask)))))) - -(defun mapping-notify (display request start count) - ;; Called on a mapping-notify event to update - ;; the keyboard-mapping cache in DISPLAY - (declare (type display display) - (type (member :modifier :keyboard :pointer) request) - (type card8 start count) - (ignore count start)) - ;; Invalidate the keyboard mapping to force the next key translation to get it - (case request - (:modifier - (setf (display-modifier-mapping display) nil)) - (:keyboard - (setf (display-keysym-mapping display) nil)))) - -(defun keysym-in-map-p (display keysym keymap) - ;; Returns T if keysym is found in keymap - (declare (type display display) - (type keysym keysym) - (type (bit-vector 256) keymap)) - (declare (clx-values boolean)) - ;; The keysym may appear in the keymap more than once, - ;; So we have to search the entire keysym map. - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (map (display-keyboard-mapping display)) - (jmax (min 2 (array-dimension map 1))) - (i min (1+ i))) - ((> i max)) - (declare (type card8 min max jmax) - (type (simple-array keysym (* *)) map)) - (when (and (plusp (aref keymap i)) - (dotimes (j jmax) - (when (= keysym (aref map i j)) (return t)))) - (return t)))) - -(defun character-in-map-p (display character keymap) - ;; Implementation dependent function. - ;; Returns T if character is found in keymap - (declare (type display display) - (type character character) - (type (bit-vector 256) keymap)) - (declare (clx-values boolean)) - ;; Check all one bits in keymap - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (jmax (array-dimension (display-keyboard-mapping display) 1)) - (i min (1+ i))) - ((> i max)) - (declare (type card8 min max jmax)) - (when (and (plusp (aref keymap i)) - ;; Match when character is in mapping for this keycode - (dotimes (j jmax) - (when (eql character (keycode->character display i 0 :keysym-index j)) - (return t)))) - (return t)))) - -(defun keysym->keycodes (display keysym) - ;; Return keycodes for keysym, as multiple values - (declare (type display display) - (type keysym keysym)) - (declare (clx-values (or null keycode) (or null keycode) (or null keycode))) - ;; The keysym may appear in the keymap more than once, - ;; So we have to search the entire keysym map. - (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (map (display-keyboard-mapping display)) - (jmax (min 2 (array-dimension map 1))) - (i min (1+ i)) - (result nil)) - ((> i max) (values-list result)) - (declare (type card8 min max jmax) - (type (simple-array keysym (* *)) map)) - (dotimes (j jmax) - (when (= keysym (aref map i j)) - (push i result))))) diff --git a/code/alieneval.lisp b/code/alieneval.lisp deleted file mode 100644 index 8c85f14f7611be0862cc14118e76247be832cf77..0000000000000000000000000000000000000000 --- a/code/alieneval.lisp +++ /dev/null @@ -1,1950 +0,0 @@ -;;; -*- Package: ALIEN -*- -;;; -;;; ********************************************************************** -;;; 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/code/alieneval.lisp,v 1.27 1992/11/11 02:33:52 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains any the part of the Alien implementation that -;;; is not part of the compiler. -;;; -(in-package "ALIEN") -(use-package "EXT") -(use-package "SYSTEM") - -(export '(alien * array struct union enum function integer signed unsigned - boolean values single-float double-float system-area-pointer - def-alien-type def-alien-variable sap-alien - extern-alien with-alien slot deref addr cast alien-sap alien-size - alien-funcall def-alien-routine make-alien free-alien - null-alien)) - -(in-package "ALIEN-INTERNALS") -(in-package "ALIEN") - -(import '(alien alien-value alien-value-type parse-alien-type - unparse-alien-type alien-type-= alien-subtype-p alien-typep - - def-alien-type-class def-alien-type-translator def-alien-type-method - invoke-alien-type-method - - alien-type alien-type-p alien-type-bits alien-type-alignment - alien-integer-type alien-integer-type-p alien-integer-type-signed - alien-boolean-type alien-boolean-type-p - alien-enum-type alien-enum-type-p - alien-float-type alien-float-type-p - alien-single-float-type alien-single-float-type-p - alien-double-float-type alien-double-float-type-p - alien-pointer-type alien-pointer-type-p alien-pointer-type-to - make-alien-pointer-type - alien-array-type alien-array-type-p alien-array-type-element-type - alien-array-type-dimensions - alien-record-type alien-record-type-p alien-record-type-fields - alien-record-field alien-record-field-p alien-record-field-name - alien-record-field-type alien-record-field-offset - alien-function-type alien-function-type-p make-alien-function-type - alien-function-type-result-type alien-function-type-arg-types - alien-values-type alien-values-type-p alien-values-type-values - *values-type-okay* - - %set-slot %slot-addr %set-deref %deref-addr - - %heap-alien %set-heap-alien %heap-alien-addr - heap-alien-info heap-alien-info-p heap-alien-info-type - heap-alien-info-sap-form - - local-alien %set-local-alien %local-alien-addr - local-alien-info local-alien-info-p local-alien-info-type - local-alien-info-force-to-memory-p - %local-alien-forced-to-memory-p - make-local-alien dispose-local-alien note-local-alien-type - - %cast %sap-alien align-offset - - extract-alien-value deposit-alien-value naturalize deport - compute-lisp-rep-type compute-alien-rep-type - compute-extract-lambda compute-deposit-lambda - compute-naturalize-lambda compute-deport-lambda) - "ALIEN-INTERNALS") - -(export '(alien alien-value alien-value-type parse-alien-type - unparse-alien-type alien-type-= alien-subtype-p alien-typep - - def-alien-type-class def-alien-type-translator def-alien-type-method - invoke-alien-type-method - - alien-type alien-type-p alien-type-bits alien-type-alignment - alien-integer-type alien-integer-type-p alien-integer-type-signed - alien-boolean-type alien-boolean-type-p - alien-enum-type alien-enum-type-p - alien-float-type alien-float-type-p - alien-single-float-type alien-single-float-type-p - alien-double-float-type alien-double-float-type-p - alien-pointer-type alien-pointer-type-p alien-pointer-type-to - make-alien-pointer-type - alien-array-type alien-array-type-p alien-array-type-element-type - alien-array-type-dimensions - alien-record-type alien-record-type-p alien-record-type-fields - alien-record-field alien-record-field-p alien-record-field-name - alien-record-field-type alien-record-field-offset - alien-function-type alien-function-type-p make-alien-function-type - alien-function-type-result-type alien-function-type-arg-types - alien-values-type alien-values-type-p alien-values-type-values - *values-type-okay* - - %set-slot %slot-addr %set-deref %deref-addr - - %heap-alien %set-heap-alien %heap-alien-addr - heap-alien-info heap-alien-info-p heap-alien-info-type - heap-alien-info-sap-form - - local-alien %set-local-alien %local-alien-addr - local-alien-info local-alien-info-p local-alien-info-type - local-alien-info-force-to-memory-p - %local-alien-forced-to-memory-p - make-local-alien dispose-local-alien note-local-alien-type - - %cast %sap-alien align-offset - - extract-alien-value deposit-alien-value naturalize deport - compute-lisp-rep-type compute-alien-rep-type - compute-extract-lambda compute-deposit-lambda - compute-naturalize-lambda compute-deport-lambda) - "ALIEN-INTERNALS") - - - -;;;; Utility functions. - -(defun align-offset (offset alignment) - (let ((extra (rem offset alignment))) - (if (zerop extra) offset (+ offset (- alignment extra))))) - -(defun guess-alignment (bits) - (cond ((null bits) nil) - ((> bits 16) 32) - ((> bits 8) 16) - ((> bits 1) 8) - (t 1))) - - -;;;; Alien-type-info stuff. - -(eval-when (compile eval load) - -(defstruct (alien-type-class - (:print-function %print-alien-type-class)) - (name nil :type symbol) - (include nil :type (or null alien-type-class)) - (unparse nil :type (or null function)) - (type= nil :type (or null function)) - (lisp-rep nil :type (or null function)) - (alien-rep nil :type (or null function)) - (extract-gen nil :type (or null function)) - (deposit-gen nil :type (or null function)) - (naturalize-gen nil :type (or null function)) - (deport-gen nil :type (or null function)) - ;; Cast? - (arg-tn nil :type (or null function)) - (result-tn nil :type (or null function)) - (subtypep nil :type (or null function))) - -(defun %print-alien-type-class (type-class stream depth) - (declare (ignore depth)) - (print-unreadable-object (type-class stream :type t) - (prin1 (alien-type-class-name type-class) stream))) - -(defvar *alien-type-classes* (make-hash-table :test #'eq)) - -(defun alien-type-class-or-lose (name) - (or (gethash name *alien-type-classes*) - (error "No alien type class ~S" name))) - -(defun create-alien-type-class-if-necessary (name include) - (let ((old (gethash name *alien-type-classes*)) - (include (and include (alien-type-class-or-lose include)))) - (if old - (setf (alien-type-class-include old) include) - (setf (gethash name *alien-type-classes*) - (make-alien-type-class :name name :include include))))) - -(defconstant method-slot-alist - '((:unparse . alien-type-class-unparse) - (:type= . alien-type-class-type=) - (:subtypep . alien-type-class-subtypep) - (:lisp-rep . alien-type-class-lisp-rep) - (:alien-rep . alien-type-class-alien-rep) - (:extract-gen . alien-type-class-extract-gen) - (:deposit-gen . alien-type-class-deposit-gen) - (:naturalize-gen . alien-type-class-naturalize-gen) - (:deport-gen . alien-type-class-deport-gen) - ;; Cast? - (:arg-tn . alien-type-class-arg-tn) - (:result-tn . alien-type-class-result-tn))) - -(defun method-slot (method) - (cdr (or (assoc method method-slot-alist) - (error "No method ~S" method)))) - -); eval-when - - -(defmacro def-alien-type-class ((name &key include) &rest slots) - (let ((defstruct-name - (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE")))) - (multiple-value-bind - (include include-defstruct overrides) - (etypecase include - (null - (values nil 'alien-type nil)) - (symbol - (values - include - (intern (concatenate 'string - "ALIEN-" (symbol-name include) "-TYPE")) - nil)) - (list - (values - (car include) - (intern (concatenate 'string - "ALIEN-" (symbol-name (car include)) "-TYPE")) - (cdr include)))) - `(progn - (eval-when (compile load eval) - (create-alien-type-class-if-necessary ',name ',(or include 'root))) - (defstruct (,defstruct-name - (:include ,include-defstruct - (:class ',name) - ,@overrides)) - ,@slots))))) - -(defmacro def-alien-type-method ((class method) lambda-list &rest body) - (let ((defun-name (intern (concatenate 'string - (symbol-name class) - "-" - (symbol-name method) - "-METHOD")))) - `(progn - (defun ,defun-name ,lambda-list - ,@body) - (setf (,(method-slot method) (alien-type-class-or-lose ',class)) - #',defun-name)))) - -(defmacro invoke-alien-type-method (method type &rest args) - (let ((slot (method-slot method))) - (once-only ((type type)) - `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type)) - (alien-type-class-include class))) - ((null class) - (error "Method ~S not defined for ~S" - ',method (alien-type-class ,type))) - (let ((fn (,slot class))) - (when fn - (return fn)))) - ,type ,@args)))) - - - -;;;; Alien-type defstruct. - -(eval-when (compile load eval) - (create-alien-type-class-if-necessary 'root nil)) - -(defstruct (alien-type - (:print-function %print-alien-type) - (:make-load-form-fun :just-dump-it-normally)) - (class 'root :type symbol) - (bits nil :type (or null unsigned-byte)) - (alignment (guess-alignment bits) :type (or null unsigned-byte))) - -(defun %print-alien-type (type stream depth) - (declare (ignore depth)) - (print-unreadable-object (type stream :type t) - (prin1 (unparse-alien-type type) stream))) - - -;;;; Type parsing and unparsing. - -(defvar *auxiliary-type-definitions* nil) -(defvar *new-auxiliary-types*) - -;;; WITH-AUXILIARY-ALIEN-TYPES -- internal. -;;; -;;; Process stuff in a new scope. -;;; -(defmacro with-auxiliary-alien-types (&body body) - `(let ((*auxiliary-type-definitions* - (if (boundp '*new-auxiliary-types*) - (append *new-auxiliary-types* *auxiliary-type-definitions*) - *auxiliary-type-definitions*)) - (*new-auxiliary-types* nil)) - ,@body)) - -;;; PARSE-ALIEN-TYPE -- public -;;; -(defun parse-alien-type (type) - "Parse the list structure TYPE as an alien type specifier and return - the resultant alien-type structure." - (if (boundp '*new-auxiliary-types*) - (%parse-alien-type type) - (let ((*new-auxiliary-types* nil)) - (%parse-alien-type type)))) - -(defun %parse-alien-type (type) - (if (consp type) - (let ((translator (info alien-type translator (car type)))) - (unless translator - (error "Unknown alien type: ~S" type)) - (funcall translator type)) - (case (info alien-type kind type) - (:primitive - (let ((translator (info alien-type translator type))) - (unless translator - (error "No translator for primitive alien type ~S?" type)) - (funcall translator (list type)))) - (:defined - (or (info alien-type definition type) - (error "Definition missing for alien type ~S?" type))) - (:unknown - (error "Unknown alien type: ~S" type))))) - -(defun auxiliary-alien-type (kind name) - (flet ((aux-defn-matches (x) - (and (eq (first x) kind) (eq (second x) name)))) - (let ((in-auxiliaries - (or (find-if #'aux-defn-matches *new-auxiliary-types*) - (find-if #'aux-defn-matches *auxiliary-type-definitions*)))) - (if in-auxiliaries - (values (third in-auxiliaries) t) - (ecase kind - (:struct - (info alien-type struct name)) - (:union - (info alien-type union name)) - (:enum - (info alien-type enum name))))))) - -(defun %set-auxiliary-alien-type (kind name defn) - (flet ((aux-defn-matches (x) - (and (eq (first x) kind) (eq (second x) name)))) - (when (find-if #'aux-defn-matches *new-auxiliary-types*) - (error "Attempt to multiple define ~A ~S." kind name)) - (when (find-if #'aux-defn-matches *auxiliary-type-definitions*) - (error "Attempt to shadow definition of ~A ~S." kind name))) - (push (list kind name defn) *new-auxiliary-types*) - defn) - -(defsetf auxiliary-alien-type %set-auxiliary-alien-type) - -(defun verify-local-auxiliaries-okay () - (dolist (info *new-auxiliary-types*) - (destructuring-bind (kind name defn) info - (declare (ignore defn)) - (when (ecase kind - (:struct - (info alien-type struct name)) - (:union - (info alien-type union name)) - (:enum - (info alien-type enum name))) - (error "Attempt to shadow definition of ~A ~S." kind name))))) - -;;; *record-type-already-unparsed* -- internal -;;; -;;; Holds the list of record types that have already been unparsed. This is -;;; used to keep from outputing the slots again if the same structure shows -;;; up twice. -;;; -(defvar *record-types-already-unparsed*) - -;;; UNPARSE-ALIEN-TYPE -- public. -;;; -(defun unparse-alien-type (type) - "Convert the alien-type structure TYPE back into a list specification of - the type." - (declare (type alien-type type)) - (let ((*record-types-already-unparsed* nil)) - (%unparse-alien-type type))) - -;;; %UNPARSE-ALIEN-TYPE -- internal. -;;; -;;; Does all the work of UNPARSE-ALIEN-TYPE. It's seperate because we need -;;; to recurse inside the binding of *record-types-already-unparsed*. -;;; -(defun %unparse-alien-type (type) - (invoke-alien-type-method :unparse type)) - - - - -;;;; Alien type defining stuff. - -(defmacro def-alien-type-translator (name lambda-list &body body) - (let ((whole (gensym)) - (defun-name (intern (concatenate 'string - "ALIEN-" - (symbol-name name) - "-TYPE-TRANSLATOR")))) - (multiple-value-bind - (body decls docs) - (lisp::parse-defmacro lambda-list whole body name - 'def-alien-type-translator) - `(progn - (defun ,defun-name (,whole) - ,decls - (block ,name - ,body)) - (%def-alien-type-translator ',name #',defun-name ,docs))))) - -(defun %def-alien-type-translator (name translator docs) - (declare (ignore docs)) - (setf (info alien-type kind name) :primitive) - (setf (info alien-type translator name) translator) - (clear-info alien-type definition name) - #+nil - (setf (documentation name 'alien-type) docs) - name) - - -(defmacro def-alien-type (name type) - "Define the alien type NAME to be equivalent to TYPE. Name may be NIL for - STRUCT and UNION types, in which case the name is taken from the type - specifier." - (with-auxiliary-alien-types - (let ((alien-type (parse-alien-type type))) - `(eval-when (compile load eval) - ,@(when *new-auxiliary-types* - `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) - ,@(when name - `((%def-alien-type ',name ',alien-type))))))) - -(defun %def-auxiliary-alien-types (types) - (dolist (info types) - (destructuring-bind (kind name defn) info - (macrolet ((frob (kind) - `(let ((old (info alien-type ,kind name))) - (unless (or (null old) (alien-type-= old defn)) - (warn "Redefining ~A ~S to be:~% ~S,~%was:~% ~S" - kind name defn old)) - (setf (info alien-type ,kind name) defn)))) - (ecase kind - (:struct (frob struct)) - (:union (frob union)) - (:enum (frob enum))))))) - -(defun %def-alien-type (name new) - (ecase (info alien-type kind name) - (:primitive - (error "~S is a built-in alien type." name)) - (:defined - (let ((old (info alien-type definition name))) - (unless (or (null old) (alien-type-= new old)) - (warn "Redefining ~S to be:~% ~S,~%was~% ~S" name - (unparse-alien-type new) (unparse-alien-type old))))) - (:unknown)) - (setf (info alien-type definition name) new) - (setf (info alien-type kind name) :defined) - name) - - - -;;;; Interfaces to the different methods - -(defun alien-type-= (type1 type2) - "Return T iff TYPE1 and TYPE2 describe equivalent alien types." - (or (eq type1 type2) - (and (eq (alien-type-class type1) - (alien-type-class type2)) - (invoke-alien-type-method :type= type1 type2)))) - -(defun alien-subtype-p (type1 type2) - "Return T iff the alien type TYPE1 is a subtype of TYPE2. Currently, the - only supported subtype relationships are is that any pointer type is a - subtype of (* t), and any array type first dimension will match - (array <eltype> nil ...). Otherwise, the two types have to be - ALIEN-TYPE-=." - (or (eq type1 type2) - (invoke-alien-type-method :subtypep type1 type2))) - -(defun alien-typep (object type) - "Return T iff OBJECT is an alien of type TYPE." - (let ((lisp-rep-type (compute-lisp-rep-type type))) - (if lisp-rep-type - (typep object lisp-rep-type) - (and (alien-value-p object) - (alien-subtype-p (alien-value-type object) type))))) - - -(defun compute-naturalize-lambda (type) - `(lambda (alien ignore) - (declare (ignore ignore)) - ,(invoke-alien-type-method :naturalize-gen type 'alien))) - -(defun compute-deport-lambda (type) - (declare (type alien-type type)) - (multiple-value-bind - (form value-type) - (invoke-alien-type-method :deport-gen type 'value) - `(lambda (value ignore) - (declare (type ,(or value-type - (compute-lisp-rep-type type) - `(alien ,type)) - value) - (ignore ignore)) - ,form))) - -(defun compute-extract-lambda (type) - `(lambda (sap offset ignore) - (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (ignore ignore)) - (naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset) - ',type))) - -(defun compute-deposit-lambda (type) - (declare (type alien-type type)) - `(lambda (sap offset ignore value) - (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (ignore ignore)) - (let ((value (deport value ',type))) - ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value) - ;; Note: the reason we don't just return the pre-deported value - ;; is because that would inhibit any (deport (naturalize ...)) - ;; optimizations that might have otherwise happen. Re-naturalizing - ;; the value might cause extra consing, but is flushable, so probably - ;; results in better code. - (naturalize value ',type)))) - -(defun compute-lisp-rep-type (type) - (invoke-alien-type-method :lisp-rep type)) - -(defun compute-alien-rep-type (type) - (invoke-alien-type-method :alien-rep type)) - - - - - -;;;; Default methods. - -(def-alien-type-method (root :unparse) (type) - `(!!unknown-alien-type!! ,(type-of type))) - -(def-alien-type-method (root :type=) (type1 type2) - (declare (ignore type1 type2)) - t) - -(def-alien-type-method (root :subtypep) (type1 type2) - (alien-type-= type1 type2)) - -(def-alien-type-method (root :lisp-rep) (type) - (declare (ignore type)) - nil) - -(def-alien-type-method (root :alien-rep) (type) - (declare (ignore type)) - '*) - -(def-alien-type-method (root :naturalize-gen) (type alien) - (declare (ignore alien)) - (error "Cannot represent ~S typed aliens." type)) - -(def-alien-type-method (root :deport-gen) (type object) - (declare (ignore object)) - (error "Cannot represent ~S typed aliens." type)) - -(def-alien-type-method (root :extract-gen) (type sap offset) - (declare (ignore sap offset)) - (error "Cannot represent ~S typed aliens." type)) - -(def-alien-type-method (root :deposit-gen) (type sap offset value) - `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value)) - -(def-alien-type-method (root :arg-tn) (type state) - (declare (ignore state)) - (error "Cannot pass aliens of type ~S as arguments to call-out" - (unparse-alien-type type))) - -(def-alien-type-method (root :result-tn) (type state) - (declare (ignore state)) - (error "Cannot return aliens of type ~S from call-out" - (unparse-alien-type type))) - - -;;;; The INTEGER type. - -(def-alien-type-class (integer) - (signed t :type (member t nil))) - -(def-alien-type-translator signed (&optional (bits vm:word-bits)) - (make-alien-integer-type :bits bits)) - -(def-alien-type-translator integer (&optional (bits vm:word-bits)) - (make-alien-integer-type :bits bits)) - -(def-alien-type-translator unsigned (&optional (bits vm:word-bits)) - (make-alien-integer-type :bits bits :signed nil)) - -(def-alien-type-method (integer :unparse) (type) - (list (if (alien-integer-type-signed type) 'signed 'unsigned) - (alien-integer-type-bits type))) - -(def-alien-type-method (integer :type=) (type1 type2) - (and (eq (alien-integer-type-signed type1) - (alien-integer-type-signed type2)) - (= (alien-integer-type-bits type1) - (alien-integer-type-bits type2)))) - -(def-alien-type-method (integer :lisp-rep) (type) - (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) - (alien-integer-type-bits type))) - -(def-alien-type-method (integer :alien-rep) (type) - (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) - (alien-integer-type-bits type))) - -(def-alien-type-method (integer :naturalize-gen) (type alien) - (declare (ignore type)) - alien) - -(def-alien-type-method (integer :deport-gen) (type value) - (declare (ignore type)) - value) - -(def-alien-type-method (integer :extract-gen) (type sap offset) - (declare (type alien-integer-type type)) - (let ((ref-fun - (if (alien-integer-type-signed type) - (case (alien-integer-type-bits type) - (8 'signed-sap-ref-8) - (16 'signed-sap-ref-16) - (32 'signed-sap-ref-32)) - (case (alien-integer-type-bits type) - (8 'sap-ref-8) - (16 'sap-ref-16) - (32 'sap-ref-32))))) - (if ref-fun - `(,ref-fun ,sap (/ ,offset vm:byte-bits)) - (error "Cannot extract ~D bit integers." - (alien-integer-type-bits type))))) - - - -;;;; The BOOLEAN type. - -(def-alien-type-class (boolean :include integer)) - -(def-alien-type-translator boolean (&optional (bits vm:word-bits)) - (make-alien-boolean-type :bits bits :signed nil)) - -(def-alien-type-method (boolean :unparse) (type) - `(boolean ,(alien-boolean-type-bits type))) - -(def-alien-type-method (boolean :lisp-rep) (type) - (declare (ignore type)) - `(member t nil)) - -(def-alien-type-method (boolean :naturalize-gen) (type alien) - (declare (ignore type)) - `(not (zerop ,alien))) - -(def-alien-type-method (boolean :deport-gen) (value type) - (declare (ignore type)) - `(if ,value 1 0)) - - -;;;; The ENUM type. - -(def-alien-type-class (enum :include (integer (:bits 32))) - name ; name of this enum (if any) - from ; alist from keywords to integers. - to ; alist or vector from integers to keywords. - kind ; Kind of from mapping, :vector or :alist. - offset) ; Offset to add to value for :vector from mapping. - -(def-alien-type-translator enum (&whole type name &rest mappings) - (cond (mappings - (let ((result (parse-enum name mappings))) - (when name - (multiple-value-bind - (old old-p) - (auxiliary-alien-type :enum name) - (when old-p - (unless (alien-type-= result old) - (warn "Redefining alien enum ~S" name)))) - (setf (auxiliary-alien-type :enum name) result)) - result)) - (name - (multiple-value-bind - (result found) - (auxiliary-alien-type :enum name) - (unless found - (error "Unknown enum type: ~S" name)) - result)) - (t - (error "Empty enum type: ~S" type)))) - -(defun parse-enum (name elements) - (when (null elements) - (error "An anumeration must contain at least one element.")) - (let ((min nil) - (max nil) - (from-alist ()) - (prev -1)) - (declare (list from-alist)) - (dolist (el elements) - (multiple-value-bind - (sym val) - (if (listp el) - (values (first el) (second el)) - (values el (1+ prev))) - (setf prev val) - (unless (keywordp sym) - (error "Enumeration element ~S is not a keyword." sym)) - (unless (integerp val) - (error "Element value ~S is not an integer." val)) - (unless (and max (> max val)) (setq max val)) - (unless (and min (< min val)) (setq min val)) - (when (rassoc val from-alist) - (error "Element value ~S used more than once." val)) - (when (assoc sym from-alist :test #'eq) - (error "Enumeration element ~S used more than once." sym)) - (push (cons sym val) from-alist))) - (let* ((signed (minusp min)) - (min-bits (if signed - (1+ (max (integer-length min) - (integer-length max))) - (integer-length max)))) - (when (> min-bits 32) - (error "Can't represent enums needing more than 32 bits.")) - (setf from-alist (sort from-alist #'< :key #'cdr)) - (cond - ;; - ;; If range is at least 20% dense, use vector mapping. Crossover - ;; point solely on basis of space would be 25%. Vector mapping - ;; is always faster, so give the benefit of the doubt. - ((< 0.2 (/ (float (length from-alist)) (float (- max min)))) - ;; - ;; If offset is small and ignorable, ignore it to save time. - (when (< 0 min 10) (setq min 0)) - (let ((to (make-array (1+ (- max min))))) - (dolist (el from-alist) - (setf (svref to (- (cdr el) min)) (car el))) - (make-alien-enum-type :name name :signed signed - :from from-alist :to to :kind - :vector :offset (- min)))) - (t - (make-alien-enum-type :name name :signed signed - :from from-alist - :to (mapcar #'(lambda (x) (cons (cdr x) (car x))) - from-alist) - :kind :alist)))))) - -(def-alien-type-method (enum :unparse) (type) - `(enum ,(alien-enum-type-name type) - ,@(let ((prev -1)) - (mapcar #'(lambda (mapping) - (let ((sym (car mapping)) - (value (cdr mapping))) - (prog1 - (if (= (1+ prev) value) - sym - `(,sym ,value)) - (setf prev value)))) - (alien-enum-type-from type))))) - -(def-alien-type-method (enum :type=) (type1 type2) - (and (eq (alien-enum-type-name type1) - (alien-enum-type-name type2)) - (equal (alien-enum-type-from type1) - (alien-enum-type-from type2)))) - -(def-alien-type-method (enum :lisp-rep) (type) - `(member ,@(mapcar #'car (alien-enum-type-from type)))) - -(def-alien-type-method (enum :naturalize-gen) (type alien) - (ecase (alien-enum-type-kind type) - (:vector - `(svref ',(alien-enum-type-to type) - (+ ,alien ,(alien-enum-type-offset type)))) - (:alist - `(ecase ,alien - ,@(mapcar #'(lambda (mapping) - `(,(car mapping) ,(cdr mapping))) - (alien-enum-type-to type)))))) - -(def-alien-type-method (enum :deport-gen) (type value) - `(ecase ,value - ,@(mapcar #'(lambda (mapping) - `(,(car mapping) ,(cdr mapping))) - (alien-enum-type-from type)))) - - - -;;;; the FLOAT types. - -(def-alien-type-class (float) - (type (required-argument) :type symbol)) - -(def-alien-type-method (float :unparse) (type) - (alien-float-type-type type)) - -(def-alien-type-method (float :lisp-rep) (type) - (alien-float-type-type type)) - -(def-alien-type-method (float :alien-rep) (type) - (alien-float-type-type type)) - -(def-alien-type-method (float :naturalize-gen) (type alien) - (declare (ignore type)) - alien) - -(def-alien-type-method (float :deport-gen) (type value) - (declare (ignore type)) - value) - - -(def-alien-type-class (single-float :include (float (:bits 32)))) - -(def-alien-type-translator single-float () - (make-alien-single-float-type :type 'single-float)) - -(def-alien-type-method (single-float :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap-ref-single ,sap (/ ,offset vm:byte-bits))) - - -(def-alien-type-class (double-float :include (float (:bits 64)))) - -(def-alien-type-translator double-float () - (make-alien-double-float-type :type 'double-float)) - -(def-alien-type-method (double-float :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap-ref-double ,sap (/ ,offset vm:byte-bits))) - - - -;;;; The SAP type - -(def-alien-type-class (system-area-pointer)) - -(def-alien-type-translator system-area-pointer () - (make-alien-system-area-pointer-type :bits vm:word-bits)) - -(def-alien-type-method (system-area-pointer :unparse) (type) - (declare (ignore type)) - 'system-area-pointer) - -(def-alien-type-method (system-area-pointer :lisp-rep) (type) - (declare (ignore type)) - 'system-area-pointer) - -(def-alien-type-method (system-area-pointer :alien-rep) (type) - (declare (ignore type)) - 'system-area-pointer) - -(def-alien-type-method (system-area-pointer :naturalize-gen) (type alien) - (declare (ignore type)) - alien) - -(def-alien-type-method (system-area-pointer :deport-gen) (type object) - (declare (ignore type)) - object) - -(def-alien-type-method (system-area-pointer :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap-ref-sap ,sap (/ ,offset vm:byte-bits))) - - -;;;; the ALIEN-VALUE type. - -(def-alien-type-class (alien-value :include system-area-pointer)) - -(def-alien-type-method (alien-value :lisp-rep) (type) - (declare (ignore type)) - nil) - -(def-alien-type-method (alien-value :naturalize-gen) (type alien) - `(%sap-alien ,alien ',type)) - -(def-alien-type-method (alien-value :deport-gen) (type value) - (declare (ignore type)) - `(alien-sap ,value)) - - - -;;;; The POINTER type. - -(def-alien-type-class (pointer :include (alien-value (:bits vm:word-bits))) - (to nil :type (or alien-type null))) - -(def-alien-type-translator * (to) - (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to)))) - -(def-alien-type-method (pointer :unparse) (type) - (let ((to (alien-pointer-type-to type))) - `(* ,(if to - (%unparse-alien-type to) - t)))) - -(def-alien-type-method (pointer :type=) (type1 type2) - (let ((to1 (alien-pointer-type-to type1)) - (to2 (alien-pointer-type-to type2))) - (if to1 - (if to2 - (alien-type-= to1 to2) - nil) - (null to2)))) - -(def-alien-type-method (pointer :subtypep) (type1 type2) - (and (alien-pointer-type-p type2) - (let ((to1 (alien-pointer-type-to type1)) - (to2 (alien-pointer-type-to type2))) - (if to1 - (if to2 - (alien-subtype-p to1 to2) - t) - nil)))) - -(def-alien-type-method (pointer :deport-gen) (type value) - (values - `(etypecase ,value - (null - (int-sap 0)) - (system-area-pointer - ,value) - ((alien ,type) - (alien-sap ,value))) - `(or null system-area-pointer (alien ,type)))) - - -;;;; The MEM-BLOCK type. - -(def-alien-type-class (mem-block :include alien-value)) - -(def-alien-type-method (mem-block :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap+ ,sap (/ ,offset vm:byte-bits))) - -(def-alien-type-method (mem-block :deposit-gen) (type sap offset value) - (let ((bits (alien-mem-block-type-bits type))) - (unless bits - (error "Cannot deposit aliens of type ~S (unknown size)." type)) - `(kernel:system-area-copy ,value 0 ,sap ,offset ',bits))) - - -;;;; The ARRAY type. - -(def-alien-type-class (array :include mem-block) - (element-type (required-argument) :type alien-type) - (dimensions (required-argument) :type list)) - -(def-alien-type-translator array (ele-type &rest dims) - (when dims - (unless (typep (first dims) '(or kernel:index null)) - (error "First dimension is not a non-negative fixnum or NIL: ~S" - (first dims))) - (let ((loser (find-if-not #'(lambda (x) (typep x 'kernel:index)) - (rest dims)))) - (when loser - (error "Dimension is not a non-negative fixnum: ~S" loser)))) - - (let ((type (parse-alien-type ele-type))) - (make-alien-array-type - :element-type type - :dimensions dims - :alignment (alien-type-alignment type) - :bits (if (and (alien-type-bits type) - (every #'integerp dims)) - (* (align-offset (alien-type-bits type) - (alien-type-alignment type)) - (reduce #'* dims)))))) - -(def-alien-type-method (array :unparse) (type) - `(array ,(%unparse-alien-type (alien-array-type-element-type type)) - ,@(alien-array-type-dimensions type))) - -(def-alien-type-method (array :type=) (type1 type2) - (and (equal (alien-array-type-dimensions type1) - (alien-array-type-dimensions type2)) - (alien-type-= (alien-array-type-element-type type1) - (alien-array-type-element-type type2)))) - -(def-alien-type-method (array :subtypep) (type1 type2) - (and (alien-array-type-p type2) - (let ((dim1 (alien-array-type-dimensions type1)) - (dim2 (alien-array-type-dimensions type2))) - (and (= (length dim1) (length dim2)) - (or (and dim2 - (null (car dim2)) - (equal (cdr dim1) (cdr dim2))) - (equal dim1 dim2)) - (alien-subtype-p (alien-array-type-element-type type1) - (alien-array-type-element-type type2)))))) - - -;;;; The RECORD type. - -(defstruct (alien-record-field - (:print-function %print-alien-field) - (:make-load-form-fun :just-dump-it-normally)) - (name (required-argument) :type symbol) - (type (required-argument) :type alien-type) - (bits nil :type (or unsigned-byte null)) - (offset 0 :type unsigned-byte)) - -(defun %print-alien-field (field stream depth) - (declare (ignore depth)) - (print-unreadable-object (field stream :type t) - (funcall (formatter "~S ~S~@[:~D~]") - stream - (alien-record-field-type field) - (alien-record-field-name field) - (alien-record-field-bits field)))) - -(def-alien-type-class (record :include mem-block) - (kind :struct :type (member :struct :union)) - (name nil :type (or symbol null)) - (fields nil :type list)) - -(def-alien-type-translator struct (name &rest fields) - (parse-alien-record-type :struct name fields)) - -(def-alien-type-translator union (name &rest fields) - (parse-alien-record-type :union name fields)) - -(defun parse-alien-record-type (kind name fields) - (if fields - (let* ((old (and name (auxiliary-alien-type kind name))) - (result (if (or (null old) - (alien-record-type-fields old)) - (make-alien-record-type :name name :kind kind) - old))) - (when (and name (not (eq old result))) - (setf (auxiliary-alien-type kind name) result)) - (parse-alien-record-fields result fields) - result) - (if name - (or (auxiliary-alien-type kind name) - (setf (auxiliary-alien-type kind name) - (make-alien-record-type :name name :kind kind))) - (make-alien-record-type :kind kind)))) - -;;; PARSE-ALIEN-RECORD-FIELDS -- internal -;;; -;;; Used by parse-alien-type to parse the fields of struct and union -;;; types. RESULT holds the record type we are paring the fields of, -;;; and FIELDS is the list of field specifications. -;;; -(defun parse-alien-record-fields (result fields) - (declare (type alien-record-type result) - (type list fields)) - (let ((total-bits 0) - (overall-alignment 1) - (parsed-fields nil)) - (dolist (field fields) - (destructuring-bind (var type &optional bits) field - (declare (ignore bits)) - (let* ((field-type (parse-alien-type type)) - (bits (alien-type-bits field-type)) - (alignment (alien-type-alignment field-type)) - (parsed-field - (make-alien-record-field :type field-type - :name var))) - (push parsed-field parsed-fields) - (when (null bits) - (error "Unknown size: ~S" - (unparse-alien-type field-type))) - (when (null alignment) - (error "Unknown alignment: ~S" - (unparse-alien-type field-type))) - (setf overall-alignment (max overall-alignment alignment)) - (ecase (alien-record-type-kind result) - (:struct - (let ((offset (align-offset total-bits alignment))) - (setf (alien-record-field-offset parsed-field) offset) - (setf total-bits (+ offset bits)))) - (:union - (setf total-bits (max total-bits bits))))))) - (let ((new (nreverse parsed-fields))) - (setf (alien-record-type-fields result) new)) - (setf (alien-record-type-alignment result) overall-alignment) - (setf (alien-record-type-bits result) - (align-offset total-bits overall-alignment)))) - -(def-alien-type-method (record :unparse) (type) - `(,(case (alien-record-type-kind type) - (:struct 'struct) - (:union 'union) - (t '???)) - ,(alien-record-type-name type) - ,@(unless (member type *record-types-already-unparsed* :test #'eq) - (push type *record-types-already-unparsed*) - (mapcar #'(lambda (field) - `(,(alien-record-field-name field) - ,(%unparse-alien-type (alien-record-field-type field)) - ,@(if (alien-record-field-bits field) - (list (alien-record-field-bits field))))) - (alien-record-type-fields type))))) - -(defun record-fields-match (fields1 fields2) - (declare (type list fields1 fields2)) - (or (eq fields1 fields2) - (and fields1 - fields2 - (let ((field1 (car fields1)) - (field2 (car fields2))) - (declare (type alien-record-field field1 field2)) - (and (eq (alien-record-field-name field1) - (alien-record-field-name field2)) - (eql (alien-record-field-bits field1) - (alien-record-field-bits field2)) - (eql (alien-record-field-offset field1) - (alien-record-field-offset field2)) - (alien-type-= (alien-record-field-type field1) - (alien-record-field-type field2)))) - (record-fields-match (cdr fields1) (cdr fields2))))) - -(def-alien-type-method (record :type=) (type1 type2) - (and (eq (alien-record-type-name type1) - (alien-record-type-name type2)) - (eq (alien-record-type-kind type1) - (alien-record-type-kind type2)) - (= (length (alien-record-type-fields type1)) - (length (alien-record-type-fields type2))) - (record-fields-match (alien-record-type-fields type1) - (alien-record-type-fields type2)))) - - -;;;; The FUNCTION and VALUES types. - -(defvar *values-type-okay* nil) - -(def-alien-type-class (function :include mem-block) - (result-type (required-argument) :type alien-type) - (arg-types (required-argument) :type list) - (stub nil :type (or null function))) - -(def-alien-type-translator function (result-type &rest arg-types) - (make-alien-function-type - :result-type (let ((*values-type-okay* t)) - (parse-alien-type result-type)) - :arg-types (mapcar #'parse-alien-type arg-types))) - -(def-alien-type-method (function :unparse) (type) - `(function ,(%unparse-alien-type (alien-function-type-result-type type)) - ,@(mapcar #'%unparse-alien-type - (alien-function-type-arg-types type)))) - -(def-alien-type-method (function :type=) (type1 type2) - (and (alien-type-= (alien-function-type-result-type type1) - (alien-function-type-result-type type2)) - (= (length (alien-function-type-arg-types type1)) - (length (alien-function-type-arg-types type2))) - (every #'alien-type-p - (alien-function-type-arg-types type1) - (alien-function-type-arg-types type2)))) - - -(def-alien-type-class (values) - (values (required-argument) :type list)) - -(def-alien-type-translator values (&rest values) - (unless *values-type-okay* - (error "Cannot use values types here.")) - (let ((*values-type-okay* nil)) - (make-alien-values-type - :values (mapcar #'parse-alien-type values)))) - -(def-alien-type-method (values :unparse) (type) - `(values ,@(mapcar #'%unparse-alien-type - (alien-values-type-values type)))) - -(def-alien-type-method (values :type=) (type1 type2) - (and (= (length (alien-values-type-values type1)) - (length (alien-values-type-values type2))) - (every #'alien-type-= - (alien-values-type-values type1) - (alien-values-type-values type2)))) - - - -;;;; Alien variables. - -;;; HEAP-ALIEN-INFO -- defstruct. -;;; -;;; Information describing a heap-allocated alien. -;;; -(defstruct (heap-alien-info - (:print-function %print-heap-alien-info) - (:make-load-form-fun :just-dump-it-normally)) - ;; The type of this alien. - (type (required-argument) :type alien-type) - ;; The form to evaluate to produce the SAP pointing to where in the heap - ;; it is. - (sap-form (required-argument))) -;;; -(defun %print-heap-alien-info (info stream depth) - (declare (ignore depth)) - (print-unreadable-object (info stream :type t) - (funcall (formatter "~S ~S") - stream - (heap-alien-info-sap-form info) - (unparse-alien-type (heap-alien-info-type info))))) - -;;; LOCAL-ALIEN-INFO -- public defstruct. -;;; -;;; Information about local aliens. The WITH-ALIEN macro builds one of these -;;; structures and local-alien and friends comunicate information about how -;;; that local alien is represented. -;;; -(defstruct (local-alien-info - (:print-function %print-local-alien-info) - (:make-load-form-fun :just-dump-it-normally)) - ;; The type of the local alien. - (type (required-argument) :type alien-type) - ;; T if this local alien must be forced into memory. Using the ADDR macro - ;; on a local alien will set this. - (force-to-memory-p (or (alien-array-type-p type) (alien-record-type-p type)) - :type (member t nil))) -;;; -(defun %print-local-alien-info (info stream depth) - (declare (ignore depth)) - (print-unreadable-object (info stream :type t) - (funcall (formatter "~:[~;(forced to stack) ~]~S") - stream - (local-alien-info-force-to-memory-p info) - (unparse-alien-type (local-alien-info-type info))))) - -;;; GUESS-ALIEN-NAME-FROM-LISP-NAME -- internal. -;;; -;;; Make a string out of the symbol, converting all uppercase letters to -;;; lower case and hyphens into underscores. -;;; -(defun guess-alien-name-from-lisp-name (lisp-name) - (declare (type symbol lisp-name)) - (nsubstitute #\_ #\- (string-downcase (symbol-name lisp-name)))) - -;;; GUESS-LISP-NAME-FROM-ALIEN-NAME -- internal. -;;; -;;; The opposite of GUESS-ALIEN-NAME-FROM-LISP-NAME. Make a symbol out of the -;;; string, converting all lowercase letters to uppercase and underscores into -;;; hyphens. -;;; -(defun guess-lisp-name-from-alien-name (alien-name) - (declare (type simple-string alien-name)) - (intern (nsubstitute #\- #\_ (string-upcase alien-name)))) - -;;; PICK-LISP-AND-ALIEN-NAMES -- internal. -;;; -;;; Extract the lisp and alien names from NAME. If only one is given, guess -;;; the other. -;;; -(defun pick-lisp-and-alien-names (name) - (etypecase name - (string - (values (guess-lisp-name-from-alien-name name) name)) - (symbol - (values name (guess-alien-name-from-lisp-name name))) - (list - (unless (= (length name) 2) - (error "Badly formed alien name.")) - (values (cadr name) (car name))))) - -;;; DEF-ALIEN-VARIABLE -- public -;;; -(defmacro def-alien-variable (name type) - "Define NAME as an external alien variable of type TYPE. NAME should be - a list of a symbol to use as the Lisp name, and a string holding the alien - name. If NAME is just a symbol or string, then the other name is guessed - from the one supplied." - (multiple-value-bind - (lisp-name alien-name) - (pick-lisp-and-alien-names name) - (with-auxiliary-alien-types - (let ((alien-type (parse-alien-type type))) - `(eval-when (compile load eval) - ,@(when *new-auxiliary-types* - `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) - (%def-alien-variable ',lisp-name - ',alien-name - ',alien-type)))))) - -;;; %DEF-ALIEN-VARIABLE -- internal -;;; -;;; Do the actual work of DEF-ALIEN-VARIABLE. -;;; -(defun %def-alien-variable (lisp-name alien-name type) - (setf (info variable kind lisp-name) :alien) - (setf (info variable where-from lisp-name) :defined) - (clear-info variable constant-value lisp-name) - (setf (info variable alien-info lisp-name) - (make-heap-alien-info :type type - :sap-form `(foreign-symbol-address - ',alien-name)))) - -;;; EXTERN-ALIEN -- public. -;;; -(defmacro extern-alien (name type) - "Access the alien variable named NAME, assuming it is of type TYPE. This - is setfable." - (let ((alien-name (etypecase name - (symbol (guess-alien-name-from-lisp-name name)) - (string name)))) - `(%heap-alien ',(make-heap-alien-info - :type (parse-alien-type type) - :sap-form `(foreign-symbol-address ',alien-name))))) - -;;; WITH-ALIEN -- public. -;;; -(defmacro with-alien (bindings &body body) - "Establish some local alien variables. Each BINDING is of the form: - VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ] - ALLOCATION should be one of: - :LOCAL (the default) - The alien is allocated on the stack, and has dynamic extent. - :STATIC - The alien is allocated on the heap, and has infinate extent. The alien - is allocated at load time, so the same piece of memory is used each time - this form executes. - :EXTERN - No alien is allocated, but VAR is established as a local name for - the external alien given by EXTERNAL-NAME." - (with-auxiliary-alien-types - (dolist (binding (reverse bindings)) - (destructuring-bind - (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) - binding - (let ((alien-type (parse-alien-type type))) - (multiple-value-bind - (allocation initial-value) - (if opt2p - (values opt1 opt2) - (case opt1 - (:extern - (values opt1 (guess-alien-name-from-lisp-name symbol))) - (:static - (values opt1 nil)) - (t - (values :local opt1)))) - (setf body - (ecase allocation - #+nil - (:static - (let ((sap - (make-symbol (concatenate 'string "SAP-FOR-" - (symbol-name symbol))))) - `((let ((,sap (load-time-value (%make-alien ...)))) - (declare (type system-area-pointer ,sap)) - (symbol-macrolet - ((,symbol (sap-alien ,sap ,type))) - ,@(when initial-value - `((setq ,symbol ,initial-value))) - ,@body))))) - (:extern - (let ((info (make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-address - ',initial-value)))) - `((symbol-macrolet - ((,symbol (%heap-alien ',info))) - ,@body)))) - (:local - (let ((var (gensym)) - (initval (if initial-value (gensym))) - (info (make-local-alien-info - :type alien-type))) - `((let ((,var (make-local-alien ',info)) - ,@(when initial-value - `((,initval ,initial-value)))) - (note-local-alien-type ',info ,var) - (multiple-value-prog1 - (symbol-macrolet - ((,symbol (local-alien ',info ,var))) - ,@(when initial-value - `((setq ,symbol ,initval))) - ,@body) - (dispose-local-alien ',info ,var)))))))))))) - (verify-local-auxiliaries-okay) - `(compiler-let (*auxiliary-type-definitions* - ',(append *new-auxiliary-types* - *auxiliary-type-definitions*)) - ,@body))) - - -;;;; Runtime C values that don't correspond directly to Lisp types. - -;;; ALIEN-VALUE -;;; -(defstruct (alien-value - (:print-function %print-alien-value)) - (sap (required-argument) :type system-area-pointer) - (type (required-argument) :type alien-type)) -;;; -(defun %print-alien-value (value stream depth) - (declare (ignore depth)) - (print-unreadable-object (value stream) - (funcall (formatter "Alien ~S at #x~8,'0X") - stream - (unparse-alien-type (alien-value-type value)) - (sap-int (alien-value-sap value))))) - -(declaim (freeze-type alien-value)) - -(declaim (inline null-alien)) -(defun null-alien (x) - "Return true if X (which must be an Alien pointer) is null, false otherwise." - (zerop (sap-int (alien-sap x)))) - - -(defmacro sap-alien (sap type) - "Convert the System-Area-Pointer SAP to an Alien of the specified Type (not - evaluated.) Type must be pointer-like." - (let ((alien-type (parse-alien-type type))) - (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer) - `(%sap-alien ,sap ',alien-type) - (error "Cannot make aliens of type ~S out of SAPs" type)))) - -(defun %sap-alien (sap type) - (declare (type system-area-pointer sap) - (type alien-type type)) - (make-alien-value :sap sap :type type)) - -(defun alien-sap (alien) - "Return a System-Area-Pointer pointing to Alien's data." - (declare (type alien-value alien)) - (alien-value-sap alien)) - - - -;;;; Allocation/Deallocation of heap aliens. - -;;; MAKE-ALIEN -- public. -;;; -(defmacro make-alien (type &optional size) - "Allocate an alien of type TYPE and return an alien pointer to it. If SIZE - is supplied, how it is interpreted depends on TYPE. If TYPE is an array - type, SIZE is used as the first dimension for the allocated array. If TYPE - is not an array, then SIZE is the number of elements to allocate. The - memory is allocated using ``malloc'', so it can be passed to foreign - functions which use ``free''." - (let ((alien-type (if (alien-type-p type) type (parse-alien-type type)))) - (multiple-value-bind - (size-expr element-type) - (if (alien-array-type-p alien-type) - (let ((dims (alien-array-type-dimensions alien-type))) - (cond - (size - (unless dims - (error - "Cannot override the size of zero-dimensional arrays.")) - (when (constantp size) - (setf alien-type (copy-alien-array-type alien-type)) - (setf (alien-array-type-dimensions alien-type) - (cons (eval size) (cdr dims))))) - (dims - (setf size (car dims))) - (t - (setf size 1))) - (values `(* ,size ,@(cdr dims)) - (alien-array-type-element-type alien-type))) - (values (or size 1) alien-type)) - (let ((bits (alien-type-bits element-type)) - (alignment (alien-type-alignment element-type))) - (unless bits - (error "Size of ~S unknown." (unparse-alien-type element-type))) - (unless alignment - (error "Alignment of ~S unknown." (unparse-alien-type element-type))) - `(%sap-alien (%make-alien (* ,(align-offset bits alignment) - ,size-expr)) - ',(make-alien-pointer-type :to alien-type)))))) - -;;; %MAKE-ALIEN -- internal -;;; -;;; Allocate a block of memory at least BITS bits long and return a system -;;; area pointer to it. -;;; -(declaim (inline %make-alien)) -(defun %make-alien (bits) - (declare (type kernel:index bits) (optimize-interface (safety 2))) - (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned)) - (ash (the kernel:index (+ bits 7)) -3))) - -;;; FREE-ALIEN -- public -;;; -(declaim (inline free-alien)) -(defun free-alien (alien) - "Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated - by MAKE-ALIEN or ``malloc''." - (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) - (alien-sap alien)) - nil) - - -;;;; The SLOT operator - -;;; SLOT-OR-LOSE -- internal. -;;; -;;; Find the field named SLOT, or die trying. -;;; -(defun slot-or-lose (type slot) - (declare (type alien-record-type type) - (type symbol slot)) - (or (find slot (alien-record-type-fields type) - :key #'alien-record-field-name) - (error "No slot named ~S in ~S" slot type))) - -;;; SLOT -- public -;;; -;;; Extract the value from the named slot from the record alien. If the -;;; alien is actually a pointer, then deref it first. -;;; -(defun slot (alien slot) - "Extract SLOT from the Alien STRUCT or UNION ALIEN. May be set with SETF." - (declare (type alien-value alien) - (type symbol slot) - (optimize (inhibit-warnings 3))) - (let ((type (alien-value-type alien))) - (etypecase type - (alien-pointer-type - (slot (deref alien) slot)) - (alien-record-type - (let ((field (slot-or-lose type slot))) - (extract-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field))))))) - -;;; %SET-SLOT -- public setf method -;;; -;;; Deposite the value in the specified slot of the record alien. If the -;;; alien is really a pointer, deref it first. The compiler uses this -;;; when it can't figure out anything better. -;;; -(defun %set-slot (alien slot value) - (declare (type alien-value alien) - (type symbol slot) - (optimize (inhibit-warnings 3))) - (let ((type (alien-value-type alien))) - (etypecase type - (alien-pointer-type - (%set-slot (deref alien) slot value)) - (alien-record-type - (let ((field (slot-or-lose type slot))) - (deposit-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field) - value)))))) -;;; -(defsetf slot %set-slot) - -;;; %SLOT-ADDR -- internal -;;; -;;; Compute the address of the specified slot and return a pointer to it. -;;; -(defun %slot-addr (alien slot) - (declare (type alien-value alien) - (type symbol slot) - (optimize (inhibit-warnings 3))) - (let ((type (alien-value-type alien))) - (etypecase type - (alien-pointer-type - (%slot-addr (deref alien) slot)) - (alien-record-type - (let* ((field (slot-or-lose type slot)) - (offset (alien-record-field-offset field)) - (field-type (alien-record-field-type field))) - (%sap-alien (sap+ (alien-sap alien) (/ offset vm:byte-bits)) - (make-alien-pointer-type :to field-type))))))) - - -;;;; The DEREF operator. - -;;; DEREF-GUTS -- internal. -;;; -;;; Does most of the work of the different DEREF methods. Returns two values: -;;; the type and the offset (in bits) of the refered to alien. -;;; -(defun deref-guts (alien indices) - (declare (type alien-value alien) - (type list indices) - (values alien-type integer)) - (let ((type (alien-value-type alien))) - (etypecase type - (alien-pointer-type - (when (cdr indices) - (error "Too many indices when derefing ~S: ~D" - type - (length indices))) - (let ((element-type (alien-pointer-type-to type))) - (values element-type - (if indices - (* (align-offset (alien-type-bits element-type) - (alien-type-alignment element-type)) - (car indices)) - 0)))) - (alien-array-type - (unless (= (length indices) (length (alien-array-type-dimensions type))) - (error "Incorrect number of indices when derefing ~S: ~D" - type (length indices))) - (labels ((frob (dims indices offset) - (if (null dims) - offset - (frob (cdr dims) (cdr indices) - (+ (if (zerop offset) - 0 - (* offset (car dims))) - (car indices)))))) - (let ((element-type (alien-array-type-element-type type))) - (values element-type - (* (align-offset (alien-type-bits element-type) - (alien-type-alignment element-type)) - (frob (alien-array-type-dimensions type) - indices 0))))))))) - -;;; DEREF -- public -;;; -;;; Dereference the alien and return the results. -;;; -(defun deref (alien &rest indices) - "De-reference an Alien pointer or array. If an array, the indices are used - as the indices of the array element to access. If a pointer, one index can - optionally be specified, giving the equivalent of C pointer arithmetic." - (declare (type alien-value alien) - (type list indices) - (optimize (inhibit-warnings 3))) - (multiple-value-bind - (target-type offset) - (deref-guts alien indices) - (extract-alien-value (alien-value-sap alien) - offset - target-type))) - -;;; %SET-DEREF -- public setf method -;;; -(defun %set-deref (alien value &rest indices) - (declare (type alien-value alien) - (type list indices) - (optimize (inhibit-warnings 3))) - (multiple-value-bind - (target-type offset) - (deref-guts alien indices) - (deposit-alien-value (alien-value-sap alien) - offset - target-type - value))) -;;; -(defsetf deref (alien &rest indices) (value) - `(%set-deref ,alien ,value ,@indices)) - -;;; %DEREF-ADDR -- public -;;; -(defun %deref-addr (alien &rest indices) - (declare (type alien-value alien) - (type list indices) - (optimize (inhibit-warnings 3))) - (multiple-value-bind - (target-type offset) - (deref-guts alien indices) - (%sap-alien (sap+ (alien-value-sap alien) (/ offset vm:byte-bits)) - (make-alien-pointer-type :to target-type)))) - - -;;;; Accessing heap alien variables. - -(defun %heap-alien (info) - (declare (type heap-alien-info info) - (optimize (inhibit-warnings 3))) - (extract-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info))) - -(defun %set-heap-alien (info value) - (declare (type heap-alien-info info) - (optimize (inhibit-warnings 3))) - (deposit-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info) - value)) -;;; -(defsetf %heap-alien %set-heap-alien) - -(defun %heap-alien-addr (info) - (declare (type heap-alien-info info) - (optimize (inhibit-warnings 3))) - (%sap-alien (eval (heap-alien-info-sap-form info)) - (make-alien-pointer-type :to (heap-alien-info-type info)))) - - - -;;;; Accessing local aliens. - -(defun make-local-alien (info) - (let ((alien (eval `(make-alien ,(local-alien-info-type info))))) - (finalize info #'(lambda () (free-alien alien))) - alien)) - -(defun note-local-alien-type (info alien) - (declare (ignore info alien)) - nil) - -(defun local-alien (info alien) - (declare (ignore info)) - (deref alien)) - -(defun %set-local-alien (info alien value) - (declare (ignore info)) - (setf (deref alien) value)) - -(define-setf-method local-alien (&whole whole info alien) - (let ((value (gensym)) - (info (if (and (consp info) - (eq (car info) 'quote)) - (second info) - (error "Something is wrong; local-alien-info not found: ~S" - whole)))) - (values nil - nil - (list value) - (if c:*converting-for-interpreter* - `(%set-local-alien ',info ,alien ,value) - `(if (%local-alien-forced-to-memory-p ',info) - (%set-local-alien ',info ,alien ,value) - (setf ,alien - (deport ,value ',(local-alien-info-type info))))) - whole))) - -(defun %local-alien-forced-to-memory-p (info) - (local-alien-info-force-to-memory-p info)) - -(defun %local-alien-addr (info alien) - (declare (type local-alien-info info)) - (unless (local-alien-info-force-to-memory-p info) - (error "~S isn't forced to memory. Something went wrong." alien)) - alien) - -(defun dispose-local-alien (info alien) - (declare (ignore info)) - #+nil - (cancel-finalization info) - (free-alien alien)) - - -;;;; The ADDR macro. - -(defmacro addr (expr &environment env) - "Return an Alien pointer to the data addressed by Expr, which must be a call - to SLOT or DEREF, or a reference to an Alien variable." - (let ((form (macroexpand expr env))) - (or (typecase form - (cons - (case (car form) - (slot - (cons '%slot-addr (cdr form))) - (deref - (cons '%deref-addr (cdr form))) - (%heap-alien - (cons '%heap-alien-addr (cdr form))) - (local-alien - (let ((info - (let ((info-arg (second form))) - (and (consp info-arg) - (eq (car info-arg) 'quote) - (second info-arg))))) - (unless (local-alien-info-p info) - (error "Something is wrong, local-alien-info not found: ~S" - form)) - (setf (local-alien-info-force-to-memory-p info) t)) - (cons '%local-alien-addr (cdr form))))) - (symbol - (let ((kind (info variable kind form))) - (when (eq kind :alien) - `(%heap-alien-addr ',(info variable alien-info form)))))) - (error "~S is not a valid L-value" form)))) - - -;;;; The CAST macro. - -(defmacro cast (alien type) - "Convert ALIEN to an Alien of the specified TYPE (not evaluated.) Both types - must be Alien array, pointer or function types." - `(%cast ,alien ',(parse-alien-type type))) - -(defun %cast (alien target-type) - (declare (type alien-value alien) - (type alien-type target-type) - (optimize-interface (safety 2)) - (optimize (inhibit-warnings 3))) - (if (or (alien-pointer-type-p target-type) - (alien-array-type-p target-type) - (alien-function-type-p target-type)) - (let ((alien-type (alien-value-type alien))) - (if (or (alien-pointer-type-p alien-type) - (alien-array-type-p alien-type) - (alien-function-type-p alien-type)) - (naturalize (alien-value-sap alien) target-type) - (error "~S cannot be casted." alien))) - (error "Cannot cast to alien type ~S" (unparse-alien-type target-type)))) - - - -;;;; The ALIEN-SIZE macro. - -(defmacro alien-size (type &optional (units :bits)) - "Return the size of the alien type TYPE. UNITS specifies the units to - use and can be either :BITS, :BYTES, or :WORDS." - (let* ((alien-type (parse-alien-type type)) - (bits (alien-type-bits alien-type))) - (if bits - (values (ceiling bits - (ecase units - (:bits 1) - (:bytes vm:byte-bits) - (:words vm:word-bits)))) - (error "Unknown size for alien type ~S." - (unparse-alien-type alien-type))))) - - - -;;;; Naturalize, deport, extract-alien-value, deposit-alien-value - -(defun naturalize (alien type) - (declare (type alien-type type)) - (funcall (coerce (compute-naturalize-lambda type) 'function) - alien type)) - -(defun deport (value type) - (declare (type alien-type type)) - (funcall (coerce (compute-deport-lambda type) 'function) - value type)) - -(defun extract-alien-value (sap offset type) - (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (type alien-type type)) - (funcall (coerce (compute-extract-lambda type) 'function) - sap offset type)) - -(defun deposit-alien-value (sap offset type value) - (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (type alien-type type)) - (funcall (coerce (compute-deposit-lambda type) 'function) - sap offset type value)) - - - -;;;; alien-funcall, def-alien-function - -(defun alien-funcall (alien &rest args) - "Call the foreign function ALIEN with the specified arguments. ALIEN's - type specifies the argument and result types." - (declare (type alien-value alien)) - (let ((type (alien-value-type alien))) - (typecase type - (alien-pointer-type - (apply #'alien-funcall (deref alien) args)) - (alien-function-type - (unless (= (length (alien-function-type-arg-types type)) - (length args)) - (error "Wrong number of arguments for ~S~%Expected ~D, got ~D." - type - (length (alien-function-type-arg-types type)) - (length args))) - (let ((stub (alien-function-type-stub type))) - (unless stub - (setf stub - (let ((fun (gensym)) - (parms (loop repeat (length args) collect (gensym)))) - (compile nil - `(lambda (,fun ,@parms) - (declare (type (alien ,type) ,fun)) - (alien-funcall ,fun ,@parms))))) - (setf (alien-function-type-stub type) stub)) - (apply stub alien args))) - (t - (error "~S is not an alien function." alien))))) - -(defmacro def-alien-routine (name result-type &rest args) - "Def-C-Routine Name Result-Type - {(Arg-Name Arg-Type [Style])}* - - Define a foreign interface function for the routine with the specified Name, - which may be either a string, symbol or list of the form (symbol string). - Return-Type is the Alien fypte for the function return value. VOID may be - used to specify a function with no result. - - The remaining forms specifiy individual arguments that are passed to the - routine. Arg-Name is a symbol that names the argument, primarily for - documentation. Arg-Type is the C-Type of the argument. Style specifies the - say that the argument is passed. - - :IN - An :In argument is simply passed by value. The value to be passed is - obtained from argument(s) to the interface function. No values are - returned for :In arguments. This is the default mode. - - :OUT - The specified argument type must be a pointer to a fixed sized object. - A pointer to a preallocated object is passed to the routine, and the - the object is accessed on return, with the value being returned from - the interface function. :OUT and :IN-OUT cannot be used with pointers - to arrays, records or functions. - - :COPY - Similar to :IN, except that the argument values are stored in on - the stack, and a pointer to the object is passed instead of - the values themselves. - - :IN-OUT - A combination of :OUT and :COPY. A pointer to the argument is passed, - with the object being initialized from the supplied argument and - the return value being determined by accessing the object on return." - (multiple-value-bind - (lisp-name alien-name) - (pick-lisp-and-alien-names name) - (collect ((docs) (lisp-args) (arg-types) (alien-vars) - (alien-args) (results)) - (dolist (arg args) - (if (stringp arg) - (docs arg) - (destructuring-bind (name type &optional (style :in)) arg - (unless (member style '(:in :copy :out :in-out)) - (error "Bogus argument style ~S in ~S." style arg)) - (unless (eq style :out) - (lisp-args name)) - (cond ((eq style :in) - (arg-types type) - (alien-args name)) - (t - (arg-types `(* ,type)) - (if (eq style :out) - (alien-vars `(,name ,type)) - (alien-vars `(,name ,type ,name))) - (alien-args `(addr ,name)))) - (when (or (eq style :out) (eq style :in-out)) - (results name))))) - `(defun ,lisp-name ,(lisp-args) - ,@(docs) - (with-alien - ((,lisp-name (function ,result-type ,@(arg-types)) - :extern ,alien-name) - ,@(alien-vars)) - ,(if (alien-values-type-p result-type) - (let ((temps (loop - repeat (length (alien-values-type-values - result-type)) - collect (gensym)))) - `(multiple-value-bind - ,temps - (alien-funcall ,lisp-name ,@(alien-args)) - (values ,@temps ,@(results)))) - `(values (alien-funcall ,lisp-name ,@(alien-args)) - ,@(results)))))))) diff --git a/code/array.lisp b/code/array.lisp deleted file mode 100644 index 9375b884f74dd52695e47e57211c0ce52e1c1a28..0000000000000000000000000000000000000000 --- a/code/array.lisp +++ /dev/null @@ -1,980 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/array.lisp,v 1.17 1992/12/10 00:35:16 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Functions to implement arrays for CMU Common Lisp. -;;; Written by Skef Wholey. -;;; Worked over for the MIPS port by William Lott. -;;; -(in-package "LISP") - -(export '(array-rank-limit array-dimension-limit array-total-size-limit - make-array vector aref array-element-type array-rank - array-dimension array-dimensions array-in-bounds-p - array-row-major-index array-total-size svref bit sbit - bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2 - bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p - fill-pointer vector-push vector-push-extend vector-pop adjust-array - adjustable-array-p row-major-aref array-displacement)) - -(in-package "KERNEL") -(export '(%with-array-data)) -(in-package "LISP") - -(defconstant array-rank-limit 65529 - "The exclusive upper bound on the rank of an array.") - -(defconstant array-dimension-limit most-positive-fixnum - "The exclusive upper bound any given dimension of an array.") - -(defconstant array-total-size-limit most-positive-fixnum - "The exclusive upper bound on the total number of elements in an array.") - - - -;;;; Random accessor functions. - -;;; These functions are needed by the interpreter, 'cause the compiler inlines -;;; them. - -(macrolet ((frob (name) - `(progn - (defun ,name (array) - (,name array)) - (defun (setf ,name) (value array) - (setf (,name array) value))))) - (frob %array-fill-pointer) - (frob %array-fill-pointer-p) - (frob %array-available-elements) - (frob %array-data-vector) - (frob %array-displacement) - (frob %array-displaced-p)) - -(defun %array-rank (array) - (%array-rank array)) - -(defun %array-dimension (array axis) - (%array-dimension array axis)) - -(defun %set-array-dimension (array axis value) - (%set-array-dimension array axis value)) - -(defun %check-bound (array bound index) - (declare (type index bound) - (fixnum index)) - (%check-bound array bound index)) - -;;; %WITH-ARRAY-DATA -- Interface -;;; -;;; The guts of the WITH-ARRAY-DATA macro (in sysmacs). Note that this -;;; function is only called if we have an array header or an error, so it -;;; doesn't have to be too tense. -;;; -(defun %with-array-data (array start end) - (declare (array array) (type index start) (type (or index null) end) - (values (simple-array * (*)) index index index)) - (let* ((size (array-total-size array)) - (end (cond (end - (unless (<= end size) - (error "End ~D is greater than total size ~D." - end size)) - end) - (t size)))) - (when (> start end) - (error "Start ~D is greater than end ~D." start end)) - (do ((data array (%array-data-vector data)) - (cumulative-offset 0 - (+ cumulative-offset - (%array-displacement data)))) - ((not (array-header-p data)) - (values data - (+ cumulative-offset start) - (+ cumulative-offset end) - cumulative-offset)) - (declare (type index cumulative-offset))))) - - -;;;; MAKE-ARRAY - -(eval-when (compile eval) - -(defmacro pick-type (type &rest specs) - `(cond ,@(mapcar #'(lambda (spec) - `(,(if (eq (car spec) t) - t - `(subtypep ,type ',(car spec))) - ,@(cdr spec))) - specs))) - -); eval-when - - -(defun %vector-type-code (type) - (pick-type type - (base-char (values #.vm:simple-string-type #.vm:byte-bits)) - (bit (values #.vm:simple-bit-vector-type 1)) - ((unsigned-byte 2) (values #.vm:simple-array-unsigned-byte-2-type 2)) - ((unsigned-byte 4) (values #.vm:simple-array-unsigned-byte-4-type 4)) - ((unsigned-byte 8) (values #.vm:simple-array-unsigned-byte-8-type 8)) - ((unsigned-byte 16) (values #.vm:simple-array-unsigned-byte-16-type 16)) - ((unsigned-byte 32) (values #.vm:simple-array-unsigned-byte-32-type 32)) - (single-float (values #.vm:simple-array-single-float-type 32)) - (double-float (values #.vm:simple-array-double-float-type 64)) - (t (values #.vm:simple-vector-type #.vm:word-bits)))) - -(defun %complex-vector-type-code (type) - (pick-type type - (base-char #.vm:complex-string-type) - (bit #.vm:complex-bit-vector-type) - (t #.vm:complex-vector-type))) - -(defun make-array (dimensions &key - (element-type t) - (initial-element nil initial-element-p) - initial-contents adjustable fill-pointer - displaced-to displaced-index-offset) - "Creates an array of the specified Dimensions. See manual for details." - (let* ((dimensions (if (listp dimensions) dimensions (list dimensions))) - (array-rank (length (the list dimensions))) - (simple (and (null fill-pointer) - (not adjustable) - (null displaced-to)))) - (declare (fixnum array-rank)) - (when (and displaced-index-offset (null displaced-to)) - (error "Can't specify :displaced-index-offset without :displaced-to")) - (if (and simple (= array-rank 1)) - ;; Its a (simple-array * (*)) - (multiple-value-bind (type bits) - (%vector-type-code element-type) - (declare (type (unsigned-byte 8) type) - (type (integer 1 64) bits)) - (let* ((length (car dimensions)) - (array (allocate-vector - type - length - (ceiling (* (if (= type vm:simple-string-type) - (1+ length) - length) - bits) - vm:word-bits)))) - (declare (type index length)) - (when initial-element-p - (fill array initial-element)) - (when initial-contents - (when initial-element - (error "Cannot specify both :initial-element and ~ - :initial-contents")) - (unless (= length (length initial-contents)) - (error "~D elements in the initial-contents, but the ~ - vector length is ~D." - (length initial-contents) - length)) - (replace array initial-contents)) - array)) - ;; It's either a complex array or a multidimensional array. - (let* ((total-size (reduce #'* dimensions)) - (data (or displaced-to - (data-vector-from-inits - dimensions total-size element-type - initial-contents initial-element initial-element-p))) - (array (make-array-header - (cond ((= array-rank 1) - (%complex-vector-type-code element-type)) - (simple vm:simple-array-type) - (t vm:complex-array-type)) - array-rank))) - (cond (fill-pointer - (unless (= array-rank 1) - (error "Only vectors can have fill pointers.")) - (setf (%array-fill-pointer array) - (if (eq fill-pointer t) - (car dimensions) - fill-pointer)) - (setf (%array-fill-pointer-p array) t)) - (t - (setf (%array-fill-pointer array) total-size) - (setf (%array-fill-pointer-p array) nil))) - (setf (%array-available-elements array) total-size) - (setf (%array-data-vector array) data) - (cond (displaced-to - (when (or initial-element-p initial-contents) - (error "Neither :initial-element nor :initial-contents ~ - can be specified along with :displaced-to")) - (let ((offset (or displaced-index-offset 0))) - (when (> (+ offset total-size) - (array-total-size displaced-to)) - (error "~S doesn't have enough elements." displaced-to)) - (setf (%array-displacement array) offset) - (setf (%array-displaced-p array) t))) - (t - (setf (%array-displaced-p array) nil))) - (let ((axis 0)) - (dolist (dim dimensions) - (setf (%array-dimension array axis) dim) - (incf axis))) - array)))) - -;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array -;;; characteristics. Dimensions is only used to pass to FILL-DATA-VECTOR -;;; for error checking on the structure of initial-contents. -;;; -(defun data-vector-from-inits (dimensions total-size element-type - initial-contents initial-element - initial-element-p) - (when (and initial-contents initial-element-p) - (error "Cannot supply both :initial-contents and :initial-element to - either make-array or adjust-array.")) - (let ((data (if initial-element-p - (make-array total-size - :element-type element-type - :initial-element initial-element) - (make-array total-size - :element-type element-type)))) - (cond (initial-element-p - (unless (simple-vector-p data) - (unless (typep initial-element element-type) - (error "~S cannot be used to initialize an array of type ~S." - initial-element element-type)) - (fill (the vector data) initial-element))) - (initial-contents - (fill-data-vector data dimensions initial-contents))) - data)) - - -(defun fill-data-vector (vector dimensions initial-contents) - (let ((index 0)) - (labels ((frob (axis dims contents) - (cond ((null dims) - (setf (aref vector index) contents) - (incf index)) - (t - (unless (typep contents 'sequence) - (error "Malformed :initial-contents. ~S is not a ~ - sequence, but ~D more layer~:P needed." - contents - (- (length dimensions) axis))) - (unless (= (length contents) (car dims)) - (error "Malformed :initial-contents. Dimension of ~ - axis ~D is ~D, but ~S is ~D long." - axis (car dims) contents (length contents))) - (if (listp contents) - (dolist (content contents) - (frob (1+ axis) (cdr dims) content)) - (dotimes (i (length contents)) - (frob (1+ axis) (cdr dims) (aref contents i)))))))) - (frob 0 dimensions initial-contents)))) - - -;;; Some people out there are still calling MAKE-VECTOR: -;;; -(setf (symbol-function 'make-vector) #'make-array) - - -(defun vector (&rest objects) - "Constructs a simple-vector from the given objects." - (coerce (the list objects) 'simple-vector)) - - - -;;;; Accessor/Setter functions. - -(defun data-vector-ref (array index) - (with-array-data ((vector array) (index index) (end)) - (declare (ignore end) (optimize (safety 3))) - (macrolet ((dispatch (&rest stuff) - `(etypecase vector - ,@(mapcar #'(lambda (type) - (let ((atype `(simple-array ,type (*)))) - `(,atype - (data-vector-ref (the ,atype vector) - index)))) - stuff)))) - (dispatch - t - bit - character - (unsigned-byte 2) - (unsigned-byte 4) - (unsigned-byte 8) - (unsigned-byte 16) - (unsigned-byte 32) - single-float - double-float)))) - -(defun data-vector-set (array index new-value) - (with-array-data ((vector array) (index index) (end)) - (declare (ignore end) (optimize (safety 3))) - (macrolet ((dispatch (&rest stuff) - `(etypecase vector - ,@(mapcar #'(lambda (type) - (let ((atype `(simple-array ,type (*)))) - `(,atype - (data-vector-set (the ,atype vector) - index - (the ,type new-value))))) - stuff)))) - (dispatch - t - bit - character - (unsigned-byte 2) - (unsigned-byte 4) - (unsigned-byte 8) - (unsigned-byte 16) - (unsigned-byte 32) - single-float - double-float)))) - - - -(defun %array-row-major-index (array subscripts - &optional (invalid-index-error-p t)) - (declare (array array) - (list subscripts)) - (let ((rank (array-rank array))) - (unless (= rank (length subscripts)) - (error "Wrong number of subscripts, ~D, for array of rank ~D" - (length subscripts) rank)) - (if (array-header-p array) - (do ((subs (nreverse subscripts) (cdr subs)) - (axis (1- (array-rank array)) (1- axis)) - (chunk-size 1) - (result 0)) - ((null subs) result) - (declare (list subs) (fixnum axis chunk-size result)) - (let ((index (car subs)) - (dim (%array-dimension array axis))) - (declare (fixnum index dim)) - (unless (< -1 index dim) - (if invalid-index-error-p - (error "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S" - index axis array) - (return-from %array-row-major-index nil))) - (incf result (* chunk-size index)) - (setf chunk-size (* chunk-size dim)))) - (let ((index (first subscripts))) - (unless (< -1 index (length (the (simple-array * (*)) array))) - (if invalid-index-error-p - (error "Invalid index ~D in ~S" index array) - (return-from %array-row-major-index nil))) - index)))) - -(defun array-in-bounds-p (array &rest subscripts) - "Returns T if the Subscipts are in bounds for the Array, Nil otherwise." - (if (%array-row-major-index array subscripts nil) - t)) - -(defun array-row-major-index (array &rest subscripts) - (%array-row-major-index array subscripts)) - -(defun aref (array &rest subscripts) - "Returns the element of the Array specified by the Subscripts." - (row-major-aref array (%array-row-major-index array subscripts))) - -(defun %aset (array &rest stuff) - (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) - (setf (row-major-aref array (%array-row-major-index array subscripts)) - new-value))) - -(declaim (inline (setf aref))) -(defun (setf aref) (new-value array &rest subscripts) - (declare (type array array)) - (setf (row-major-aref array (%array-row-major-index array subscripts)) - new-value)) - -(defun row-major-aref (array index) - "Returns the element of array corressponding to the row-major index. This is - SETF'able." - (declare (optimize (safety 1))) - (row-major-aref array index)) - - -(defun %set-row-major-aref (array index new-value) - (declare (optimize (safety 1))) - (setf (row-major-aref array index) new-value)) - -(defun svref (simple-vector index) - "Returns the Index'th element of the given Simple-Vector." - (declare (optimize (safety 1))) - (aref simple-vector index)) - -(defun %svset (simple-vector index new) - (declare (optimize (safety 1))) - (setf (aref simple-vector index) new)) - - -(defun bit (bit-array &rest subscripts) - "Returns the bit from the Bit-Array at the specified Subscripts." - (declare (type (array bit) bit-array) (optimize (safety 1))) - (row-major-aref bit-array (%array-row-major-index bit-array subscripts))) - - -(defun %bitset (bit-array &rest stuff) - (declare (type (array bit) bit-array) (optimize (safety 1))) - (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) - (setf (row-major-aref bit-array - (%array-row-major-index bit-array subscripts)) - new-value))) - -(declaim (inline (setf bit))) -(defun (setf bit) (new-value bit-array &rest subscripts) - (declare (type (array bit) bit-array) (optimize (safety 1))) - (setf (row-major-aref bit-array - (%array-row-major-index bit-array subscripts)) - new-value)) - -(defun sbit (simple-bit-array &rest subscripts) - "Returns the bit from the Simple-Bit-Array at the specified Subscripts." - (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1))) - (row-major-aref simple-bit-array - (%array-row-major-index simple-bit-array subscripts))) - -(defun %sbitset (simple-bit-array &rest stuff) - (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1))) - (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) - (setf (row-major-aref simple-bit-array - (%array-row-major-index simple-bit-array subscripts)) - new-value))) - -(declaim (inline (setf sbit))) -(defun (setf sbit) (new-value bit-array &rest subscripts) - (declare (type (simple-array bit) bit-array) (optimize (safety 1))) - (setf (row-major-aref bit-array - (%array-row-major-index bit-array subscripts)) - new-value)) - - -;;;; Random array properties. - -(defun array-element-type (array) - "Returns the type of the elements of the array" - (let ((type (get-type array))) - (macrolet ((pick-element-type (&rest stuff) - `(cond ,@(mapcar #'(lambda (stuff) - (cons - (let ((item (car stuff))) - (cond ((eq item t) - t) - ((listp item) - (cons 'or - (mapcar #'(lambda (x) - `(= type ,x)) - item))) - (t - `(= type ,item)))) - (cdr stuff))) - stuff)))) - (pick-element-type - ((vm:simple-string-type vm:complex-string-type) 'base-char) - ((vm:simple-bit-vector-type vm:complex-bit-vector-type) 'bit) - (vm:simple-vector-type t) - (vm:simple-array-unsigned-byte-2-type '(unsigned-byte 2)) - (vm:simple-array-unsigned-byte-4-type '(unsigned-byte 4)) - (vm:simple-array-unsigned-byte-8-type '(unsigned-byte 8)) - (vm:simple-array-unsigned-byte-16-type '(unsigned-byte 16)) - (vm:simple-array-unsigned-byte-32-type '(unsigned-byte 32)) - (vm:simple-array-single-float-type 'single-float) - (vm:simple-array-double-float-type 'double-float) - ((vm:simple-array-type vm:complex-vector-type vm:complex-array-type) - (with-array-data ((array array) (start) (end)) - (declare (ignore start end)) - (array-element-type array))) - (t - (error "~S is not an array." array)))))) - - -(defun array-rank (array) - "Returns the number of dimensions of the Array." - (cond ((array-header-p array) - (%array-rank array)) - ((vectorp array) - 1) - (t - (error "~S is not an array." array)))) - -(defun array-dimension (array axis-number) - "Returns length of dimension Axis-Number of the Array." - (declare (array array) (type index axis-number)) - (when (>= axis-number (array-rank array)) - (error "~D is too big; ~S only has ~D dimension~:P" - axis-number array (array-rank array))) - (if (array-header-p array) - (%array-dimension array axis-number) - (length (the (simple-array * (*)) array)))) - -(defun array-dimensions (array) - "Returns a list whose elements are the dimensions of the array" - (declare (array array)) - (if (array-header-p array) - (do ((results nil (cons (array-dimension array index) results)) - (index (1- (array-rank array)) (1- index))) - ((minusp index) results)) - (list (array-dimension array 0)))) - -(defun array-total-size (array) - "Returns the total number of elements in the Array." - (declare (array array)) - (if (array-header-p array) - (%array-available-elements array) - (length (the vector array)))) - -(defun array-displacement (array) - "Returns values of :displaced-to and :displaced-index-offset options to - make-array, or the defaults nil and 0 if not a displaced array." - (declare (array array)) - (values (%array-data-vector array) (%array-displacement array))) - -(defun adjustable-array-p (array) - "Returns T if (adjust-array array...) would return an array identical - to the argument, this happens for complex arrays." - (declare (array array)) - (not (typep array '(simple-array * (*))))) - - -;;;; Fill pointer frobbing stuff. - -(defun array-has-fill-pointer-p (array) - "Returns T if the given Array has a fill pointer, or Nil otherwise." - (declare (array array)) - (and (array-header-p array) (%array-fill-pointer-p array))) - -(defun fill-pointer (vector) - "Returns the Fill-Pointer of the given Vector." - (declare (vector vector)) - (if (and (array-header-p vector) (%array-fill-pointer-p vector)) - (%array-fill-pointer vector) - (error "~S is not an array with a fill-pointer." vector))) - -(defun %set-fill-pointer (vector new) - (declare (vector vector) (fixnum new)) - (if (and (array-header-p vector) (%array-fill-pointer-p vector)) - (if (> new (%array-available-elements vector)) - (error "New fill pointer, ~S, is larger than the length of the vector." - new) - (setf (%array-fill-pointer vector) new)) - (error "~S is not an array with a fill-pointer." vector))) - -(defun vector-push (new-el array) - "Attempts to set the element of Array designated by the fill pointer - to New-El and increment fill pointer by one. If the fill pointer is - too large, Nil is returned, otherwise the index of the pushed element is - returned." - (declare (vector array)) - (let ((fill-pointer (fill-pointer array))) - (declare (fixnum fill-pointer)) - (cond ((= fill-pointer (%array-available-elements array)) - nil) - (t - (setf (aref array fill-pointer) new-el) - (setf (%array-fill-pointer array) (1+ fill-pointer)) - fill-pointer)))) - -(defun vector-push-extend (new-el array &optional - (extension (if (zerop (length array)) - 1 - (length array)))) - "Like Vector-Push except that if the fill pointer gets too large, the - Array is extended rather than Nil being returned." - (declare (vector array) (fixnum extension)) - (let ((fill-pointer (fill-pointer array))) - (declare (fixnum fill-pointer)) - (when (= fill-pointer (%array-available-elements array)) - (adjust-array array (+ fill-pointer extension))) - (setf (aref array fill-pointer) new-el) - (setf (%array-fill-pointer array) (1+ fill-pointer)) - fill-pointer)) - -(defun vector-pop (array) - "Attempts to decrease the fill-pointer by 1 and return the element - pointer to by the new fill pointer. If the original value of the fill - pointer is 0, an error occurs." - (declare (vector array)) - (let ((fill-pointer (fill-pointer array))) - (declare (fixnum fill-pointer)) - (if (zerop fill-pointer) - (error "Nothing left to pop.") - (aref array - (setf (%array-fill-pointer array) - (1- fill-pointer)))))) - - -;;;; Adjust-array - -(defun adjust-array (array dimensions &key - (element-type (array-element-type array)) - (initial-element nil initial-element-p) - initial-contents fill-pointer - displaced-to displaced-index-offset) - "Adjusts the Array's dimensions to the given Dimensions and stuff." - (let ((dimensions (if (listp dimensions) dimensions (list dimensions)))) - (cond ((/= (the fixnum (length (the list dimensions))) - (the fixnum (array-rank array))) - (error "Number of dimensions not equal to rank of array.")) - ((not (subtypep element-type (array-element-type array))) - (error "New element type, ~S, is incompatible with old." - element-type))) - (let ((array-rank (length (the list dimensions)))) - (declare (fixnum array-rank)) - (when (and fill-pointer (> array-rank 1)) - (error "Multidimensional arrays can't have fill pointers.")) - (cond (initial-contents - ;; Array former contents replaced by initial-contents. - (if (or initial-element-p displaced-to) - (error "Initial contents may not be specified with ~ - the :initial-element or :displaced-to option.")) - (let* ((array-size (apply #'* dimensions)) - (array-data (data-vector-from-inits - dimensions array-size element-type - initial-contents initial-element - initial-element-p))) - (if (adjustable-array-p array) - (set-array-header array array-data array-size - (get-new-fill-pointer array array-size - fill-pointer) - 0 dimensions nil) - (if (array-header-p array) - ;; Simple multidimensional or single dimensional array. - (make-array dimensions - :element-type element-type - :initial-contents initial-contents) - array-data)))) - (displaced-to - ;; No initial-contents supplied is already established. - (when initial-element - (error "The :initial-element option may not be specified ~ - with :displaced-to.")) - (unless (subtypep element-type (array-element-type displaced-to)) - (error "One can't displace an array of type ~S into another of ~ - type ~S." - element-type (array-element-type displaced-to))) - (let ((displacement (or displaced-index-offset 0)) - (array-size (apply #'* dimensions))) - (declare (fixnum displacement array-size)) - (if (< (the fixnum (array-total-size displaced-to)) - (the fixnum (+ displacement array-size))) - (error "The :displaced-to array is too small.")) - (if (adjustable-array-p array) - ;; None of the original contents appear in adjusted array. - (set-array-header array displaced-to array-size - (get-new-fill-pointer array array-size - fill-pointer) - displacement dimensions t) - ;; Simple multidimensional or single dimensional array. - (make-array dimensions - :element-type element-type - :displaced-to displaced-to - :displaced-index-offset - displaced-index-offset)))) - ((= array-rank 1) - (let ((old-length (array-total-size array)) - (new-length (car dimensions)) - new-data) - (declare (fixnum old-length new-length)) - (with-array-data ((old-data array) (old-start) - (old-end old-length)) - (cond ((or (%array-displaced-p array) - (< old-length new-length)) - (setf new-data - (data-vector-from-inits - dimensions new-length element-type - initial-contents initial-element - initial-element-p)) - (replace new-data old-data - :start2 old-start :end2 old-end)) - (t (setf new-data - (shrink-vector old-data new-length)))) - (if (adjustable-array-p array) - (set-array-header array new-data new-length - (get-new-fill-pointer array new-length - fill-pointer) - 0 dimensions nil) - new-data)))) - (t - (let ((old-length (%array-available-elements array)) - (new-length (apply #'* dimensions))) - (declare (fixnum old-length new-length)) - (with-array-data ((old-data array) (old-start) - (old-end old-length)) - (declare (ignore old-end)) - (let ((new-data (if (or (%array-displaced-p array) - (> new-length old-length)) - (data-vector-from-inits - dimensions new-length - element-type () initial-element - initial-element-p) - old-data))) - (zap-array-data old-data (array-dimensions array) old-start - new-data dimensions new-length element-type - initial-element initial-element-p) - (set-array-header array new-data new-length - new-length 0 dimensions nil))))))))) - -(defun get-new-fill-pointer (old-array new-array-size fill-pointer) - (cond ((not fill-pointer) - (when (array-has-fill-pointer-p old-array) - (when (> (%array-fill-pointer old-array) new-array-size) - (error "Cannot adjust-array an array (~S) to a size (~S) that is ~ - smaller than it's fill pointer (~S)." - old-array new-array-size (fill-pointer old-array))) - (%array-fill-pointer old-array))) - ((not (array-has-fill-pointer-p old-array)) - (error "Cannot supply a non-NIL value (~S) for :fill-pointer ~ - in adjust-array unless the array (~S) was originally ~ - created with a fill pointer." - fill-pointer - old-array)) - ((numberp fill-pointer) - (when (> fill-pointer new-array-size) - (error "Cannot supply a value for :fill-pointer (~S) that is larger ~ - than the new length of the vector (~S)." - fill-pointer new-array-size)) - fill-pointer) - ((eq fill-pointer t) - new-array-size) - (t - (error "Bogus value for :fill-pointer in adjust-array: ~S" - fill-pointer)))) - -(defun shrink-vector (vector new-size) - "Destructively alters the Vector, changing its length to New-Size, which - must be less than or equal to its current size." - (declare (vector vector)) - (unless (array-header-p vector) - (macrolet ((frob (name &rest things) - `(etypecase ,name - ,@(mapcar #'(lambda (thing) - `(,(car thing) - (fill (truly-the ,(car thing) ,name) - ,(cadr thing) - :start new-size))) - things)))) - (frob vector - (simple-vector 0) - (simple-base-string (code-char 0)) - (simple-bit-vector 0) - ((simple-array (unsigned-byte 2) (*)) 0) - ((simple-array (unsigned-byte 4) (*)) 0) - ((simple-array (unsigned-byte 8) (*)) 0) - ((simple-array (unsigned-byte 16) (*)) 0) - ((simple-array (unsigned-byte 32) (*)) 0) - ((simple-array single-float (*)) (coerce 0 'single-float)) - ((simple-array double-float (*)) (coerce 0 'double-float))))) - ;; Only arrays have fill-pointers, but vectors have their length parameter - ;; in the same place. - (setf (%array-fill-pointer vector) new-size) - vector) - -(defun set-array-header (array data length fill-pointer displacement dimensions - &optional displacedp) - "Fills in array header with provided information. Returns array." - (setf (%array-data-vector array) data) - (setf (%array-available-elements array) length) - (cond (fill-pointer - (setf (%array-fill-pointer array) fill-pointer) - (setf (%array-fill-pointer-p array) t)) - (t - (setf (%array-fill-pointer array) length) - (setf (%array-fill-pointer-p array) nil))) - (setf (%array-displacement array) displacement) - (if (listp dimensions) - (dotimes (axis (array-rank array)) - (declare (type index axis)) - (setf (%array-dimension array axis) (pop dimensions))) - (setf (%array-dimension array 0) dimensions)) - (setf (%array-displaced-p array) displacedp) - array) - - - -;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY. - -;;; Make a temporary to be used when old-data and new-data are EQ. -;;; -(defvar *zap-array-data-temp* (make-array 1000 :initial-element t)) - -(defun zap-array-data-temp (length element-type initial-element - initial-element-p) - (declare (fixnum length)) - (when (> length (the fixnum (length *zap-array-data-temp*))) - (setf *zap-array-data-temp* - (make-array length :initial-element t))) - (when initial-element-p - (unless (typep initial-element element-type) - (error "~S cannot be used to initialize an array of type ~S." - initial-element element-type)) - (fill (the simple-vector *zap-array-data-temp*) initial-element - :end length)) - *zap-array-data-temp*) - - -;;; ZAP-ARRAY-DATA -- Internal. -;;; -;;; This does the grinding work for ADJUST-ARRAY. It zaps the data from the -;;; Old-Data in an arrangement specified by the Old-Dims to the New-Data in an -;;; arrangement specified by the New-Dims. Offset is a displaced offset to be -;;; added to computed indexes of Old-Data. New-Length, Element-Type, -;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data -;;; are EQ; in this case, a temporary must be used and filled appropriately. -;;; When Old-Data and New-Data are not EQ, New-Data has already been filled -;;; with any specified initial-element. -;;; -(defun zap-array-data (old-data old-dims offset new-data new-dims new-length - element-type initial-element initial-element-p) - (declare (list old-dims new-dims)) - (setq old-dims (nreverse old-dims)) - (setq new-dims (reverse new-dims)) - (if (eq old-data new-data) - (let ((temp (zap-array-data-temp new-length element-type - initial-element initial-element-p))) - (zap-array-data-aux old-data old-dims offset temp new-dims) - (dotimes (i new-length) (setf (aref new-data i) (aref temp i)))) - (zap-array-data-aux old-data old-dims offset new-data new-dims))) - -(defun zap-array-data-aux (old-data old-dims offset new-data new-dims) - (declare (fixnum offset)) - (let ((limits (mapcar #'(lambda (x y) - (declare (fixnum x y)) - (1- (the fixnum (min x y)))) - old-dims new-dims))) - (macrolet ((bump-index-list (index limits) - `(do ((subscripts ,index (cdr subscripts)) - (limits ,limits (cdr limits))) - ((null subscripts) nil) - (cond ((< (the fixnum (car subscripts)) - (the fixnum (car limits))) - (rplaca subscripts - (1+ (the fixnum (car subscripts)))) - (return ,index)) - (t (rplaca subscripts 0)))))) - (do ((index (make-list (length old-dims) :initial-element 0) - (bump-index-list index limits))) - ((null index)) - (setf (aref new-data (row-major-index-from-dims index new-dims)) - (aref old-data - (+ (the fixnum (row-major-index-from-dims index old-dims)) - offset))))))) - -;;; ROW-MAJOR-INDEX-FROM-DIMS -- Internal. -;;; -;;; This figures out the row-major-order index of an array reference from a -;;; list of subscripts and a list of dimensions. This is for internal calls -;;; only, and the subscripts and dim-list variables are assumed to be reversed -;;; from what the user supplied. -;;; -(defun row-major-index-from-dims (rev-subscripts rev-dim-list) - (do ((rev-subscripts rev-subscripts (cdr rev-subscripts)) - (rev-dim-list rev-dim-list (cdr rev-dim-list)) - (chunk-size 1) - (result 0)) - ((null rev-dim-list) result) - (declare (fixnum chunk-size result)) - (setq result (+ result - (the fixnum (* (the fixnum (car rev-subscripts)) - chunk-size)))) - (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list)))))) - - - -;;;; Some bit stuff. - -(defun bit-array-same-dimensions-p (array1 array2) - (declare (type (array bit) array1 array2)) - (and (= (array-rank array1) - (array-rank array2)) - (dotimes (index (array-rank array1) t) - (when (/= (array-dimension array1 index) - (array-dimension array2 index)) - (return nil))))) - -(defun pick-result-array (result-bit-array bit-array-1) - (case result-bit-array - ((t) bit-array-1) - ((nil) (make-array (array-dimensions bit-array-1) - :element-type 'bit - :initial-element 0)) - (t - (unless (bit-array-same-dimensions-p bit-array-1 - result-bit-array) - (error "~S and ~S do not have the same dimensions." - bit-array-1 result-bit-array)) - result-bit-array))) - -(defmacro def-bit-array-op (name function) - `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array) - ,(format nil - "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ - BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ - If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ - RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ - All the arrays must have the same rank and dimensions." - (symbol-name function)) - (declare (type (array bit) bit-array-1 bit-array-2) - (type (or (array bit) (member t nil)) result-bit-array)) - (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2) - (error "~S and ~S do not have the same dimensions." - bit-array-1 bit-array-2)) - (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) - (if (and (simple-bit-vector-p bit-array-1) - (simple-bit-vector-p bit-array-2) - (simple-bit-vector-p result-bit-array)) - (locally (declare (optimize (speed 3) (safety 0))) - (,name bit-array-1 bit-array-2 result-bit-array)) - (with-array-data ((data1 bit-array-1) (start1) (end1)) - (declare (ignore end1)) - (with-array-data ((data2 bit-array-2) (start2) (end2)) - (declare (ignore end2)) - (with-array-data ((data3 result-bit-array) (start3) (end3)) - (do ((index-1 start1 (1+ index-1)) - (index-2 start2 (1+ index-2)) - (index-3 start3 (1+ index-3))) - ((>= index-3 end3) result-bit-array) - (declare (type index index-1 index-2 index-3)) - (setf (sbit data3 index-3) - (logand (,function (sbit data1 index-1) - (sbit data2 index-2)) - 1)))))))))) - -(def-bit-array-op bit-and logand) -(def-bit-array-op bit-ior logior) -(def-bit-array-op bit-xor logxor) -(def-bit-array-op bit-eqv logeqv) -(def-bit-array-op bit-nand lognand) -(def-bit-array-op bit-nor lognor) -(def-bit-array-op bit-andc1 logandc1) -(def-bit-array-op bit-andc2 logandc2) -(def-bit-array-op bit-orc1 logorc1) -(def-bit-array-op bit-orc2 logorc2) - -(defun bit-not (bit-array &optional result-bit-array) - "Performs a bit-wise logical NOT on the elements of BIT-ARRAY, - putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, - BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is - created. Both arrays must have the same rank and dimensions." - (declare (type (array bit) bit-array) - (type (or (array bit) (member t nil)) result-bit-array)) - (let ((result-bit-array (pick-result-array result-bit-array bit-array))) - (if (and (simple-bit-vector-p bit-array) - (simple-bit-vector-p result-bit-array)) - (locally (declare (optimize (speed 3) (safety 0))) - (bit-not bit-array result-bit-array)) - (with-array-data ((src bit-array) (src-start) (src-end)) - (declare (ignore src-end)) - (with-array-data ((dst result-bit-array) (dst-start) (dst-end)) - (do ((src-index src-start (1+ src-index)) - (dst-index dst-start (1+ dst-index))) - ((>= dst-index dst-end) result-bit-array) - (declare (type index src-index dst-index)) - (setf (sbit dst dst-index) - (logxor (sbit src src-index) 1)))))))) diff --git a/code/backq.lisp b/code/backq.lisp deleted file mode 100644 index 3ada581b3908c0867cead413944a835475906546..0000000000000000000000000000000000000000 --- a/code/backq.lisp +++ /dev/null @@ -1,298 +0,0 @@ -;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/backq.lisp,v 1.6 1992/08/14 01:34:40 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; BACKQUOTE: Code Spice Lispified by Lee Schumacher. -;;; (unparsing by Miles Bader) -;;; -(in-package 'lisp) - - -;;; The flags passed back by BACKQUOTIFY can be interpreted as follows: -;;; -;;; |`,|: [a] => a -;;; NIL: [a] => a ;the NIL flag is used only when a is NIL -;;; T: [a] => a ;the T flag is used when a is self-evaluating -;;; QUOTE: [a] => (QUOTE a) -;;; APPEND: [a] => (APPEND . a) -;;; NCONC: [a] => (NCONC . a) -;;; LIST: [a] => (LIST . a) -;;; LIST*: [a] => (LIST* . a) -;;; -;;; The flags are combined according to the following set of rules: -;;; ([a] means that a should be converted according to the previous table) -;;; -;;; \ car || otherwise | QUOTE or | |`,@| | |`,.| -;;;cdr \ || | T or NIL | | -;;;================================================================================ -;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d]) -;;; NIL || LIST ([a]) | QUOTE (a) | <hair> a | <hair> a -;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d]) -;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d]) -;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d) -;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d]) -;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d]) -;;; -;;;<hair> involves starting over again pretending you had read ".,a)" instead -;;; of ",@a)" - -(defvar *backquote-count* 0 "How deep we are into backquotes") -(defvar *bq-comma-flag* '(|,|)) -(defvar *bq-at-flag* '(|,@|)) -(defvar *bq-dot-flag* '(|,.|)) -(defvar *bq-vector-flag* '(|bqv|)) - -;; This is the actual character macro. -(defun backquote-macro (stream ignore) - (declare (ignore ignore)) - (let ((*backquote-count* (1+ *backquote-count*))) - (multiple-value-bind (flag thing) - (backquotify stream (read stream t nil t)) - (if (eq flag *bq-at-flag*) - (%reader-error stream ",@ after backquote in ~S" thing)) - (if (eq flag *bq-dot-flag*) - (%reader-error stream ",. after backquote in ~S" thing)) - (values (backquotify-1 flag thing) 'list)))) - -(defun comma-macro (stream ignore) - (declare (ignore ignore)) - (unless (> *backquote-count* 0) - (when *read-suppress* - (return-from comma-macro nil)) - (%reader-error stream "Comma not inside a backquote.")) - (let ((c (read-char stream)) - (*backquote-count* (1- *backquote-count*))) - (values - (cond ((char= c #\@) - (cons *bq-at-flag* (read stream t nil t))) - ((char= c #\.) - (cons *bq-dot-flag* (read stream t nil t))) - (t (unread-char c stream) - (cons *bq-comma-flag* (read stream t nil t)))) - 'list))) - -;;; This does the expansion from table 2. -(defun backquotify (stream code) - (cond ((atom code) - (cond ((null code) (values nil nil)) - ((or (numberp code) - (eq code t)) - ;; Keywords are self evaluating. Install after packages. - (values t code)) - (t (values 'quote code)))) - ((or (eq (car code) *bq-at-flag*) - (eq (car code) *bq-dot-flag*)) - (values (car code) (cdr code))) - ((eq (car code) *bq-comma-flag*) - (comma (cdr code))) - ((eq (car code) *bq-vector-flag*) - (multiple-value-bind (dflag d) (backquotify stream (cdr code)) - (values 'vector (backquotify-1 dflag d)))) - (t (multiple-value-bind (aflag a) (backquotify stream (car code)) - (multiple-value-bind (dflag d) (backquotify stream (cdr code)) - (if (eq dflag *bq-at-flag*) - ;; get the errors later. - (%reader-error stream ",@ after dot in ~S" code)) - (if (eq dflag *bq-dot-flag*) - (%reader-error stream ",. after dot in ~S" code)) - (cond - ((eq aflag *bq-at-flag*) - (if (null dflag) - (comma a) - (values 'append - (cond ((eq dflag 'append) - (cons a d )) - (t (list a (backquotify-1 dflag d))))))) - ((eq aflag *bq-dot-flag*) - (if (null dflag) - (comma a) - (values 'nconc - (cond ((eq dflag 'nconc) - (cons a d)) - (t (list a (backquotify-1 dflag d))))))) - ((null dflag) - (if (memq aflag '(quote t nil)) - (values 'quote (list a)) - (values 'list (list (backquotify-1 aflag a))))) - ((memq dflag '(quote t)) - (if (memq aflag '(quote t nil)) - (values 'quote (cons a d )) - (values 'list* (list (backquotify-1 aflag a) - (backquotify-1 dflag d))))) - (t (setq a (backquotify-1 aflag a)) - (if (memq dflag '(list list*)) - (values dflag (cons a d)) - (values 'list* - (list a (backquotify-1 dflag d))))))))))) - -;;; This handles the <hair> cases -(defun comma (code) - (cond ((atom code) - (cond ((null code) - (values nil nil)) - ((or (numberp code) (eq code 't)) - (values t code)) - (t (values *bq-comma-flag* code)))) - ((eq (car code) 'quote) - (values (car code) (cadr code))) - ((memq (car code) '(append list list* nconc)) - (values (car code) (cdr code))) - ((eq (car code) 'cons) - (values 'list* (cdr code))) - (t (values *bq-comma-flag* code)))) - -;;; This handles table 1. -(defun backquotify-1 (flag thing) - (cond ((or (eq flag *bq-comma-flag*) - (memq flag '(t nil))) - thing) - ((eq flag 'quote) - (list 'quote thing)) - ((eq flag 'list*) - (cond ((null (cddr thing)) - (cons 'backq-cons thing)) - (t - (cons 'backq-list* thing)))) - ((eq flag 'vector) - (list 'backq-vector thing)) - (t (cons (cdr - (assq flag - '((cons . backq-cons) - (list . backq-list) - (append . backq-append) - (nconc . backq-nconc)))) - thing)))) - - -;;;; Magic backq- versions of builtin functions. - -;;; Use synonyms for the lisp functions we use, so we can recognize backquoted -;;; material when pretty-printing - -(defun backq-list (&rest args) - args) -(defun backq-list* (&rest args) - (apply #'list* args)) -(defun backq-append (&rest args) - (apply #'append args)) -(defun backq-nconc (&rest args) - (apply #'nconc args)) -(defun backq-cons (x y) - (cons x y)) - -(macrolet ((frob (b-name name) - `(define-compiler-macro ,b-name (&rest args) - `(,',name ,@args)))) - (frob backq-list list) - (frob backq-list* list*) - (frob backq-append append) - (frob backq-nconc nconc) - (frob backq-cons cons)) - -(defun backq-vector (list) - (declare (list list)) - (coerce list 'simple-vector)) - - -;;;; Unparsing - -(defun backq-unparse-expr (form splicing) - (ecase splicing - ((nil) - `(backq-comma ,form)) - ((t) - `((backq-comma-at ,form))) - (:nconc - `((backq-comma-dot ,form))) - )) - -(defun backq-unparse (form &optional splicing) - "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*, - BACKQ-APPEND, etc. produced by the backquote reader macro, will return a - corresponding backquote input form. In this form, `,' `,@' and `,.' are - represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and - BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma. - SPLICING indicates whether a comma-escape return should be modified for - splicing with other forms: a value of T or :NCONC meaning that an extra - level of parentheses should be added." - (if (atom form) - (backq-unparse-expr form splicing) - (case (car form) - (backq-list - (mapcar #'backq-unparse (cdr form))) - (backq-list* - (do ((tail (cdr form) (cdr tail)) - (accum nil)) - ((null (cdr tail)) - (nconc (nreverse accum) - (backq-unparse (car tail) t))) - (push (backq-unparse (car tail)) accum))) - (backq-append - (mapcan #'(lambda (el) (backq-unparse el t)) - (cdr form))) - (backq-nconc - (mapcan #'(lambda (el) (backq-unparse el :nconc)) - (cdr form))) - (backq-cons - (cons (backq-unparse (cadr form) nil) - (backq-unparse (caddr form) t))) - (backq-vector - (coerce (backq-unparse (cadr form)) 'vector)) - (quote - (cadr form)) - (t - (backq-unparse-expr form splicing))))) - -(defun pprint-backquote (stream form &rest noise) - (declare (ignore noise)) - (write-char #\` stream) - (write (backq-unparse form) :stream stream)) - -(defun pprint-backq-comma (stream form &rest noise) - (declare (ignore noise)) - (ecase (car form) - (backq-comma - (write-char #\, stream)) - (backq-comma-at - (princ ",@" stream)) - (backq-comma-dot - (princ ",." stream))) - (write (cadr form) :stream stream)) - - -;;;; BACKQ-INIT and BACKQ-PP-INIT - -;;; BACKQ-INIT -- interface. -;;; -;;; This is called by %INITIAL-FUNCTION. -;;; -(defun backq-init () - (let ((*readtable* std-lisp-readtable)) - (set-macro-character #\` #'backquote-macro) - (set-macro-character #\, #'comma-macro))) - -;;; BACKQ-PP-INIT -- interface. -;;; -;;; This is called by PPRINT-INIT. This must be seperate from BACKQ-INIT -;;; because SET-PPRINT-DISPATCH doesn't work until the compiler is loaded. -;;; -(defun backq-pp-init () - (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote) - (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote) - (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote) - (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote) - (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote) - (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote) - - (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma) - (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma) - (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma)) diff --git a/code/bignum-test.lisp b/code/bignum-test.lisp deleted file mode 100644 index 992361c9b622bc244a99a53f535f7f136ae645fa..0000000000000000000000000000000000000000 --- a/code/bignum-test.lisp +++ /dev/null @@ -1,104 +0,0 @@ -;;;; -*- Package: Bignum -*- -;;; -;;; ********************************************************************** -;;; 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/code/bignum-test.lisp,v 1.3 1991/05/24 19:35:48 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Some stuff to check that bignum operations are retuning the correct -;;; results. -;;; -(in-package "BIGNUM") - -(defvar *in-bignum-wrapper* nil) - -(defmacro def-bignum-wrapper (name lambda-list &body body) - (let ((var-name (ext:symbolicate "*OLD-" name "*")) - (wrap-name (ext:symbolicate "WRAP-" name)) - (args (mapcar #'(lambda (x) - (if (listp x) (car x) x)) - (remove-if #'(lambda (x) - (member x lambda-list-keywords)) - lambda-list)))) - `(progn - (defvar ,var-name (fdefinition ',name)) - (defun ,wrap-name ,lambda-list - (if *in-bignum-wrapper* - (funcall ,var-name ,@args) - (let ((*in-bignum-wrapper* t)) - ,@body))) - (setf (fdefinition ',name) #',wrap-name)))) - -(defun big= (x y) - (= (if (typep x 'bignum) - (%normalize-bignum x (%bignum-length x)) - x) - (if (typep y 'bignum) - (%normalize-bignum y (%bignum-length y)) - y))) - -(def-bignum-wrapper add-bignums (x y) - (let ((res (funcall *old-add-bignums* x y))) - (assert (big= (- res y) x)) - res)) - -(def-bignum-wrapper multiply-bignums (x y) - (let ((res (funcall *old-multiply-bignums* x y))) - (if (zerop x) - (assert (zerop res)) - (multiple-value-bind (q r) (truncate res x) - (assert (and (zerop r) (big= q y))))) - res)) - -(def-bignum-wrapper negate-bignum (x &optional (fully-normalized t)) - (let ((res (funcall *old-negate-bignum* x fully-normalized))) - (assert (big= (- res) x)) - res)) - -(def-bignum-wrapper subtract-bignum (x y) - (let ((res (funcall *old-subtract-bignum* x y))) - (assert (big= (+ res y) x)) - res)) - -(def-bignum-wrapper multiply-bignum-and-fixnum (x y) - (let ((res (funcall *old-multiply-bignum-and-fixnum* x y))) - (if (zerop x) - (assert (zerop res)) - (multiple-value-bind (q r) (truncate res x) - (assert (and (zerop r) (big= q y))))) - res)) - -(def-bignum-wrapper multiply-fixnums (x y) - (let ((res (funcall *old-multiply-fixnums* x y))) - (if (zerop x) - (assert (zerop res)) - (multiple-value-bind (q r) (truncate res x) - (assert (and (zerop r) (big= q y))))) - res)) - -(def-bignum-wrapper bignum-ashift-right (x shift) - (let ((res (funcall *old-bignum-ashift-right* x shift))) - (assert (big= (ash res shift) (logand x (ash -1 shift)))) - res)) - -(def-bignum-wrapper bignum-ashift-left (x shift) - (let ((res (funcall *old-bignum-ashift-left* x shift))) - (assert (big= (ash res (- shift)) x)) - res)) - -(def-bignum-wrapper bignum-truncate (x y) - (multiple-value-bind (q r) - (funcall *old-bignum-truncate* x y) - (assert (big= (+ (* q y) r) x)) - (values q r))) - -(def-bignum-wrapper bignum-compare (x y) - (let ((res (funcall *old-bignum-compare* x y))) - (assert (big= (signum (- x y)) res)) - res)) diff --git a/code/bignum.lisp b/code/bignum.lisp deleted file mode 100644 index d051ae573dd6165db3cbdace6358f7856927ae98..0000000000000000000000000000000000000000 --- a/code/bignum.lisp +++ /dev/null @@ -1,2563 +0,0 @@ -;;; -*- Mode: completion; Log: code.log; Package: bignum -*- -;;; -;;; ********************************************************************** -;;; 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/code/bignum.lisp,v 1.19 1991/06/12 17:24:18 chiles Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains code to implement bignum support. -;;; - -(in-package "BIGNUM") -(use-package "KERNEL") - -;;; These symbols define the interface to the number code. - -(export '(add-bignums multiply-bignums negate-bignum subtract-bignum - multiply-bignum-and-fixnum multiply-fixnums - bignum-ashift-right bignum-ashift-left bignum-gcd - bignum-to-float float-bignum-ratio bignum-integer-length - bignum-logical-and bignum-logical-ior bignum-logical-xor - bignum-logical-not bignum-load-byte bignum-deposit-byte - bignum-truncate bignum-plus-p bignum-compare make-small-bignum - bignum-logcount)) - -;;; These symbols define the interface to the compiler. - -(export '(bignum-type bignum-element-type bignum-index %allocate-bignum - %bignum-length %bignum-set-length %bignum-ref %bignum-set - %digit-0-or-plusp %add-with-carry %subtract-with-borrow - %multiply-and-add %multiply %lognot %logand %logior %logxor - %fixnum-to-digit %floor %fixnum-digit-with-correct-sign %ashl - %ashr %digit-logical-shift-right)) - - - -;;;; Notes. - -;;; The following interfaces will either be assembler routines or code sequences -;;; expanded into the code as basic bignum operations: -;;; General: -;;; %BIGNUM-LENGTH -;;; %ALLOCATE-BIGNUM -;;; %BIGNUM-REF -;;; %NORMALIZE-BIGNUM -;;; %BIGNUM-SET-LENGTH -;;; %FIXNUM-DIGIT-WITH-CORRECT-SIGN -;;; %SIGN-DIGIT -;;; %ASHR -;;; %ASHL -;;; %BIGNUM-0-OR-PLUSP -;;; %DIGIT-LOGICAL-SHIFT-RIGHT -;;; General (May not exist when done due to sole use in %-routines.) -;;; %DIGIT-0-OR-PLUSP -;;; Addition: -;;; %ADD-WITH-CARRY -;;; Subtraction: -;;; %SUBTRACT-WITH-BORROW -;;; Multiplication -;;; %MULTIPLY -;;; Negation -;;; %LOGNOT -;;; Shifting (in place) -;;; %NORMALIZE-BIGNUM-BUFFER -;;; GCD/Relational operators: -;;; %DIGIT-COMPARE -;;; %DIGIT-GREATER -;;; Relational operators: -;;; %LOGAND -;;; %LOGIOR -;;; %LOGXOR -;;; LDB -;;; %FIXNUM-TO-DIGIT -;;; TRUNCATE -;;; %FLOOR -;;; -;;; -;;; Note: The floating routines know about the float representation. -;;; -;;; PROBLEM 1: -;;; There might be a problem with various LET's and parameters that take a -;;; digit value. We need to write these so those things stay in 32-bit -;;; registers and number stack slots. I bind locals to these values, and I -;;; use function on them -- ZEROP, ASH, etc. -;;; -;;; PROBLEM 2: -;;; In shifting and byte operations, I use masks and logical operations that -;;; could result in intermediate bignums. This is hidden by the current system, -;;; but I may need to write these in a way that keeps these masks and logical -;;; operations from diving into the Lisp level bignum code. -;;; -;;; To do: -;;; fixnums -;;; logior, logxor, logand -;;; depending on relationals, < (twice) and <= (twice) -;;; or write compare thing (twice). -;;; LDB on fixnum with bignum result. -;;; DPB on fixnum with bignum result. -;;; TRUNCATE returns zero or one as one value and fixnum or minus fixnum -;;; for the other value when given (truncate fixnum bignum). -;;; Returns (truncate bignum fixnum) otherwise. -;;; addition -;;; subtraction (twice) -;;; multiply -;;; GCD -;;; write MASK-FIELD and DEPOSIT-FIELD in terms of logical operations. -;;; DIVIDE -;;; IF (/ x y) with bignums: -;;; do the truncate, and if rem is 0, return quotient. -;;; if rem is non-0 -;;; gcd of x and y. -;;; "truncate" each by gcd, ignoring remainder 0. -;;; form ratio of each result, bottom is positive. -;;; - - - -;;;; What's a bignum? - -(eval-when (compile load eval) ;Necessary for DEFTYPE. - -(defconstant digit-size 32) - -(defconstant maximum-bignum-length (1- (ash 1 (- 32 vm:type-bits)))) - -) ;eval-when - - - -;;;; Internal inline routines. - -;;; %ALLOCATE-BIGNUM must zero all elements. -;;; -(defun %allocate-bignum (length) - (declare (type bignum-index length)) - (%allocate-bignum length)) - -;;; Extract the length of the bignum. -;;; -(defun %bignum-length (bignum) - (declare (type bignum-type bignum)) - (%bignum-length bignum)) - -;;; %BIGNUM-REF needs to access bignums as obviously as possible, and it needs -;;; to be able to return 32 bits somewhere no one looks for real objects. -;;; -(defun %bignum-ref (bignum i) - (declare (type bignum-type bignum) - (type bignum-index i)) - (%bignum-ref bignum i)) -;;; -(defun %bignum-set (bignum i value) - (declare (type bignum-type bignum) - (type bignum-index i) - (type bignum-element-type value)) - (%bignum-set bignum i value)) -;;; -(defsetf %bignum-ref %bignum-set) - -;;; Return T if digit is positive, or NIL if negative. -;;; -(defun %digit-0-or-plusp (digit) - (declare (type bignum-element-type digit)) - (not (logbitp (1- digit-size) digit))) - -(proclaim '(inline %bignum-0-or-plusp)) -(defun %bignum-0-or-plusp (bignum len) - (declare (type bignum-type bignum) - (type bignum-index len)) - (%digit-0-or-plusp (%bignum-ref bignum (1- len)))) - -;;; %ADD-WITH-CARRY -- Internal. -;;; -;;; This should be in assembler, and should not cons intermediate results. It -;;; returns a 32bit digit and a carry resulting from adding together a, b, and -;;; an incoming carry. -;;; -(defun %add-with-carry (a b carry) - (declare (type bignum-element-type a b) - (type (mod 2) carry)) - (%add-with-carry a b carry)) - -;;; %SUBTRACT-WITH-BORROW -- Internal. -;;; -;;; This should be in assembler, and should not cons intermediate results. It -;;; returns a 32bit digit and a borrow resulting from subtracting b from a, and -;;; subtracting a possible incoming borrow. -;;; -;;; We really do: a - b - 1 + borrow, where borrow is either 0 or 1. -;;; -(defun %subtract-with-borrow (a b borrow) - (declare (type bignum-element-type a b) - (type (mod 2) borrow)) - (%subtract-with-borrow a b borrow)) - -;;; %MULTIPLY -- Internal. -;;; -;;; This multiplies two digit-size (32-bit) numbers, returning a 64-bit result -;;; split into two 32-bit quantities. -;;; -(defun %multiply (x y) - (declare (type bignum-element-type x y)) - (%multiply x y)) - -;;; %MULTIPLY-AND-ADD -- Internal. -;;; -;;; This multiplies x-digit and y-digit, producing high and low digits -;;; manifesting the result. Then it adds the low digit, res-digit, and -;;; carry-in-digit. Any carries (note, you still have to add two digits at a -;;; time possibly producing two carries) from adding these three digits get -;;; added to the high digit from the multiply, producing the next carry digit. -;;; Res-digit is optional since two uses of this primitive multiplies a single -;;; digit bignum by a multiple digit bignum, and in this situation there is no -;;; need for a result buffer accumulating partial results which is where the -;;; res-digit comes from. -;;; -(defun %multiply-and-add (x-digit y-digit carry-in-digit &optional (res-digit 0)) - (declare (type bignum-element-type x-digit y-digit res-digit carry-in-digit)) - (%multiply-and-add x-digit y-digit carry-in-digit res-digit)) - -;;; %LOGNOT -- Internal. -;;; -(defun %lognot (digit) - (declare (type bignum-element-type digit)) - (%lognot digit)) - -;;; %LOGAND -- Internal. -;;; %LOGIOR -- Internal. -;;; %LOGXOR -- Internal. -;;; -;;; Do the 32bit unsigned op. -;;; -(proclaim '(inline %logand %logior %logxor)) -(defun %logand (a b) - (declare (type bignum-element-type a b)) - (logand a b)) -(defun %logior (a b) - (declare (type bignum-element-type a b)) - (logior a b)) -(defun %logxor (a b) - (declare (type bignum-element-type a b)) - (logxor a b)) - -;;; %FIXNUM-TO-DIGIT -- Internal. -;;; -;;; This takes a fixnum and sets it up as an unsigned 32-bit quantity. In -;;; the new system this will mean shifting it right two bits. -;;; -(defun %fixnum-to-digit (x) - (declare (fixnum x)) - (logand x (1- (ash 1 digit-size)))) - -#-32x16-divide -;;; %FLOOR -- Internal. -;;; -;;; This takes three digits and returns the FLOOR'ed result of dividing the -;;; first two as a 64-bit integer by the third. -;;; -;;; DO WEIRD let AND setq STUFF TO SLIME THE COMPILER INTO ALLOWING THE %FLOOR -;;; TRANSFORM TO EXPAND INTO PSEUDO-ASSEMBLER FOR WHICH THE COMPILER CAN LATER -;;; CORRECTLY ALLOCATE REGISTERS. -;;; -(defun %floor (a b c) - (let ((a a) (b b) (c c)) - (declare (type bignum-element-type a b c)) - (setq a a b b c c) - (%floor a b c))) - - -;;; %FIXNUM-DIGIT-WITH-CORRECT-SIGN -- Internal. -;;; -;;; Convert the digit to a regular integer assuming that the digit is signed. -;;; -(defun %fixnum-digit-with-correct-sign (digit) - (declare (type bignum-element-type digit)) - (if (logbitp (1- digit-size) digit) - (logior digit (ash -1 digit-size)) - digit)) - -;;; %ASHR -- Internal. -;;; -;;; Do an arithmetic shift right of data even though bignum-element-type is -;;; unsigned. -;;; -(defun %ashr (data count) - (declare (type bignum-element-type data) - (type (mod 32) count)) - (%ashr data count)) - -;;; %ASHL -- Internal. -;;; -;;; This takes a 32-bit quantity and shifts it to the left, returning a 32-bit -;;; quantity. -(defun %ashl (data count) - (declare (type bignum-element-type data) - (type (mod 32) count)) - (%ashl data count)) - -;;; %DIGIT-LOGICAL-SHIFT-RIGHT -- Internal -;;; -;;; Do an unsigned (logical) right shift of a digit by Count. -;;; -(defun %digit-logical-shift-right (data count) - (declare (type bignum-element-type data) - (type (mod 32) count)) - (%digit-logical-shift-right data count)) - - -;;; %BIGNUM-SET-LENGTH -- Internal. -;;; -;;; Change the length of bignum to be newlen. Newlen must be the same or -;;; smaller than the old length, and any elements beyond newlen must be zeroed. -;;; -(defun %bignum-set-length (bignum newlen) - (declare (type bignum-type bignum) - (type bignum-index newlen)) - (%bignum-set-length bignum newlen)) - -;;; %SIGN-DIGIT -- Internal. -;;; -;;; This returns 0 or "-1" depending on whether the bignum is positive. This -;;; is suitable for infinite sign extension to complete additions, -;;; subtractions, negations, etc. This cannot return a -1 represented as -;;; a negative fixnum since it would then have to low zeros. -;;; -(proclaim '(inline %sign-digit)) -(defun %sign-digit (bignum len) - (declare (type bignum-type bignum) - (type bignum-index len)) - (%ashr (%bignum-ref bignum (1- len)) (1- digit-size))) - - - -;;; %DIGIT-COMPARE and %DIGIT-GREATER -- Internal. -;;; -;;; These take two 32 bit quantities and compare or contrast them without -;;; wasting time with incorrect type checking. -;;; -(proclaim '(inline %digit-compare %digit-greater)) -(defun %digit-compare (x y) - (= x y)) -;;; -(defun %digit-greater (x y) - (> x y)) - - -(proclaim '(optimize (speed 3) (safety 0))) - - -;;;; Addition. - -(defun add-bignums (a b) - (declare (type bignum-type a b)) - (let ((len-a (%bignum-length a)) - (len-b (%bignum-length b))) - (declare (type bignum-index len-a len-b)) - (multiple-value-bind (a len-a b len-b) - (if (> len-a len-b) - (values a len-a b len-b) - (values b len-b a len-a)) - (declare (type bignum-type a b) - (type bignum-index len-a len-b)) - (let* ((len-res (1+ len-a)) - (res (%allocate-bignum len-res)) - (carry 0)) - (declare (type bignum-index len-res) - (type bignum-type res) - (type (mod 2) carry)) - (dotimes (i len-b) - (declare (type bignum-index i)) - (multiple-value-bind - (v k) - (%add-with-carry (%bignum-ref a i) (%bignum-ref b i) carry) - (declare (type bignum-element-type v) - (type (mod 2) k)) - (setf (%bignum-ref res i) v) - (setf carry k))) - (if (/= len-a len-b) - (finish-add a res carry (%sign-digit b len-b) len-b len-a) - (setf (%bignum-ref res len-a) - (%add-with-carry (%sign-digit a len-a) - (%sign-digit b len-b) - carry))) - (%normalize-bignum res len-res))))) - -;;; FINISH-ADD -- Internal. -;;; -;;; This takes the longer of two bignums and propagates the carry through its -;;; remaining high order digits. -;;; -(defun finish-add (a res carry sign-digit-b start end) - (declare (type bignum-type a res) - (type (mod 2) carry) - (type bignum-element-type sign-digit-b) - (type bignum-index start end)) - (do ((i start (1+ i))) - ((= i end) - (setf (%bignum-ref res end) - (%add-with-carry (%sign-digit a end) sign-digit-b carry))) - (declare (type bignum-index i)) - (multiple-value-bind (v k) - (%add-with-carry (%bignum-ref a i) sign-digit-b carry) - (setf (%bignum-ref res i) v) - (setf carry k))) - (ext:undefined-value)) - - -;;;; Subtraction. - -(eval-when (compile eval) - -;;; SUBTRACT-BIGNUM-LOOP -- Internal. -;;; -;;; This subtracts b from a plugging result into res. Return-fun is the -;;; function to call that fixes up the result returning any useful values, such -;;; as the result. This macro may evaluate its arguments more than once. -;;; -(defmacro subtract-bignum-loop (a len-a b len-b res len-res return-fun) - (let ((borrow (gensym)) - (a-digit (gensym)) - (a-sign (gensym)) - (b-digit (gensym)) - (b-sign (gensym)) - (i (gensym)) - (v (gensym)) - (k (gensym))) - `(let* ((,borrow 1) - (,a-sign (%sign-digit ,a ,len-a)) - (,b-sign (%sign-digit ,b ,len-b))) - (declare (type bignum-element-type ,a-sign ,b-sign)) - (dotimes (,i ,len-res) - (declare (type bignum-index ,i)) - (let ((,a-digit (if (< ,i ,len-a) (%bignum-ref ,a ,i) ,a-sign)) - (,b-digit (if (< ,i ,len-b) (%bignum-ref ,b ,i) ,b-sign))) - (declare (type bignum-element-type ,a-digit ,b-digit)) - (multiple-value-bind - (,v ,k) - (%subtract-with-borrow ,a-digit ,b-digit ,borrow) - (setf (%bignum-ref ,res ,i) ,v) - (setf ,borrow ,k)))) - (,return-fun ,res ,len-res)))) - -) ;EVAL-WHEN - -(defun subtract-bignum (a b) - (declare (type bignum-type a b)) - (let* ((len-a (%bignum-length a)) - (len-b (%bignum-length b)) - (len-res (1+ (max len-a len-b))) - (res (%allocate-bignum len-res))) - (declare (type bignum-index len-a len-b len-res)) ;Test len-res for bounds? - (subtract-bignum-loop a len-a b len-b res len-res %normalize-bignum))) - -;;; SUBTRACT-BIGNUM-BUFFERS -- Internal. -;;; -;;; Operations requiring a subtraction without the overhead of intermediate -;;; results, such as GCD, use this. It assumes Result is big enough for the -;;; result. -;;; -(defun subtract-bignum-buffers (a len-a b len-b result) - (declare (type bignum-type a b) - (type bignum-index len-a len-b)) - (let ((len-res (max len-a len-b))) - (subtract-bignum-loop a len-a b len-b result len-res - %normalize-bignum-buffer))) - - - -;;;; Multiplication. - -(defun multiply-bignums (a b) - (declare (type bignum-type a b)) - (let* ((a-plusp (%bignum-0-or-plusp a (%bignum-length a))) - (b-plusp (%bignum-0-or-plusp b (%bignum-length b))) - (a (if a-plusp a (negate-bignum a))) - (b (if b-plusp b (negate-bignum b))) - (len-a (%bignum-length a)) - (len-b (%bignum-length b)) - (len-res (+ len-a len-b)) - (res (%allocate-bignum len-res)) - (negate-res (not (eq a-plusp b-plusp)))) - (declare (type bignum-index len-a len-b len-res)) - (dotimes (i len-a) - (declare (type bignum-index i)) - (let ((carry-digit 0) - (x (%bignum-ref a i)) - (k i)) - (declare (type bignum-index k) - (type bignum-element-type carry-digit x)) - (dotimes (j len-b) - (multiple-value-bind (big-carry res-digit) - (%multiply-and-add x (%bignum-ref b j) - (%bignum-ref res k) - carry-digit) - (declare (type bignum-element-type big-carry res-digit)) - (setf (%bignum-ref res k) res-digit) - (setf carry-digit big-carry) - (incf k))) - (setf (%bignum-ref res k) carry-digit))) - (when negate-res (negate-bignum-in-place res)) - (%normalize-bignum res len-res))) - -(defun multiply-bignum-and-fixnum (bignum fixnum) - (declare (type bignum-type bignum) (type fixnum fixnum)) - (let* ((bignum-plus-p (%bignum-0-or-plusp bignum (%bignum-length bignum))) - (fixnum-plus-p (not (minusp fixnum))) - (bignum (if bignum-plus-p bignum (negate-bignum bignum))) - (bignum-len (%bignum-length bignum)) - (fixnum (%fixnum-to-digit (if fixnum-plus-p fixnum (- fixnum)))) - (result (%allocate-bignum (1+ bignum-len))) - (carry-digit 0)) - (declare (type bignum-type bignum result) - (type bignum-index bignum-len) - (type bignum-element-type fixnum carry-digit)) - (dotimes (index bignum-len) - (declare (type bignum-index index)) - (multiple-value-bind - (next-digit low) - (%multiply-and-add (%bignum-ref bignum index) fixnum carry-digit) - (declare (type bignum-element-type next-digit low)) - (setf carry-digit next-digit) - (setf (%bignum-ref result index) low))) - (setf (%bignum-ref result bignum-len) carry-digit) - (unless (eq bignum-plus-p fixnum-plus-p) - (negate-bignum-in-place result)) - (%normalize-bignum result (1+ bignum-len)))) - -(defun multiply-fixnums (a b) - (declare (fixnum a b)) - (let* ((a-minusp (minusp a)) - (b-minusp (minusp b))) - (multiple-value-bind (high low) - (%multiply (%fixnum-to-digit (if a-minusp (- a) a)) - (%fixnum-to-digit (if b-minusp (- b) b))) - (declare (type bignum-element-type high low)) - (if (and (zerop high) - (%digit-0-or-plusp low)) - (let ((low (ext:truly-the (unsigned-byte 31) - (%fixnum-digit-with-correct-sign low)))) - (if (eq a-minusp b-minusp) - low - (- low))) - (let ((res (%allocate-bignum 2))) - (%bignum-set res 0 low) - (%bignum-set res 1 high) - (unless (eq a-minusp b-minusp) (negate-bignum-in-place res)) - (%normalize-bignum res 2)))))) - - - -;;;; BIGNUM-REPLACE and WITH-BIGNUM-BUFFERS. - -(eval-when (compile eval) - -;;; BIGNUM-REPLACE -- Internal. -;;; -(defmacro bignum-replace (dest src &key (start1 '0) end1 (start2 '0) end2 - from-end) - (ext:once-only ((n-dest dest) - (n-src src)) - (let ((n-start1 (gensym)) - (n-end1 (gensym)) - (n-start2 (gensym)) - (n-end2 (gensym)) - (i1 (gensym)) - (i2 (gensym)) - (end1 (or end1 `(%bignum-length ,n-dest))) - (end2 (or end2 `(%bignum-length ,n-src)))) - (if from-end - `(let ((,n-start1 ,start1) - (,n-start2 ,start2)) - (do ((,i1 (1- ,end1) (1- ,i1)) - (,i2 (1- ,end2) (1- ,i2))) - ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2))) - (declare (fixnum ,i1 ,i2)) - (%bignum-set ,n-dest ,i1 - (%bignum-ref ,n-src ,i2)))) - `(let ((,n-end1 ,end1) - (,n-end2 ,end2)) - (do ((,i1 ,start1 (1+ ,i1)) - (,i2 ,start2 (1+ ,i2))) - ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2))) - (declare (type bignum-index ,i1 ,i2)) - (%bignum-set ,n-dest ,i1 - (%bignum-ref ,n-src ,i2)))))))) - - -;;; WITH-BIGNUM-BUFFERS -- Internal. -;;; -;;; Could do freelisting someday. -;;; -(defmacro with-bignum-buffers (specs &body body) - "WITH-BIGNUM-BUFFERS ({(var size [init])}*) Form*" - (ext:collect ((binds) - (inits)) - (dolist (spec specs) - (let ((name (first spec)) - (size (second spec))) - (binds `(,name (%allocate-bignum ,size))) - (let ((init (third spec))) - (when init - (inits `(bignum-replace ,name ,init)))))) - `(let* ,(binds) - ,@(inits) - ,@body))) - -) ;EVAL-WHEN - - - -;;;; GCD. - -(defun bignum-gcd (a b) - (declare (type bignum-type a b)) - (let* ((a (if (%bignum-0-or-plusp a (%bignum-length a)) - a - (negate-bignum a nil))) - (b (if (%bignum-0-or-plusp b (%bignum-length b)) - b - (negate-bignum b nil))) - (len-a (%bignum-length a)) - (len-b (%bignum-length b))) - (declare (type bignum-index len-a len-b)) - (with-bignum-buffers ((a-buffer len-a a) - (b-buffer len-b b) - (res-buffer (max len-a len-b))) - (let* ((factors-of-two - (bignum-factors-of-two a-buffer len-a - b-buffer len-b)) - (len-a (make-gcd-bignum-odd - a-buffer - (bignum-buffer-ashift-right a-buffer len-a - factors-of-two))) - (len-b (make-gcd-bignum-odd - b-buffer - (bignum-buffer-ashift-right b-buffer len-b - factors-of-two)))) - (declare (type bignum-index len-a len-b)) - (let ((x a-buffer) - (len-x len-a) - (y b-buffer) - (len-y len-b) - (z res-buffer)) - (loop - (multiple-value-bind - (u v len-v r len-r) - (bignum-gcd-order-and-subtract x len-x y len-y z) - (declare (type bignum-index len-v len-r)) - (when (and (= len-r 1) (zerop (%bignum-ref r 0))) - (if (zerop factors-of-two) - (let ((ret (%allocate-bignum len-v))) - (dotimes (i len-v) - (setf (%bignum-ref ret i) (%bignum-ref v i))) - (return (%normalize-bignum ret len-v))) - (return (bignum-ashift-left v factors-of-two len-v)))) - (setf x v len-x len-v) - (setf y r len-y (make-gcd-bignum-odd r len-r)) - (setf z u)))))))) - - -(defun bignum-gcd-order-and-subtract (a len-a b len-b res) - (declare (type bignum-index len-a len-b) (type bignum-type a b)) - (cond ((= len-a len-b) - (do ((i (1- len-a) (1- i))) - ((= i -1) - (setf (%bignum-ref res 0) 0) - (values a b len-b res 1)) - (let ((a-digit (%bignum-ref a i)) - (b-digit (%bignum-ref b i))) - (cond ((%digit-compare a-digit b-digit)) - ((%digit-greater a-digit b-digit) - (return - (values a b len-b res - (subtract-bignum-buffers a len-a b len-b res)))) - (t - (return - (values b a len-a res - (subtract-bignum-buffers b len-b a len-a res)))))))) - ((> len-a len-b) - (values a b len-b res - (subtract-bignum-buffers a len-a b len-b res))) - (t - (values b a len-a res - (subtract-bignum-buffers b len-b a len-a res))))) - -(defun make-gcd-bignum-odd (a len-a) - (declare (type bignum-type a) (type bignum-index len-a)) - (dotimes (index len-a) - (declare (type bignum-index index)) - (do ((digit (%bignum-ref a index) (%ashr digit 1)) - (increment 0 (1+ increment))) - ((zerop digit)) - (declare (type (mod 32) increment)) - (when (oddp digit) - (return-from make-gcd-bignum-odd - (bignum-buffer-ashift-right a len-a - (+ (* index digit-size) - increment))))))) - -(defun bignum-factors-of-two (a len-a b len-b) - (declare (type bignum-index len-a len-b) (type bignum-type a)) - (do ((i 0 (1+ i)) - (end (min len-a len-b))) - ((= i end) (error "Unexpected zero bignums?")) - (declare (type bignum-index i end)) - (let ((or-digits (%logior (%bignum-ref a i) (%bignum-ref b i)))) - (unless (zerop or-digits) - (return (do ((j 0 (1+ j)) - (or-digits or-digits (%ashr or-digits 1))) - ((oddp or-digits) (+ (* i digit-size) j)) - (declare (type (mod 32) j)))))))) - - -;;;; Negation - -(eval-when (compile eval) - -;;; BIGNUM-NEGATE-LOOP -- Internal. -;;; -;;; This negates bignum-len digits of bignum, storing the resulting digits into -;;; result (possibly EQ to bignum) and returning whatever end-carry there is. -;;; -(defmacro bignum-negate-loop (bignum bignum-len &optional (result nil resultp)) - (let ((carry (gensym)) - (end (gensym)) - (value (gensym)) - (last (gensym))) - `(let* (,@(if (not resultp) `(,last)) - (,carry - (multiple-value-bind (,value ,carry) - (%add-with-carry - (%lognot (%bignum-ref ,bignum 0)) 1 0) - ,(if resultp - `(setf (%bignum-ref ,result 0) ,value) - `(setf ,last ,value)) - ,carry)) - (i 1) - (,end ,bignum-len)) - (declare (type bit ,carry) - (type bignum-index i ,end)) - (loop - (when (= i ,end) (return)) - (multiple-value-bind (,value temp) - (%add-with-carry - (%lognot (%bignum-ref ,bignum i)) 0 ,carry) - ,(if resultp - `(setf (%bignum-ref ,result i) ,value) - `(setf ,last ,value)) - (setf ,carry temp)) - (incf i)) - ,(if resultp carry `(values ,carry ,last))))) - -) ;EVAL-WHEN - -;;; NEGATE-BIGNUM -- Public. -;;; -;;; Fully-normalize is an internal optional. It cause this to always return -;;; a bignum, without any extraneous digits, and it never returns a fixnum. -;;; -(defun negate-bignum (x &optional (fully-normalize t)) - (declare (type bignum-type x)) - (let* ((len-x (%bignum-length x)) - (len-res (1+ len-x)) - (res (%allocate-bignum len-res))) - (declare (type bignum-index len-x len-res)) ;Test len-res for range? - (let ((carry (bignum-negate-loop x len-x res))) - (setf (%bignum-ref res len-x) - (%add-with-carry (%lognot (%sign-digit x len-x)) 0 carry))) - (if fully-normalize - (%normalize-bignum res len-res) - (%mostly-normalize-bignum res len-res)))) - -;;; NEGATE-BIGNUM-IN-PLACE -- Internal. -;;; -;;; This assumes bignum is positive; that is, the result of negating it will -;;; stay in the provided allocated bignum. -;;; -(defun negate-bignum-in-place (bignum) - (bignum-negate-loop bignum (%bignum-length bignum) bignum) - bignum) - - - -;;;; Shifting. - -(defconstant all-ones-digit #xFFFFFFFF) - -(eval-when (compile eval) - -;;; SHIFT-RIGHT-UNALIGNED -- Internal. -;;; -;;; This macro is used by BIGNUM-ASHIFT-RIGHT, BIGNUM-BUFFER-ASHIFT-RIGHT, and -;;; BIGNUM-LDB-BIGNUM-RES. They supply a termination form that references -;;; locals established by this form. Source is the source bignum. Start-digit -;;; is the first digit in source from which we pull bits. Start-pos is the -;;; first bit we want. Res-len-form is the form that computes the length of -;;; the resulting bignum. Termination is a DO termination form with a test and -;;; body. When result is supplied, it is the variable to which this binds a -;;; newly allocated bignum. -;;; -;;; Given start-pos, 1-31 inclusively, of shift, we form the j'th resulting -;;; digit from high bits of the i'th source digit and the start-pos number of -;;; bits from the i+1'th source digit. -;;; -(defmacro shift-right-unaligned (source start-digit start-pos res-len-form - termination - &optional result) - `(let* ((high-bits-in-first-digit (- digit-size ,start-pos)) - (res-len ,res-len-form) - (res-len-1 (1- res-len)) - ,@(if result `((,result (%allocate-bignum res-len))))) - (declare (type bignum-index res-len res-len-1)) - (do ((i ,start-digit i+1) - (i+1 (1+ ,start-digit) (1+ i+1)) - (j 0 (1+ j))) - ,termination - (declare (type bignum-index i i+1 j)) - (setf (%bignum-ref ,(if result result source) j) - (%logior (%digit-logical-shift-right (%bignum-ref ,source i) - ,start-pos) - (%ashl (%bignum-ref ,source i+1) - high-bits-in-first-digit)))))) - -) ;EVAL-WHEN - - -;;; BIGNUM-ASHIFT-RIGHT -- Public. -;;; -;;; First compute the number of whole digits to shift, shifting them by -;;; skipping them when we start to pick up bits, and the number of bits to -;;; shift the remaining digits into place. If the number of digits is greater -;;; than the length of the bignum, then the result is either 0 or -1. If we -;;; shift on a digit boundary (that is, n-bits is zero), then we just copy -;;; digits. The last branch handles the general case which uses a macro that a -;;; couple other routines use. The fifth argument to the macro references -;;; locals established by the macro. -;;; -(defun bignum-ashift-right (bignum x) - (declare (type bignum-type bignum) - (fixnum x)) - (let ((bignum-len (%bignum-length bignum))) - (declare (type bignum-index bignum-len)) - (multiple-value-bind (digits n-bits) - (truncate x digit-size) - (declare (type bignum-index digits)) - (cond - ((>= digits bignum-len) - (if (%bignum-0-or-plusp bignum bignum-len) 0 -1)) - ((zerop n-bits) - (bignum-ashift-right-digits bignum digits)) - (t - (shift-right-unaligned bignum digits n-bits (- bignum-len digits) - ((= j res-len-1) - (setf (%bignum-ref res j) - (%ashr (%bignum-ref bignum i) n-bits)) - (%normalize-bignum res res-len)) - res)))))) - -;;; BIGNUM-ASHIFT-RIGHT-DIGITS -- Internal. -;;; -(defun bignum-ashift-right-digits (bignum digits) - (declare (type bignum-type bignum) - (type bignum-index digits)) - (let* ((res-len (- (%bignum-length bignum) digits)) - (res (%allocate-bignum res-len))) - (declare (type bignum-index res-len) - (type bignum-type res)) - (bignum-replace res bignum :start2 digits) - (%normalize-bignum res res-len))) - - -;;; BIGNUM-BUFFER-ASHIFT-RIGHT -- Internal. -;;; -;;; GCD uses this for an in-place shifting operation. This is different enough -;;; from BIGNUM-ASHIFT-RIGHT that it isn't worth folding the bodies into a -;;; macro, but they share the basic algorithm. This routine foregoes a first -;;; test for digits being greater than or equal to bignum-len since that will -;;; never happen for its uses in GCD. We did fold the last branch into a macro -;;; since it was duplicated a few times, and the fifth argument to it -;;; references locals established by the macro. -;;; -(defun bignum-buffer-ashift-right (bignum bignum-len x) - (declare (type bignum-index bignum-len) (fixnum x)) - (multiple-value-bind (digits n-bits) - (truncate x digit-size) - (declare (type bignum-index digits)) - (cond - ((zerop n-bits) - (let ((new-end (- bignum-len digits))) - (bignum-replace bignum bignum :end1 new-end :start2 digits - :end2 bignum-len) - (%normalize-bignum-buffer bignum new-end))) - (t - (shift-right-unaligned bignum digits n-bits (- bignum-len digits) - ((= j res-len-1) - (setf (%bignum-ref bignum j) - (%ashr (%bignum-ref bignum i) n-bits)) - (%normalize-bignum-buffer bignum res-len))))))) - - - -;;; BIGNUM-ASHIFT-LEFT -- Public. -;;; -;;; This handles shifting a bignum buffer to provide fresh bignum data for some -;;; internal routines. We know bignum is safe when called with bignum-len. -;;; First we compute the number of whole digits to shift, shifting them -;;; starting to store farther along the result bignum. If we shift on a digit -;;; boundary (that is, n-bits is zero), then we just copy digits. The last -;;; branch handles the general case. -;;; -(defun bignum-ashift-left (bignum x &optional bignum-len) - (declare (type bignum-type bignum) - (fixnum x) - (type (or null bignum-index) bignum-len)) - (multiple-value-bind (digits n-bits) - (truncate x digit-size) - (let* ((bignum-len (or bignum-len (%bignum-length bignum))) - (res-len (+ digits bignum-len 1))) - (when (> res-len maximum-bignum-length) - (error "Can't represent result of left shift.")) - (if (zerop n-bits) - (bignum-ashift-left-digits bignum bignum-len digits) - (bignum-ashift-left-unaligned bignum digits n-bits res-len))))) - -;;; BIGNUM-ASHIFT-LEFT-DIGITS -- Internal. -;;; -(defun bignum-ashift-left-digits (bignum bignum-len digits) - (declare (type bignum-index bignum-len digits)) - (let* ((res-len (+ bignum-len digits)) - (res (%allocate-bignum res-len))) - (declare (type bignum-index res-len)) - (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len - :from-end t) - res)) - -;;; BIGNUM-ASHIFT-LEFT-UNALIGNED -- Internal. -;;; -;;; BIGNUM-TRUNCATE uses this to store into a bignum buffer by supplying res. -;;; When res comes in non-nil, then this foregoes allocating a result, and it -;;; normalizes the buffer instead of the would-be allocated result. -;;; -;;; We start storing into one digit higher than digits, storing a whole result -;;; digit from parts of two contiguous digits from bignum. When the loop -;;; finishes, we store the remaining bits from bignum's first digit in the -;;; first non-zero result digit, digits. We also grab some left over high -;;; bits from the last digit of bignum. -;;; -(defun bignum-ashift-left-unaligned (bignum digits n-bits res-len - &optional (res nil resp)) - (declare (type bignum-index digits res-len) - (type (mod #.digit-size) n-bits)) - (let* ((remaining-bits (- digit-size n-bits)) - (res-len-1 (1- res-len)) - (res (or res (%allocate-bignum res-len)))) - (declare (type bignum-index res-len res-len-1)) - (do ((i 0 i+1) - (i+1 1 (1+ i+1)) - (j (1+ digits) (1+ j))) - ((= j res-len-1) - (setf (%bignum-ref res digits) - (%ashl (%bignum-ref bignum 0) n-bits)) - (setf (%bignum-ref res j) - (%ashr (%bignum-ref bignum i) remaining-bits)) - (if resp - (%normalize-bignum-buffer res res-len) - (%normalize-bignum res res-len))) - (declare (type bignum-index i i+1 j)) - (setf (%bignum-ref res j) - (%logior (%digit-logical-shift-right (%bignum-ref bignum i) - remaining-bits) - (%ashl (%bignum-ref bignum i+1) n-bits)))))) - - -;;;; Relational operators. - -;;; BIGNUM-PLUS-P -- Public. -;;; -;;; Return T iff bignum is positive. -;;; -(defun bignum-plus-p (bignum) - (declare (type bignum-type bignum)) - (%bignum-0-or-plusp bignum (%bignum-length bignum))) - -;;; BIGNUM-COMPARE -- Public. -;;; -;;; This compares two bignums returning -1, 0, or 1, depending on whether a -;;; is less than, equal to, or greater than b. -;;; -(proclaim '(function bignum-compare (bignum bignum) (integer -1 1))) -(defun bignum-compare (a b) - (declare (type bignum-type a b)) - (let* ((len-a (%bignum-length a)) - (len-b (%bignum-length b)) - (a-plusp (%bignum-0-or-plusp a len-a)) - (b-plusp (%bignum-0-or-plusp b len-b))) - (declare (type bignum-index len-a len-b)) - (cond ((not (eq a-plusp b-plusp)) - (if a-plusp 1 -1)) - ((= len-a len-b) - (do ((i (1- len-a) (1- i))) - (()) - (declare (type bignum-index i)) - (let ((a-digit (%bignum-ref a i)) - (b-digit (%bignum-ref b i))) - (declare (type bignum-element-type a-digit b-digit)) - (when (%digit-greater a-digit b-digit) - (return 1)) - (when (%digit-greater b-digit a-digit) - (return -1))) - (when (zerop i) (return 0)))) - ((> len-a len-b) - (if a-plusp 1 -1)) - (t (if a-plusp -1 1))))) - - -;;;; Float conversion. - -;;; FLOAT-BIGNUM-RATIO -- Internal -;;; -;;; Given a Ratio with arbitrarily large numerator and denominator, convert -;;; it to a float in the specified Format without causing spurious floating -;;; overflows. What we do is discard all of the numerator and denominator -;;; except for the format's precision + guard bits. We float these -;;; integers, do the floating division, and then scaled the result accordingly. -;;; -;;; The use of digit-size as the number of guard bits is relatively -;;; arbitrary. We want to keep around some extra bits so that we rarely do -;;; round-to-even when there were low bits that could have caused us to round -;;; up. We really only need to discard enough bits to ensure that floating the -;;; result doesn't overflow. -;;; -(defun float-bignum-ratio (ratio format) - (declare (optimize (ext:inhibit-warnings 3))) - (let* ((bits-to-keep (+ (float-format-digits format) digit-size)) - (num (numerator ratio)) - (num-len (integer-length num)) - (num-shift (min (- bits-to-keep num-len) 0)) - (den (denominator ratio)) - (den-len (integer-length den)) - (den-shift (min (- bits-to-keep den-len) 0))) - (multiple-value-bind - (decoded exp sign) - (decode-float (/ (coerce (ash num num-shift) format) - (coerce (ash den den-shift) format))) - (* sign (scale-float decoded (+ exp (- num-shift) den-shift)))))) - - -;;; xxx-FLOAT-FROM-BITS -- Internal -;;; -;;; Make a single or double float with the specified significand, exponent -;;; and sign. -;;; -(defun single-float-from-bits (bits exp plusp) - (declare (fixnum exp)) - (declare (optimize (ext:inhibit-warnings 3))) - (let ((res (dpb exp - vm:single-float-exponent-byte - (logandc2 (ext:truly-the (unsigned-byte 31) - (%bignum-ref bits 1)) - vm:single-float-hidden-bit)))) - (make-single-float - (if plusp - res - (logior res (ash -1 vm:float-sign-shift)))))) -;;; -(defun double-float-from-bits (bits exp plusp) - (declare (fixnum exp)) - (declare (optimize (ext:inhibit-warnings 3))) - (let ((hi (dpb exp - vm:double-float-exponent-byte - (logandc2 (ext:truly-the (unsigned-byte 31) - (%bignum-ref bits 2)) - vm:double-float-hidden-bit)))) - (make-double-float - (if plusp - hi - (logior hi (ash -1 vm:float-sign-shift))) - (%bignum-ref bits 1)))) - - -;;; BIGNUM-TO-FLOAT -- Interface -;;; -;;; Convert Bignum to a float in the specified Format, rounding to the best -;;; approximation. -;;; -(defun bignum-to-float (bignum format) - (let* ((plusp (bignum-plus-p bignum)) - (x (if plusp bignum (negate-bignum bignum))) - (len (bignum-integer-length x)) - (digits (float-format-digits format)) - (keep (+ digits digit-size)) - (shift (- keep len)) - (shifted (if (minusp shift) - (bignum-ashift-right x (- shift)) - (bignum-ashift-left x shift))) - (low (%bignum-ref shifted 0)) - (round-bit (ash 1 (1- digit-size)))) - (declare (type bignum-index len digits keep) (fixnum shift)) - (labels ((round-up () - (let ((rounded (add-bignums shifted round-bit))) - (if (> (integer-length rounded) keep) - (float-from-bits (bignum-ashift-right rounded 1) - (1+ len)) - (float-from-bits rounded len)))) - (float-from-bits (bits len) - (declare (type bignum-index len)) - (ecase format - (single-float - (single-float-from-bits - bits - (check-exponent len vm:single-float-bias - vm:single-float-normal-exponent-max) - plusp)) - (double-float - (double-float-from-bits - bits - (check-exponent len vm:double-float-bias - vm:double-float-normal-exponent-max) - plusp)))) - (check-exponent (exp bias max) - (declare (type bignum-index len)) - (let ((exp (+ exp bias))) - (when (> exp max) - (error "Too large to be represented as a ~S:~% ~S" - format x)) - exp))) - - (cond - ;; - ;; Round down if round bit is 0. - ((zerop (logand round-bit low)) - (float-from-bits shifted len)) - ;; - ;; If only round bit is set, then round to even. - ((and (= low round-bit) - (dotimes (i (- (%bignum-length x) (ceiling keep digit-size)) - t) - (unless (zerop (%bignum-ref x i)) (return nil)))) - (let ((next (%bignum-ref shifted 1))) - (if (oddp next) - (round-up) - (float-from-bits shifted len)))) - ;; - ;; Otherwise, round up. - (t - (round-up)))))) - - -;;;; Integer length and logcount - -(defun bignum-integer-length (bignum) - (declare (type bignum-type bignum)) - (let* ((len (%bignum-length bignum)) - (len-1 (1- len)) - (digit (%bignum-ref bignum len-1))) - (declare (type bignum-index len len-1) - (type bignum-element-type digit)) - (+ (integer-length (%fixnum-digit-with-correct-sign digit)) - (* len-1 digit-size)))) - -(defun bignum-logcount (bignum) - (declare (type bignum-type bignum)) - (let* ((length (%bignum-length bignum)) - (plusp (%bignum-0-or-plusp bignum length)) - (result 0)) - (declare (type bignum-index length) - (fixnum result)) - (do ((index 0 (1+ index))) - ((= index length) result) - (let ((digit (%bignum-ref bignum index))) - (declare (type bignum-element-type digit)) - (incf result (logcount (if plusp digit (%lognot digit)))))))) - - -;;;; Logical operations. - -;;; NOT. -;;; - -;;; BIGNUM-LOGICAL-NOT -- Public. -;;; -(defun bignum-logical-not (a) - (declare (type bignum-type a)) - (let* ((len (%bignum-length a)) - (res (%allocate-bignum len))) - (declare (type bignum-index len)) - (dotimes (i len res) - (declare (type bignum-index i)) - (setf (%bignum-ref res i) (%lognot (%bignum-ref a i)))))) - - -;;; AND. -;;; - -;;; BIGNUM-LOGICAL-AND -- Public. -;;; -(defun bignum-logical-and (a b) - (declare (type bignum-type a b)) - (let* ((len-a (%bignum-length a)) - (len-b (%bignum-length b)) - (a-plusp (%bignum-0-or-plusp a len-a)) - (b-plusp (%bignum-0-or-plusp b len-b))) - (declare (type bignum-index len-a len-b)) - (cond - ((< len-a len-b) - (if a-plusp - (logand-shorter-positive a len-a b (%allocate-bignum len-a)) - (logand-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) - ((< len-b len-a) - (if b-plusp - (logand-shorter-positive b len-b a (%allocate-bignum len-b)) - (logand-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) - (t (logand-shorter-positive a len-a b (%allocate-bignum len-a)))))) - -;;; LOGAND-SHORTER-POSITIVE -- Internal. -;;; -;;; This takes a shorter bignum, a and len-a, that is positive. Because this -;;; is AND, we don't care about any bits longer than a's since its infinite 0 -;;; sign bits will mask the other bits out of b. The result is len-a big. -;;; -(defun logand-shorter-positive (a len-a b res) - (declare (type bignum-type a b res) - (type bignum-index len-a)) - (dotimes (i len-a) - (declare (type bignum-index i)) - (setf (%bignum-ref res i) - (%logand (%bignum-ref a i) (%bignum-ref b i)))) - (%normalize-bignum res len-a)) - -;;; LOGAND-SHORTER-NEGATIVE -- Internal. -;;; -;;; This takes a shorter bignum, a and len-a, that is negative. Because this -;;; is AND, we just copy any bits longer than a's since its infinite 1 sign -;;; bits will include any bits from b. The result is len-b big. -;;; -(defun logand-shorter-negative (a len-a b len-b res) - (declare (type bignum-type a b res) - (type bignum-index len-a len-b)) - (dotimes (i len-a) - (declare (type bignum-index i)) - (setf (%bignum-ref res i) - (%logand (%bignum-ref a i) (%bignum-ref b i)))) - (do ((i len-a (1+ i))) - ((= i len-b)) - (declare (type bignum-index i)) - (setf (%bignum-ref res i) (%bignum-ref b i))) - (%normalize-bignum res len-b)) - -;;; IOR. -;;; - -;;; BIGNUM-LOGICAL-IOR -- Public. -;;; -(defun bignum-logical-ior (a b) - (declare (type bignum-type a b)) - (let* ((len-a (%bignum-length a)) - (len-b (%bignum-length b)) - (a-plusp (%bignum-0-or-plusp a len-a)) - (b-plusp (%bignum-0-or-plusp b len-b))) - (declare (type bignum-index len-a len-b)) - (cond - ((< len-a len-b) - (if a-plusp - (logior-shorter-positive a len-a b len-b (%allocate-bignum len-b)) - (logior-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) - ((< len-b len-a) - (if b-plusp - (logior-shorter-positive b len-b a len-a (%allocate-bignum len-a)) - (logior-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) - (t (logior-shorter-positive a len-a b len-b (%allocate-bignum len-a)))))) - -;;; LOGIOR-SHORTER-POSITIVE -- Internal. -;;; -;;; This takes a shorter bignum, a and len-a, that is positive. Because this -;;; is IOR, we don't care about any bits longer than a's since its infinite -;;; 0 sign bits will mask the other bits out of b out to len-b. The result -;;; is len-b long. -;;; -(defun logior-shorter-positive (a len-a b len-b res) - (declare (type bignum-type a b res) - (type bignum-index len-a len-b)) - (dotimes (i len-a) - (declare (type bignum-index i)) - (setf (%bignum-ref res i) - (%logior (%bignum-ref a i) (%bignum-ref b i)))) - (do ((i len-a (1+ i))) - ((= i len-b)) - (declare (type bignum-index i)) - (setf (%bignum-ref res i) (%bignum-ref b i))) - (%normalize-bignum res len-b)) - -;;; LOGIOR-SHORTER-NEGATIVE -- Internal. -;;; -;;; This takes a shorter bignum, a and len-a, that is negative. Because this -;;; is IOR, we just copy any bits longer than a's since its infinite 1 sign -;;; bits will include any bits from b. The result is len-b long. -;;; -(defun logior-shorter-negative (a len-a b len-b res) - (declare (type bignum-type a b res) - (type bignum-index len-a len-b)) - (dotimes (i len-a) - (declare (type bignum-index i)) - (setf (%bignum-ref res i) - (%logior (%bignum-ref a i) (%bignum-ref b i)))) - (do ((i len-a (1+ i)) - (sign (%sign-digit a len-a))) - ((= i len-b)) - (declare (type bignum-index i)) - (setf (%bignum-ref res i) sign)) - (%normalize-bignum res len-b)) - -;;; XOR. -;;; - -;;; BIGNUM-LOGICAL-XOR -- Public. -;;; -(defun bignum-logical-xor (a b) - (declare (type bignum-type a b)) - (let ((len-a (%bignum-length a)) - (len-b (%bignum-length b))) - (declare (type bignum-index len-a len-b)) - (if (< len-a len-b) - (bignum-logical-xor-aux a len-a b len-b (%allocate-bignum len-b)) - (bignum-logical-xor-aux b len-b a len-a (%allocate-bignum len-a))))) - -;;; BIGNUM-LOGICAL-XOR-AUX -- Internal. -;;; -;;; This takes the the shorter of two bignums in a and len-a. Res is len-b -;;; long. Do the XOR. -;;; -(defun bignum-logical-xor-aux (a len-a b len-b res) - (declare (type bignum-type a b res) - (type bignum-index len-a len-b)) - (dotimes (i len-a) - (declare (type bignum-index i)) - (setf (%bignum-ref res i) - (%logxor (%bignum-ref a i) (%bignum-ref b i)))) - (do ((i len-a (1+ i)) - (sign (%sign-digit a len-a))) - ((= i len-b)) - (declare (type bignum-index i)) - (setf (%bignum-ref res i) (%logxor sign (%bignum-ref b i)))) - (%normalize-bignum res len-b)) - - - -;;;; LDB (load byte) - -#| -FOR NOW WE DON'T USE LDB OR DPB. WE USE SHIFTS AND MASKS IN NUMBERS.LISP WHICH -IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! - - -(defconstant maximum-fixnum-bits #+ibm-rt-pc 27 #-ibm-rt-pc 30) - -;;; BIGNUM-LOAD-BYTE -- Public. -;;; -(defun bignum-load-byte (byte bignum) - (declare (type bignum-type bignum)) - (let ((byte-len (byte-size byte)) - (byte-pos (byte-position byte))) - (if (< byte-len maximum-fixnum-bits) - (bignum-ldb-fixnum-res bignum byte-len byte-pos) - (bignum-ldb-bignum-res bignum byte-len byte-pos)))) - -;;; BIGNUM-LDB-FIXNUM-RES -- Internal. -;;; -;;; This returns a fixnum result of loading a byte from a bignum. In order, we -;;; check for the following conditions: -;;; Insufficient bignum digits to start loading a byte -- -;;; Return 0 or byte-len 1's depending on sign of bignum. -;;; One bignum digit containing the whole byte spec -- -;;; Grab 'em, shift 'em, and mask out what we don't want. -;;; Insufficient bignum digits to cover crossing a digit boundary -- -;;; Grab the available bits in the last digit, and or in whatever -;;; virtual sign bits we need to return a full byte spec. -;;; Else (we cross a digit boundary with all bits available) -- -;;; Make a couple masks, grab what we want, shift it around, and -;;; LOGIOR it all together. -;;; Because (< maximum-fixnum-bits digit-size) and -;;; (< byte-len maximum-fixnum-bits), -;;; we only cross one digit boundary if any. -;;; -(defun bignum-ldb-fixnum-res (bignum byte-len byte-pos) - (multiple-value-bind (skipped-digits pos) - (truncate byte-pos digit-size) - (let ((bignum-len (%bignum-length bignum)) - (s-digits+1 (1+ skipped-digits))) - (declare (type bignum-index bignum-len s-digits+1)) - (if (>= skipped-digits bignum-len) - (if (%bignum-0-or-plusp bignum bignum-len) - 0 - (%make-ones byte-len)) - (let ((end (+ pos byte-len))) - (cond ((<= end digit-size) - (logand (ash (%bignum-ref bignum skipped-digits) (- pos)) - ;; Must LOGAND after shift here. - (%make-ones byte-len))) - ((>= s-digits+1 bignum-len) - (let* ((available-bits (- digit-size pos)) - (res (logand (ash (%bignum-ref bignum skipped-digits) - (- pos)) - ;; LOGAND should be unnecessary here - ;; with a logical right shift or a - ;; correct unsigned-byte-32 one. - (%make-ones available-bits)))) - (if (%bignum-0-or-plusp bignum bignum-len) - res - (logior (%ashl (%make-ones (- end digit-size)) - available-bits) - res)))) - (t - (let* ((high-bits-in-first-digit (- digit-size pos)) - (high-mask (%make-ones high-bits-in-first-digit)) - (low-bits-in-next-digit (- end digit-size)) - (low-mask (%make-ones low-bits-in-next-digit))) - (declare (type bignum-element-type high-mask low-mask)) - (logior (%ashl (logand (%bignum-ref bignum s-digits+1) - low-mask) - high-bits-in-first-digit) - (logand (ash (%bignum-ref bignum skipped-digits) - (- pos)) - ;; LOGAND should be unnecessary here with - ;; a logical right shift or a correct - ;; unsigned-byte-32 one. - high-mask)))))))))) - -;;; BIGNUM-LDB-BIGNUM-RES -- Internal. -;;; -;;; This returns a bignum result of loading a byte from a bignum. In order, we -;;; check for the following conditions: -;;; Insufficient bignum digits to start loading a byte -- -;;; Byte-pos starting on a digit boundary -- -;;; Byte spec contained in one bignum digit -- -;;; Grab the bits we want and stick them in a single digit result. -;;; Since we know byte-pos is non-zero here, we know our single digit -;;; will have a zero high sign bit. -;;; Else (unaligned multiple digits) -- -;;; This is like doing a shift right combined with either masking -;;; out unwanted high bits from bignum or filling in virtual sign -;;; bits if bignum had insufficient bits. We use SHIFT-RIGHT-ALIGNED -;;; and reference lots of local variables this macro establishes. -;;; -(defun bignum-ldb-bignum-res (bignum byte-len byte-pos) - (multiple-value-bind (skipped-digits pos) - (truncate byte-pos digit-size) - (let ((bignum-len (%bignum-length bignum))) - (declare (type bignum-index bignum-len)) - (cond - ((>= skipped-digits bignum-len) - (make-bignum-virtual-ldb-bits bignum bignum-len byte-len)) - ((zerop pos) - (make-aligned-ldb-bignum bignum bignum-len byte-len skipped-digits)) - ((< (+ pos byte-len) digit-size) - (let ((res (%allocate-bignum 1))) - (setf (%bignum-ref res 0) - (logand (%ashr (%bignum-ref bignum skipped-digits) pos) - (%make-ones byte-len))) - res)) - (t - (make-unaligned-ldb-bignum bignum bignum-len - byte-len skipped-digits pos)))))) - -;;; MAKE-BIGNUM-VIRTUAL-LDB-BITS -- Internal. -;;; -;;; This returns bits from bignum that don't physically exist. These are -;;; all zero or one depending on the sign of the bignum. -;;; -(defun make-bignum-virtual-ldb-bits (bignum bignum-len byte-len) - (if (%bignum-0-or-plusp bignum bignum-len) - 0 - (multiple-value-bind (res-len-1 extra) - (truncate byte-len digit-size) - (declare (type bignum-index res-len-1)) - (let* ((res-len (1+ res-len-1)) - (res (%allocate-bignum res-len))) - (declare (type bignum-index res-len)) - (do ((j 0 (1+ j))) - ((= j res-len-1) - (setf (%bignum-ref res j) (%make-ones extra)) - (%normalize-bignum res res-len)) - (declare (type bignum-index j)) - (setf (%bignum-ref res j) all-ones-digit)))))) - -;;; MAKE-ALIGNED-LDB-BIGNUM -- Internal. -;;; -;;; Since we are picking up aligned digits, we just copy the whole digits -;;; we want and fill in extra bits. We might have a byte-len that extends -;;; off the end of the bignum, so we may have to fill in extra 1's if the -;;; bignum is negative. -;;; -(defun make-aligned-ldb-bignum (bignum bignum-len byte-len skipped-digits) - (multiple-value-bind (res-len-1 extra) - (truncate byte-len digit-size) - (declare (type bignum-index res-len-1)) - (let* ((res-len (1+ res-len-1)) - (res (%allocate-bignum res-len))) - (declare (type bignum-index res-len)) - (do ((i skipped-digits (1+ i)) - (j 0 (1+ j))) - ((or (= j res-len-1) (= i bignum-len)) - (cond ((< i bignum-len) - (setf (%bignum-ref res j) - (logand (%bignum-ref bignum i) - (the bignum-element-type (%make-ones extra))))) - ((%bignum-0-or-plusp bignum bignum-len)) - (t - (do ((j j (1+ j))) - ((= j res-len-1) - (setf (%bignum-ref res j) (%make-ones extra))) - (setf (%bignum-ref res j) all-ones-digit)))) - (%normalize-bignum res res-len)) - (declare (type bignum-index i j)) - (setf (%bignum-ref res j) (%bignum-ref bignum i)))))) - -;;; MAKE-UNALIGNED-LDB-BIGNUM -- Internal. -;;; -;;; This grabs unaligned bignum bits from bignum assuming byte-len causes at -;;; least one digit boundary crossing. We use SHIFT-RIGHT-UNALIGNED referencing -;;; lots of local variables established by it. -;;; -(defun make-unaligned-ldb-bignum (bignum bignum-len byte-len skipped-digits pos) - (multiple-value-bind (res-len-1 extra) - (truncate byte-len digit-size) - (shift-right-unaligned - bignum skipped-digits pos (1+ res-len-1) - ((or (= j res-len-1) (= i+1 bignum-len)) - (cond ((= j res-len-1) - (cond - ((< extra high-bits-in-first-digit) - (setf (%bignum-ref res j) - (logand (ash (%bignum-ref bignum i) minus-start-pos) - ;; Must LOGAND after shift here. - (%make-ones extra)))) - (t - (setf (%bignum-ref res j) - (logand (ash (%bignum-ref bignum i) minus-start-pos) - ;; LOGAND should be unnecessary here with a logical - ;; right shift or a correct unsigned-byte-32 one. - high-mask)) - (when (%bignum-0-or-plusp bignum bignum-len) - (setf (%bignum-ref res j) - (logior (%bignum-ref res j) - (%ashl (%make-ones - (- extra high-bits-in-first-digit)) - high-bits-in-first-digit))))))) - (t - (setf (%bignum-ref res j) - (logand (ash (%bignum-ref bignum i) minus-start-pos) - ;; LOGAND should be unnecessary here with a logical - ;; right shift or a correct unsigned-byte-32 one. - high-mask)) - (unless (%bignum-0-or-plusp bignum bignum-len) - ;; Fill in upper half of this result digit with 1's. - (setf (%bignum-ref res j) - (logior (%bignum-ref res j) - (%ashl low-mask high-bits-in-first-digit))) - ;; Fill in any extra 1's we need to be byte-len long. - (do ((j (1+ j) (1+ j))) - ((>= j res-len-1) - (setf (%bignum-ref res j) (%make-ones extra))) - (setf (%bignum-ref res j) all-ones-digit))))) - (%normalize-bignum res res-len)) - res))) - - - -;;;; DPB (deposit byte). - -(defun bignum-deposit-byte (new-byte byte-spec bignum) - (declare (type bignum-type bignum)) - (let* ((byte-len (byte-size byte-spec)) - (byte-pos (byte-position byte-spec)) - (bignum-len (%bignum-length bignum)) - (bignum-plusp (%bignum-0-or-plusp bignum bignum-len)) - (byte-end (+ byte-pos byte-len)) - (res-len (1+ (max (ceiling byte-end digit-size) bignum-len))) - (res (%allocate-bignum res-len))) - (declare (type bignum-index bignum-len res-len)) - ;; - ;; Fill in an extra sign digit in case we set what would otherwise be the - ;; last digit's last bit. Normalize at the end in case this was - ;; unnecessary. - (unless bignum-plusp - (setf (%bignum-ref res (1- res-len)) all-ones-digit)) - (multiple-value-bind (end-digit end-bits) - (truncate byte-end digit-size) - (declare (type bignum-index end-digit)) - ;; - ;; Fill in bits from bignum up to byte-pos. - (multiple-value-bind (pos-digit pos-bits) - (truncate byte-pos digit-size) - (declare (type bignum-index pos-digit)) - (do ((i 0 (1+ i)) - (end (min pos-digit bignum-len))) - ((= i end) - (cond ((< i bignum-len) - (unless (zerop pos-bits) - (setf (%bignum-ref res i) - (logand (%bignum-ref bignum i) - (%make-ones pos-bits))))) - (bignum-plusp) - (t - (do ((i i (1+ i))) - ((= i pos-digit) - (unless (zerop pos-bits) - (setf (%bignum-ref res i) (%make-ones pos-bits)))) - (setf (%bignum-ref res i) all-ones-digit))))) - (setf (%bignum-ref res i) (%bignum-ref bignum i))) - ;; - ;; Fill in bits from new-byte. - (if (typep new-byte 'fixnum) - (deposit-fixnum-bits new-byte byte-len pos-digit pos-bits - end-digit end-bits res) - (deposit-bignum-bits new-byte byte-len pos-digit pos-bits - end-digit end-bits res))) - ;; - ;; Fill in remaining bits from bignum after byte-spec. - (when (< end-digit bignum-len) - (setf (%bignum-ref res end-digit) - (logior (logand (%bignum-ref bignum end-digit) - (%ashl (%make-ones (- digit-size end-bits)) - end-bits)) - ;; DEPOSIT-FIXNUM-BITS and DEPOSIT-BIGNUM-BITS only store - ;; bits from new-byte into res's end-digit element, so - ;; we don't need to mask out unwanted high bits. - (%bignum-ref res end-digit))) - (do ((i (1+ end-digit) (1+ i))) - ((= i bignum-len)) - (setf (%bignum-ref res i) (%bignum-ref bignum i))))) - (%normalize-bignum res res-len))) - -;;; DEPOSIT-FIXNUM-BITS -- Internal. -;;; -;;; This starts at result's pos-digit skipping pos-bits, and it stores bits -;;; from new-byte, a fixnum, into result. It effectively stores byte-len -;;; number of bits, but never stores past end-digit and end-bits in result. -;;; The first branch fires when all the bits we want from new-byte are present; -;;; if byte-len crosses from the current result digit into the next, the last -;;; argument to DEPOSIT-FIXNUM-DIGIT is a mask for those bits. The second -;;; branch handles the need to grab more bits than the fixnum new-byte has, but -;;; new-byte is positive; therefore, any virtual bits are zero. The mask for -;;; bits that don't fit in the current result digit is simply the remaining -;;; bits in the bignum digit containing new-byte; we don't care if we store -;;; some extra in the next result digit since they will be zeros. The last -;;; branch handles the need to grab more bits than the fixnum new-byte has, but -;;; new-byte is negative; therefore, any virtual bits must be explicitly filled -;;; in as ones. We call DEPOSIT-FIXNUM-DIGIT to grab what bits actually exist -;;; and to fill in the current result digit. -;;; -(defun deposit-fixnum-bits (new-byte byte-len pos-digit pos-bits - end-digit end-bits result) - (declare (type bignum-index pos-digit end-digit)) - (let ((other-bits (- digit-size pos-bits)) - (new-byte-digit (%fixnum-to-digit new-byte))) - (declare (type bignum-element-type new-byte-digit)) - (cond ((< byte-len maximum-fixnum-bits) - (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits - other-bits result - (- byte-len other-bits))) - ((or (plusp new-byte) (zerop new-byte)) - (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits - other-bits result pos-bits)) - (t - (multiple-value-bind - (digit bits) - (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits - other-bits result - (if (< (- byte-len other-bits) digit-size) - (- byte-len other-bits) - digit-size)) - (declare (type bignum-index digit)) - (cond ((< digit end-digit) - (setf (%bignum-ref result digit) - (logior (%bignum-ref result digit) - (%ashl (%make-ones (- digit-size bits)) bits))) - (do ((i (1+ digit) (1+ i))) - ((= i end-digit) - (setf (%bignum-ref result i) (%make-ones end-bits))) - (setf (%bignum-ref result i) all-ones-digit))) - ((> digit end-digit)) - ((< bits end-bits) - (setf (%bignum-ref result digit) - (logior (%bignum-ref result digit) - (%ashl (%make-ones (- end-bits bits)) - bits)))))))))) - -;;; DEPOSIT-FIXNUM-DIGIT -- Internal. -;;; -;;; This fills in the current result digit from new-byte-digit. The first case -;;; handles everything we want fitting in the current digit, and other-bits is -;;; the number of bits remaining to be filled in result's current digit. This -;;; number is digit-size minus pos-bits. The second branch handles filling in -;;; result's current digit, and it shoves the unused bits of new-byte-digit -;;; into the next result digit. This is correct regardless of new-byte-digit's -;;; sign. It returns the new current result digit and how many bits already -;;; filled in the result digit. -;;; -(defun deposit-fixnum-digit (new-byte-digit byte-len pos-digit pos-bits - other-bits result next-digit-bits-needed) - (declare (type bignum-index pos-digit) - (type bignum-element-type new-byte-digit next-digit-mask)) - (cond ((<= byte-len other-bits) - ;; Bits from new-byte fit in the current result digit. - (setf (%bignum-ref result pos-digit) - (logior (%bignum-ref result pos-digit) - (%ashl (logand new-byte-digit (%make-ones byte-len)) - pos-bits))) - (if (= byte-len other-bits) - (values (1+ pos-digit) 0) - (values pos-digit (+ byte-len pos-bits)))) - (t - ;; Some of new-byte's bits go in current result digit. - (setf (%bignum-ref result pos-digit) - (logior (%bignum-ref result pos-digit) - (%ashl (logand new-byte-digit (%make-ones other-bits)) - pos-bits))) - (let ((pos-digit+1 (1+ pos-digit))) - ;; The rest of new-byte's bits go in the next result digit. - (setf (%bignum-ref result pos-digit+1) - (logand (ash new-byte-digit (- other-bits)) - ;; Must LOGAND after shift here. - (%make-ones next-digit-bits-needed))) - (if (= next-digit-bits-needed digit-size) - (values (1+ pos-digit+1) 0) - (values pos-digit+1 next-digit-bits-needed)))))) - -;;; DEPOSIT-BIGNUM-BITS -- Internal. -;;; -;;; This starts at result's pos-digit skipping pos-bits, and it stores bits -;;; from new-byte, a bignum, into result. It effectively stores byte-len -;;; number of bits, but never stores past end-digit and end-bits in result. -;;; When handling a starting bit unaligned with a digit boundary, we check -;;; in the second branch for the byte spec fitting into the pos-digit element -;;; after after pos-bits; DEPOSIT-UNALIGNED-BIGNUM-BITS expects at least one -;;; digit boundary crossing. -;;; -(defun deposit-bignum-bits (bignum-byte byte-len pos-digit pos-bits - end-digit end-bits result) - (declare (type bignum-index pos-digit end-digit)) - (cond ((zerop pos-bits) - (deposit-aligned-bignum-bits bignum-byte pos-digit end-digit end-bits - result)) - ((or (= end-digit pos-digit) - (and (= end-digit (1+ pos-digit)) - (zerop end-bits))) - (setf (%bignum-ref result pos-digit) - (logior (%bignum-ref result pos-digit) - (%ashl (logand (%bignum-ref bignum-byte 0) - (%make-ones byte-len)) - pos-bits)))) - (t (deposit-unaligned-bignum-bits bignum-byte pos-digit pos-bits - end-digit end-bits result)))) - -;;; DEPOSIT-ALIGNED-BIGNUM-BITS -- Internal. -;;; -;;; This deposits bits from bignum-byte into result starting at pos-digit and -;;; the zero'th bit. It effectively only stores bits to end-bits in the -;;; end-digit element of result. The loop termination code takes care of -;;; picking up the last digit's bits or filling in virtual negative sign bits. -;;; -(defun deposit-aligned-bignum-bits (bignum-byte pos-digit end-digit end-bits - result) - (declare (type bignum-index pos-digit end-digit)) - (let* ((bignum-len (%bignum-length bignum-byte)) - (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len))) - (declare (type bignum-index bignum-len)) - (do ((i 0 (1+ i )) - (j pos-digit (1+ j))) - ((or (= j end-digit) (= i bignum-len)) - (cond ((= j end-digit) - (cond ((< i bignum-len) - (setf (%bignum-ref result j) - (logand (%bignum-ref bignum-byte i) - (%make-ones end-bits)))) - (bignum-plusp) - (t - (setf (%bignum-ref result j) (%make-ones end-bits))))) - (bignum-plusp) - (t - (do ((j j (1+ j))) - ((= j end-digit) - (setf (%bignum-ref result j) (%make-ones end-bits))) - (setf (%bignum-ref result j) all-ones-digit))))) - (setf (%bignum-ref result j) (%bignum-ref bignum-byte i))))) - -;;; DEPOSIT-UNALIGNED-BIGNUM-BITS -- Internal. -;;; -;;; This assumes at least one digit crossing. -;;; -(defun deposit-unaligned-bignum-bits (bignum-byte pos-digit pos-bits - end-digit end-bits result) - (declare (type bignum-index pos-digit end-digit)) - (let* ((bignum-len (%bignum-length bignum-byte)) - (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len)) - (low-mask (%make-ones pos-bits)) - (bits-past-pos-bits (- digit-size pos-bits)) - (high-mask (%make-ones bits-past-pos-bits)) - (minus-high-bits (- bits-past-pos-bits))) - (declare (type bignum-element-type low-mask high-mask) - (type bignum-index bignum-len)) - (do ((i 0 (1+ i)) - (j pos-digit j+1) - (j+1 (1+ pos-digit) (1+ j+1))) - ((or (= j end-digit) (= i bignum-len)) - (cond - ((= j end-digit) - (setf (%bignum-ref result j) - (cond - ((>= pos-bits end-bits) - (logand (%bignum-ref result j) (%make-ones end-bits))) - ((< i bignum-len) - (logior (%bignum-ref result j) - (%ashl (logand (%bignum-ref bignum-byte i) - (%make-ones (- end-bits pos-bits))) - pos-bits))) - (bignum-plusp - (logand (%bignum-ref result j) - ;; 0's between pos-bits and end-bits positions. - (logior (%ashl (%make-ones (- digit-size end-bits)) - end-bits) - low-mask))) - (t (logior (%bignum-ref result j) - (%ashl (%make-ones (- end-bits pos-bits)) - pos-bits)))))) - (bignum-plusp) - (t - (setf (%bignum-ref result j) - (%ashl (%make-ones bits-past-pos-bits) pos-bits)) - (do ((j j+1 (1+ j))) - ((= j end-digit) - (setf (%bignum-ref result j) (%make-ones end-bits))) - (declare (type bignum-index j)) - (setf (%bignum-ref result j) all-ones-digit))))) - (declare (type bignum-index i j j+1)) - (let ((digit (%bignum-ref bignum-byte i))) - (declare (type bignum-element-type digit)) - (setf (%bignum-ref result j) - (logior (%bignum-ref result j) - (%ashl (logand digit high-mask) pos-bits))) - (setf (%bignum-ref result j+1) - (logand (ash digit minus-high-bits) - ;; LOGAND should be unnecessary here with a logical right - ;; shift or a correct unsigned-byte-32 one. - low-mask)))))) - -|# - - -;;;; TRUNCATE. - -;;; This is the original sketch of the algorithm from which I implemented this -;;; TRUNCATE, assuming both operands are bignums. I should modify this to work -;;; with the documentation on my functions, as a general introduction. I've -;;; left this here just in case someone needs it in the future. Don't look -;;; at this unless reading the functions' comments leaves you at a loss. -;;; Remember this comes from Knuth, so the book might give you the right general -;;; overview. -;;; -;;; -;;; (truncate x y): -;;; -;;; If X's magnitude is less than Y's, then result is 0 with remainder X. -;;; -;;; Make x and y positive, copying x if it is already positive. -;;; -;;; Shift y left until there's a 1 in the 30'th bit (most significant, non-sign -;;; digit) -;;; Just do most sig digit to determine how much to shift whole number. -;;; Shift x this much too. -;;; Remember this initial shift count. -;;; -;;; Allocate q to be len-x minus len-y quantity plus 1. -;;; -;;; i = last digit of x. -;;; k = last digit of q. -;;; -;;; LOOP -;;; -;;; j = last digit of y. -;;; -;;; compute guess. -;;; if x[i] = y[j] then g = #xFFFFFFFF -;;; else g = x[i]x[i-1]/y[j]. -;;; -;;; check guess. -;;; %UNSIGNED-MULTIPLY returns b and c defined below. -;;; a = x[i-1] - (logand (* g y[j]) #xFFFFFFFF). -;;; Use %UNSIGNED-MULTIPLY taking low-order result. -;;; b = (logand (ash (* g y[j-1]) -32) #xFFFFFFFF). -;;; c = (logand (* g y[j-1]) #xFFFFFFFF). -;;; if a < b, okay. -;;; if a > b, guess is too high -;;; g = g - 1; go back to "check guess". -;;; if a = b and c > x[i-2], guess is too high -;;; g = g - 1; go back to "check guess". -;;; GUESS IS 32-BIT NUMBER, SO USE THING TO KEEP IN SPECIAL REGISTER -;;; SAME FOR A, B, AND C. -;;; -;;; Subtract g * y from x[i - len-y+1]..x[i]. See paper for doing this in step. -;;; If x[i] < 0, guess is fucked. -;;; negative g, then add 1 -;;; zero or positive g, then subtract 1 -;;; AND add y back into x[len-y+1..i]. -;;; -;;; q[k] = g. -;;; i = i - 1. -;;; k = k - 1. -;;; -;;; If k>=0, goto LOOP. -;;; -;;; -;;; Now quotient is good, but remainder is not. -;;; Shift x right by saved initial left shifting count. -;;; -;;; Check quotient and remainder signs. -;;; x pos y pos --> q pos r pos -;;; x pos y neg --> q neg r pos -;;; x neg y pos --> q neg r neg -;;; x neg y neg --> q pos r neg -;;; -;;; Normalize quotient and remainder. Cons result if necessary. -;;; - - - -;;; These are used by BIGNUM-TRUNCATE and friends in the general case. -;;; -(defvar *truncate-x*) -(defvar *truncate-y*) - -;;; BIGNUM-TRUNCATE -- Public. -;;; -;;; This divides x by y returning the quotient and remainder. In the general -;;; case, we shift y to setup for the algorithm, and we use two buffers to save -;;; consing intermediate values. X gets destructively modified to become the -;;; remainder, and we have to shift it to account for the initial Y shift. -;;; After we multiple bind q and r, we first fix up the signs and then return -;;; the normalized results. -;;; -(defun bignum-truncate (x y) - (declare (type bignum-type x y)) - (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) - (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) - (x (if x-plusp x (negate-bignum x nil))) - (y (if y-plusp y (negate-bignum y nil))) - (len-x (%bignum-length x)) - (len-y (%bignum-length y))) - (multiple-value-bind - (q r) - (cond ((< len-y 2) - (bignum-truncate-single-digit x len-x y)) - ((plusp (bignum-compare y x)) - (let ((res (%allocate-bignum len-x))) - (dotimes (i len-x) - (setf (%bignum-ref res i) (%bignum-ref x i))) - (values 0 res))) - (t - (let ((len-x+1 (1+ len-x))) - (with-bignum-buffers ((*truncate-x* len-x+1) - (*truncate-y* (1+ len-y))) - (let ((y-shift (shift-y-for-truncate y))) - (shift-and-store-truncate-buffers x len-x y len-y y-shift) - (values (do-truncate len-x+1 len-y) - ;; DO-TRUNCATE must execute first. - (cond - ((zerop y-shift) - (let ((res (%allocate-bignum len-y))) - (declare (type bignum-type res)) - (bignum-replace res *truncate-x* :end2 len-y) - (%normalize-bignum res len-y))) - (t - (shift-right-unaligned - *truncate-x* 0 y-shift len-y - ((= j res-len-1) - (setf (%bignum-ref res j) - (%ashr (%bignum-ref *truncate-x* i) - y-shift)) - (%normalize-bignum res res-len)) - res))))))))) - (let ((quotient (cond ((eq x-plusp y-plusp) q) - ((typep q 'fixnum) (the fixnum (- q))) - (t (negate-bignum-in-place q)))) - (rem (cond (x-plusp r) - ((typep r 'fixnum) (the fixnum (- r))) - (t (negate-bignum-in-place r))))) - (values (if (typep quotient 'fixnum) - quotient - (%normalize-bignum quotient (%bignum-length quotient))) - (if (typep rem 'fixnum) - rem - (%normalize-bignum rem (%bignum-length rem)))))))) - -;;; BIGNUM-TRUNCATE-SINGLE-DIGIT -- Internal. -;;; -;;; This divides x by y when y is a single bignum digit. BIGNUM-TRUNCATE fixes -;;; up the quotient and remainder with respect to sign and normalization. -;;; -;;; We don't have to worry about shifting y to make its most significant digit -;;; sufficiently large for %FLOOR to return 32-bit quantities for the q-digit -;;; and r-digit. If y is a single digit bignum, it is already large enough -;;; for %FLOOR. That is, it has some bits on pretty high in the digit. -;;; -(defun bignum-truncate-single-digit (x len-x y) - (declare (type bignum-index len-x)) - (let ((q (%allocate-bignum len-x)) - (r 0) - (y (%bignum-ref y 0))) - (declare (type bignum-element-type r y)) - (do ((i (1- len-x) (1- i))) - ((minusp i)) - (multiple-value-bind (q-digit r-digit) - (%floor r (%bignum-ref x i) y) - (declare (type bignum-element-type q-digit r-digit)) - (setf (%bignum-ref q i) q-digit) - (setf r r-digit))) - (let ((rem (%allocate-bignum 1))) - (setf (%bignum-ref rem 0) r) - (values q rem)))) - -;;; DO-TRUNCATE -- Internal. -;;; -;;; This divides *truncate-x* by *truncate-y*, and len-x and len-y tell us how -;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies -;;; *truncate-x* on each interation, and this buffer becomes our remainder. -;;; -;;; *truncate-x* definitely has at least three digits, and it has one more than -;;; *truncate-y*. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to -;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS. -;;; -(defun do-truncate (len-x len-y) - (declare (type bignum-index len-x len-y)) - (let* ((len-q (- len-x len-y)) - ;; Add one for extra sign digit in case high bit is on. - (q (%allocate-bignum (1+ len-q))) - (k (1- len-q)) - (y1 (%bignum-ref *truncate-y* (1- len-y))) - (y2 (%bignum-ref *truncate-y* (- len-y 2))) - (i (1- len-x)) - (i-1 (1- i)) - (i-2 (1- i-1)) - (low-x-digit (- i len-y))) - (declare (type bignum-index len-q k i i-1 i-2 low-x-digit) - (type bignum-element-type y1 y2)) - (loop - (setf (%bignum-ref q k) - (try-bignum-truncate-guess - ;; This modifies *truncate-x*. Must access elements each pass. - (bignum-truncate-guess y1 y2 - (%bignum-ref *truncate-x* i) - (%bignum-ref *truncate-x* i-1) - (%bignum-ref *truncate-x* i-2)) - len-y low-x-digit)) - (cond ((zerop k) (return)) - (t (decf k) - (decf low-x-digit) - (shiftf i i-1 i-2 (1- i-2))))) - q)) - -;;; TRY-BIGNUM-TRUNCATE-GUESS -- Internal. -;;; -;;; This takes a digit guess, multiplies it by *truncate-y* for a result one -;;; greater in length than len-y, and subtracts this result from *truncate-x*. -;;; Low-x-digit is the first digit of x to start the subtraction, and we know x -;;; is long enough to subtract a len-y plus one length bignum from it. Next we -;;; check the result of the subtraction, and if the high digit in x became -;;; negative, then our guess was one too big. In this case, return one less -;;; than guess passed in, and add one value of y back into x to account for -;;; subtracting one too many. Knuth shows that the guess is wrong on the order -;;; of 3/b, where b is the base (2 to the digit-size power) -- pretty rarely. -;;; -(defun try-bignum-truncate-guess (guess len-y low-x-digit) - (declare (type bignum-index low-x-digit len-y) - (type bignum-element-type guess)) - (let ((carry-digit 0) - (borrow 1) - (i low-x-digit)) - (declare (type bignum-element-type carry-digit) - (type bignum-index i) - (fixnum borrow)) - ;; Multiply guess and divisor, subtracting from dividend simultaneously. - (dotimes (j len-y) - (multiple-value-bind (high-digit low-digit) - (%multiply-and-add guess (%bignum-ref *truncate-y* j) - carry-digit) - (declare (type bignum-element-type high-digit low-digit)) - (setf carry-digit high-digit) - (multiple-value-bind (x temp-borrow) - (%subtract-with-borrow (%bignum-ref *truncate-x* i) - low-digit borrow) - (declare (type bignum-element-type x) - (fixnum temp-borrow)) - (setf (%bignum-ref *truncate-x* i) x) - (setf borrow temp-borrow))) - (incf i)) - (setf (%bignum-ref *truncate-x* i) - (%subtract-with-borrow (%bignum-ref *truncate-x* i) - carry-digit borrow)) - ;; See if guess is off by one, adding one Y back in if necessary. - (cond ((%digit-0-or-plusp (%bignum-ref *truncate-x* i)) - guess) - (t - ;; If subtraction has negative result, add one divisor value back - ;; in. The guess was one too large in magnitude. - (let ((i low-x-digit) - (carry 0)) - (dotimes (j len-y) - (multiple-value-bind (v k) - (%add-with-carry (%bignum-ref *truncate-y* j) - (%bignum-ref *truncate-x* i) - carry) - (declare (type bignum-element-type v)) - (setf (%bignum-ref *truncate-x* i) v) - (setf carry k)) - (incf i)) - (setf (%bignum-ref *truncate-x* i) - (%add-with-carry (%bignum-ref *truncate-x* i) 0 carry))) - (%subtract-with-borrow guess 1 1))))) - -;;; BIGNUM-TRUNCATE-GUESS -- Internal. -;;; -;;; This returns a guess for the next division step. Y1 is the highest y -;;; digit, and y2 is the second to highest y digit. The x... variables are -;;; the three highest x digits for the next division step. -;;; -;;; From Knuth, our guess is either all ones or x-i and x-i-1 divided by y1, -;;; depending on whether x-i and y1 are the same. We test this guess by -;;; determining whether guess*y2 is greater than the three high digits of x -;;; minus guess*y1 shifted left one digit: -;;; ------------------------------ -;;; | x-i | x-i-1 | x-i-2 | -;;; ------------------------------ -;;; ------------------------------ -;;; - | g*y1 high | g*y1 low | 0 | -;;; ------------------------------ -;;; ... < guess*y2 ??? -;;; If guess*y2 is greater, then we decrement our guess by one and try again. -;;; This returns a guess that is either correct or one too large. -;;; -(defun bignum-truncate-guess (y1 y2 x-i x-i-1 x-i-2) - (declare (type bignum-element-type y1 y2 x-i x-i-1 x-i-2)) - (let ((guess (if (%digit-compare x-i y1) - all-ones-digit - (%floor x-i x-i-1 y1)))) - (declare (type bignum-element-type guess)) - (loop - (multiple-value-bind (high-guess*y1 low-guess*y1) - (%multiply guess y1) - (declare (type bignum-element-type low-guess*y1 high-guess*y1)) - (multiple-value-bind (high-guess*y2 low-guess*y2) - (%multiply guess y2) - (declare (type bignum-element-type high-guess*y2 low-guess*y2)) - (multiple-value-bind (middle-digit borrow) - (%subtract-with-borrow x-i-1 low-guess*y1 1) - (declare (type bignum-element-type middle-digit) - (fixnum borrow)) - ;; Supplying borrow of 1 means there was no borrow, and we know - ;; x-i-2 minus 0 requires no borrow. - (let ((high-digit (%subtract-with-borrow x-i high-guess*y1 borrow))) - (declare (type bignum-element-type high-digit)) - (if (and (%digit-compare high-digit 0) - (or (%digit-greater high-guess*y2 middle-digit) - (and (%digit-compare middle-digit high-guess*y2) - (%digit-greater low-guess*y2 x-i-2)))) - (setf guess (%subtract-with-borrow guess 1 1)) - (return guess))))))))) - -;;; SHIFT-Y-FOR-TRUNCATE -- Internal. -;;; -;;; This returns the amount to shift y to place a one in the second highest -;;; bit. Y must be positive. If the last digit of y is zero, then y has a -;;; one in the previous digit's sign bit, so we know it will take one less -;;; than digit-size to get a one where we want. Otherwise, we count how many -;;; right shifts it takes to get zero; subtracting this value from digit-size -;;; tells us how many high zeros there are which is one more than the shift -;;; amount sought. -;;; -;;; Note: This is exactly the same as one less than the integer-length of the -;;; last digit subtracted from the digit-size. -;;; -;;; We shift y to make it sufficiently large that doing the 64-bit by 32-bit -;;; %FLOOR calls ensures the quotient and remainder fit in 32-bits. -;;; -(defun shift-y-for-truncate (y) - (let* ((len (%bignum-length y)) - (last (%bignum-ref y (1- len)))) - (declare (type bignum-index len) - (type bignum-element-type last)) - (- digit-size (integer-length last) 1))) - -;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS -- Internal. -;;; -;;; Stores two bignums into the truncation bignum buffers, shifting them on the -;;; way in. This assumes x and y are positive and at least two in length, and -;;; it assumes *truncate-x* and *truncate-y* are one digit longer than x and y. -;;; -(defun shift-and-store-truncate-buffers (x len-x y len-y shift) - (declare (type bignum-index len-x len-y) - (type (integer 0 (#.digit-size)) shift)) - (cond ((zerop shift) - (bignum-replace *truncate-x* x :end1 len-x) - (bignum-replace *truncate-y* y :end1 len-y)) - (t - (bignum-ashift-left-unaligned x 0 shift (1+ len-x) *truncate-x*) - (bignum-ashift-left-unaligned y 0 shift (1+ len-y) *truncate-y*)))) - - - -;;;; %FLOOR primitive for BIGNUM-TRUNCATE. - -;;; When a machine leaves out a 64-bit by 32-bit divide instruction (that is, -;;; two bignum-digits divided by one), we have to roll our own (the hard way). -;;; Basically, we treat the operation as four 16-bit digits divided by two -;;; 16-bit digits. This means we have duplicated most of the code above to do -;;; this nearly general 16-bit digit bignum divide, but we've unrolled loops -;;; and made use of other properties of this specific divide situation. -;;; - - -;;; -;;; %FLOOR for machines with a 32x32 divider. -;;; - -(proclaim '(inline 32x16-subtract-with-borrow 32x16-add-with-carry - 32x16-divide 32x16-multiply 32x16-multiply-split)) - -#+32x16-divide -(defconstant 32x16-base-1 #xFFFF) - -;;; 32X16-SUBTRACT-WITH-BORROW -- Internal. [optionally IN ASSEMBLER] -;;; -;;; This is similar to %SUBTRACT-WITH-BORROW. It returns a 16-bit difference -;;; and a borrow. Returning a 1 for the borrow means there was no borrow, and -;;; 0 means there was one. -;;; -#+32x16-divide -(defun 32x16-subtract-with-borrow (a b borrow) - (declare (type (unsigned-byte 16) a b) - (type (integer 0 1) borrow)) - (let ((diff (+ (- a b) borrow 32x16-base-1))) - (declare (type (unsigned-byte 17) diff)) - (values (logand diff #xFFFF) - (ash diff -16)))) - -;;; 32X16-ADD-WITH-CARRY -- Internal. [optionally IN ASSEMBLER] -;;; -;;; This adds a and b, 16-bit quantities, with the carry k. It returns a -;;; 16-bit sum and a second value, 0 or 1, indicating whether there was a -;;; carry. -;;; -#+32x16-divide -(defun 32x16-add-with-carry (a b k) - (declare (type (unsigned-byte 16) a b) - (type (integer 0 1) k)) - (let ((res (the fixnum (+ a b k)))) - (declare (type (unsigned-byte 17) res)) - (if (zerop (the fixnum (logand #x10000 res))) - (values res 0) - (values (the (unsigned-byte 16) (logand #xFFFF res)) - 1)))) - -;;; 32x16-DIVIDE -- Internal [IN ASSEMBLER] -;;; -;;; This is probably a 32-bit by 32-bit divide instruction. -;;; -#+32x16-divide -(defun 32x16-divide (a b c) - (declare (type (unsigned-byte 16) a b c)) - (floor (the bignum-element-type - (logior (the bignum-element-type (ash a 16)) - b)) - c)) - -;;; 32X16-MULTIPLY -- Internal. [optionally IN ASSEMBLER] -;;; -;;; This basically exists since we know the answer won't overflow -;;; bignum-element-type. It's probably just a basic multiply instruction, but -;;; it can't cons an intermediate bignum. The result goes in a non-descriptor -;;; register. -;;; -#+32x16-divide -(defun 32x16-multiply (a b) - (declare (type (unsigned-byte 16) a b)) - (the bignum-element-type (* a b))) - -;;; 32X16-MULTIPLY-SPLIT -- Internal. [optionally IN ASSEMBLER] -;;; -;;; This multiplies a and b, 16-bit quantities, and returns the result as two -;;; 16-bit quantities, high and low. -;;; -#+32x16-divide -(defun 32x16-multiply-split (a b) - (let ((res (32x16-multiply a b))) - (declare (the bignum-element-type res)) - (values (the (unsigned-byte 16) (logand #xFFFF (ash res -16))) - (the (unsigned-byte 16) (logand #xFFFF res))))) - - - -;;; The %FLOOR below uses this buffer the same way BIGNUM-TRUNCATE uses -;;; *truncate-x*. There's no y buffer since we pass around the two 16-bit -;;; digits and use them slightly differently than the general truncation -;;; algorithm above. -;;; -#+32x16-divide -(defvar *32x16-truncate-x* (make-array 4 :element-type '(unsigned-byte 16) - :initial-element 0)) - -;;; %FLOOR -- Internal. LEFT IMPLEMENTED AT LISP LEVEL -;;; -;;; This does the same thing as the %FLOOR above, but it does it at Lisp level -;;; when there is no 64x32-bit divide instruction on the machine. -;;; -;;; It implements the higher level tactics of BIGNUM-TRUNCATE, but it makes use -;;; of special situation provided, four 16-bit digits divided by two 16-bit -;;; digits. -;;; -#+32x16-divide -(defun %floor (a b c) - (declare (type bignum-element-type a b c)) - ;; - ;; Setup *32x16-truncate-x* buffer from a and b. - (setf (aref *32x16-truncate-x* 0) - (the (unsigned-byte 16) (logand #xFFFF b))) - (setf (aref *32x16-truncate-x* 1) - (the (unsigned-byte 16) - (logand #xFFFF - (the (unsigned-byte 16) (ash b -16))))) - (setf (aref *32x16-truncate-x* 2) - (the (unsigned-byte 16) (logand #xFFFF a))) - (setf (aref *32x16-truncate-x* 3) - (the (unsigned-byte 16) - (logand #xFFFF - (the (unsigned-byte 16) (ash a -16))))) - ;; - ;; From DO-TRUNCATE, but unroll the loop. - (let* ((y1 (logand #xFFFF (ash c -16))) - (y2 (logand #xFFFF c)) - (q (the bignum-element-type - (ash (32x16-try-bignum-truncate-guess - (32x16-truncate-guess y1 y2 - (aref *32x16-truncate-x* 3) - (aref *32x16-truncate-x* 2) - (aref *32x16-truncate-x* 1)) - y1 y2 1) - 16)))) - (declare (type bignum-element-type q) - (type (unsigned-byte 16) y1 y2)) - (values (the bignum-element-type - (logior q - (the (unsigned-byte 16) - (32x16-try-bignum-truncate-guess - (32x16-truncate-guess - y1 y2 - (aref *32x16-truncate-x* 2) - (aref *32x16-truncate-x* 1) - (aref *32x16-truncate-x* 0)) - y1 y2 0)))) - (the bignum-element-type - (logior (the bignum-element-type - (ash (aref *32x16-truncate-x* 1) 16)) - (the (unsigned-byte 16) - (aref *32x16-truncate-x* 0))))))) - -;;; 32X16-TRY-BIGNUM-TRUNCATE-GUESS -- Internal. -;;; -;;; This is similar to TRY-BIGNUM-TRUNCATE-GUESS, but this unrolls the two -;;; loops. This also substitutes for %DIGIT-0-OR-PLUSP the equivalent -;;; expression without any embellishment or pretense of abstraction. The first -;;; loop is unrolled, but we've put the body of the loop into the function -;;; 32X16-TRY-GUESS-ONE-RESULT-DIGIT. -;;; -#+32x16-divide -(defun 32x16-try-bignum-truncate-guess (guess y-high y-low low-x-digit) - (declare (type bignum-index low-x-digit) - (type (unsigned-byte 16) guess y-high y-low)) - (let ((high-x-digit (+ 2 low-x-digit))) - ;; - ;; Multiply guess and divisor, subtracting from dividend simultaneously. - (multiple-value-bind - (guess*y-hold carry borrow) - (32x16-try-guess-one-result-digit guess y-low 0 0 1 low-x-digit) - (declare (type (unsigned-byte 16) guess*y-hold) - (fixnum carry borrow)) - (multiple-value-bind - (guess*y-hold carry borrow) - (32x16-try-guess-one-result-digit guess y-high guess*y-hold - carry borrow (1+ low-x-digit)) - (declare (type (unsigned-byte 16) guess*y-hold) - (fixnum borrow) - (ignore carry)) - (setf (aref *32x16-truncate-x* high-x-digit) - (32x16-subtract-with-borrow (aref *32x16-truncate-x* high-x-digit) - guess*y-hold borrow)))) - ;; - ;; See if guess is off by one, adding one Y back in if necessary. - (cond ((zerop (logand #x8000 (aref *32x16-truncate-x* high-x-digit))) - ;; The subtraction result is zero or positive. - guess) - (t - ;; If subtraction has negative result, add one divisor value back in. - ;; The guess was one two large in magnitude. - (multiple-value-bind (v carry) - (32x16-add-with-carry y-low - (aref *32x16-truncate-x* - low-x-digit) - 0) - (declare (type (unsigned-byte 16) v)) - (setf (aref *32x16-truncate-x* low-x-digit) v) - (multiple-value-bind (v carry) - (32x16-add-with-carry y-high - (aref *32x16-truncate-x* - (1+ low-x-digit)) - carry) - (setf (aref *32x16-truncate-x* (1+ low-x-digit)) v) - (setf (aref *32x16-truncate-x* high-x-digit) - (32x16-add-with-carry (aref *32x16-truncate-x* high-x-digit) - carry 0)))) - (if (zerop (logand #x8000 guess)) - (1- guess) - (1+ guess)))))) - -;;; 32X16-TRY-GUESS-ONE-RESULT-DIGIT -- Internal. -;;; -;;; This is similar to the body of the loop in TRY-BIGNUM-TRUNCATE-GUESS that -;;; multiplies the guess by y and subtracts the result from x simultaneously. -;;; This returns the digit remembered as part of the multiplication, the carry -;;; from additions done on behalf of the multiplication, and the borrow from -;;; doing the subtraction. -;;; -#+32x16-divide -(defun 32x16-try-guess-one-result-digit (guess y-digit guess*y-hold - carry borrow x-index) - (multiple-value-bind (high-digit low-digit) - (32x16-multiply-split guess y-digit) - (declare (type (unsigned-byte 16) high-digit low-digit)) - (multiple-value-bind (low-digit temp-carry) - (32x16-add-with-carry low-digit guess*y-hold carry) - (declare (type (unsigned-byte 16) low-digit)) - (multiple-value-bind (high-digit temp-carry) - (32x16-add-with-carry high-digit temp-carry 0) - (declare (type (unsigned-byte 16) high-digit)) - (multiple-value-bind (x temp-borrow) - (32x16-subtract-with-borrow - (aref *32x16-truncate-x* x-index) - low-digit borrow) - (declare (type (unsigned-byte 16) x)) - (setf (aref *32x16-truncate-x* x-index) x) - (values high-digit temp-carry temp-borrow)))))) - -;;; 32X16-TRUNCATE-GUESS -- Internal. -;;; -;;; This is similar to BIGNUM-TRUNCATE-GUESS, but instead of computing the -;;; guess exactly as described in the its comments (digit by digit), this -;;; massages the 16-bit quantities into 32-bit quantities and performs the -;;; -#+32x16-divide -(defun 32x16-truncate-guess (y1 y2 x-i x-i-1 x-i-2) - (declare (type (unsigned-byte 16) y1 y2 x-i x-i-1 x-i-2)) - (let ((guess (if (= x-i y1) - #xFFFF - (32x16-divide x-i x-i-1 y1)))) - (declare (type (unsigned-byte 16) guess)) - (loop - (let* ((guess*y1 (the bignum-element-type - (ash (logand #xFFFF - (the bignum-element-type - (32x16-multiply guess y1))) - 16))) - (x-y (%subtract-with-borrow - (the bignum-element-type - (logior (the bignum-element-type - (ash x-i-1 16)) - x-i-2)) - guess*y1 - 1)) - (guess*y2 (the bignum-element-type (%multiply guess y2)))) - (declare (type bignum-element-type guess*y1 x-y guess*y2)) - (if (%digit-greater guess*y2 x-y) - (decf guess) - (return guess)))))) - - -;;;; General utilities. - -;;; MAKE-SMALL-BIGNUM -- Public. -;;; -;;; Allocate a single word bignum that holds fixnum. This is useful when -;;; we are trying to mix fixnum and bignum operands. -;;; -(proclaim '(inline make-small-bignum)) -(defun make-small-bignum (fixnum) - (let ((res (%allocate-bignum 1))) - (setf (%bignum-ref res 0) (%fixnum-to-digit fixnum)) - res)) - -;;; %NORMALIZE-BIGNUM-BUFFER -- Internal. -;;; -;;; Internal in-place operations use this to fixup remaining digits in the -;;; incoming data, such as in-place shifting. This is basically the same as -;;; the first form in %NORMALIZE-BIGNUM, but we return the length of the buffer -;;; instead of shrinking the bignum. -;;; -#+nil(proclaim '(ext:maybe-inline %normalize-bignum-buffer)) -(defun %normalize-bignum-buffer (result len) - (declare (type bignum-type result) - (type bignum-index len)) - (unless (= len 1) - (do ((next-digit (%bignum-ref result (- len 2)) - (%bignum-ref result (- len 2))) - (sign-digit (%bignum-ref result (1- len)) next-digit)) - ((not (zerop (logxor sign-digit (%ashr next-digit (1- digit-size)))))) - (when (= (decf len) 1) - (return)) - (setf (%bignum-ref result len) 0))) - len) - -;;; %NORMALIZE-BIGNUM -- Internal. -;;; -;;; This drops the last digit if it is unnecessary sign information. It -;;; repeats this as needed, possibly ending with a fixnum. If the resulting -;;; length from shrinking is one, see if our one word is a fixnum. Shift the -;;; possible fixnum bits completely out of the word, and compare this with -;;; shifting the sign bit all the way through. If the bits are all 1's or 0's -;;; in both words, then there are just sign bits between the fixnum bits and -;;; the sign bit. If we do have a fixnum, shift it over for the two low-tag -;;; bits. -;;; -(defun %normalize-bignum (result len) - (declare (type bignum-type result) - (type bignum-index len) - #+nil(inline %normalize-bignum-buffer)) - (let ((newlen (%normalize-bignum-buffer result len))) - (declare (type bignum-index newlen)) - (unless (= newlen len) - (%bignum-set-length result newlen)) - (if (= newlen 1) - (let ((digit (%bignum-ref result 0))) - (if (= (%ashr digit 29) (%ashr digit (1- digit-size))) - (%fixnum-digit-with-correct-sign digit) - result)) - result))) - -;;; %MOSTLY-NORMALIZE-BIGNUM -- Internal. -;;; -;;; This drops the last digit if it is unnecessary sign information. It -;;; repeats this as needed, possibly ending with a fixnum magnitude but never -;;; returning a fixnum. -;;; -(defun %mostly-normalize-bignum (result len) - (declare (type bignum-type result) - (type bignum-index len) - #+nil(inline %normalize-bignum-buffer)) - (let ((newlen (%normalize-bignum-buffer result len))) - (declare (type bignum-index newlen)) - (unless (= newlen len) - (%bignum-set-length result newlen)) - result)) diff --git a/code/bit-bash.lisp b/code/bit-bash.lisp deleted file mode 100644 index 868d37d424ebd01f0abfe71ec6e1d3ae5d7b8b5a..0000000000000000000000000000000000000000 --- a/code/bit-bash.lisp +++ /dev/null @@ -1,518 +0,0 @@ -;;; -*- Log: code.log; Package: VM -*- -;;; -;;; ********************************************************************** -;;; 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/code/bit-bash.lisp,v 1.16 1992/07/31 17:50:18 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Functions to implement bit bashing. -;;; -;;; Written by William Lott. -;;; - -(in-package "VM") - - - -;;;; Constants and Types. - - -(eval-when (compile load eval) - -(defconstant unit-bits vm:word-bits - "The number of bits to process at a time.") - -(defconstant max-bits (ash most-positive-fixnum -2) - "The maximum number of bits that can be delt with during a single call.") - - -(deftype unit () - `(unsigned-byte ,unit-bits)) - -(deftype offset () - `(integer 0 ,max-bits)) - -(deftype bit-offset () - `(integer 0 (,unit-bits))) - -(deftype bit-count () - `(integer 1 (,unit-bits))) - -(deftype word-offset () - `(integer 0 (,(ceiling max-bits unit-bits)))) - - -); eval-when - - - -;;;; Support routines. - -;;; A particular implementation must offer either VOPs to translate these, or -;;; deftransforms to convert them into something supported by the architecture. -;;; -(macrolet ((frob (name &rest args) - `(defun ,name ,args - (,name ,@args)))) - (frob 32bit-logical-not x) - (frob 32bit-logical-and x y) - (frob 32bit-logical-or x y) - (frob 32bit-logical-xor x y) - (frob 32bit-logical-nor x y) - (frob 32bit-logical-eqv x y) - (frob 32bit-logical-nand x y) - (frob 32bit-logical-andc1 x y) - (frob 32bit-logical-andc2 x y) - (frob 32bit-logical-orc1 x y) - (frob 32bit-logical-orc2 x y)) - - -(eval-when (compile eval) - (defmacro byte-order-dispatch (big-endian little-endian) - (ecase (c:backend-byte-order c:*target-backend*) - (:big-endian big-endian) - (:little-endian little-endian)))) - -(defun shift-towards-start (number count) - "Shift NUMBER by COUNT bits, adding zero bits at the ``end'' and removing - bits from the ``start.'' On big-endian machines this is a left-shift and - on little-endian machines this is a right-shift. Note: only the low 5 bits - of count are significant." - (declare (type unit number) (fixnum count)) - (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count))) - (declare (type bit-offset count)) - (if (zerop count) - number - (byte-order-dispatch - (ash (ldb (byte (- unit-bits count) 0) number) count) - (ash number (- count)))))) - -(defun shift-towards-end (number count) - "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing - bits from the ``end.'' On big-endian machines this is a right-shift and - on little-endian machines this is a left-shift." - (declare (type unit number) (fixnum count)) - (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count))) - (declare (type bit-offset count)) - (if (zerop count) - number - (byte-order-dispatch - (ash number (- count)) - (ash (ldb (byte (- unit-bits count) 0) number) count))))) - -(proclaim '(inline start-mask end-mask fix-sap-and-offset)) -(defun start-mask (count) - "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for - the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant." - (declare (fixnum count)) - (shift-towards-start (1- (ash 1 unit-bits)) (- count))) - -(defun end-mask (count) - "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for - the remaining ``start'' bits. Only the lower 5 bits of COUNT are - significant." - (declare (fixnum count)) - (shift-towards-end (1- (ash 1 unit-bits)) (- count))) - -(defun fix-sap-and-offset (sap offset) - "Align the SAP to a word boundry, and update the offset accordingly." - (declare (type system-area-pointer sap) - (type index offset) - (values system-area-pointer index)) - (let ((address (sap-int sap))) - (values (int-sap (32bit-logical-andc2 address 3)) - (+ (* (logand address 3) byte-bits) offset)))) - -(declaim (inline word-sap-ref %set-word-sap-ref)) -;;; -(defun word-sap-ref (sap offset) - (declare (type system-area-pointer sap) - (type index offset) - (values (unsigned-byte 32)) - (optimize (speed 3) (safety 0) (inhibit-warnings 3))) - (sap-ref-32 sap (the index (ash offset 2)))) -;;; -(defun %set-word-sap-ref (sap offset value) - (declare (type system-area-pointer sap) - (type index offset) - (type (unsigned-byte 32) value) - (values (unsigned-byte 32)) - (optimize (speed 3) (safety 0) (inhibit-warnings 3))) - (setf (sap-ref-32 sap (the index (ash offset 2))) value)) -;;; -(defsetf word-sap-ref %set-word-sap-ref) - - - -;;;; DO-CONSTANT-BIT-BASH - -(proclaim '(inline do-constant-bit-bash)) -(defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn) - "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits." - (declare (type offset dst-offset) (type unit value) - (type function dst-ref-fn dst-set-fn)) - (multiple-value-bind (dst-word-offset dst-bit-offset) - (floor dst-offset unit-bits) - (declare (type word-offset dst-word-offset) - (type bit-offset dst-bit-offset)) - (multiple-value-bind (words final-bits) - (floor (+ dst-bit-offset length) unit-bits) - (declare (type word-offset words) (type bit-offset final-bits)) - (if (zerop words) - (unless (zerop length) - (funcall dst-set-fn dst dst-word-offset - (if (= length unit-bits) - value - (let ((mask (shift-towards-end (start-mask length) - dst-bit-offset))) - (declare (type unit mask)) - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 - (funcall dst-ref-fn dst dst-word-offset) - mask)))))) - (let ((interior (floor (- length final-bits) unit-bits))) - (unless (zerop dst-bit-offset) - (let ((mask (end-mask (- dst-bit-offset)))) - (declare (type unit mask)) - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 - (funcall dst-ref-fn dst dst-word-offset) - mask)))) - (incf dst-word-offset)) - (dotimes (i interior) - (funcall dst-set-fn dst dst-word-offset value) - (incf dst-word-offset)) - (unless (zerop final-bits) - (let ((mask (start-mask final-bits))) - (declare (type unit mask)) - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 - (funcall dst-ref-fn dst dst-word-offset) - mask))))))))) - (undefined-value)) - - -;;;; DO-UNARY-BIT-BASH - -(proclaim '(inline do-unary-bit-bash)) -(defun do-unary-bit-bash (src src-offset dst dst-offset length - dst-ref-fn dst-set-fn src-ref-fn) - (declare (type offset src-offset dst-offset length) - (type function dst-ref-fn dst-set-fn src-ref-fn)) - (multiple-value-bind (dst-word-offset dst-bit-offset) - (floor dst-offset unit-bits) - (declare (type word-offset dst-word-offset) - (type bit-offset dst-bit-offset)) - (multiple-value-bind (src-word-offset src-bit-offset) - (floor src-offset unit-bits) - (declare (type word-offset src-word-offset) - (type bit-offset src-bit-offset)) - (cond - ((<= (+ dst-bit-offset length) unit-bits) - ;; We are only writing one word, so it doesn't matter what order - ;; we do it in. But we might be reading from multiple words, so take - ;; care. - (cond - ((zerop length) - ;; Actually, we arn't even writing one word. This is real easy. - ) - ((= length unit-bits) - ;; dst-bit-offset must be equal to zero, or we would be writing - ;; multiple words. If src-bit-offset is also zero, then we - ;; just transfer the single word. Otherwise we have to extract bits - ;; from two src words. - (funcall dst-set-fn dst dst-word-offset - (if (zerop src-bit-offset) - (funcall src-ref-fn src src-word-offset) - (32bit-logical-or - (shift-towards-start - (funcall src-ref-fn src src-word-offset) - src-bit-offset) - (shift-towards-end - (funcall src-ref-fn src (1+ src-word-offset)) - (- src-bit-offset)))))) - (t - ;; We are only writing some portion of the dst word, so we need to - ;; preserve the extra bits. Also, we still don't know if we need - ;; one or two source words. - (let ((mask (shift-towards-end (start-mask length) dst-bit-offset)) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value - (if (> src-bit-offset dst-bit-offset) - ;; The source starts further into the word than does - ;; the dst, so the source could extend into the next - ;; word. If it does, we have to merge the two words, - ;; and if not, we can just shift the first word. - (let ((src-bit-shift (- src-bit-offset dst-bit-offset))) - (if (> (+ src-bit-offset length) unit-bits) - (32bit-logical-or - (shift-towards-start - (funcall src-ref-fn src src-word-offset) - src-bit-shift) - (shift-towards-end - (funcall src-ref-fn src (1+ src-word-offset)) - (- src-bit-shift))) - (shift-towards-start - (funcall src-ref-fn src src-word-offset) - src-bit-shift))) - ;; The dst starts further into the word than does the - ;; source, so we know the source can not extend into - ;; a second word (or else the dst would too, and we - ;; wouldn't be in this branch. - (shift-towards-end - (funcall src-ref-fn src src-word-offset) - (- dst-bit-offset src-bit-offset))))) - (declare (type unit mask orig value)) - ;; Replace the dst word. - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 orig mask))))))) - ((= src-bit-offset dst-bit-offset) - ;; The source and dst are aligned, so we don't need to shift - ;; anything. But we have to pick the direction of the loop - ;; in case the source and dst are really the same thing. - (multiple-value-bind (words final-bits) - (floor (+ dst-bit-offset length) unit-bits) - (declare (type word-offset words) (type bit-offset final-bits)) - (let ((interior (floor (- length final-bits) unit-bits))) - (declare (type word-offset interior)) - (cond - ((<= dst-offset src-offset) - ;; We need to loop from left to right - (unless (zerop dst-bit-offset) - ;; We are only writing part of the first word, so mask off the - ;; bits we want to preserve. - (let ((mask (end-mask (- dst-bit-offset))) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (funcall src-ref-fn src src-word-offset))) - (declare (type unit mask orig value)) - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or (32bit-logical-and value mask) - (32bit-logical-andc2 orig mask)))) - (incf src-word-offset) - (incf dst-word-offset)) - ;; Just copy the interior words. - (dotimes (i interior) - (funcall dst-set-fn dst dst-word-offset - (funcall src-ref-fn src src-word-offset)) - (incf src-word-offset) - (incf dst-word-offset)) - (unless (zerop final-bits) - ;; We are only writing part of the last word. - (let ((mask (start-mask final-bits)) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (funcall src-ref-fn src src-word-offset))) - (declare (type unit mask orig value)) - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 orig mask)))))) - (t - ;; We need to loop from right to left. - (incf dst-word-offset words) - (incf src-word-offset words) - (unless (zerop final-bits) - (let ((mask (start-mask final-bits)) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (funcall src-ref-fn src src-word-offset))) - (declare (type unit mask orig value)) - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 orig mask))))) - (dotimes (i interior) - (decf src-word-offset) - (decf dst-word-offset) - (funcall dst-set-fn dst dst-word-offset - (funcall src-ref-fn src src-word-offset))) - (unless (zerop dst-bit-offset) - (decf src-word-offset) - (decf dst-word-offset) - (let ((mask (end-mask (- dst-bit-offset))) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (funcall src-ref-fn src src-word-offset))) - (declare (type unit mask orig value)) - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 orig mask)))))))))) - (t - ;; They arn't aligned. - (multiple-value-bind (words final-bits) - (floor (+ dst-bit-offset length) unit-bits) - (declare (type word-offset words) (type bit-offset final-bits)) - (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits)) - (interior (floor (- length final-bits) unit-bits))) - (declare (type bit-offset src-shift) - (type word-offset interior)) - (cond - ((<= dst-offset src-offset) - ;; We need to loop from left to right - (let ((prev 0) - (next (funcall src-ref-fn src src-word-offset))) - (declare (type unit prev next)) - (flet ((get-next-src () - (setf prev next) - (setf next (funcall src-ref-fn src - (incf src-word-offset))))) - (declare (inline get-next-src)) - (unless (zerop dst-bit-offset) - (when (> src-bit-offset dst-bit-offset) - (get-next-src)) - (let ((mask (end-mask (- dst-bit-offset))) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (32bit-logical-or - (shift-towards-start prev src-shift) - (shift-towards-end next (- src-shift))))) - (declare (type unit mask orig value)) - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 orig mask))) - (incf dst-word-offset))) - (dotimes (i interior) - (get-next-src) - (let ((value (32bit-logical-or - (shift-towards-end next (- src-shift)) - (shift-towards-start prev src-shift)))) - (declare (type unit value)) - (funcall dst-set-fn dst dst-word-offset value) - (incf dst-word-offset))) - (unless (zerop final-bits) - (let ((value - (if (> (+ final-bits src-shift) unit-bits) - (progn - (get-next-src) - (32bit-logical-or - (shift-towards-end next (- src-shift)) - (shift-towards-start prev src-shift))) - (shift-towards-start next src-shift))) - (mask (start-mask final-bits)) - (orig (funcall dst-ref-fn dst dst-word-offset))) - (declare (type unit mask orig value)) - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 orig mask)))))))) - (t - ;; We need to loop from right to left. - (incf dst-word-offset words) - (incf src-word-offset - (1- (ceiling (+ src-bit-offset length) unit-bits))) - (let ((next 0) - (prev (funcall src-ref-fn src src-word-offset))) - (declare (type unit prev next)) - (flet ((get-next-src () - (setf next prev) - (setf prev (funcall src-ref-fn src - (decf src-word-offset))))) - (declare (inline get-next-src)) - (unless (zerop final-bits) - (when (> final-bits (- unit-bits src-shift)) - (get-next-src)) - (let ((value (32bit-logical-or - (shift-towards-end next (- src-shift)) - (shift-towards-start prev src-shift))) - (mask (start-mask final-bits)) - (orig (funcall dst-ref-fn dst dst-word-offset))) - (declare (type unit mask orig value)) - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 orig mask))))) - (decf dst-word-offset) - (dotimes (i interior) - (get-next-src) - (let ((value (32bit-logical-or - (shift-towards-end next (- src-shift)) - (shift-towards-start prev src-shift)))) - (declare (type unit value)) - (funcall dst-set-fn dst dst-word-offset value) - (decf dst-word-offset))) - (unless (zerop dst-bit-offset) - (if (> src-bit-offset dst-bit-offset) - (get-next-src) - (setf next prev prev 0)) - (let ((mask (end-mask (- dst-bit-offset))) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (32bit-logical-or - (shift-towards-start prev src-shift) - (shift-towards-end next (- src-shift))))) - (declare (type unit mask orig value)) - (funcall dst-set-fn dst dst-word-offset - (32bit-logical-or - (32bit-logical-and value mask) - (32bit-logical-andc2 orig mask))))))))))))))) - (undefined-value)) - - -;;;; The actual bashers. - -(defun bit-bash-fill (value dst dst-offset length) - (declare (type unit value) (type offset dst-offset length)) - (locally - (declare (optimize (speed 3) (safety 0))) - (do-constant-bit-bash dst dst-offset length value - #'%raw-bits #'%set-raw-bits))) - -(defun system-area-fill (value dst dst-offset length) - (declare (type unit value) (type offset dst-offset length)) - (locally - (declare (optimize (speed 3) (safety 0))) - (multiple-value-bind (dst dst-offset) - (fix-sap-and-offset dst dst-offset) - (do-constant-bit-bash dst dst-offset length value - #'word-sap-ref #'%set-word-sap-ref)))) - -(defun bit-bash-copy (src src-offset dst dst-offset length) - (declare (type offset src-offset dst-offset length)) - (locally - (declare (optimize (speed 3) (safety 0)) - (inline do-unary-bit-bash)) - (do-unary-bit-bash src src-offset dst dst-offset length - #'%raw-bits #'%set-raw-bits #'%raw-bits))) - -(defun system-area-copy (src src-offset dst dst-offset length) - (declare (type offset src-offset dst-offset length)) - (locally - (declare (optimize (speed 3) (safety 0))) - (multiple-value-bind (src src-offset) - (fix-sap-and-offset src src-offset) - (declare (type system-area-pointer src)) - (multiple-value-bind (dst dst-offset) - (fix-sap-and-offset dst dst-offset) - (declare (type system-area-pointer dst)) - (do-unary-bit-bash src src-offset dst dst-offset length - #'word-sap-ref #'%set-word-sap-ref - #'word-sap-ref))))) - -(defun copy-to-system-area (src src-offset dst dst-offset length) - (declare (type offset src-offset dst-offset length)) - (locally - (declare (optimize (speed 3) (safety 0))) - (multiple-value-bind (dst dst-offset) - (fix-sap-and-offset dst dst-offset) - (do-unary-bit-bash src src-offset dst dst-offset length - #'word-sap-ref #'%set-word-sap-ref #'%raw-bits)))) - -(defun copy-from-system-area (src src-offset dst dst-offset length) - (declare (type offset src-offset dst-offset length)) - (locally - (declare (optimize (speed 3) (safety 0))) - (multiple-value-bind (src src-offset) - (fix-sap-and-offset src src-offset) - (do-unary-bit-bash src src-offset dst dst-offset length - #'%raw-bits #'%set-raw-bits #'word-sap-ref)))) - diff --git a/code/byte-interp.lisp b/code/byte-interp.lisp deleted file mode 100644 index a53ce11b954a552bea71b14395dd432d848ab97f..0000000000000000000000000000000000000000 --- a/code/byte-interp.lisp +++ /dev/null @@ -1,1423 +0,0 @@ -;;; -*- Package: C -*- -;;; -;;; ********************************************************************** -;;; 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/code/byte-interp.lisp,v 1.3 1992/09/07 16:10:36 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the noise to interpret byte-compiled stuff. -;;; -;;; Written by William Lott -;;; - -(in-package "C") - - - -;;;; Types. - -(deftype stack-pointer () - `(integer 0 ,(1- most-positive-fixnum))) - -(defconstant max-pc (1- (ash 1 24))) - -(deftype pc () - `(integer 0 ,max-pc)) - -(deftype return-pc () - `(integer ,(- max-pc) ,max-pc)) - - - -;;;; The stack. - -(declaim (inline current-stack-pointer)) -(defun current-stack-pointer () - (declare (values stack-pointer)) - *eval-stack-top*) - -(declaim (inline (setf current-stack-pointer))) -(defun (setf current-stack-pointer) (new-value) - (declare (type stack-pointer new-value) - (values stack-pointer)) - (setf *eval-stack-top* new-value)) - -(declaim (inline eval-stack-ref)) -(defun eval-stack-ref (offset) - (declare (type stack-pointer offset)) - (svref eval::*eval-stack* offset)) - -(declaim (inline (setf eval-stack-ref))) -(defun (setf eval-stack-ref) (new-value offset) - (declare (type stack-pointer offset)) - (setf (svref eval::*eval-stack* offset) new-value)) - -(defun push-eval-stack (value) - (let ((len (length (the simple-vector eval::*eval-stack*))) - (sp (current-stack-pointer))) - (when (= len sp) - (let ((new-stack (make-array (ash len 1)))) - (replace new-stack eval::*eval-stack* :end1 len :end2 len) - (setf eval::*eval-stack* new-stack))) - (setf (current-stack-pointer) (1+ sp)) - (setf (eval-stack-ref sp) value))) - -(defun pop-eval-stack () - (let* ((new-sp (1- (current-stack-pointer))) - (value (eval-stack-ref new-sp))) - (setf (current-stack-pointer) new-sp) - value)) - -(defmacro multiple-value-pop-eval-stack ((&rest vars) &body body) - (declare (optimize (inhibit-warnings 3))) - (let ((num-vars (length vars)) - (index -1) - (new-sp-var (gensym "NEW-SP-")) - (decls nil)) - (loop - (unless (and (consp body) (consp (car body)) (eq (caar body) 'declare)) - (return)) - (push (pop body) decls)) - `(let ((,new-sp-var (- (current-stack-pointer) ,num-vars))) - (declare (type stack-pointer ,new-sp-var)) - (let ,(mapcar #'(lambda (var) - `(,var (eval-stack-ref - (+ ,new-sp-var ,(incf index))))) - vars) - ,@(nreverse decls) - (setf (current-stack-pointer) ,new-sp-var) - ,@body)))) - -(defun stack-copy (dest src count) - (declare (type stack-pointer dest src count)) - (dotimes (i count) - (setf (eval-stack-ref dest) (eval-stack-ref src)) - (incf dest) - (incf src))) - - - -;;;; Component access magic. - -(declaim (inline component-ref)) -(defun component-ref (component pc) - (declare (type code-component component) - (type pc pc)) - (system:sap-ref-8 (code-instructions component) pc)) - -(declaim (inline (setf component-ref))) -(defun (setf component-ref) (value component pc) - (declare (type (unsigned-byte 8) value) - (type code-component component) - (type pc pc)) - (setf (system:sap-ref-8 (code-instructions component) pc) value)) - -(declaim (inline component-ref-signed)) -(defun component-ref-signed (component pc) - (let ((byte (component-ref component pc))) - (if (logbitp 7 byte) - (logior (ash -1 8) byte) - byte))) - -(declaim (inline component-ref-24)) -(defun component-ref-24 (component pc) - (logior (ash (component-ref component pc) 16) - (ash (component-ref component (1+ pc)) 8) - (component-ref component (+ pc 2)))) - - -;;;; Debugging support. - -;;; WITH-DEBUGGER-INFO -- internal. -;;; -;;; This macro binds three magic variables. When the debugger notices that -;;; these three variables are bound, it makes a byte-code frame out of the -;;; supplied information instead of a compiled frame. We set each var in -;;; addition to binding it so the compiler doens't optimize away the binding. -;;; -(defmacro with-debugger-info ((component pc fp) &body body) - `(let ((%byte-interp-component ,component) - (%byte-interp-pc ,pc) - (%byte-interp-fp ,fp)) - (declare (optimize (debug 3))) - (setf %byte-interp-component %byte-interp-component) - (setf %byte-interp-pc %byte-interp-pc) - (setf %byte-interp-fp %byte-interp-fp) - ,@body)) - - -(defun byte-install-breakpoint (component pc) - (declare (type code-component component) - (type pc pc) - (values (unsigned-byte 8))) - (let ((orig (component-ref component pc))) - (setf (component-ref component pc) - #.(logior byte-xop - (xop-index-or-lose 'breakpoint))) - orig)) - -(defun byte-remove-breakpoint (component pc orig) - (declare (type code-component component) - (type pc pc) - (type (unsigned-byte 8) orig) - (values (unsigned-byte 8))) - (setf (component-ref component pc) orig)) - -(defun byte-skip-breakpoint (component pc fp orig) - (declare (type code-component component) - (type pc pc) - (type stack-pointer fp) - (type (unsigned-byte 8) orig)) - (byte-interpret-byte component fp pc orig)) - - - - -;;;; System constants - -;;; We don't just use *system-constants* directly because we want to be -;;; able to change it in the compiler without breaking the running -;;; byte interpreter. -;;; -(defconstant system-constants #.*system-constants*) - - - -;;;; Byte compiled function constructors/extractors. - -(defun make-byte-compiled-function (xep) - (declare (type byte-xep xep)) - (set-function-subtype - #'(lambda (&rest args) - (let ((old-sp (current-stack-pointer)) - (num-args (length args))) - (declare (type stack-pointer old-sp)) - (dolist (arg args) - (push-eval-stack arg)) - (invoke-xep nil 0 old-sp 0 num-args xep))) - vm:byte-code-function-type)) - -(defun byte-compiled-function-xep (function) - (declare (type function function) - (values byte-xep)) - (or (system:find-if-in-closure #'byte-xep-p function) - (error "Couldn't find the XEP in ~S" function))) - -(defun make-byte-compiled-closure (xep closure-vars) - (declare (type byte-xep xep) - (type simple-vector closure-vars)) - (set-function-subtype - #'(lambda (&rest args) - (let ((old-sp (current-stack-pointer)) - (num-args (length args))) - (declare (type stack-pointer old-sp)) - (dolist (arg args) - (push-eval-stack arg)) - (invoke-xep nil 0 old-sp 0 num-args xep closure-vars))) - vm:byte-code-closure-type)) - -(defun byte-compiled-closure-xep (closure) - (declare (type function closure) - (values byte-xep)) - (or (system:find-if-in-closure #'byte-xep-p closure) - (error "Couldn't find the XEP in ~S" closure))) - -(defun byte-compiled-closure-closure-vars (closure) - (declare (type function closure) - (values simple-vector)) - (or (system:find-if-in-closure #'simple-vector-p closure) - (error "Couldn't find the closure vars in ~S" closure))) - -(defun set-function-subtype (function subtype) - (setf (function-subtype function) subtype) - function) - - - -;;;; Inlines. - -(defmacro expand-into-inlines () - (declare (optimize (inhibit-warnings 3))) - (labels ((build-dispatch (bit base) - (if (minusp bit) - (let ((info (nth base *inline-functions*))) - (if info - (let* ((spec (type-specifier - (inline-function-info-type info))) - (arg-types (second spec)) - (result-type (third spec)) - (args (mapcar #'(lambda (x) - (declare (ignore x)) - (gensym)) - arg-types)) - (func - `(the ,result-type - (,(inline-function-info-function info) - ,@args)))) - `(multiple-value-pop-eval-stack ,args - (declare ,@(mapcar #'(lambda (type var) - `(type ,type ,var)) - arg-types args)) - ,(if (and (consp result-type) - (eq (car result-type) 'values)) - (let ((results - (mapcar #'(lambda (x) - (declare (ignore x)) - (gensym)) - (cdr result-type)))) - `(multiple-value-bind - ,results ,func - ,@(mapcar #'(lambda (res) - `(push-eval-stack ,res)) - results))) - `(push-eval-stack ,func)))) - `(error "Unknown inline function, id=~D" ,base))) - `(if (zerop (logand byte ,(ash 1 bit))) - ,(build-dispatch (1- bit) base) - ,(build-dispatch (1- bit) (+ base (ash 1 bit))))))) - (build-dispatch 4 0))) - -(declaim (inline value-cell-setf)) -(defun value-cell-setf (value cell) - (value-cell-set cell value) - value) - -(declaim (inline setf-symbol-value)) -(defun setf-symbol-value (value symbol) - (setf (symbol-value symbol) value)) - -(declaim (inline %byte-special-bind)) -(defun %byte-special-bind (value symbol) - (system:%primitive bind value symbol) - (values)) - -(declaim (inline %byte-special-unbind)) -(defun %byte-special-unbind () - (system:%primitive unbind) - (values)) - -(declaim (inline cons-unique-tag)) -(defun cons-unique-tag () - (list '#:%unique-tag%)) - - -;;;; Two-arg function stubs: -;;; -;;; We have two-arg versions of some n-ary functions that are normally -;;; open-coded. - -(defun two-arg-char= (x y) (char= x y)) -(defun two-arg-char< (x y) (char< x y)) -(defun two-arg-char> (x y) (char> x y)) -(defun two-arg-char-equal (x y) (char-equal x y)) -(defun two-arg-char-lessp (x y) (char-lessp x y)) -(defun two-arg-char-greaterp (x y) (char-greaterp x y)) - - -;;;; XOPs - -;;; Extension operations (XOPs) are random magic things that the byte -;;; interpreter needs to do, but can't be represented as a function call. -;;; When the byte interpreter encounters an XOP in the byte stream, it -;;; tail-calls the corresponding XOP routine extracted from *byte-xops*. -;;; The XOP routine can do whatever it wants, probably re-invoking the -;;; byte interpreter. - -;;; UNDEFINED-XOP -- internal. -;;; -;;; If a real XOP hasn't been defined, this gets invoked and signals an -;;; error. This shouldn't happen in normal operation. -;;; -(defun undefined-xop (component old-pc pc fp) - (declare (ignore component old-pc pc fp)) - (error "Undefined XOP.")) - -;;; *BYTE-XOPS* -- Simple vector of the XOP functions. -;;; -(declaim (type (simple-vector 256) *byte-xops*)) -(defvar *byte-xops* - (make-array 256 :initial-element #'undefined-xop)) - -;;; DEFINE-XOP -- internal. -;;; -;;; Define a XOP function and install it in *BYTE-XOPS*. -;;; -(eval-when (compile eval) - (defmacro define-xop (name lambda-list &body body) - (let ((defun-name (symbolicate "BYTE-" name "-XOP"))) - `(progn - (defun ,defun-name ,lambda-list - ,@body) - (setf (aref *byte-xops* ,(xop-index-or-lose name)) #',defun-name) - ',defun-name)))) - -;;; BREAKPOINT -- Xop. -;;; -;;; This is spliced in by the debugger in order to implement breakpoints. -;;; -(define-xop breakpoint (component old-pc pc fp) - (declare (type code-component component) - (type pc old-pc) - (ignore pc) - (type stack-pointer fp)) - ;; Invoke the debugger. - (with-debugger-info (component old-pc fp) - (di::handle-breakpoint component old-pc fp)) - ;; Retry the breakpoint XOP in case it was replaced with the original - ;; displaced byte-code. - (byte-interpret component old-pc fp)) - -;;; DUP -- Xop. -;;; -;;; This just duplicates whatever is on the top of the stack. -;;; -(define-xop dup (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let ((value (eval-stack-ref (1- (current-stack-pointer))))) - (push-eval-stack value)) - (byte-interpret component pc fp)) - -;;; MAKE-CLOSURE -- Xop. -;;; -(define-xop make-closure (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let* ((num-closure-vars (pop-eval-stack)) - (closure-vars (make-array num-closure-vars))) - (declare (type index num-closure-vars) - (type simple-vector closure-vars)) - (iterate frob ((index (1- num-closure-vars))) - (unless (minusp index) - (setf (svref closure-vars index) (pop-eval-stack)) - (frob (1- index)))) - (push-eval-stack (make-byte-compiled-closure (pop-eval-stack) - closure-vars))) - (byte-interpret component pc fp)) - -(define-xop merge-unknown-values (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (labels ((grovel (remaining-blocks block-count-ptr) - (declare (type index remaining-blocks) - (type stack-pointer block-count-ptr)) - (declare (values index stack-pointer)) - (let ((block-count (eval-stack-ref block-count-ptr))) - (declare (type index block-count)) - (if (= remaining-blocks 1) - (values block-count block-count-ptr) - (let ((src (- block-count-ptr block-count))) - (declare (type index src)) - (multiple-value-bind - (values-above dst) - (grovel (1- remaining-blocks) (1- src)) - (stack-copy dst src block-count) - (values (+ values-above block-count) - (+ dst block-count)))))))) - (multiple-value-bind - (total-count end-ptr) - (grovel (pop-eval-stack) (1- (current-stack-pointer))) - (setf (eval-stack-ref end-ptr) total-count) - (setf (current-stack-pointer) (1+ end-ptr)))) - (byte-interpret component pc fp)) - -(define-xop default-unknown-values (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let* ((desired (pop-eval-stack)) - (supplied (pop-eval-stack)) - (delta (- desired supplied))) - (declare (type index desired supplied) - (type fixnum delta)) - (cond ((minusp delta) - (incf (current-stack-pointer) delta)) - ((plusp delta) - (dotimes (i delta) - (push-eval-stack nil))))) - (byte-interpret component pc fp)) - -;;; THROW -- XOP -;;; -;;; %THROW is compiled down into this xop. The stack contains the tag, the -;;; values, and then a count of the values. We special case various small -;;; numbers of values to keep from consing if we can help it. -;;; -;;; Basically, we just extract the values and the tag and then do a throw. -;;; The native compiler will convert this throw into whatever is necessary -;;; to throw, so we don't have to duplicate all that cruft. -;;; -(define-xop throw (component old-pc pc fp) - (declare (type code-component component) - (type pc old-pc) - (ignore pc) - (type stack-pointer fp)) - (let ((num-results (pop-eval-stack))) - (declare (type index num-results)) - (case num-results - (0 - (let ((tag (pop-eval-stack))) - (with-debugger-info (component old-pc fp) - (throw tag (values))))) - (1 - (multiple-value-pop-eval-stack - (tag result) - (with-debugger-info (component old-pc fp) - (throw tag result)))) - (2 - (multiple-value-pop-eval-stack - (tag result0 result1) - (with-debugger-info (component old-pc fp) - (throw tag (values result0 result1))))) - (t - (let ((results nil)) - (dotimes (i num-results) - (push (pop-eval-stack) results)) - (let ((tag (pop-eval-stack))) - (with-debugger-info (component old-pc fp) - (throw tag (values-list results))))))))) - -;;; CATCH -- XOP -;;; -;;; This is used for both CATCHes and BLOCKs that are closed over. We -;;; establish a catcher for the supplied tag (from the stack top), and -;;; recursivly enter the byte interpreter. If the byte interpreter exits, -;;; it must have been because of a BREAKUP (see below), so we branch (by -;;; tail-calling the byte interpreter) to the pc returned by BREAKUP. -;;; If we are thrown to, then we branch to the address encoded in the 3 bytes -;;; following the catch XOP. -;;; -(define-xop catch (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let ((new-pc (block nil - (let ((results - (multiple-value-list - (catch (pop-eval-stack) - (return (byte-interpret component (+ pc 3) fp)))))) - (let ((num-results 0)) - (declare (type index num-results)) - (dolist (result results) - (push-eval-stack result) - (incf num-results)) - (push-eval-stack num-results)) - (component-ref-24 component pc))))) - (byte-interpret component new-pc fp))) - -;;; BREAKUP -- XOP -;;; -;;; Blow out of the dynamically nested CATCH or TAGBODY. We just return the -;;; pc following the BREAKUP XOP and the drop-through code in CATCH or -;;; TAGBODY will do the correct thing. -;;; -(define-xop breakup (component old-pc pc fp) - (declare (ignore component old-pc fp) - (type pc pc)) - pc) - -;;; RETURN-FROM -- XOP -;;; -;;; This is exactly like THROW, except that the tag is the last thing on -;;; the stack instead of the first. This is used for RETURN-FROM (hence the -;;; name). -;;; -(define-xop return-from (component old-pc pc fp) - (declare (type code-component component) - (type pc old-pc) - (ignore pc) - (type stack-pointer fp)) - (let ((tag (pop-eval-stack)) - (num-results (pop-eval-stack))) - (declare (type index num-results)) - (case num-results - (0 - (with-debugger-info (component old-pc fp) - (throw tag (values)))) - (1 - (let ((value (pop-eval-stack))) - (with-debugger-info (component old-pc fp) - (throw tag value)))) - (2 - (multiple-value-pop-eval-stack - (result0 result1) - (with-debugger-info (component old-pc fp) - (throw tag (values result0 result1))))) - (t - (let ((results nil)) - (dotimes (i num-results) - (push (pop-eval-stack) results)) - (with-debugger-info (component old-pc fp) - (throw tag (values-list results)))))))) - -;;; TAGBODY -- XOP -;;; -;;; Similar to CATCH, except for TAGBODY. One significant difference is that -;;; when thrown to, we don't want to leave the dynamic extent of the tagbody -;;; so we loop around and re-enter the catcher. We keep looping until BREAKUP -;;; is used to blow out. When that happens, we just branch to the pc supplied -;;; by BREAKUP. -;;; -(define-xop tagbody (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let* ((tag (pop-eval-stack)) - (new-pc (block nil - (loop - (setf pc - (catch tag - (return (byte-interpret component pc fp)))))))) - (byte-interpret component new-pc fp))) - -;;; GO -- XOP -;;; -;;; Yup, you guessed it. This XOP implements GO. There are no values to -;;; pass, so we don't have to mess with them, and multiple exits can all be -;;; using the same tag so we have to pass the pc we want to go to. -;;; -(define-xop go (component old-pc pc fp) - (declare (type code-component component) - (type pc old-pc pc) - (type stack-pointer fp)) - (let ((tag (pop-eval-stack)) - (new-pc (component-ref-24 component pc))) - (with-debugger-info (component old-pc fp) - (throw tag new-pc)))) - -;;; UNWIND-PROTECT -- XOP -;;; -;;; Unwind-protects are handled significantly different in the byte compiler -;;; and the native compiler. Basically, we just use the native-compiler's -;;; unwind-protect, and let it worry about continuing the unwind. -;;; -(define-xop unwind-protect (component old-pc pc fp) - (declare (type code-component component) - (ignore old-pc) - (type pc pc) - (type stack-pointer fp)) - (let ((new-pc nil)) - (unwind-protect - (setf new-pc (byte-interpret component (+ pc 3) fp)) - (unless new-pc - ;; The cleanup function expects 3 values to be one the stack, so - ;; we have to put something there. - (push-eval-stack nil) - (push-eval-stack nil) - (push-eval-stack nil) - ;; Now run the cleanup code. - (byte-interpret component (component-ref-24 component pc) fp))) - (byte-interpret component new-pc fp))) - - -(define-xop fdefn-function-or-lose (component old-pc pc fp) - (let* ((fdefn (pop-eval-stack)) - (fun (fdefn-function fdefn))) - (declare (type fdefn fdefn)) - (cond (fun - (push-eval-stack fun) - (byte-interpret component pc fp)) - (t - (with-debugger-info (component old-pc fp) - (error 'undefined-function :name (fdefn-name fdefn))))))) - - - -;;;; Type checking: - -;;; -;;; These two hashtables map between type specifiers and type predicate -;;; functions that test those types. They are initialized according to the -;;; standard type predicates of the target system. -;;; -(defvar *byte-type-predicates* (make-hash-table :test #'equal)) -(defvar *byte-predicate-types* (make-hash-table :test #'eq)) - -(loop for (type predicate) in - '#.(loop for (type . predicate) in - (backend-type-predicates *target-backend*) - collect `(,(type-specifier type) ,predicate)) - do - (let ((fun (fdefinition predicate))) - (setf (gethash type *byte-type-predicates*) fun) - (setf (gethash fun *byte-predicate-types*) type))) - - -;;; LOAD-TYPE-PREDICATE -- Internal -;;; -;;; Called by the loader to convert a type specifier into a type predicate -;;; (as used by the TYPE-CHECK XOP.) If it is a structure type with a -;;; predicate or has a predefined predicate, then return the predicate -;;; function, otherwise return the CTYPE structure for the type. -;;; -(defun load-type-predicate (desc) - (or (gethash desc *byte-type-predicates*) - (let ((type (specifier-type desc))) - (if (structure-type-p type) - (let ((info (info type defined-structure-info - (structure-type-name type)))) - (if (and info (eq (dd-type info) 'structure)) - (let ((pred (dd-predicate info))) - (if (and pred (fboundp pred)) - (fdefinition pred) - type)) - type)) - type)))) - - -;;; TYPE-CHECK -- Xop. -;;; -;;; Check the type of the value on the top of the stack. The type is -;;; designated by an entry in the constants. If the value is a function, then -;;; it is called as a type predicate. Otherwise, the value is a CTYPE object, -;;; and we call %%TYPEP on it. -;;; -(define-xop type-check (component old-pc pc fp) - (declare (type code-component component) - (type pc old-pc pc) - (type stack-pointer fp)) - (multiple-value-bind - (operand new-pc) - (let ((operand (component-ref component pc))) - (if (= operand #xff) - (values (component-ref-24 component (1+ pc)) (+ pc 4)) - (values operand (1+ pc)))) - (let ((value (eval-stack-ref (1- (current-stack-pointer)))) - (type (code-header-ref component - (+ operand vm:code-constants-offset)))) - (unless (if (functionp type) - (funcall type value) - (lisp::%%typep value type)) - (with-debugger-info (component old-pc fp) - (error 'type-error - :datum value - :expected-type (if (functionp type) - (gethash type *byte-predicate-types*) - (type-specifier type)))))) - - (byte-interpret component new-pc fp))) - - -;;;; The byte-interpreter. - - -;;; The various operations are encoded as follows. -;;; -;;; 0000xxxx push-local op -;;; 0001xxxx push-arg op [push-local, but negative] -;;; 0010xxxx push-constant op -;;; 0011xxxx push-system-constant op -;;; 0100xxxx push-int op -;;; 0101xxxx push-neg-int op -;;; 0110xxxx pop-local op -;;; 0111xxxx pop-n op -;;; 1000nxxx call op -;;; 1001nxxx tail-call op -;;; 1010nxxx multiple-call op -;;; 10110xxx local-call -;;; 10111xxx local-tail-call -;;; 11000xxx local-multiple-call -;;; 11001xxx return -;;; 1101000r branch -;;; 1101001r if-true -;;; 1101010r if-false -;;; 1101011r if-eq -;;; 11011xxx Xop -;;; 11100000 -;;; to various inline functions. -;;; 11111111 -;;; -;;; This encoding is rather hard wired into BYTE-INTERPRET due to the binary -;;; dispatch tree. -;;; - -#+nil (declaim (start-block byte-interpret byte-interpret-byte - invoke-xep invoke-local-entry-point)) - -(defvar *byte-trace* nil) - -;;; BYTE-INTERPRET -- Internal Interface. -;;; -;;; Main entry point to the byte interpreter. -;;; -(defun byte-interpret (component pc fp) - (declare (type code-component component) - (type pc pc) - (type stack-pointer fp)) - (byte-interpret-byte component pc fp (component-ref component pc))) - -;;; BYTE-INTERPRET-BYTE -- Internal. -;;; -;;; This is seperated from BYTE-INTERPRET so we can continue from a breakpoint -;;; without having to replace the breakpoint with the original instruction -;;; and arrange to somehow put the breakpoint back after executing the -;;; instruction. We just leave the breakpoint there, and calls this function -;;; with the byte the breakpoint displaced. -;;; -(defun byte-interpret-byte (component pc fp byte) - (declare (type code-component component) - (type pc pc) - (type stack-pointer fp) - (type (unsigned-byte 8) byte)) - (locally (declare (optimize (inhibit-warnings 3))) - (when *byte-trace* - (format *trace-output* "pc=~D, fp=~D, sp=~D, byte=#b~8,'0B, frame=~S~%" - pc fp (current-stack-pointer) byte - (subseq eval::*eval-stack* fp (current-stack-pointer))))) - (if (zerop (logand byte #x80)) - ;; Some stack operation. No matter what, we need the operand, - ;; so compute it. - (multiple-value-bind - (operand new-pc) - (let ((operand (logand byte #xf))) - (if (= operand #xf) - (let ((operand (component-ref component (1+ pc)))) - (if (= operand #xff) - (values (component-ref-24 component (+ pc 2)) - (+ pc 5)) - (values operand (+ pc 2)))) - (values operand (1+ pc)))) - (if (zerop (logand byte #x40)) - (push-eval-stack (if (zerop (logand byte #x20)) - (if (zerop (logand byte #x10)) - (eval-stack-ref (+ fp operand)) - (eval-stack-ref (- fp operand 5))) - (if (zerop (logand byte #x10)) - (code-header-ref - component - (+ operand vm:code-constants-offset)) - (svref system-constants operand)))) - (if (zerop (logand byte #x20)) - (push-eval-stack (if (zerop (logand byte #x10)) - operand - (- (1+ operand)))) - (if (zerop (logand byte #x10)) - (setf (eval-stack-ref (+ fp operand)) (pop-eval-stack)) - (if (zerop operand) - (let ((operand (pop-eval-stack))) - (declare (type index operand)) - (decf (current-stack-pointer) operand)) - (decf (current-stack-pointer) operand))))) - (byte-interpret component new-pc fp)) - (if (zerop (logand byte #x40)) - ;; Some kind of call. - (let ((args (let ((args (logand byte #x07))) - (if (= args #x07) - (pop-eval-stack) - args)))) - (if (zerop (logand byte #x20)) - (let ((named (not (zerop (logand byte #x08))))) - (if (zerop (logand byte #x10)) - ;; Call for single value. - (do-call component pc (1+ pc) fp args named) - ;; Tail call. - (do-tail-call component pc fp args named))) - (if (zerop (logand byte #x10)) - ;; Call for multiple-values. - (do-call component pc (- (1+ pc)) fp args - (not (zerop (logand byte #x08)))) - (if (zerop (logand byte #x08)) - ;; Local call - (do-local-call component pc (+ pc 4) fp args) - ;; Local tail-call - (do-tail-local-call component pc fp args))))) - (if (zerop (logand byte #x20)) - ;; local-multiple-call, Return, branch, or Xop. - (if (zerop (logand byte #x10)) - ;; local-multiple-call or return. - (if (zerop (logand byte #x08)) - ;; Local-multiple-call. - (do-local-call component pc (- (+ pc 4)) fp - (let ((args (logand byte #x07))) - (if (= args #x07) - (pop-eval-stack) - args))) - ;; Return. - (let ((num-results - (let ((num-results (logand byte #x7))) - (if (= num-results 7) - (pop-eval-stack) - num-results)))) - (do-return fp num-results))) - ;; Branch or Xop. - (if (zerop (logand byte #x08)) - ;; Branch. - (if (if (zerop (logand byte #x04)) - (if (zerop (logand byte #x02)) - t - (pop-eval-stack)) - (if (zerop (logand byte #x02)) - (not (pop-eval-stack)) - (multiple-value-pop-eval-stack - (val1 val2) - (eq val1 val2)))) - ;; Branch taken. - (byte-interpret - component - (if (zerop (logand byte #x01)) - (component-ref-24 component (1+ pc)) - (+ pc 2 - (component-ref-signed component (1+ pc)))) - fp) - ;; Branch not taken. - (byte-interpret component - (if (zerop (logand byte #x01)) - (+ pc 4) - (+ pc 2)) - fp)) - ;; Xop. - (multiple-value-bind - (sub-code new-pc) - (let ((operand (logand byte #x7))) - (if (= operand #x7) - (values (component-ref component (+ pc 1)) - (+ pc 2)) - (values operand (1+ pc)))) - (funcall (the function (svref *byte-xops* sub-code)) - component pc new-pc fp)))) - ;; Random inline function. - (progn - (expand-into-inlines) - (byte-interpret component (1+ pc) fp)))))) - -(defun do-local-call (component pc old-pc old-fp num-args) - (declare (type pc pc) - (type return-pc old-pc) - (type stack-pointer old-fp) - (type (integer 0 #.call-arguments-limit) num-args)) - (invoke-local-entry-point component (component-ref-24 component (1+ pc)) - component old-pc - (- (current-stack-pointer) num-args) - old-fp)) - -(defun do-tail-local-call (component pc fp num-args) - (declare (type code-component component) (type pc pc) - (type stack-pointer fp) - (type index num-args)) - (let ((old-fp (eval-stack-ref (- fp 1))) - (old-sp (eval-stack-ref (- fp 2))) - (old-pc (eval-stack-ref (- fp 3))) - (old-component (eval-stack-ref (- fp 4))) - (start-of-args (- (current-stack-pointer) num-args))) - (stack-copy old-sp start-of-args num-args) - (setf (current-stack-pointer) (+ old-sp num-args)) - (invoke-local-entry-point component (component-ref-24 component (1+ pc)) - old-component old-pc old-sp old-fp))) - -(defun invoke-local-entry-point (component target old-component old-pc old-sp - old-fp &optional closure-vars) - (declare (type pc target) - (type return-pc old-pc) - (type stack-pointer old-sp old-fp) - (type (or null simple-vector) closure-vars)) - (when closure-vars - (iterate more ((index (1- (length closure-vars)))) - (unless (minusp index) - (push-eval-stack (svref closure-vars index)) - (more (1- index))))) - (push-eval-stack old-component) - (push-eval-stack old-pc) - (push-eval-stack old-sp) - (push-eval-stack old-fp) - (multiple-value-bind - (stack-frame-size entry-pc) - (let ((byte (component-ref component target))) - (if (= byte 255) - (values (component-ref-24 component (1+ target)) (+ target 4)) - (values (* byte 2) (1+ target)))) - (declare (type pc entry-pc)) - (let ((fp (current-stack-pointer))) - (setf (current-stack-pointer) (+ fp stack-frame-size)) - (byte-interpret component entry-pc fp)))) - - -;;; BYTE-APPLY -- Internal -;;; -;;; Call a function with some arguments popped off of the interpreter stack, -;;; and restore the SP to the specifier value. -;;; -(defun byte-apply (function num-args restore-sp) - (declare (function function) (type index num-args)) - (let ((start (- (current-stack-pointer) num-args))) - (declare (type stack-pointer start)) - (macrolet ((frob () - `(case num-args - ,@(loop for n below 8 - collect `(,n (call-1 ,n))) - (t - (let ((args ()) - (end (+ start num-args))) - (declare (type stack-pointer end)) - (do ((i start (1+ i))) - ((= i end)) - (declare (type stack-pointer i)) - (push (eval-stack-ref i) args)) - (setf (current-stack-pointer) restore-sp) - (apply function args))))) - (call-1 (n) - (collect ((binds) - (args)) - (dotimes (i n) - (let ((dum (gensym))) - (binds `(,dum (eval-stack-ref (+ start ,i)))) - (args dum))) - `(let ,(binds) - (setf (current-stack-pointer) restore-sp) - (funcall function ,@(args)))))) - (frob)))) - - -(defun do-call (old-component call-pc ret-pc old-fp num-args named) - (declare (type code-component old-component) - (type pc call-pc) - (type return-pc ret-pc) - (type stack-pointer old-fp) - (type (integer 0 #.call-arguments-limit) num-args) - (type (member t nil) named)) - (let* ((old-sp (- (current-stack-pointer) num-args 1)) - (fun-or-fdefn (eval-stack-ref old-sp)) - (function (if named - (or (fdefn-function fun-or-fdefn) - (with-debugger-info (old-component call-pc old-fp) - (error 'undefined-function - :name (fdefn-name fun-or-fdefn)))) - fun-or-fdefn))) - (declare (type stack-pointer old-sp) - (type (or function fdefn) fun-or-fdefn) - (type function function)) - (case (function-subtype function) - (#.vm:byte-code-function-type - (invoke-xep old-component ret-pc old-sp old-fp num-args - (byte-compiled-function-xep function))) - (#.vm:byte-code-closure-type - (invoke-xep old-component ret-pc old-sp old-fp num-args - (byte-compiled-closure-xep function) - (byte-compiled-closure-closure-vars function))) - (t - (cond ((minusp ret-pc) - (let* ((ret-pc (- ret-pc)) - (results - (multiple-value-list - (with-debugger-info - (old-component ret-pc old-fp) - (byte-apply function num-args old-sp))))) - (dolist (result results) - (push-eval-stack result)) - (push-eval-stack (length results)) - (byte-interpret old-component ret-pc old-fp))) - (t - (push-eval-stack - (with-debugger-info - (old-component ret-pc old-fp) - (byte-apply function num-args old-sp))) - (byte-interpret old-component ret-pc old-fp))))))) - - -(defun do-tail-call (component pc fp num-args named) - (declare (type code-component component) - (type pc pc) - (type stack-pointer fp) - (type (integer 0 #.call-arguments-limit) num-args) - (type (member t nil) named)) - (let* ((start-of-args (- (current-stack-pointer) num-args)) - (fun-or-fdefn (eval-stack-ref (1- start-of-args))) - (function (if named - (or (fdefn-function fun-or-fdefn) - (with-debugger-info (component pc fp) - (error 'undefined-function - :name (fdefn-name fun-or-fdefn)))) - fun-or-fdefn)) - (old-fp (eval-stack-ref (- fp 1))) - (old-sp (eval-stack-ref (- fp 2))) - (old-pc (eval-stack-ref (- fp 3))) - (old-component (eval-stack-ref (- fp 4)))) - (declare (type stack-pointer old-fp old-sp start-of-args) - (type return-pc old-pc) - (type (or fdefn function) fun-or-fdefn) - (type function function)) - (case (function-subtype function) - (#.vm:byte-code-function-type - (stack-copy old-sp start-of-args num-args) - (setf (current-stack-pointer) (+ old-sp num-args)) - (invoke-xep old-component old-pc old-sp old-fp num-args - (byte-compiled-function-xep function))) - (#.vm:byte-code-closure-type - (stack-copy old-sp start-of-args num-args) - (setf (current-stack-pointer) (+ old-sp num-args)) - (invoke-xep old-component old-pc old-sp old-fp num-args - (byte-compiled-closure-xep function) - (byte-compiled-closure-closure-vars function))) - (t - ;; We are tail-calling native code. - (cond ((null old-component) - ;; We were called by native code. - (byte-apply function num-args old-sp)) - ((minusp old-pc) - ;; We were called for multiple values. So return multiple - ;; values. - (let ((results - (multiple-value-list - (with-debugger-info - (old-component old-pc old-fp) - (byte-apply function num-args old-sp))))) - (dolist (result results) - (push-eval-stack result)) - (push-eval-stack (length results))) - (byte-interpret old-component old-pc old-fp)) - (t - ;; We were called for one value. So return one value. - (push-eval-stack - (with-debugger-info - (old-component old-pc old-fp) - (byte-apply function num-args old-sp))) - (byte-interpret old-component old-pc old-fp))))))) - -(defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep - &optional closure-vars) - (declare (type (or null code-component) old-component) - (type index num-args) - (type return-pc ret-pc) - (type stack-pointer old-sp old-fp) - (type byte-xep xep) - (type (or null simple-vector) closure-vars)) - (let ((entry-point - (let ((min (byte-xep-min-args xep)) - (max (byte-xep-max-args xep))) - (cond - ((< num-args min) - ;; ### Flame out point. - (error "Not enough arguments.")) - ((<= num-args max) - (nth (- num-args min) (byte-xep-entry-points xep))) - ((null (byte-xep-more-args-entry-point xep)) - ;; ### Flame out point. - (error "Too many arguments.")) - (t - (let* ((more-args-supplied (- num-args max)) - (sp (current-stack-pointer)) - (more-args-start (- sp more-args-supplied)) - (restp (byte-xep-rest-arg-p xep)) - (rest (and restp - (do ((index (1- sp) (1- index)) - (result nil - (cons (eval-stack-ref index) - result))) - ((< index more-args-start) result) - (declare (type index index)))))) - (declare (type index more-args-supplied) - (type stack-pointer more-args-start)) - (cond - ((not (byte-xep-keywords-p xep)) - (assert restp) - (setf (current-stack-pointer) (1+ more-args-start)) - (setf (eval-stack-ref more-args-start) rest)) - (t - (unless (evenp more-args-supplied) - ;; ### Flame out. - (error "Odd number of keyword arguments.")) - (let* ((num-more-args (byte-xep-num-more-args xep)) - (new-sp (+ more-args-start num-more-args)) - (temp (max sp new-sp)) - (temp-sp (+ temp more-args-supplied)) - (keywords (byte-xep-keywords xep))) - (declare (type index temp) - (type stack-pointer new-sp temp-sp)) - (setf (current-stack-pointer) temp-sp) - (stack-copy temp more-args-start more-args-supplied) - (when restp - (setf (eval-stack-ref more-args-start) rest) - (incf more-args-start)) - (let ((index more-args-start)) - (dolist (keyword keywords) - (setf (eval-stack-ref index) (cadr keyword)) - (incf index) - (when (caddr keyword) - (setf (eval-stack-ref index) nil) - (incf index)))) - (let ((index temp-sp) - (allow (eq (byte-xep-keywords-p xep) :allow-others)) - (bogus-key nil) - (bogus-key-p nil)) - (declare (type stack-pointer index)) - (loop - (decf index 2) - (when (< index more-args-start) - (return)) - (let ((key (eval-stack-ref index)) - (value (eval-stack-ref (1+ index)))) - (if (eq key :allow-other-keys) - (setf allow value) - (let ((target more-args-start)) - (declare (type stack-pointer target)) - (dolist (keyword keywords - (setf bogus-key key - bogus-key-p t)) - (cond ((eq (car keyword) key) - (setf (eval-stack-ref target) value) - (when (caddr keyword) - (setf (eval-stack-ref (1+ target)) - t)) - (return)) - ((caddr keyword) - (incf target 2)) - (t - (incf target)))))))) - (when (and bogus-key-p (not allow)) - ;; ### Flame out. - (error "Unknown keyword: ~S" bogus-key))) - (setf (current-stack-pointer) new-sp))))) - (byte-xep-more-args-entry-point xep)))))) - (declare (type pc entry-point)) - (invoke-local-entry-point (byte-xep-component xep) entry-point - old-component ret-pc old-sp old-fp - closure-vars))) - -(defun do-return (fp num-results) - (declare (type stack-pointer fp) (type index num-results)) - (let ((old-component (eval-stack-ref (- fp 4)))) - (typecase old-component - (code-component - ;; Returning to more byte-interpreted code. - (do-local-return old-component fp num-results)) - (null - ;; Returning to native code. - (let ((old-sp (eval-stack-ref (- fp 2)))) - (case num-results - (0 - (setf (current-stack-pointer) old-sp) - (values)) - (1 - (let ((result (pop-eval-stack))) - (setf (current-stack-pointer) old-sp) - result)) - (t - (let ((results nil)) - (dotimes (i num-results) - (push (pop-eval-stack) results)) - (setf (current-stack-pointer) old-sp) - (values-list results)))))) - (t - ;; ### Function end breakpoint? - (error "function-end breakpoints not supported."))))) - -(defun do-local-return (old-component fp num-results) - (declare (type stack-pointer fp) (type index num-results)) - (let ((old-fp (eval-stack-ref (- fp 1))) - (old-sp (eval-stack-ref (- fp 2))) - (old-pc (eval-stack-ref (- fp 3)))) - (declare (type (signed-byte 25) old-pc)) - (if (plusp old-pc) - ;; Wants single value. - (let ((result (if (zerop num-results) - nil - (eval-stack-ref (- (current-stack-pointer) - num-results))))) - (setf (current-stack-pointer) old-sp) - (push-eval-stack result) - (byte-interpret old-component old-pc old-fp)) - ;; Wants multiple values. - (progn - (stack-copy old-sp (- (current-stack-pointer) num-results) - num-results) - (setf (current-stack-pointer) (+ old-sp num-results)) - (push-eval-stack num-results) - (byte-interpret old-component (- old-pc) old-fp))))) - -;(declaim (end-block byte-interpret byte-interpret-byte invoke-xep)) - - -;;;; Random testing noise. - -(defun dump-byte-fun (fun) - (declare (optimize (inhibit-warnings 3))) - (let* ((xep (system:find-if-in-closure #'byte-xep-p fun)) - (component (byte-xep-component xep)) - (bytes (* (code-header-ref component vm:code-code-size-slot) - vm:word-bytes))) - (dotimes (index bytes) - (format t "~3D: #b~8,'0B~%" index (component-ref component index))))) - - -(defun disassem-byte-fun (fun) - (declare (optimize (inhibit-warnings 3))) - (let* ((xep (system:find-if-in-closure #'byte-xep-p fun)) - (component (byte-xep-component xep)) - (bytes (* (code-header-ref component vm:code-code-size-slot) - vm:word-bytes)) - (index 0)) - (labels ((newline () - (format t "~&~4D:" index)) - (next-byte () - (let ((byte (component-ref component index))) - (format t " ~2,'0X" byte) - (incf index) - byte)) - (extract-24-bits () - (logior (ash (next-byte) 16) - (ash (next-byte) 8) - (next-byte))) - (extract-extended-op () - (let ((byte (next-byte))) - (if (= byte 255) - (extract-24-bits) - byte))) - (extract-4-bit-op (byte) - (let ((4-bits (ldb (byte 4 0) byte))) - (if (= 4-bits 15) - (extract-extended-op) - 4-bits))) - (extract-3-bit-op (byte) - (let ((3-bits (ldb (byte 3 0) byte))) - (if (= 3-bits 7) - :var - 3-bits))) - (extract-branch-target (byte) - (if (logbitp 0 byte) - (let ((disp (next-byte))) - (if (logbitp 7 disp) - (+ index disp -256) - (+ index disp))) - (extract-24-bits))) - (note (string &rest noise) - (format t "~12T~?" string noise)) - (get-constant (index) - (let ((index (+ index vm:code-constants-offset))) - (if (< (1- vm:code-constants-offset) - index - (get-header-data component)) - (code-header-ref component index) - "<bogus index>")))) - - (newline) - (let ((frame-size - (let ((byte (next-byte))) - (if (< byte 255) - (* byte 2) - (logior (ash (next-byte) 16) - (ash (next-byte) 8) - (next-byte)))))) - (note "Entry point, frame-size=~D~%" frame-size)) - (loop - (unless (< index bytes) - (return)) - (newline) - (let ((byte (next-byte))) - (macrolet ((dispatch (&rest clauses) - `(cond ,@(mapcar #'(lambda (clause) - `((= (logand byte ,(caar clause)) - ,(cadar clause)) - ,@(cdr clause))) - clauses)))) - (dispatch - ((#b11110000 #b00000000) - (let ((op (extract-4-bit-op byte))) - (note "push-local ~D" op))) - ((#b11110000 #b00010000) - (let ((op (extract-4-bit-op byte))) - (note "push-arg ~D" op))) - ((#b11110000 #b00100000) - (let ((index (+ (extract-4-bit-op byte) - vm:code-constants-offset)) - (*print-level* 3) - (*print-lines* 2)) - (note "push-const ~S" - (if (< (1- vm:code-constants-offset) - index - (get-header-data component)) - (code-header-ref component index) - "<bogus index>")))) - ((#b11110000 #b00110000) - (let ((op (extract-4-bit-op byte)) - (*print-level* 3) - (*print-lines* 2)) - (note "push-sys-const ~S" - (svref system-constants op)))) - ((#b11110000 #b01000000) - (let ((op (extract-4-bit-op byte))) - (note "push-int ~D" op))) - ((#b11110000 #b01010000) - (let ((op (extract-4-bit-op byte))) - (note "push-neg-int ~D" (- (1+ op))))) - ((#b11110000 #b01100000) - (let ((op (extract-4-bit-op byte))) - (note "pop-local ~D" op))) - ((#b11110000 #b01110000) - (let ((op (extract-4-bit-op byte))) - (note "pop-n ~D" op))) - ((#b11110000 #b10000000) - (let ((op (extract-3-bit-op byte))) - (note "~:[~;named-~]call, ~D args" - (logbitp 3 byte) op))) - ((#b11110000 #b10010000) - (let ((op (extract-3-bit-op byte))) - (note "~:[~;named-~]tail-call, ~D args" - (logbitp 3 byte) op))) - ((#b11110000 #b10100000) - (let ((op (extract-3-bit-op byte))) - (note "~:[~;named-~]multiple-call, ~D args" - (logbitp 3 byte) op))) - ((#b11111000 #b10110000) - ;; local call - (let ((op (extract-3-bit-op byte)) - (target (extract-24-bits))) - (note "local call ~D, ~D args" target op))) - ((#b11111000 #b10111000) - ;; local tail-call - (let ((op (extract-3-bit-op byte)) - (target (extract-24-bits))) - (note "local tail-call ~D, ~D args" target op))) - ((#b11111000 #b11000000) - ;; local-multiple-call - (let ((op (extract-3-bit-op byte)) - (target (extract-24-bits))) - (note "local multiple-call ~D, ~D args" target op))) - ((#b11111000 #b11001000) - ;; return - (let ((op (extract-3-bit-op byte))) - (note "return, ~D vals" op))) - ((#b11111110 #b11010000) - ;; branch - (note "branch ~D" (extract-branch-target byte))) - ((#b11111110 #b11010010) - ;; if-true - (note "if-true ~D" (extract-branch-target byte))) - ((#b11111110 #b11010100) - ;; if-false - (note "if-false ~D" (extract-branch-target byte))) - ((#b11111110 #b11010110) - ;; if-eq - (note "if-eq ~D" (extract-branch-target byte))) - ((#b11111000 #b11011000) - ;; XOP - (let* ((low-3-bits (extract-3-bit-op byte)) - (xop (nth (if (eq low-3-bits :var) (next-byte) low-3-bits) - *xop-names*))) - (note "xop ~A~@[ ~D~]" - xop - (case xop - ((catch go unwind-protect) - (extract-24-bits)) - (type-check - (get-constant (extract-extended-op))))))) - - ((#b11100000 #b11100000) - ;; inline - (note "inline ~A" - (inline-function-info-function - (nth (ldb (byte 5 0) byte) *inline-functions*))))))))))) - diff --git a/code/c-call.lisp b/code/c-call.lisp deleted file mode 100644 index 33bad1aac2b1367ef2db7bbe172a7b8b5af215be..0000000000000000000000000000000000000000 --- a/code/c-call.lisp +++ /dev/null @@ -1,88 +0,0 @@ -;;; -*- Package: C-CALL -*- -;;; -;;; ********************************************************************** -;;; 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/code/c-call.lisp,v 1.12 1992/12/18 13:52:26 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains some extensions to the Alien facility to simplify -;;; importing C interfaces. -;;; -(in-package "C-CALL") -(use-package "ALIEN") -(use-package "ALIEN-INTERNALS") -(use-package "SYSTEM") - -(export '(char short int long unsigned-char unsigned-short unsigned-int - unsigned-long float double c-string void)) - - -;;;; Extra types. - -(def-alien-type char (integer 8)) -(def-alien-type short (integer 16)) -(def-alien-type int (integer 32)) -(def-alien-type long (integer 32)) - -(def-alien-type unsigned-char (unsigned 8)) -(def-alien-type unsigned-short (unsigned 16)) -(def-alien-type unsigned-int (unsigned 32)) -(def-alien-type unsigned-long (unsigned 32)) - -(def-alien-type float single-float) -(def-alien-type double double-float) - -(def-alien-type-translator void () - (parse-alien-type '(values))) - - - -;;;; C string support. - -(def-alien-type-class (c-string :include pointer)) - -(def-alien-type-translator c-string () - (make-alien-c-string-type :to (parse-alien-type 'char))) - -(def-alien-type-method (c-string :unparse) (type) - (declare (ignore type)) - 'c-string) - -(def-alien-type-method (c-string :lisp-rep) (type) - (declare (ignore type)) - '(or simple-base-string null (alien (* char)))) - -(def-alien-type-method (c-string :naturalize-gen) (type alien) - (declare (ignore type)) - `(if (zerop (sap-int ,alien)) - nil - (%naturalize-c-string ,alien))) - -(def-alien-type-method (c-string :deport-gen) (type value) - (declare (ignore type)) - `(etypecase ,value - (null (int-sap 0)) - ((alien (* char)) (alien-sap ,value)) - (simple-base-string (vector-sap ,value)))) - -(defun %naturalize-c-string (sap) - (declare (type system-area-pointer sap)) - (with-alien ((ptr (* char) sap)) - (locally - (declare (optimize (speed 3) (safety 0))) - (let ((length (loop - for offset of-type fixnum upfrom 0 - until (zerop (deref ptr offset)) - finally (return offset)))) - (let ((result (make-string length))) - (kernel:copy-from-system-area (alien-sap ptr) 0 - result (* vm:vector-data-offset - vm:word-bits) - (* length vm:byte-bits)) - result))))) diff --git a/code/char.lisp b/code/char.lisp deleted file mode 100644 index b769897ac5ad9c9ff4fb953e026aceb28b91f846..0000000000000000000000000000000000000000 --- a/code/char.lisp +++ /dev/null @@ -1,375 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/char.lisp,v 1.6 1991/11/09 02:47:07 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Character functions for Spice Lisp. Part of the standard Spice Lisp -;;; environment. -;;; -;;; This file assumes the use of ASCII codes and the specific character formats -;;; used in Spice Lisp and Vax Common Lisp. It is optimized for performance -;;; rather than for portability and elegance, and may have to be rewritten if -;;; the character representation is changed. -;;; -;;; Written by Guy Steele. -;;; Rewritten by David Dill. -;;; Hacked up for speed by Scott Fahlman. -;;; Font support flushed and type hackery rewritten by Rob MacLachlan. -;;; -(in-package 'lisp) - -(export '(char-code-limit standard-char-p graphic-char-p - alpha-char-p upper-case-p lower-case-p both-case-p digit-char-p - alphanumericp char= char/= char< char> char<= char>= char-equal - char-not-equal char-lessp char-greaterp char-not-greaterp - char-not-lessp character char-code code-char char-upcase - char-downcase digit-char char-int char-name name-char)) - - -;;; Compile some trivial character operations via inline expansion: -;;; -(proclaim '(inline standard-char-p graphic-char-p alpha-char-p - upper-case-p lower-case-p both-case-p alphanumericp - char-int)) - - -(defconstant char-code-limit 256 - "The upper exclusive bound on values produced by CHAR-CODE.") - -(deftype char-code () - `(integer 0 (,char-code-limit))) - - -(defparameter char-name-alist - `(("NULL" . ,(code-char 0)) - ("BELL" . ,(code-char 7)) - ("BACKSPACE" . ,(code-char 8)) ("BS" . ,(code-char 8)) - ("TAB" . ,(code-char 9)) - ("NEWLINE" . ,(code-char 10)) ("NL" . ,(code-char 10)) - ("LINEFEED" . ,(code-char 10)) ("LF" . ,(code-char 10)) - ("VT" . ,(code-char 11)) - ("PAGE" . ,(code-char 12)) ("FORM" . ,(code-char 12)) - ("FORMFEED" . ,(code-char 12)) ("FF" . ,(code-char 12)) - ("RETURN" . ,(code-char 13)) ("CR" . ,(code-char 13)) - ("ESCAPE" . ,(code-char 27)) ("ESC" . ,(code-char 27)) - ("ALTMODE" . ,(code-char 27)) ("ALT" . ,(code-char 27)) - ("SPACE" . ,(code-char 32)) ("SP" . ,(code-char 32)) - ("DELETE" . ,(code-char 127)) ("RUBOUT" . ,(code-char 127))) - "This is the alist of (character-name . character) for characters - with long names. The first name in this list for a given character - is used on typeout and is the preferred form for input.") - - -;;;; Accessor functions: - -(defun char-code (char) - "Returns the integer code of CHAR." - (etypecase char - (base-char (char-code (truly-the base-char char))))) - - -(defun char-int (char) - "Returns the integer code of CHAR. This is the same as char-code, as - CMU Common Lisp does not implement character bits or fonts." - (char-code char)) - - -(defun code-char (code) - "Returns the character with the code CODE." - (declare (type char-code code)) - (code-char code)) - - -(defun character (object) - "Coerces its argument into a character object if possible. Accepts - characters, strings and symbols of length 1, and integers." - (typecase object - (character object) - (char-code (code-char object)) - (string (if (= 1 (length (the string object))) - (char object 0) - (error "String is not of length one: ~S" object))) - (symbol (if (= 1 (length (symbol-name object))) - (schar (symbol-name object) 0) - (error "Symbol name is not of length one: ~S" object))) - (t - (error "~S cannot be coerced to a character.")))) - - - -(defun char-name (char) - "Given a character object, char-name returns the name for that - object (a symbol)." - (car (rassoc char char-name-alist))) - - -(defun name-char (name) - "Given an argument acceptable to string, name-char returns a character - object whose name is that symbol, if one exists. Otherwise, () is returned." - (cdr (assoc (string name) char-name-alist :test #'string-equal))) - - - - -;;;; Predicates: - -(defun standard-char-p (char) - "The argument must be a character object. Standard-char-p returns T if the - argument is a standard character -- one of the 95 ASCII printing characters - or <return>." - (declare (character char)) - (and (typep char 'base-char) - (let ((n (char-code (the base-char char)))) - (or (< 31 n 127) - (= n 10))))) - -(defun %standard-char-p (thing) - "Return T if and only if THING is a standard-char. Differs from - standard-char-p in that THING doesn't have to be a character." - (and (characterp thing) (standard-char-p thing))) - -(defun graphic-char-p (char) - "The argument must be a character object. Graphic-char-p returns T if the - argument is a printing character (space through ~ in ASCII), otherwise - returns ()." - (declare (character char)) - (and (typep char 'base-char) - (< 31 - (char-code (the base-char char)) - 127))) - - -(defun alpha-char-p (char) - "The argument must be a character object. Alpha-char-p returns T if the - argument is an alphabetic character, A-Z or a-z; otherwise ()." - (declare (character char)) - (let ((m (char-code char))) - (or (< 64 m 91) (< 96 m 123)))) - - -(defun upper-case-p (char) - "The argument must be a character object; upper-case-p returns T if the - argument is an upper-case character, () otherwise." - (declare (character char)) - (< 64 - (char-code char) - 91)) - - -(defun lower-case-p (char) - "The argument must be a character object; lower-case-p returns T if the - argument is a lower-case character, () otherwise." - (declare (character char)) - (< 96 - (char-code char) - 123)) - - -(defun both-case-p (char) - "The argument must be a character object. Both-case-p returns T if the - argument is an alphabetic character and if the character exists in - both upper and lower case. For ASCII, this is the same as Alpha-char-p." - (declare (character char)) - (let ((m (char-code char))) - (or (< 64 m 91) (< 96 m 123)))) - - -(defun digit-char-p (char &optional (radix 10.)) - "If char is a digit in the specified radix, returns the fixnum for - which that digit stands, else returns NIL. Radix defaults to 10 - (decimal)." - (declare (character char)) - (let ((m (- (char-code char) 48))) - (cond ((<= radix 10.) - ;; Special-case decimal and smaller radices. - (if (and (>= m 0) (< m radix)) m nil)) - ;; Cannot handle radix past Z. - ((> radix 36) - (error "~S too large to be an input radix." radix)) - ;; Digits 0 - 9 are used as is, since radix is larger. - ((and (>= m 0) (< m 10)) m) - ;; Check for upper case A - Z. - ((and (>= (setq m (- m 7)) 10) (< m radix)) m) - ;; Also check lower case a - z. - ((and (>= (setq m (- m 32)) 10) (< m radix)) m) - ;; Else, fail. - (t nil)))) - - -(defun alphanumericp (char) - "Given a character-object argument, alphanumericp returns T if the - argument is either numeric or alphabetic." - (declare (character char)) - (let ((m (char-code char))) - (or (< 47 m 58) (< 64 m 91) (< 96 m 123)))) - - -(defun char= (character &rest more-characters) - "Returns T if all of its arguments are the same character." - (do ((clist more-characters (cdr clist))) - ((atom clist) T) - (unless (eq (car clist) character) (return nil)))) - - -(defun char/= (character &rest more-characters) - "Returns T if no two of its arguments are the same character." - (do* ((head character (car list)) - (list more-characters (cdr list))) - ((atom list) T) - (unless (do* ((l list (cdr l))) ;inner loop returns T - ((atom l) T) ; iff head /= rest. - (if (eq head (car l)) (return nil))) - (return nil)))) - - -(defun char< (character &rest more-characters) - "Returns T if its arguments are in strictly increasing alphabetic order." - (do* ((c character (car list)) - (list more-characters (cdr list))) - ((atom list) T) - (unless (< (char-int c) - (char-int (car list))) - (return nil)))) - - -(defun char> (character &rest more-characters) - "Returns T if its arguments are in strictly decreasing alphabetic order." - (do* ((c character (car list)) - (list more-characters (cdr list))) - ((atom list) T) - (unless (> (char-int c) - (char-int (car list))) - (return nil)))) - - -(defun char<= (character &rest more-characters) - "Returns T if its arguments are in strictly non-decreasing alphabetic order." - (do* ((c character (car list)) - (list more-characters (cdr list))) - ((atom list) T) - (unless (<= (char-int c) - (char-int (car list))) - (return nil)))) - - -(defun char>= (character &rest more-characters) - "Returns T if its arguments are in strictly non-increasing alphabetic order." - (do* ((c character (car list)) - (list more-characters (cdr list))) - ((atom list) T) - (unless (>= (char-int c) - (char-int (car list))) - (return nil)))) - - - -;;; Equal-Char-Code is used by the following functions as a version of char-int -;;; which loses font, bits, and case info. - -(defmacro equal-char-code (character) - `(let ((ch (char-code ,character))) - (if (< 96 ch 123) (- ch 32) ch))) - - - -(defun char-equal (character &rest more-characters) - "Returns T if all of its arguments are the same character. - Font, bits, and case are ignored." - (do ((clist more-characters (cdr clist))) - ((atom clist) T) - (unless (= (equal-char-code (car clist)) - (equal-char-code character)) - (return nil)))) - - -(defun char-not-equal (character &rest more-characters) - "Returns T if no two of its arguments are the same character. - Font, bits, and case are ignored." - (do* ((head character (car list)) - (list more-characters (cdr list))) - ((atom list) T) - (unless (do* ((l list (cdr l))) - ((atom l) T) - (if (= (equal-char-code head) - (equal-char-code (car l))) - (return nil))) - (return nil)))) - - -(defun char-lessp (character &rest more-characters) - "Returns T if its arguments are in strictly increasing alphabetic order. - Font, bits, and case are ignored." - (do* ((c character (car list)) - (list more-characters (cdr list))) - ((atom list) T) - (unless (< (equal-char-code c) - (equal-char-code (car list))) - (return nil)))) - - -(defun char-greaterp (character &rest more-characters) - "Returns T if its arguments are in strictly decreasing alphabetic order. - Font, bits, and case are ignored." - (do* ((c character (car list)) - (list more-characters (cdr list))) - ((atom list) T) - (unless (> (equal-char-code c) - (equal-char-code (car list))) - (return nil)))) - - -(defun char-not-greaterp (character &rest more-characters) - "Returns T if its arguments are in strictly non-decreasing alphabetic order. - Font, bits, and case are ignored." - (do* ((c character (car list)) - (list more-characters (cdr list))) - ((atom list) T) - (unless (<= (equal-char-code c) - (equal-char-code (car list))) - (return nil)))) - - -(defun char-not-lessp (character &rest more-characters) - "Returns T if its arguments are in strictly non-increasing alphabetic order. - Font, bits, and case are ignored." - (do* ((c character (car list)) - (list more-characters (cdr list))) - ((atom list) T) - (unless (>= (equal-char-code c) - (equal-char-code (car list))) - (return nil)))) - - - - -;;;; Miscellaneous functions: - -(defun char-upcase (char) - "Returns CHAR converted to upper-case if that is possible." - (declare (character char)) - (if (lower-case-p char) - (code-char (- (char-code char) 32)) - char)) - -(defun char-downcase (char) - "Returns CHAR converted to lower-case if that is possible." - (declare (character char)) - (if (upper-case-p char) - (code-char (+ (char-code char) 32)) - char)) - -(defun digit-char (weight &optional (radix 10)) - "All arguments must be integers. Returns a character object that - represents a digit of the given weight in the specified radix. Returns - NIL if no such character exists. The character will have the specified - font attributes." - (and (>= weight 0) (< weight radix) (< weight 36) - (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight))))) diff --git a/code/clx-ext.lisp b/code/clx-ext.lisp deleted file mode 100644 index 99726c189ea77cdf5790a6a939280efe44620469..0000000000000000000000000000000000000000 --- a/code/clx-ext.lisp +++ /dev/null @@ -1,593 +0,0 @@ -;;; -*- Package: Extensions; Log: code.log; Mode: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/clx-ext.lisp,v 1.9 1991/12/17 08:21:39 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains code to extend CLX in the CMU Common Lisp environment. -;;; -;;; Written by Bill Chiles and Chris Hoover. -;;; - -(in-package "EXTENSIONS") - -(export '(open-clx-display with-clx-event-handling enable-clx-event-handling - disable-clx-event-handling object-set-event-handler - default-clx-event-handler - flush-display-events carefully-add-font-paths - - serve-key-press serve-key-release serve-button-press - serve-button-release serve-motion-notify serve-enter-notify - serve-leave-notify serve-focus-in serve-focus-out - serve-exposure serve-graphics-exposure serve-no-exposure - serve-visibility-notify serve-create-notify serve-destroy-notify - serve-unmap-notify serve-map-notify serve-map-request - serve-reparent-notify serve-configure-notify serve-gravity-notify - serve-resize-request serve-configure-request serve-circulate-notify - serve-circulate-request serve-property-notify serve-selection-clear - serve-selection-request serve-selection-notify serve-colormap-notify - serve-client-message)) - - - -;;;; OPEN-CLX-DISPLAY. - -(defun open-clx-display (&optional (string (cdr (assoc :display - *environment-list* - :test #'eq)))) - "Parses a display specification including display and screen numbers. - This returns nil when there is no DISPLAY environment variable. If string - is non-nil, and any fields are missing in the specification, this signals an - error. If you specify a screen, then this sets XLIB:DISPLAY-DEFAULT-SCREEN - to that screen since CLX initializes this form to the first of - XLIB:SCREEN-ROOTS. This returns the display and screen objects." - (when string - (let* ((string (coerce string 'simple-string)) - (length (length string)) - (host-name "unix") - (display-num nil) - (screen-num nil)) - (declare (simple-string string)) - (let ((colon (position #\: string :test #'char=))) - (cond ((null colon) - (error "Missing display number in DISPLAY environment variable.")) - (t - (unless (zerop colon) (setf host-name (subseq string 0 colon))) - (let* ((start (1+ colon)) - (first-dot (position #\. string - :test #'char= :start start))) - (cond ((= start (or first-dot length)) - (error "Badly formed display number in DISPLAY ~ - environment variable.")) - ((null first-dot) - (setf display-num (parse-integer string :start start))) - (t - (setf display-num (parse-integer string :start start - :end first-dot)) - (let* ((start (1+ first-dot)) - (second-dot (position #\. string :test #'char= - :start start))) - (cond ((= start (or second-dot length)) - (error "Badly formed screen number in ~ - DISPLAY environment variable.")) - (t - (setf screen-num - (parse-integer string :start start - :end second-dot))))))))))) - (let ((display (xlib:open-display host-name :display display-num))) - (when screen-num - (let* ((screens (xlib:display-roots display)) - (num-screens (length screens))) - (when (>= screen-num num-screens) - (xlib:close-display display) - (error "No such screen number (~D)." screen-num)) - (setf (xlib:display-default-screen display) - (elt screens screen-num)))) - (values display (xlib:display-default-screen display)))))) - - - -;;;; Font Path Manipulation - -(defun carefully-add-font-paths (display font-pathnames - &optional (operation :append)) - "Adds the list of font pathnames, Font-Pathnames, to the font path of - the server Display but does so carefully by checking to make sure that - the font pathnames are not already on the server's font path. If any - of the font pathnames are on the server's font path, they will remain - in their current positions. Operation may be specified as either - :prepend or :append and specifies whether to add the additional font - pathnames to the beginning or the end of the server's original font - path." - (let ((font-path (xlib:font-path display)) - (result ())) - (dolist (elt font-pathnames) - (enumerate-search-list (pathname elt) - (lisp::enumerate-matches (name pathname) - (unless (member name font-path :test #'string=) - (push name result))))) - (when result - (ecase operation - (:prepend - (setf (xlib:font-path display) (revappend result font-path))) - (:append - (setf (xlib:font-path display) - (append font-path (nreverse result)))))))) - - -;;;; Enabling and disabling event handling through SYSTEM:SERVE-EVENT. - -(defvar *clx-fds-to-displays* (make-hash-table :test #'eql) - "This is a hash table that maps CLX file descriptors to CLX display - structures. For every CLX file descriptor know to SYSTEM:SERVE-EVENT, - there must be a mapping from that file descriptor to its CLX display - structure when events are handled via SYSTEM:SERVE-EVENT.") - -(defmacro with-clx-event-handling ((display handler) &rest body) - "Evaluates body in a context where events are handled for the display - by calling handler on the display. This destroys any previously established - handler for display." - `(unwind-protect - (progn - (enable-clx-event-handling ,display ,handler) - ,@body) - (disable-clx-event-handling ,display))) - -;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in -;;; *display-event-handlers*. It also uses SYSTEM:ADD-FD-HANDLER to have -;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows -;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a -;;; file descriptor, the file descriptor is also mapped to the display in -;;; *clx-fds-to-displays*, so the user's handler can be called on the display. -;;; -(defun enable-clx-event-handling (display handler) - "After calling this, when SYSTEM:SERVE-EVENT notices input on display's - connection to the X11 server, handler is called on the display. Handler - is invoked in a dynamic context with an error handler bound that will - flush all events from the display and return. By returning, it declines - to handle the error, but it will have cleared all events; thus, entering - the debugger will not result in infinite errors due to streams that wait - via SYSTEM:SERVE-EVENT for input. Calling this repeatedly on the same - display establishes handler as a new handler, replacing any previous one - for display." - (check-type display xlib:display) - (let ((change-handler (assoc display *display-event-handlers*))) - (if change-handler - (setf (cdr change-handler) handler) - (let ((fd (fd-stream-fd (xlib::display-input-stream display)))) - (system:add-fd-handler fd :input #'call-display-event-handler) - (setf (gethash fd *clx-fds-to-displays*) display) - (push (cons display handler) *display-event-handlers*))))) - -;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps -;;; the display to its handler. If we can't find the display, we remove the -;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the -;;; display from *display-event-handlers*. This is necessary to try to keep -;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and -;;; over. This is possible since many CMU Common Lisp streams loop over -;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are -;;; possible. -;;; -(defun call-display-event-handler (file-descriptor) - (let ((display (gethash file-descriptor *clx-fds-to-displays*))) - (unless display - (system:invalidate-descriptor file-descriptor) - (setf *display-event-handlers* - (delete file-descriptor *display-event-handlers* - :key #'(lambda (d/h) - (fd-stream-fd - (xlib::display-input-stream - (car d/h)))))) - (error "File descriptor ~S not associated with any CLX display.~%~ - It has been removed from system:serve-event's knowledge." - file-descriptor)) - (let ((handler (cdr (assoc display *display-event-handlers*)))) - (unless handler - (flush-display-events display) - (error "Display ~S not associated with any event handler." display)) - (handler-bind ((error #'(lambda (condx) - (declare (ignore condx)) - (flush-display-events display)))) - (funcall handler display))))) - -(defun disable-clx-event-handling (display) - "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING." - (setf *display-event-handlers* - (delete display *display-event-handlers* :key #'car)) - (let ((fd (fd-stream-fd (xlib::display-input-stream display)))) - (remhash fd *clx-fds-to-displays*) - (system:invalidate-descriptor fd))) - - - -;;;; Object set event handling. - -;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear -;;; events on the display before signalling any errors. This is necessary -;;; since reading on certain CMU Common Lisp streams involves SERVER, and -;;; getting an error while trying to handle an event causes repeated attempts -;;; to handle the same event. -;;; -(defvar *process-clx-event-display* nil) - -(defvar *object-set-event-handler-print* nil) - -(proclaim '(declaration values)) - -(defun object-set-event-handler (display) - "This display event handler uses object sets to map event windows cross - event types to handlers. It uses XLIB:EVENT-CASE to bind all the slots - of each event, calling the handlers on all these values in addition to - the event key and send-event-p. Describe EXT:SERVE-MUMBLE, where mumble - is an event keyword name for the exact order of arguments. - :mapping-notify and :keymap-notify events are ignored since they do not - occur on any particular window. After calling a handler, each branch - returns t to discard the event. While the handler is executing, all - errors go through a handler that flushes all the display's events and - returns. This prevents infinite errors since the debug and terminal - streams loop over SYSTEM:SERVE-EVENT. This function returns t if there - were some event to handle, nil otherwise. It returns immediately if - there is no event to handle." - (macrolet ((dispatch (event-key &rest args) - `(multiple-value-bind (object object-set) - (lisp::map-xwindow event-window) - (unless object - (cond ((not (typep event-window 'xlib:window)) - (xlib:discard-current-event display) - (warn "Discarding ~S event on non-window ~S." - ,event-key event-window) - (return-from object-set-event-handler nil)) - (t - (flush-display-events display) - (error "~S not a known X window.~%~ - Received event ~S." - event-window ,event-key)))) - (handler-bind ((error #'(lambda (condx) - (declare (ignore condx)) - (flush-display-events display)))) - (when *object-set-event-handler-print* - (print ,event-key) (force-output)) - (funcall (gethash ,event-key - (lisp::object-set-table object-set) - (lisp::object-set-default-handler - object-set)) - object ,event-key - ,@args)) - (setf result t)))) - (let ((*process-clx-event-display* display) - (result nil)) - (xlib:event-case (display :timeout 0) - ((:KEY-PRESS :KEY-RELEASE :BUTTON-PRESS :BUTTON-RELEASE) - (event-key event-window root child same-screen-p - x y root-x root-y state time code send-event-p) - (dispatch event-key event-window root child same-screen-p - x y root-x root-y state time code send-event-p)) - (:MOTION-NOTIFY (event-window root child same-screen-p - x y root-x root-y state time hint-p send-event-p) - (dispatch :motion-notify event-window root child same-screen-p - x y root-x root-y state time hint-p send-event-p)) - (:ENTER-NOTIFY (event-window root child same-screen-p - x y root-x root-y state time mode kind send-event-p) - (dispatch :enter-notify event-window root child same-screen-p - x y root-x root-y state time mode kind send-event-p)) - (:LEAVE-NOTIFY (event-window root child same-screen-p - x y root-x root-y state time mode kind send-event-p) - (dispatch :leave-notify event-window root child same-screen-p - x y root-x root-y state time mode kind send-event-p)) - (:EXPOSURE (event-window x y width height count send-event-p) - (dispatch :exposure event-window x y width height count send-event-p)) - (:GRAPHICS-EXPOSURE (event-window x y width height count major minor - send-event-p) - (dispatch :graphics-exposure event-window x y width height - count major minor send-event-p)) - (:NO-EXPOSURE (event-window major minor send-event-p) - (dispatch :no-exposure event-window major minor send-event-p)) - (:FOCUS-IN (event-window mode kind send-event-p) - (dispatch :focus-in event-window mode kind send-event-p)) - (:FOCUS-OUT (event-window mode kind send-event-p) - (dispatch :focus-out event-window mode kind send-event-p)) - (:KEYMAP-NOTIFY () - (warn "Ignoring keymap notify event.") - (when *object-set-event-handler-print* - (print :keymap-notify) (force-output)) - (setf result t)) - (:VISIBILITY-NOTIFY (event-window state send-event-p) - (dispatch :visibility-notify event-window state send-event-p)) - (:CREATE-NOTIFY (event-window window x y width height border-width - override-redirect-p send-event-p) - (dispatch :create-notify event-window window x y width height - border-width override-redirect-p send-event-p)) - (:DESTROY-NOTIFY (event-window window send-event-p) - (dispatch :destroy-notify event-window window send-event-p)) - (:UNMAP-NOTIFY (event-window window configure-p send-event-p) - (dispatch :unmap-notify event-window window configure-p send-event-p)) - (:MAP-NOTIFY (event-window window override-redirect-p send-event-p) - (dispatch :map-notify event-window window override-redirect-p - send-event-p)) - (:MAP-REQUEST (event-window window send-event-p) - (dispatch :map-request event-window window send-event-p)) - (:REPARENT-NOTIFY (event-window window parent x y override-redirect-p - send-event-p) - (dispatch :reparent-notify event-window window parent x y - override-redirect-p send-event-p)) - (:CONFIGURE-NOTIFY (event-window window x y width height border-width - above-sibling override-redirect-p send-event-p) - (dispatch :configure-notify event-window window x y width height - border-width above-sibling override-redirect-p - send-event-p)) - (:GRAVITY-NOTIFY (event-window window x y send-event-p) - (dispatch :gravity-notify event-window window x y send-event-p)) - (:RESIZE-REQUEST (event-window width height send-event-p) - (dispatch :resize-request event-window width height send-event-p)) - (:CONFIGURE-REQUEST (event-window window x y width height border-width - stack-mode above-sibling value-mask send-event-p) - (dispatch :configure-request event-window window x y width height - border-width stack-mode above-sibling value-mask - send-event-p)) - (:CIRCULATE-NOTIFY (event-window window place send-event-p) - (dispatch :circulate-notify event-window window place send-event-p)) - (:CIRCULATE-REQUEST (event-window window place send-event-p) - (dispatch :circulate-request event-window window place send-event-p)) - (:PROPERTY-NOTIFY (event-window atom state time send-event-p) - (dispatch :property-notify event-window atom state time send-event-p)) - (:SELECTION-CLEAR (event-window selection time send-event-p) - (dispatch :selection-notify event-window selection time send-event-p)) - (:SELECTION-REQUEST (event-window requestor selection target property - time send-event-p) - (dispatch :selection-request event-window requestor selection target - property time send-event-p)) - (:SELECTION-NOTIFY (event-window selection target property time - send-event-p) - (dispatch :selection-notify event-window selection target property time - send-event-p)) - (:COLORMAP-NOTIFY (event-window colormap new-p installed-p send-event-p) - (dispatch :colormap-notify event-window colormap new-p installed-p - send-event-p)) - (:MAPPING-NOTIFY (request) - (warn "Ignoring mapping notify event -- ~S." request) - (when *object-set-event-handler-print* - (print :mapping-notify) (force-output)) - (setf result t)) - (:CLIENT-MESSAGE (event-window format data send-event-p) - (dispatch :client-message event-window format data send-event-p))) - result))) - -(defun default-clx-event-handler (object event-key event-window &rest ignore) - (declare (ignore ignore)) - (flush-display-events *process-clx-event-display*) - (error "No handler for event type ~S on ~S in ~S." - event-key object (lisp::map-xwindow event-window))) - -(defun flush-display-events (display) - "Dumps all the events in display's event queue including the current one - in case this is called from within XLIB:EVENT-CASE, etc." - (xlib:discard-current-event display) - (xlib:event-case (display :discard-p t :timeout 0) - (t () nil))) - - - -;;;; Key and button service. - -(defun serve-key-press (object-set fun) - "Associate a method in the object-set with :key-press events. The method - is called on the object the event occurred, event key, event window, root, - child, same-screen-p, x, y, root-x, root-y, state, time, code, and - send-event-p." - (setf (gethash :key-press (lisp::object-set-table object-set)) fun)) - -(defun serve-key-release (object-set fun) - "Associate a method in the object-set with :key-release events. The method - is called on the object the event occurred, event key, event window, root, - child, same-screen-p, x, y, root-x, root-y, state, time, code, and - send-event-p." - (setf (gethash :key-release (lisp::object-set-table object-set)) fun)) - -(defun serve-button-press (object-set fun) - "Associate a method in the object-set with :button-press events. The method - is called on the object the event occurred, event key, event window, root, - child, same-screen-p, x, y, root-x, root-y, state, time, code, and - send-event-p." - (setf (gethash :button-press (lisp::object-set-table object-set)) fun)) - -(defun serve-button-release (object-set fun) - "Associate a method in the object-set with :button-release events. The - method is called on the object the event occurred, event key, event window, - root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and - send-event-p." - (setf (gethash :button-release (lisp::object-set-table object-set)) fun)) - - - -;;;; Mouse service. - -(defun serve-motion-notify (object-set fun) - "Associate a method in the object-set with :motion-notify events. The method - is called on the object the event occurred, event key, event window, root, - child, same-screen-p, x, y, root-x, root-y, state, time, hint-p, and - send-event-p." - (setf (gethash :motion-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-enter-notify (object-set fun) - "Associate a method in the object-set with :enter-notify events. The method - is called on the object the event occurred, event key, event window, root, - child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind, - and send-event-p." - (setf (gethash :enter-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-leave-notify (object-set fun) - "Associate a method in the object-set with :leave-notify events. The method - is called on the object the event occurred, event key, event window, root, - child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind, - and send-event-p." - (setf (gethash :leave-notify (lisp::object-set-table object-set)) fun)) - - - -;;;; Keyboard service. - -(defun serve-focus-in (object-set fun) - "Associate a method in the object-set with :focus-in events. The method - is called on the object the event occurred, event key, event window, mode, - kind, and send-event-p." - (setf (gethash :focus-in (lisp::object-set-table object-set)) fun)) - -(defun serve-focus-out (object-set fun) - "Associate a method in the object-set with :focus-out events. The method - is called on the object the event occurred, event key, event window, mode, - kind, and send-event-p." - (setf (gethash :focus-out (lisp::object-set-table object-set)) fun)) - - - -;;;; Exposure service. - -(defun serve-exposure (object-set fun) - "Associate a method in the object-set with :exposure events. The method - is called on the object the event occurred, event key, event window, x, y, - width, height, count, and send-event-p." - (setf (gethash :exposure (lisp::object-set-table object-set)) fun)) - -(defun serve-graphics-exposure (object-set fun) - "Associate a method in the object-set with :graphics-exposure events. The - method is called on the object the event occurred, event key, event window, - x, y, width, height, count, major, minor, and send-event-p." - (setf (gethash :graphics-exposure (lisp::object-set-table object-set)) fun)) - -(defun serve-no-exposure (object-set fun) - "Associate a method in the object-set with :no-exposure events. The method - is called on the object the event occurred, event key, event window, major, - minor, and send-event-p." - (setf (gethash :no-exposure (lisp::object-set-table object-set)) fun)) - - - -;;;; Structure service. - -(defun serve-visibility-notify (object-set fun) - "Associate a method in the object-set with :visibility-notify events. The - method is called on the object the event occurred, event key, event window, - state, and send-event-p." - (setf (gethash :visibility-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-create-notify (object-set fun) - "Associate a method in the object-set with :create-notify events. The - method is called on the object the event occurred, event key, event window, - window, x, y, width, height, border-width, override-redirect-p, and - send-event-p." - (setf (gethash :create-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-destroy-notify (object-set fun) - "Associate a method in the object-set with :destroy-notify events. The - method is called on the object the event occurred, event key, event window, - window, and send-event-p." - (setf (gethash :destroy-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-unmap-notify (object-set fun) - "Associate a method in the object-set with :unmap-notify events. The - method is called on the object the event occurred, event key, event window, - window, configure-p, and send-event-p." - (setf (gethash :unmap-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-map-notify (object-set fun) - "Associate a method in the object-set with :map-notify events. The - method is called on the object the event occurred, event key, event window, - window, override-redirect-p, and send-event-p." - (setf (gethash :map-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-map-request (object-set fun) - "Associate a method in the object-set with :map-request events. The - method is called on the object the event occurred, event key, event window, - window, and send-event-p." - (setf (gethash :map-request (lisp::object-set-table object-set)) fun)) - -(defun serve-reparent-notify (object-set fun) - "Associate a method in the object-set with :reparent-notify events. The - method is called on the object the event occurred, event key, event window, - window, parent, x, y, override-redirect-p, and send-event-p." - (setf (gethash :reparent-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-configure-notify (object-set fun) - "Associate a method in the object-set with :configure-notify events. The - method is called on the object the event occurred, event key, event window, - window, x, y, width, height, border-width, above-sibling, - override-redirect-p, and send-event-p." - (setf (gethash :configure-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-gravity-notify (object-set fun) - "Associate a method in the object-set with :gravity-notify events. The - method is called on the object the event occurred, event key, event window, - window, x, y, and send-event-p." - (setf (gethash :gravity-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-resize-request (object-set fun) - "Associate a method in the object-set with :resize-request events. The - method is called on the object the event occurred, event key, event window, - width, height, and send-event-p." - (setf (gethash :resize-request (lisp::object-set-table object-set)) fun)) - -(defun serve-configure-request (object-set fun) - "Associate a method in the object-set with :configure-request events. The - method is called on the object the event occurred, event key, event window, - window, x, y, width, height, border-width, stack-mode, above-sibling, - value-mask, and send-event-p." - (setf (gethash :configure-request (lisp::object-set-table object-set)) fun)) - -(defun serve-circulate-notify (object-set fun) - "Associate a method in the object-set with :circulate-notify events. The - method is called on the object the event occurred, event key, event window, - window, place, and send-event-p." - (setf (gethash :circulate-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-circulate-request (object-set fun) - "Associate a method in the object-set with :circulate-request events. The - method is called on the object the event occurred, event key, event window, - window, place, and send-event-p." - (setf (gethash :circulate-request (lisp::object-set-table object-set)) fun)) - - - -;;;; Misc. service. - -(defun serve-property-notify (object-set fun) - "Associate a method in the object-set with :property-notify events. The - method is called on the object the event occurred, event key, event window, - atom, state, time, and send-event-p." - (setf (gethash :property-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-selection-clear (object-set fun) - "Associate a method in the object-set with :selection-clear events. The - method is called on the object the event occurred, event key, event window, - selection, time, and send-event-p." - (setf (gethash :selection-clear (lisp::object-set-table object-set)) fun)) - -(defun serve-selection-request (object-set fun) - "Associate a method in the object-set with :selection-request events. The - method is called on the object the event occurred, event key, event window, - requestor, selection, target, property, time, and send-event-p." - (setf (gethash :selection-request (lisp::object-set-table object-set)) fun)) - -(defun serve-selection-notify (object-set fun) - "Associate a method in the object-set with :selection-notify events. The - method is called on the object the event occurred, event key, event window, - selection, target, property, time, and send-event-p." - (setf (gethash :selection-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-colormap-notify (object-set fun) - "Associate a method in the object-set with :colormap-notify events. The - method is called on the object the event occurred, event key, event window, - colormap, new-p, installed-p, and send-event-p." - (setf (gethash :colormap-notify (lisp::object-set-table object-set)) fun)) - -(defun serve-client-message (object-set fun) - "Associate a method in the object-set with :client-message events. The - method is called on the object the event occurred, event key, event window, - format, data, and send-event-p." - (setf (gethash :client-message (lisp::object-set-table object-set)) fun)) diff --git a/code/cmu-site.lisp b/code/cmu-site.lisp deleted file mode 100644 index 495fa84f906241e8798b4770fb47ce3deb2b4fec..0000000000000000000000000000000000000000 --- a/code/cmu-site.lisp +++ /dev/null @@ -1,20 +0,0 @@ -;;; -*- Mode: Lisp; Package: System -*- -;;; -;;; ********************************************************************** -;;; 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/code/cmu-site.lisp,v 1.1 1991/08/30 17:43:33 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Site specific initialization for CMU. This can be used as a template for -;;; non-cmu "library:site-init" files. -;;; -(in-package "SYSTEM") - -(setq *short-site-name* "CMU-SCS") -(setq *long-site-name* "Carnegie-Mellon University School of Computer Science") diff --git a/code/commandline.lisp b/code/commandline.lisp deleted file mode 100644 index 04513d404458afe3667c3258ee72e7d863739fc3..0000000000000000000000000000000000000000 --- a/code/commandline.lisp +++ /dev/null @@ -1,192 +0,0 @@ -;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/commandline.lisp,v 1.2 1991/02/08 13:31:31 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to eat the command line passed to us from the shell. -;;; Written by Bill Chiles. -;;; - -(in-package "EXTENSIONS") -(export '(*command-line-words* *command-line-switches* - *command-switch-demons* *command-line-utility-name* - *command-line-strings* cmd-switch-string command-line-switch-p - cmd-switch-name cmd-switch-value cmd-switch-words command-line-switch - defswitch cmd-switch-arg get-command-line-switch)) - -(defvar *command-line-switches* () - "A list of cmd-switch's representing the arguments used to invoke - this process.") - -(defvar *command-line-utility-name* "" - "The string name that was used to invoke this process.") - -(defvar *command-line-words* () - "A list of words between the utility name and the first switch.") - -(defvar *command-line-strings* () - "A list of strings obtained from the command line that invoked this process.") - -(defvar *command-switch-demons* () - "An Alist of (\"argument-name\" . demon-function)") - - - -(defstruct (command-line-switch (:conc-name cmd-switch-) - (:constructor make-cmd-switch - (name value words)) - (:print-function print-command-line-switch)) - name ;the name of the switch - value ;the value of that switch - words ;random words dangling between switches assigned to the - ;preceeding switch - ) - -(defun print-command-line-switch (object stream n) - (declare (ignore n)) - (write-string "#<Command Line Switch " stream) - (prin1 (cmd-switch-name object) stream) - (let ((value (cmd-switch-value object)) - (words (cmd-switch-words object))) - (when (or value words) (write-string " -- " stream) - (when value (prin1 value stream)) - (when words (prin1 words stream)))) - (write-string ">" stream)) - - - -;;;; Processing the command strings. - -(defun process-command-strings () - (setq *command-line-words* nil) - (setq *command-line-switches* nil) - (let ((cmd-strings lisp::lisp-command-line-list) - str) - (declare (special lisp::lisp-command-line-list)) - ;; Set some initial variables. - ;; - (setf *command-line-strings* (copy-list lisp::lisp-command-line-list)) - (setf *command-line-utility-name* (pop cmd-strings)) - (setq str (pop cmd-strings)) - ;; Set initial command line words. - ;; - (loop - (unless str (return nil)) - (unless (zerop (length (the simple-string str))) - (when (char= (schar str 0) #\-) - (setq *command-line-words* (reverse *command-line-words*)) - (return nil)) - (push str *command-line-words*)) - (setq str (pop cmd-strings))) - ;; Set command line switches. - ;; - (loop - (unless str - (return (setf *command-line-switches* - (nreverse *command-line-switches*)))) - (let* ((position (position #\= (the simple-string str) :test #'char=)) - (switch (subseq (the simple-string str) 1 position)) - (value (if position - (subseq (the simple-string str) (1+ position) - (length (the simple-string str)))))) - (setq str (pop cmd-strings)) - ;; Set this switches words until the next switch. - ;; - (let (word-list) - (loop - (unless str - (push (make-cmd-switch switch value (nreverse word-list)) - *command-line-switches*) - (return nil)) - (unless (zerop (length (the simple-string str))) - (when (char= #\- (schar str 0)) - (push (make-cmd-switch switch value (nreverse word-list)) - *command-line-switches*) - (return nil)) - (push str word-list)) - (setq str (pop cmd-strings)))))))) - -(defun get-command-line-switch (sname) - "Accepts the name of a switch as a string and returns the value of the - switch. If no value was specified, then any following words are returned. - If there are no following words, then t is returned. If the switch was not - specified, then nil is returned." - (let* ((name (if (char= (schar sname 0) #\-) (subseq sname 1) sname)) - (switch (find name *command-line-switches* - :test #'string-equal - :key #'cmd-switch-name))) - (when switch - (or (cmd-switch-value switch) - (cmd-switch-words switch) - T)))) - - - -;;;; Defining Switches and invoking demons. - -(defvar *complain-about-illegal-switches* t - "When set, invoking switch demons complains about illegal switches that have - not been defined with DEFSWITCH.") - -;;; This is a list of legal switch names. DEFSWITCH sets this, and -;;; INVOKE-SWITCH-DEMONS makes sure all the switches it sees are on this -;;; list. -;;; -(defvar *legal-cmd-line-switches* nil) - -;;; INVOKE-SWITCH-DEMONS cdrs down the list of *command-line-switches*. For -;;; each switch, it checks to see if there is a switch demon with the same -;;; name. If there is, then that demon is called as a function on the switch. -;;; -(defun invoke-switch-demons (&optional (switches *command-line-switches*) - (demons *command-switch-demons*)) - (dolist (switch switches t) - (let* ((name (cmd-switch-name switch)) - (demon (cdr (assoc name demons :test #'string-equal)))) - (cond (demon (funcall demon switch)) - ((or (member name *legal-cmd-line-switches* :test #'string-equal) - (not *complain-about-illegal-switches*))) - (t (warn "~S is an illegal switch" switch)))))) - -(defmacro defswitch (name &optional function) - "Associates function with the switch name in *command-switch-demons*. Name - is a simple-string that does not begin with a hyphen, unless the switch name - really does begin with one. Function is optional, but defining the switch - is necessary to keep invoking switch demons from complaining about illegal - switches. This can be inhibited with *complain-about-illegal-switches*." - (let ((gname (gensym)) - (gfunction (gensym))) - `(let ((,gname ,name) - (,gfunction ,function)) - (check-type ,gname simple-string) - (check-type ,gfunction (or symbol function) "a symbol or function") - (push ,gname *legal-cmd-line-switches*) - (when ,gfunction - (push (cons ,gname ,gfunction) *command-switch-demons*))))) - - -(defun eval-switch-demon (switch) - (eval (read-from-string (cmd-switch-arg switch)))) -(defswitch "eval" #'eval-switch-demon) - -(defun load-switch-demon (switch) - (load (cmd-switch-arg switch))) -(defswitch "load" #'load-switch-demon) - -(defun cmd-switch-arg (switch) - (or (cmd-switch-value switch) - (car (cmd-switch-words switch)) - (car *command-line-words*))) - -(defswitch "core") -(defswitch "init") -(defswitch "noinit") -(defswitch "hinit") diff --git a/code/debug-int.lisp b/code/debug-int.lisp deleted file mode 100644 index f11cdfaec132422e6d7bb13b4f5e20648b80aab9..0000000000000000000000000000000000000000 --- a/code/debug-int.lisp +++ /dev/null @@ -1,3791 +0,0 @@ -;;; -*- Mode: completion; Log: code.log; Package: DI -*- -;;; -;;; ********************************************************************** -;;; 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/code/debug-int.lisp,v 1.54 1992/12/17 09:04:41 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the implementation of the programmer's interface -;;; to writing debugging tools. -;;; -;;; Written by Bill Chiles and Rob Maclachlan. -;;; - -(in-package "DEBUG-INTERNALS" :nicknames '("DI")) - - -;;; The compiler's debug-source structure is almost exactly what we want, so -;;; just get these symbols and export them. -;;; -(import '(c::debug-source-from c::debug-source-name c::debug-source-created - c::debug-source-compiled c::debug-source-start-positions - c::make-debug-source c::debug-source c::debug-source-p)) - -(export '(debug-variable-name debug-variable-package debug-variable-symbol - debug-variable-id debug-variable-value debug-variable-validity - debug-variable-valid-value debug-variable debug-variable-p - - top-frame frame-down frame-up flush-frames-above frame-debug-function - frame-code-location eval-in-frame return-from-frame frame-catches - frame-number frame frame-p - - do-debug-function-blocks debug-function-lambda-list - debug-variable-info-available do-debug-function-variables - debug-function-symbol-variables ambiguous-debug-variables - preprocess-for-eval function-debug-function debug-function-function - debug-function-kind debug-function-name debug-function - debug-function-p debug-function-start-location - - do-debug-block-locations debug-block-successors debug-block - debug-block-p debug-block-elsewhere-p - - make-breakpoint activate-breakpoint deactivate-breakpoint - breakpoint-active-p breakpoint-hook-function breakpoint-info - breakpoint-kind breakpoint-what breakpoint breakpoint-p - delete-breakpoint function-end-cookie-valid-p - - code-location-debug-function code-location-debug-block - code-location-top-level-form-offset code-location-form-number - code-location-debug-source code-location-kind - code-location code-location-p code-location-unknown-p code-location= - - debug-source-from debug-source-name debug-source-created - debug-source-compiled debug-source-root-number - debug-source-start-positions form-number-translations - source-path-context debug-source debug-source-p - - debug-condition no-debug-info no-debug-function-returns - no-debug-blocks lambda-list-unavailable - - debug-error unhandled-condition invalid-control-stack-pointer - unknown-code-location unknown-debug-variable invalid-value - ambiguous-variable-name frame-function-mismatch - - set-breakpoint-for-editor set-location-breakpoint-for-editor - delete-breakpoint-for-editor - - *debugging-interpreter*)) - - - -;;;; Conditions. - -;;; The interface to building debugging tools signals conditions that prevent -;;; it from adhering to its contract. These are serious-conditions because the -;;; program using the interface must handle them before it can correctly -;;; continue execution. These debugging conditions are not errors since it is -;;; no fault of the programmers that the conditions occur. The interface does -;;; not provide for programs to detect these situations other than calling a -;;; routine that detects them and signals a condition. For example, -;;; programmers call A which may fail to return successfully due to a lack of -;;; debug information, and there is no B the they could have called to realize -;;; A would fail. It is not an error to have called A, but it is an error for -;;; the program to then ignore the signal generated by A since it cannot -;;; continue without A's correctly returning a value or performing some -;;; operation. -;;; -;;; Use DEBUG-SIGNAL to signal these conditions. -;;; - -(define-condition debug-condition (serious-condition) - () - (:documentation - "All debug-conditions inherit from this type. These are serious conditions - that must be handled, but they are not programmer errors.")) - -(define-condition no-debug-info (debug-condition) - () - (:documentation "There is absolutely no debugging information available.") - (:report (lambda (condition stream) - (declare (ignore condition)) - (fresh-line stream) - (write-line "No debugging information available." stream)))) - -(define-condition no-debug-function-returns (debug-condition) - (debug-function) - (:documentation - "The system could not return values from a frame with debug-function since - it lacked information about returning values.") - (:report (lambda (condition stream) - (let ((fun (debug-function-function - (no-debug-function-returns-debug-function condition)))) - (format stream - "~&Cannot return values from ~:[frame~;~:*~S~] since ~ - the debug information lacks details about returning ~ - values here." - fun))))) - -(define-condition no-debug-blocks (debug-condition) - (debug-function) - (:documentation "The debug-function has no debug-block information.") - (:report (lambda (condition stream) - (format stream "~&~S has no debug-block information." - (no-debug-blocks-debug-function condition))))) - -(define-condition no-debug-variables (debug-condition) - (debug-function) - (:documentation "The debug-function has no debug-variable information.") - (:report (lambda (condition stream) - (format stream "~&~S has no debug-variable information." - (no-debug-variables-debug-function condition))))) - -(define-condition lambda-list-unavailable (debug-condition) - (debug-function) - (:documentation - "The debug-function has no lambda-list since argument debug-variables are - unavailable.") - (:report (lambda (condition stream) - (format stream "~&~S has no lambda-list information available." - (lambda-list-unavailable-debug-function condition))))) - -(define-condition invalid-value (debug-condition) - ((debug-variable) - (frame)) - (:report (lambda (condition stream) - (format stream "~&~S has :invalid or :unknown value in ~S." - (invalid-value-debug-variable condition) - (invalid-value-frame condition))))) - -(define-condition ambiguous-variable-name (debug-condition) - ((name) - (frame)) - (:report (lambda (condition stream) - (format stream "~&~S names more than one valid variable in ~S." - (ambiguous-variable-name-name condition) - (ambiguous-variable-name-frame condition))))) - - -;;;; Errors and DEBUG-SIGNAL. - -;;; The debug-internals code tries to signal all programmer errors as subtypes -;;; of debug-error. There are calls to ERROR signalling simple-errors, but -;;; these dummy checks in the code and shouldn't come up. -;;; -;;; While under development, this code also signals errors in code branches -;;; that remain unimplemented. -;;; - -(define-condition debug-error (error) () - (:documentation - "All programmer errors from using the interface for building debugging - tools inherit from this type.")) - -(define-condition unhandled-condition (debug-error) - ((condition)) - (:report (lambda (condition stream) - (format stream "~&Unhandled debug-condition:~%~A" - (unhandled-condition-condition condition))))) - -(define-condition unknown-code-location (debug-error) - ((code-location)) - (:report (lambda (condition stream) - (format stream "~&Invalid use of an unknown code-location -- ~S." - (unknown-code-location-code-location condition))))) - -(define-condition unknown-debug-variable (debug-error) - ((debug-variable) - (debug-function)) - (:report (lambda (condition stream) - (format stream "~&~S not in ~S." - (unknown-debug-variable-debug-variable condition) - (unknown-debug-variable-debug-function condition))))) - -(define-condition invalid-control-stack-pointer (debug-error) - () - (:report (lambda (condition stream) - (declare (ignore condition)) - (fresh-line stream) - (write-string "Invalid control stack pointer." stream)))) - -(define-condition frame-function-mismatch (debug-error) - ((code-location) - (frame) - (form)) - (:report (lambda (condition stream) - (format stream - "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S" - (frame-function-mismatch-code-location condition) - (frame-function-mismatch-frame condition) - (frame-function-mismatch-form condition))))) - - -;;; DEBUG-SIGNAL -- Internal. -;;; -;;; This signals debug-conditions. If they go unhandled, then signal an -;;; unhandled-condition error. -;;; -;;; ??? Get SIGNAL in the right package! -;;; -(defmacro debug-signal (datum &rest arguments) - `(let ((condition (make-condition ,datum ,@arguments))) - (signal condition) - (error 'unhandled-condition :condition condition))) - - - -;;;; Structures. - -;;; Most of these structures model information stored in internal data -;;; structures created by the compiler. Whenever comments preface an object or -;;; type with "compiler", they refer to the internal compiler thing, not to the -;;; object or type with the same name in the "DI" package. -;;; - - -;;; -;;; Debug-variables -;;; - -;;; These exist for caching data stored in packed binary form in compiler -;;; debug-functions. Debug-functions store these. -;;; -(defstruct (debug-variable (:print-function print-debug-variable) - (:constructor nil)) - ;; - ;; String name of variable. - (name nil :type simple-string) - ;; - ;; String name of package. Nil when variable's name is uninterned. - (package nil :type (or null simple-string)) - ;; - ;; Unique integer identification relative to other variables with the same - ;; name and package. - (id 0 :type c::index) - ;; - ;; Whether the variable always has a valid value. - (alive-p nil :type c::boolean)) - -(defun print-debug-variable (obj str n) - (declare (ignore n)) - (format str "#<Debug-Variable ~A:~A:~A>" - (debug-variable-package obj) - (debug-variable-name obj) - (debug-variable-id obj))) - -(setf (documentation 'debug-variable-name 'function) - "Returns the name of the debug-variable. The name is the name of the symbol - used as an identifier when writing the code.") - -(setf (documentation 'debug-variable-package 'function) - "Returns the package name of the debug-variable. This is the package name of - the symbol used as an identifier when writing the code.") - -(setf (documentation 'debug-variable-id 'function) - "Returns the integer that makes debug-variable's name and package name unique - with respect to other debug-variable's in the same function.") - - -(defstruct (compiled-debug-variable - (:include debug-variable) - (:constructor make-compiled-debug-variable - (name package id alive-p sc-offset save-sc-offset))) - ;; - ;; Storage class and offset. (unexported). - (sc-offset nil :type c::sc-offset) - ;; - ;; Storage class and offset when saved somewhere. - (save-sc-offset nil :type (or c::sc-offset null))) - -(defstruct (interpreted-debug-variable - (:include debug-variable - (alive-p t)) - (:constructor make-interpreted-debug-variable - (name package ir1-var))) - ;; - ;; This is the IR1 structure that holds information about interpreted vars. - (ir1-var nil :type c::lambda-var)) - -;;; -;;; Frames -;;; - -;;; These represents call-frames on the stack. -;;; -(defstruct (frame (:constructor nil)) - ;; - ;; Next frame up. Null when top frame. - (up nil :type (or frame null)) - ;; - ;; Previous frame down. Nil when the bottom frame. Before computing the - ;; next frame down, this slot holds the frame pointer to the control stack - ;; for the given frame. This lets us get the next frame down and the - ;; return-pc for that frame. - (%down :unparsed :type (or frame (member nil :unparsed))) - ;; - ;; Debug-function for function whose call this frame represents. - (debug-function nil :type debug-function) - ;; - ;; Code-location to continue upon return to frame. - (code-location nil :type code-location) - ;; - ;; A-list of catch-tags to code-locations. - (%catches :unparsed :type (or list (member :unparsed))) - ;; - ;; Pointer to frame on control stack. (unexported) - ;; When is an interpreted-frame, this is an index into the interpreter's stack. - pointer - ;; - ;; This is the frame's number for prompt printing. Top is zero. - number) - -(setf (documentation 'frame-up 'function) - "Returns the frame immediately above frame on the stack. When frame is - the top of the stack, this returns nil.") - -(setf (documentation 'frame-debug-function 'function) - "Returns the debug-function for the function whose call frame represents.") - -(setf (documentation 'frame-code-location 'function) - "Returns the code-location where the frame's debug-function will continue - running when program execution returns to this frame. If someone - interrupted this frame, the result could be an unknown code-location.") - - -(defstruct (compiled-frame - (:include frame) - (:print-function print-compiled-frame) - (:constructor make-compiled-frame - (pointer up debug-function code-location number - &optional escaped))) - ;; - ;; Indicates whether someone interrupted frame. (unexported). - ;; If escaped, this is a pointer to the escape frame on the control stack. - escaped) - -(defun print-compiled-frame (obj str n) - (declare (ignore n)) - (format str "#<Compiled-Frame ~S~:[~;, interrupted~]>" - (debug-function-name (frame-debug-function obj)) - (compiled-frame-escaped obj))) - - -(defstruct (interpreted-frame - (:include frame) - (:print-function print-interpreted-frame) - (:constructor make-interpreted-frame - (pointer up debug-function code-location number - real-frame closure))) - ;; - ;; This points to the compiled-frame for EVAL:INTERNAL-APPLY-LOOP. - (real-frame nil :type compiled-frame) - ;; - ;; This is the closed over data used by the interpreter. - (closure nil :type simple-vector)) - -(defun print-interpreted-frame (obj str n) - (declare (ignore n)) - (format str "#<Interpreted-Frame ~S>" - (debug-function-name (frame-debug-function obj)))) - -;;; -;;; Debug-functions -;;; - -;;; These exist for caching data stored in packed binary form in compiler -;;; debug-functions. *compiled-debug-functions* maps a c::debug-function to a -;;; debug-function. There should only be one debug-function in existence for -;;; any function; that is, all code-locations and other objects that reference -;;; debug-functions point to unique objects. This is due to the overhead in -;;; cached information. -;;; -(defstruct (debug-function (:print-function print-debug-function)) - ;; - ;; Some representation of the function arguments. See - ;; DEBUG-FUNCTION-LAMBDA-LIST. - ;; NOTE: must parse vars before parsing arg list stuff. - (%lambda-list :unparsed) - ;; - ;; Cached debug-variable information. (unexported). - ;; These are sorted by their name. - (debug-vars :unparsed :type (or simple-vector null (member :unparsed))) - ;; - ;; Cached debug-block information. This is nil when we have tried to parse - ;; the packed binary info, but none is available. - (blocks :unparsed :type (or simple-vector null (member :unparsed))) - ;; - ;; The actual function if available. - (%function :unparsed :type (or null function (member :unparsed)))) - -(defun print-debug-function (obj str n) - (declare (ignore n)) - (format str "#<~A-Debug-Function ~S>" - (etypecase obj - (compiled-debug-function "Compiled") - (interpreted-debug-function "Interpreted") - (bogus-debug-function "Bogus")) - (debug-function-name obj))) - - -(defstruct (compiled-debug-function - (:include debug-function) - (:constructor %make-compiled-debug-function - (compiler-debug-fun component))) - ;; - ;; Compiler's dumped debug-function information. (unexported). - (compiler-debug-fun nil :type c::compiled-debug-function) - ;; - ;; Code object. (unexported). - component - ;; - ;; The :function-start breakpoint (if any) used to facilitate function - ;; end breakpoints. - (end-starter nil :type (or null breakpoint))) - -;;; This maps c::compiled-debug-functions to compiled-debug-functions, so we -;;; can get at cached stuff and not duplicate compiled-debug-function -;;; structures. -;;; -(defvar *compiled-debug-functions* (make-hash-table :test #'eq)) - -;;; MAKE-COMPILED-DEBUG-FUNCTION -- Internal. -;;; -;;; Makes a compiled-debug-function for a c::compiler-debug-function and its -;;; component. This maps the latter to the former in -;;; *compiled-debug-functions*. If there already is a compiled-debug-function, -;;; then this returns it from *compiled-debug-functions*. -;;; -(defun make-compiled-debug-function (compiler-debug-fun component) - (or (gethash compiler-debug-fun *compiled-debug-functions*) - (setf (gethash compiler-debug-fun *compiled-debug-functions*) - (%make-compiled-debug-function compiler-debug-fun component)))) - - -(defstruct (interpreted-debug-function - (:include debug-function) - (:constructor %make-interpreted-debug-function (ir1-lambda))) - ;; - ;; This is the ir1 lambda this debug-function represents. - (ir1-lambda nil :type c::clambda)) - -(defstruct (bogus-debug-function - (:include debug-function) - (:constructor make-bogus-debug-function - (%name &aux (%lambda-list nil) (debug-vars nil) - (blocks nil) (%function nil)))) - %name) - -(defvar *ir1-lambda-debug-function* (make-hash-table :test #'eq)) - -(defun make-interpreted-debug-function (ir1-lambda) - (let ((home-lambda (c::lambda-home ir1-lambda))) - (or (gethash home-lambda *ir1-lambda-debug-function*) - (setf (gethash home-lambda *ir1-lambda-debug-function*) - (%make-interpreted-debug-function home-lambda))))) - -;;; -;;; Debug-blocks. -;;; - -;;; These exist for caching data stored in packed binary form in compiler -;;; debug-blocks. -;;; -(defstruct (debug-block (:print-function print-debug-block)) - ;; - ;; Code-locations where execution continues after this block. - (successors nil :type list) - ;; - ;; This indicates whether the block is a special glob of code shared by - ;; various functions and tucked away elsewhere in a component. This kind of - ;; block has no start code-location. In an interpreted-debug-block, this is - ;; always nil. This slot is in all debug-blocks since it is an exported - ;; interface. - (elsewhere-p nil :type c::boolean)) - -(defun print-debug-block (obj str n) - (declare (ignore n)) - (format str "#<~A-Debug-Block ~S>" - (etypecase obj - (compiled-debug-block "Compiled") - (interpreted-debug-block "Interpreted")) - (debug-block-function-name obj))) - -(setf (documentation 'debug-block-successors 'function) - "Returns the list of possible code-locations where execution may continue - when the basic-block represented by debug-block completes its execution.") - -(setf (documentation 'debug-block-elsewhere-p 'function) - "Returns whether debug-block represents elsewhere code.") - - -(defstruct (compiled-debug-block (:include debug-block) - (:constructor - make-compiled-debug-block - (code-locations successors elsewhere-p))) - ;; - ;; Code-location information for the block. - (code-locations nil :type simple-vector)) - -(defstruct (interpreted-debug-block (:include debug-block - (elsewhere-p nil)) - (:constructor %make-interpreted-debug-block - (ir1-block))) - ;; - ;; This is the IR1 block this debug-block represents. - (ir1-block nil :type c::cblock) - ;; - ;; Code-location information for the block. - (locations :unparsed :type (or (member :unparsed) simple-vector))) - -(defvar *ir1-block-debug-block* (make-hash-table :test #'eq)) - -;;; MAKE-INTERPRETED-DEBUG-BLOCK -- Internal. -;;; -;;; This makes a debug-block for the interpreter's ir1-block. If we have it in -;;; the cache, return it. If we need to make it, then first make debug-blocks -;;; for all the ir1-blocks in ir1-block's home lambda; this makes sure all the -;;; successors of ir1-block have debug-blocks. We need this to fill in the -;;; resulting debug-block's successors list with debug-blocks, not ir1-blocks. -;;; After making all the possible debug-blocks we'll need to reference, go back -;;; over the list of new debug-blocks and fill in their successor slots with -;;; lists of debug-blocks. Then look up our argument ir1-block to find its -;;; debug-block since we know we have it now. -;;; -(defun make-interpreted-debug-block (ir1-block) - (check-type ir1-block c::cblock) - (let ((res (gethash ir1-block *ir1-block-debug-block*))) - (or res - (let ((lambda (c::block-home-lambda ir1-block))) - (c::do-blocks (block (c::block-component ir1-block)) - (when (eq lambda (c::block-home-lambda block)) - (push (setf (gethash block *ir1-block-debug-block*) - (%make-interpreted-debug-block block)) - res))) - (dolist (block res) - (let* ((successors nil) - (cblock (interpreted-debug-block-ir1-block block)) - (succ (c::block-succ cblock)) - (valid-succ - (if (and succ - (eq (car succ) - (c::component-tail - (c::block-component cblock)))) - () - succ))) - (dolist (sblock valid-succ) - (let ((dblock (gethash sblock *ir1-block-debug-block*))) - (when dblock - (push dblock successors)))) - (setf (debug-block-successors block) (nreverse successors)))) - (gethash ir1-block *ir1-block-debug-block*))))) - -;;; -;;; Breakpoints. -;;; - -;;; This is an internal structure that manages information about a breakpoint -;;; locations. See *component-breakpoint-offsets*. -;;; -(defstruct (breakpoint-data (:print-function print-breakpoint-data) - (:constructor make-breakpoint-data - (component offset))) - ;; - ;; This is the component in which the breakpoint lies. - component - ;; - ;; This is the byte offset into the component. - (offset nil :type c::index) - ;; - ;; The original instruction replaced by the breakpoint. - (instruction nil :type (or null (unsigned-byte 32))) - ;; - ;; A list of user breakpoints at this location. - (breakpoints nil :type list)) -;;; -(defun print-breakpoint-data (obj str n) - (declare (ignore n)) - (format str "#<Breakpoint-Data ~S at ~S>" - (debug-function-name - (debug-function-from-pc (breakpoint-data-component obj) - (breakpoint-data-offset obj))) - (breakpoint-data-offset obj))) - -(defstruct (breakpoint (:print-function print-breakpoint) - (:constructor %make-breakpoint - (hook-function what kind %info))) - ;; - ;; This is the function invoked when execution encounters the breakpoint. It - ;; takes a frame, the breakpoint, and optionally a list of values. Values - ;; are supplied for :function-end breakpoints as values to return for the - ;; function containing the breakpoint. :function-end breakpoint - ;; hook-functions also take a cookie argument. See cookie-fun slot. - (hook-function nil :type function) - ;; - ;; Code-location or debug-function. - (what nil :type (or code-location debug-function)) - ;; - ;; :code-location, :function-start, or :function-end for that kind of - ;; breakpoint. :unknown-return-partner if this is the partner of a - ;; :code-location breakpoint at an :unknown-return code-location. - (kind nil :type (member :code-location :function-start :function-end - :unknown-return-partner)) - ;; - ;; Status helps the user and the implementation. - (status :inactive :type (member :active :inactive :deleted)) - ;; - ;; This is a backpointer to a breakpoint-data. - (internal-data nil :type (or null breakpoint-data)) - ;; - ;; With code-locations whose type is :unknown-return, there are really - ;; two breakpoints: one at the multiple-value entry point, and one at - ;; the single-value entry point. This slot holds the breakpoint for the - ;; other one, or NIL if this isn't at an :unknown-return code location. - (unknown-return-partner nil :type (or null breakpoint)) - ;; - ;; :function-end breakpoints use a breakpoint at the :function-start to - ;; establish the end breakpoint upon function entry. We do this by frobbing - ;; the LRA to jump to a special piece of code that breaks and provides the - ;; return values for the returnee. This slot points to the start breakpoint, - ;; so we can activate, deactivate, and delete it. - (start-helper nil :type (or null breakpoint)) - ;; - ;; This is a hook users supply to get a dynamically unique cookie for - ;; identifying :function-end breakpoint executions. That is, if there is one - ;; :function-end breakpoint, but there may be multiple pending calls of its - ;; function on the stack. This function takes the cookie, and the - ;; hook-function takes the cookie too. - (cookie-fun nil :type (or null function)) - ;; - ;; This slot users can set with whatever information they find useful. - %info) -;;; -(defun print-breakpoint (obj str n) - (declare (ignore n)) - (let ((what (breakpoint-what obj))) - (format str "#<Breakpoint ~S~:[~;~:*~S~]>" - (etypecase what - (code-location what) - (debug-function (debug-function-name what))) - (etypecase what - (code-location nil) - (debug-function (breakpoint-kind obj)))))) - -(setf (documentation 'breakpoint-hook-function 'function) - "Returns the breakpoint's function the system calls when execution encounters - the breakpoint, and it is active. This is SETF'able.") - -(setf (documentation 'breakpoint-what 'function) - "Returns the breakpoint's what specification.") - -(setf (documentation 'breakpoint-kind 'function) - "Returns the breakpoint's kind specification.") - -;;; -;;; Code-locations. -;;; - -(defstruct (code-location (:print-function print-code-location) - (:constructor nil)) - ;; - ;; This is the debug-function containing code-location. - (debug-function nil :type debug-function) - ;; - ;; This is initially :unsure. Upon first trying to access an :unparsed slot, - ;; if the data is unavailable, then this becomes t, and the code-location is - ;; unknown. If the data is available, this becomes nil, a known location. - ;; We can't use a separate type code-location for this since we must return - ;; code-locations before we can tell whether they're known or unknown. For - ;; example, when parsing the stack, we don't want to unpack all the variables - ;; and blocks just to make frames. - (%unknown-p :unsure :type (member t nil :unsure)) - ;; - ;; This is the debug-block containing code-location. - ;; Possibly toss this out and just find it in the blocks cache in - ;; debug-function. - (%debug-block :unparsed :type (or debug-block (member :unparsed))) - ;; - ;; This is the number of forms processed by the compiler or loader before - ;; the top-level form containing this code-location. - (%tlf-offset :unparsed :type (or c::index (member :unparsed))) - ;; - ;; This is the depth-first number of the node that begins code-location - ;; within its top-level form. - (%form-number :unparsed :type (or c::index (member :unparsed)))) - -(defun print-code-location (obj str n) - (declare (ignore n)) - (format str "#<~A ~S>" - (ecase (code-location-unknown-p obj) - ((nil) (etypecase obj - (compiled-code-location "Compiled-Code-Location") - (interpreted-code-location "Interpreted-Code-Location"))) - ((t) "Unknown-Code-Location")) - (debug-function-name (code-location-debug-function obj)))) - -(setf (documentation 'code-location-debug-function 'function) - "Returns the debug-function representing information about the function - corresponding to the code-location.") - - -(defstruct (compiled-code-location - (:include code-location) - (:constructor make-known-code-location - (pc debug-function %tlf-offset %form-number - %live-set kind &aux (%unknown-p nil))) - (:constructor make-compiled-code-location (pc debug-function))) - ;; - ;; This is an index into debug-function's component slot. - (pc nil :type c::index) - ;; - ;; This is a bit-vector indexed by a variable's position in - ;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a valid - ;; value at this code-location. (unexported). - (%live-set :unparsed :type (or simple-bit-vector (member :unparsed))) - ;; - ;; (unexported) - ;; To see c::location-kind, do "(kernel:type-expand 'c::location-kind)". - (kind :unparsed :type (or (member :unparsed) c::location-kind))) - -(defstruct (interpreted-code-location - (:include code-location - (%unknown-p nil)) - (:constructor make-interpreted-code-location - (ir1-node debug-function))) - ;; - ;; This is an index into debug-function's component slot. - (ir1-node nil :type c::node)) - - -;;; -;;; Debug-sources -;;; - -(proclaim '(inline debug-source-root-number)) -;;; -(defun debug-source-root-number (debug-source) - "Returns the number of top-level forms processed by the compiler before - compiling this source. If this source is uncompiled, this is zero. This - may be zero even if the source is compiled since the first form in the first - file compiled in one compilation, for example, must have a root number of - zero -- the compiler saw no other top-level forms before it." - (c::debug-source-source-root debug-source)) - -(setf (documentation 'c::debug-source-from 'function) - "Returns an indication of the type of source. The following are the possible - values: - :file from a file (obtained by COMPILE-FILE if compiled). - :lisp from Lisp (obtained by COMPILE if compiled). - :stream from a non-file stream.") - -(setf (documentation 'c::debug-source-name 'function) - "Returns the actual source in some sense represented by debug-source, which - is related to DEBUG-SOURCE-FROM: - :file the pathname of the file. - :lisp a lambda-expression. - :stream some descriptive string that's otherwise useless.") - -(setf (documentation 'c::debug-source-created 'function) - "Returns the universal time someone created the source. This may be nil if - it is unavailable.") - -(setf (documentation 'c::debug-source-compiled 'function) - "Returns the time someone compiled the source. This is nil if the source - is uncompiled.") - -(setf (documentation 'c::debug-source-start-positions 'function) - "This function returns the file position of each top-level form as an array - if debug-source is from a :file. If DEBUG-SOURCE-FROM is :lisp or :stream, - this returns nil.") - -(setf (documentation 'c::debug-source-p 'function) - "Returns whether object is a debug-source.") - - - -;;;; Frames. - -;;; This is used in FIND-ESCAPE-FRAME and with the bogus components and LRAs -;;; used for :function-end breakpoints. When a components debug-info slot is -;;; :bogus-lra, then the real-lra-slot contains the real component to continue -;;; executing, as opposed to the bogus component which appeared in some frame's -;;; LRA location. -;;; -(defconstant real-lra-slot vm:code-constants-offset) - -;;; These are magically converted by the compiler. -;;; -(defun kernel:current-sp () (kernel:current-sp)) -(defun kernel:current-fp () (kernel:current-fp)) -(defun kernel:stack-ref (s n) (kernel:stack-ref s n)) -(defun kernel:%set-stack-ref (s n value) (kernel:%set-stack-ref s n value)) -(defun kernel:function-code-header (fun) (kernel:function-code-header fun)) -(defun kernel:lra-code-header (lra) (kernel:lra-code-header lra)) -(defun kernel:make-lisp-obj (value) (kernel:make-lisp-obj value)) -(defun kernel:get-lisp-obj-address (thing) (kernel:get-lisp-obj-address thing)) -(defun kernel:function-word-offset (fun) (kernel:function-word-offset fun)) -;;; -(defsetf kernel:stack-ref kernel:%set-stack-ref) - -(proclaim '(inline cstack-pointer-valid-p)) -(defun cstack-pointer-valid-p (x) - (declare (type system:system-area-pointer x)) - (and (system:sap< x (kernel:current-sp)) - (system:sap<= (alien:alien-sap (alien:extern-alien "control_stack" - (* t))) - x))) - -;;; TOP-FRAME -- Public. -;;; -(defun top-frame () - "Returns the top frame of the control stack as it was before calling this - function." - (multiple-value-bind (fp pc) - (kernel:%caller-frame-and-pc) - (possibly-an-interpreted-frame - (compute-calling-frame (system:int-sap (* (ext:truly-the fixnum fp) - vm:word-bytes)) - pc nil) - nil))) - -;;; FLUSH-FRAMES-ABOVE -- public. -;;; -(defun flush-frames-above (frame) - "Flush all of the frames above FRAME, and renumber all the frames below - FRAME." - (setf (frame-up frame) nil) - (do ((number 0 (1+ number)) - (frame frame (frame-%down frame))) - ((not (frame-p frame))) - (setf (frame-number frame) number))) - -;;; FRAME-DOWN -- Public. -;;; -;;; We have to access the old-fp and return-pc out of frame and pass them to -;;; COMPUTE-CALLING-FRAME. -;;; -(defun frame-down (frame) - "Returns the frame immediately below frame on the stack. When frame is - the bottom of the stack, this returns nil." - (let ((down (frame-%down frame))) - (if (eq down :unparsed) - (let* ((real (frame-real-frame frame)) - (debug-fun (frame-debug-function real))) - (setf (frame-%down frame) - (etypecase debug-fun - (compiled-debug-function - (let ((c-d-f (compiled-debug-function-compiler-debug-fun - debug-fun))) - (possibly-an-interpreted-frame - (compute-calling-frame - (system:int-sap - (* (get-context-value - real vm::ocfp-save-offset - (c::compiled-debug-function-old-fp c-d-f)) - vm:word-bytes)) - (get-context-value - real vm::lra-save-offset - (c::compiled-debug-function-return-pc c-d-f)) - frame) - frame))) - (bogus-debug-function - (let ((fp (frame-pointer real))) - (compute-calling-frame - (system:sap-ref-sap fp (* vm::ocfp-save-offset - vm:word-bytes)) - (kernel:stack-ref fp vm::lra-save-offset) - frame)))))) - down))) - - -;;; GET-CONTEXT-VALUE -- Internal. -;;; -;;; Get the old FP or return PC out of frame. Stack-slot is the standard save -;;; location offset on the stack. Loc is the saved sc-offset describing the -;;; main location. -;;; -(defun get-context-value (frame stack-slot loc) - (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type c::sc-offset loc)) - (let ((pointer (frame-pointer frame)) - (escaped (compiled-frame-escaped frame))) - (if escaped - (sub-access-debug-var-slot pointer loc escaped) - (kernel:stack-ref pointer stack-slot)))) -;;; -(defun (setf get-context-value) (value frame stack-slot loc) - (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type c::sc-offset loc)) - (let ((pointer (frame-pointer frame)) - (escaped (compiled-frame-escaped frame))) - (if escaped - (sub-set-debug-var-slot pointer loc value escaped) - (setf (kernel:stack-ref pointer stack-slot) value)))) - - -(defvar *debugging-interpreter* nil - "When set, the debugger foregoes making interpreted-frames, so you can - debug the functions that manifest the interpreter.") - -;;; POSSIBLY-AN-INTERPRETED-FRAME -- Internal. -;;; -;;; This takes a newly computed frame, frame, and the frame above it on the -;;; stack, up-frame, which is possibly nil. Frame is nil when we hit the -;;; bottom of the control stack. When frame represents a call to -;;; EVAL::INTERNAL-APPLY-LOOP, we make an interpreted frame to replace frame. -;;; The interpreted frame points to frame. -;;; -(defun possibly-an-interpreted-frame (frame up-frame) - (if (or (not frame) - (not (eq (debug-function-name (frame-debug-function frame)) - 'eval::internal-apply-loop)) - *debugging-interpreter* - (compiled-frame-escaped frame)) - frame - (flet ((get-var (name location) - (let ((vars (di:ambiguous-debug-variables - (di:frame-debug-function frame) name))) - (when (or (null vars) (> (length vars) 1)) - (error "Zero or more than one ~A variable in ~ - EVAL::INTERNAL-APPLY-LOOP?" - (string-downcase name))) - (if (eq (debug-variable-validity (car vars) location) - :valid) - (car vars))))) - (let* ((code-loc (frame-code-location frame)) - (ptr-var (get-var "FRAME-PTR" code-loc)) - (node-var (get-var "NODE" code-loc)) - (closure-var (get-var "CLOSURE" code-loc))) - (if (and ptr-var node-var closure-var) - (let* ((node (debug-variable-value node-var frame)) - (d-fun (make-interpreted-debug-function - (c::block-home-lambda (c::node-block node))))) - (make-interpreted-frame - (debug-variable-value ptr-var frame) - up-frame - d-fun - (make-interpreted-code-location node d-fun) - (frame-number frame) - frame - (debug-variable-value closure-var frame))) - frame))))) - - -;;; COMPUTE-CALLING-FRAME -- Internal. -;;; -;;; This returns a frame for the one existing in time immediately prior to the -;;; frame referenced by current-fp. This is current-fp's caller or the next -;;; frame down the control stack. If there is no down frame, this returns nil -;;; for the bottom of the stack. Up-frame is the up link for the resulting -;;; frame object, and it is nil when we call this to get the top of the stack. -;;; -;;; The current frame contains the pointer to the temporally previous frame we -;;; want, and the current frame contains the pc at which we will continue -;;; executing upon returning to that previous frame. -;;; -;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp calls -;;; into C. In this case, the code object is stored on the stack after the -;;; LRA, and the LRA is the word offset. -;;; -(defun compute-calling-frame (caller lra up-frame) - (declare (type system:system-area-pointer caller)) - (when (cstack-pointer-valid-p caller) - (multiple-value-bind - (code pc-offset escaped) - (if lra - (multiple-value-bind - (word-offset code) - (if (ext:fixnump lra) - (let ((fp (frame-pointer up-frame))) - (values lra - (kernel:stack-ref fp (1+ vm::lra-save-offset)))) - (values (kernel:get-header-data lra) - (kernel:lra-code-header lra))) - (if code - (values code - (* (1+ (- word-offset (kernel:get-header-data code))) - vm:word-bytes) - nil) - (values :foreign-function - 0 - nil))) - (find-escaped-frame caller)) - (if (eq (kernel:%code-debug-info code) :bogus-lra) - (let ((real-lra (kernel:code-header-ref code real-lra-slot))) - (compute-calling-frame caller real-lra up-frame)) - (let ((d-fun (case code - (:undefined-function - (make-bogus-debug-function - "The Undefined Function")) - (:foreign-function - (make-bogus-debug-function - "Foreign function call land")) - ((nil) - (make-bogus-debug-function - "Bogus stack frame")) - (t - (debug-function-from-pc code pc-offset))))) - (make-compiled-frame caller up-frame d-fun - (code-location-from-pc d-fun pc-offset - escaped) - (if up-frame (1+ (frame-number up-frame)) 0) - escaped)))))) - -(defun find-escaped-frame (frame-pointer) - (declare (type system:system-area-pointer frame-pointer)) - (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil)) - (alien:with-alien - ((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern)) - (let ((scp (alien:deref lisp-interrupt-contexts index))) - (when (= (system:sap-int frame-pointer) - (vm:sigcontext-register scp vm::cfp-offset)) - (system:without-gcing - (let ((code (code-object-from-bits - (vm:sigcontext-register scp vm::code-offset)))) - (when (symbolp code) - (return (values code 0 scp))) - (let* ((code-header-len (* (kernel:get-header-data code) - vm:word-bytes)) - (pc-offset - (- (system:sap-int - (vm:sigcontext-program-counter scp)) - (- (kernel:get-lisp-obj-address code) - vm:other-pointer-type) - code-header-len))) - ;; Check to see if we were executing in a branch delay slot. - #+pmax ; pmax only - (when (logbitp 31 (alien:slot scp 'mips::sc-cause)) - (incf pc-offset vm:word-bytes)) - (unless (<= 0 pc-offset - (* (kernel:code-header-ref code - vm:code-code-size-slot) - vm:word-bytes)) - ;; We were in an assembly routine. Therefore, use the LRA as - ;; the pc. - (setf pc-offset - (- (vm:sigcontext-register scp vm::lra-offset) - (kernel:get-lisp-obj-address code) - code-header-len))) - (return - (if (eq (kernel:%code-debug-info code) :bogus-lra) - (let ((real-lra (kernel:code-header-ref code - real-lra-slot))) - (values (kernel:lra-code-header real-lra) - (kernel:get-header-data real-lra) - nil)) - (values code pc-offset scp))))))))))) - -;;; CODE-OBJECT-FROM-BITS -- internal. -;;; -;;; Find the code object corresponding to the object represented by bits and -;;; return it. We assume bogus functions correspond to the -;;; undefined-function. -;;; -(defun code-object-from-bits (bits) - (declare (type (unsigned-byte 32) bits)) - (let ((object (kernel:make-lisp-obj bits))) - (if (functionp object) - (or (kernel:function-code-header object) - :undefined-function) - (let ((lowtag (kernel:get-lowtag object))) - (if (= lowtag vm:other-pointer-type) - (let ((type (kernel:get-type object))) - (cond ((= type vm:code-header-type) - object) - ((= type vm:return-pc-header-type) - (kernel:lra-code-header object)) - (t - nil)))))))) - -;;; -;;; Frame utilities. -;;; - -;;; DEBUG-FUNCTION-FROM-PC -- Internal. -;;; -;;; This returns a compiled-debug-function for code and pc. We fetch the -;;; c::debug-info and run down its function-map to get a -;;; c::compiled-debug-function from the pc. The result only needs to reference -;;; the component, for function constants, and the c::compiled-debug-function. -;;; -(defun debug-function-from-pc (component pc) - (let ((info (kernel:%code-debug-info component))) - (cond - ((not info) - (debug-signal 'no-debug-info)) - ((eq info :bogus-lra) - (make-bogus-debug-function "Function End Breakpoint")) - (t - (let* ((function-map (get-debug-info-function-map info)) - (len (length function-map))) - (declare (simple-vector function-map)) - (if (= len 1) - (make-compiled-debug-function (svref function-map 0) component) - (let ((i 1) - (elsewhere-p - (>= pc (c::compiled-debug-function-elsewhere-pc - (svref function-map 0))))) - (declare (type c::index i)) - (loop - (when (or (= i len) - (< pc (if elsewhere-p - (c::compiled-debug-function-elsewhere-pc - (svref function-map (1+ i))) - (svref function-map i)))) - (return (make-compiled-debug-function - (svref function-map (1- i)) - component))) - (incf i 2))))))))) - -;;; CODE-LOCATION-FROM-PC -- Internal. -;;; -;;; This returns a code-location for the compiled-debug-function, debug-fun, -;;; and the pc into its code vector. If we stopped at a breakpoint, find -;;; the code-location for that breakpoint. Otherwise, make an :unsure code -;;; location, so it can be filled in when we figure out what is going on. -;;; -(defun code-location-from-pc (debug-fun pc escaped) - (or (and (compiled-debug-function-p debug-fun) - escaped - (let ((data (breakpoint-data - (compiled-debug-function-component debug-fun) - pc nil))) - (when (and data (breakpoint-data-breakpoints data)) - (let ((what (breakpoint-what - (first (breakpoint-data-breakpoints data))))) - (when (compiled-code-location-p what) - what))))) - (make-compiled-code-location pc debug-fun))) - -;;; FRAME-CATCHES -- Public. -;;; -(defun frame-catches (frame) - "Returns an a-list mapping catch tags to code-locations. These are - code-locations at which execution would continue with frame as the top - frame if someone threw to the corresponding tag." - (let ((catch (system:int-sap (* lisp::*current-catch-block* vm:word-bytes))) - (res nil) - (fp (frame-pointer (frame-real-frame frame)))) - (loop - (when (zerop (sap-int catch)) (return (nreverse res))) - (when (sap= fp - (system:int-sap - (* (kernel:stack-ref catch vm:catch-block-current-cont-slot) - vm:word-bytes))) - (let* ((lra (kernel:stack-ref catch vm:catch-block-entry-pc-slot)) - (component - (kernel:stack-ref catch vm:catch-block-current-code-slot)) - (word-offset (- (1+ (kernel:get-header-data lra)) - (kernel:get-header-data component)))) - (push (cons (kernel:stack-ref catch vm:catch-block-tag-slot) - (make-compiled-code-location - (* word-offset vm:word-bytes) - (frame-debug-function frame))) - res))) - (setf catch - (system:sap-ref-sap catch - (* vm:catch-block-previous-catch-slot - vm:word-bytes)))))) - -;;; FRAME-REAL-FRAME -- Internal. -;;; -;;; If an interpreted frame, return the real frame, otherwise frame. -;;; -(defun frame-real-frame (frame) - (etypecase frame - (compiled-frame frame) - (interpreted-frame (interpreted-frame-real-frame frame)))) - - - -;;;; Debug-functions. - -;;; DO-DEBUG-FUNCTION-BLOCKS -- Public. -;;; -(defmacro do-debug-function-blocks ((block-var debug-function &optional result) - &body body) - "Executes the forms in a context with block-var bound to each debug-block in - debug-function successively. Result is an optional form to execute for - return values, and DO-DEBUG-FUNCTION-BLOCKS returns nil if there is no - result form. This signals a no-debug-blocks condition when the - debug-function lacks debug-block information." - (let ((blocks (gensym)) - (i (gensym))) - `(let ((,blocks (debug-function-debug-blocks ,debug-function))) - (declare (simple-vector ,blocks)) - (dotimes (,i (length ,blocks) ,result) - (let ((,block-var (svref ,blocks ,i))) - ,@body))))) - -;;; DO-DEBUG-FUNCTION-VARIABLES -- Public. -;;; -(defmacro do-debug-function-variables ((var debug-function &optional result) - &body body) - "Executes body in a context with var bound to each debug-variable in - debug-function. This returns the value of executing result (defaults to - nil). This may iterate over only some of debug-function's variables or none - depending on debug policy; for example, possibly the compilation only - preserved argument information." - (let ((vars (gensym)) - (i (gensym))) - `(let ((,vars (debug-function-debug-variables ,debug-function))) - (declare (type (or null simple-vector) ,vars)) - (if ,vars - (dotimes (,i (length ,vars) ,result) - (let ((,var (svref ,vars ,i))) - ,@body)) - ,result)))) - -;;; DEBUG-FUNCTION-FUNCTION -- Public. -;;; -(defun debug-function-function (debug-function) - "Returns the Common Lisp function associated with the debug-function. This - returns nil if the function is unavailable or is non-existent as a user - callable function object." - (let ((cached-value (debug-function-%function debug-function))) - (if (eq cached-value :unparsed) - (setf (debug-function-%function debug-function) - (etypecase debug-function - (compiled-debug-function - (let ((component - (compiled-debug-function-component debug-function)) - (start-pc - (c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun - debug-function)))) - (do ((entry (kernel:%code-entry-points component) - (kernel:%function-next entry))) - ((null entry) nil) - (when (= start-pc - (c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun - (function-debug-function entry)))) - (return entry))))) - (interpreted-debug-function - (c::lambda-eval-info-function - (c::leaf-info - (interpreted-debug-function-ir1-lambda debug-function)))) - (bogus-debug-function nil))) - cached-value))) - - -;;; DEBUG-FUNCTION-NAME -- Public. -;;; -(defun debug-function-name (debug-function) - "Returns the name of the function represented by debug-function. This may - be a string or a cons; do not assume it is a symbol." - (etypecase debug-function - (compiled-debug-function - (c::compiled-debug-function-name - (compiled-debug-function-compiler-debug-fun debug-function))) - (interpreted-debug-function - (c::lambda-name (interpreted-debug-function-ir1-lambda debug-function))) - (bogus-debug-function - (bogus-debug-function-%name debug-function)))) - - -;;; FUNCTION-DEBUG-FUNCTION -- Public. -;;; -(defun function-debug-function (fun) - "Returns a debug-function that represents debug information for function." - (if (eval:interpreted-function-p fun) - (let ((eval-fun (eval::get-eval-function fun))) - (make-interpreted-debug-function - (or (eval::eval-function-definition eval-fun) - (eval::convert-eval-fun eval-fun)))) - (let* ((name (kernel:%function-name fun)) - (component (kernel:function-code-header fun)) - (res (find-if - #'(lambda (x) - (and (c::compiled-debug-function-p x) - (eq (c::compiled-debug-function-name x) name) - (eq (c::compiled-debug-function-kind x) nil))) - (get-debug-info-function-map - (kernel:%code-debug-info component))))) - (if res - (make-compiled-debug-function res component) - ;; This used to be the non-interpreted branch, but William wrote it - ;; to return the debug-fun of fun's XEP instead of fun's debug-fun. - ;; The above code does this more correctly, but it doesn't get or - ;; eliminate all appropriate cases. It mostly works, and probably - ;; works for all named functions anyway. - (debug-function-from-pc component - (* (- (kernel:function-word-offset fun) - (kernel:get-header-data component)) - vm:word-bytes)))))) - - -;;; DEBUG-FUNCTION-KIND -- Public. -;;; -(defun debug-function-kind (debug-function) - "Returns the kind of the function which is one of :optional, :external, - :top-level, :cleanup, nil." - (etypecase debug-function - (compiled-debug-function - (c::compiled-debug-function-kind - (compiled-debug-function-compiler-debug-fun debug-function))) - (interpreted-debug-function - (c::lambda-kind (interpreted-debug-function-ir1-lambda debug-function))) - (bogus-debug-function - nil))) - -;;; DEBUG-VARIABLE-INFO-AVAILABLE -- Public. -;;; -(defun debug-variable-info-available (debug-function) - "Returns whether there is any variable information for debug-function." - (not (not (debug-function-debug-variables debug-function)))) - -;;; DEBUG-FUNCTION-SYMBOL-VARIABLES -- Public. -;;; -(defun debug-function-symbol-variables (debug-function symbol) - "Returns a list of debug-variables in debug-function having the same name - and package as symbol. If symbol is uninterned, then this returns a list of - debug-variables without package names and with the same name as symbol. The - result of this function is limited to the availability of variable - information in debug-function; for example, possibly debug-function only - knows about its arguments." - (let ((vars (ambiguous-debug-variables debug-function (symbol-name symbol))) - (package (if (symbol-package symbol) - (package-name (symbol-package symbol))))) - (delete-if (if (stringp package) - #'(lambda (var) - (let ((p (debug-variable-package var))) - (or (not (stringp p)) - (string/= p package)))) - #'(lambda (var) - (stringp (debug-variable-package var)))) - vars))) - -;;; AMBIGUOUS-DEBUG-VARIABLES -- Public. -;;; -(defun ambiguous-debug-variables (debug-function name-prefix-string) - "Returns a list of debug-variables in debug-function whose names contain - name-prefix-string as an intial substring. The result of this function is - limited to the availability of variable information in debug-function; for - example, possibly debug-function only knows about its arguments." - (declare (simple-string name-prefix-string)) - (let ((variables (debug-function-debug-variables debug-function))) - (declare (type (or null simple-vector) variables)) - (if variables - (let* ((len (length variables)) - (prefix-len (length name-prefix-string)) - (pos (find-variable name-prefix-string variables len)) - (res nil)) - (when pos - ;; Find names from pos to variable's len that contain prefix. - (do ((i pos (1+ i))) - ((= i len)) - (let* ((var (svref variables i)) - (name (debug-variable-name var)) - (name-len (length name))) - (declare (simple-string name)) - (when (/= (or (string/= name-prefix-string name - :end1 prefix-len :end2 name-len) - prefix-len) - prefix-len) - (return)) - (push var res))) - (setq res (nreverse res))) - res)))) - -;;; FIND-VARIABLE -- Internal. -;;; -;;; This returns a position in variables for one containing name as an initial -;;; substring. End is the length of variables if supplied. -;;; -(defun find-variable (name variables &optional end) - (declare (simple-vector variables) - (simple-string name)) - (let ((name-len (length name))) - (position name variables - :test #'(lambda (x y) - (let* ((y (debug-variable-name y)) - (y-len (length y))) - (declare (simple-string y)) - (and (>= y-len name-len) - (string= x y :end1 name-len :end2 name-len)))) - :end (or end (length variables))))) - -;;; DEBUG-FUNCTION-LAMBDA-LIST -- Public. -;;; -(defun debug-function-lambda-list (debug-function) - "Returns a list representing the lambda-list for debug-function. The list - has the following structure: - (required-var1 required-var2 - ... - (:optional var3 suppliedp-var4) - (:optional var5) - ... - (:rest var6) (:rest var7) - ... - (:keyword keyword-symbol var8 suppliedp-var9) - (:keyword keyword-symbol var10) - ... - ) - Each VARi is a debug-variable; however it may be the symbol :deleted it - is unreferenced in debug-function. This signals a lambda-list-unavaliable - condition when there is no argument list information." - (etypecase debug-function - (compiled-debug-function - (compiled-debug-function-lambda-list debug-function)) - (interpreted-debug-function - (interpreted-debug-function-lambda-list debug-function)) - (bogus-debug-function - nil))) - -;;; INTERPRETED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal. -;;; -;;; The hard part is when the lambda-list is unparsed. If it is unparsed, -;;; and all the arguments are required, this is still pretty easy; just -;;; whip the appropriate debug-variables into a list. Otherwise, we have -;;; to pick out the funny arguments including any suppliedp variables. In -;;; this situation, the ir1-lambda is an external entry point that takes -;;; arguments users really pass in. It looks at those and computes defaults -;;; and suppliedp variables, ultimately passing everything defined as a -;;; a parameter to the real function as final arguments. If this has to -;;; compute the lambda list, it caches it in debug-function. -;;; -(defun interpreted-debug-function-lambda-list (debug-function) - (let ((lambda-list (debug-function-%lambda-list debug-function)) - (debug-vars (debug-function-debug-variables debug-function)) - (ir1-lambda (interpreted-debug-function-ir1-lambda debug-function)) - (res nil)) - (if (eq lambda-list :unparsed) - (flet ((frob (v debug-vars) - (if (c::lambda-var-refs v) - (find v debug-vars - :key #'interpreted-debug-variable-ir1-var) - :deleted))) - (let ((xep-args (c::lambda-optional-dispatch ir1-lambda))) - (if (and xep-args - (eq (c::optional-dispatch-main-entry xep-args) ir1-lambda)) - ;; - ;; There are rest, optional, keyword, and suppliedp vars. - (let ((final-args (c::lambda-vars ir1-lambda))) - (dolist (xep-arg (c::optional-dispatch-arglist xep-args)) - (let ((info (c::lambda-var-arg-info xep-arg)) - (final-arg (pop final-args))) - (cond (info - (case (c::arg-info-kind info) - (:required - (push (frob final-arg debug-vars) res)) - (:keyword - (push (list :keyword - (c::arg-info-keyword info) - (frob final-arg debug-vars)) - res)) - (:rest - (push (list :rest (frob final-arg debug-vars)) - res)) - (:optional - (push (list :optional - (frob final-arg debug-vars)) - res))) - (when (c::arg-info-supplied-p info) - (nconc - (car res) - (list (frob (pop final-args) debug-vars))))) - (t - (push (frob final-arg debug-vars) res))))) - (setf (debug-function-%lambda-list debug-function) - (nreverse res))) - ;; - ;; All required args, so return them in a list. - (dolist (v (c::lambda-vars ir1-lambda) - (setf (debug-function-%lambda-list debug-function) - (nreverse res))) - (push (frob v debug-vars) res))))) - ;; - ;; Everything's unparsed and cached, so return it. - lambda-list))) - -;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal. -;;; -;;; If this has to compute the lambda list, it caches it in debug-function. -;;; -(defun compiled-debug-function-lambda-list (debug-function) - (let ((lambda-list (debug-function-%lambda-list debug-function))) - (cond ((eq lambda-list :unparsed) - (multiple-value-bind - (args argsp) - (parse-compiled-debug-function-lambda-list debug-function) - (setf (debug-function-%lambda-list debug-function) args) - (if argsp - args - (debug-signal 'lambda-list-unavailable - :debug-function debug-function)))) - (lambda-list) - ((bogus-debug-function-p debug-function) - nil) - ((c::compiled-debug-function-arguments - (compiled-debug-function-compiler-debug-fun - debug-function)) - ;; If the packed information is there (whether empty or not) as - ;; opposed to being nil, then returned our cached value (nil). - nil) - (t - ;; Our cached value is nil, and the packed lambda-list information - ;; is nil, so we don't have anything available. - (debug-signal 'lambda-list-unavailable - :debug-function debug-function))))) - -;;; PARSE-COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal. -;;; -;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST calls this when a -;;; compiled-debug-function has no lambda-list information cached. It returns -;;; the lambda-list as the first value and whether there was any argument -;;; information as the second value. Therefore, nil and t means there were no -;;; arguments, but nil and nil means there was no argument information. -;;; -(defun parse-compiled-debug-function-lambda-list (debug-function) - (let ((args (c::compiled-debug-function-arguments - (compiled-debug-function-compiler-debug-fun - debug-function)))) - (cond - ((not args) - (values nil nil)) - ((eq args :minimal) - (values (coerce (debug-function-debug-variables debug-function) 'list) - t)) - (t - (let ((vars (debug-function-debug-variables debug-function)) - (i 0) - (len (length args)) - (res nil) - (optionalp nil)) - (declare (type (or null simple-vector) vars)) - (loop - (when (>= i len) (return)) - (let ((ele (aref args i))) - (cond - ((symbolp ele) - (case ele - (c::deleted - ;; Deleted required arg at beginning of args array. - (push :deleted res)) - (c::optional-args - (setf optionalp t)) - (c::supplied-p - ;; supplied-p var immediately following keyword or optional. - ;; Stick the extra var in the result element representing - ;; the keyword or optional, which is the previous one. - (nconc (car res) - (list (compiled-debug-function-lambda-list-var - args (incf i) vars)))) - (c::rest-arg - (push (list :rest - (compiled-debug-function-lambda-list-var - args (incf i) vars)) - res)) - (c::more-arg - (error "I thought I'd never see a more-arg?")) - (t - ;; Keyword arg. - (push (list :keyword - ele - (compiled-debug-function-lambda-list-var - args (incf i) vars)) - res)))) - (optionalp - ;; We saw an optional marker, so the following non-symbols are - ;; indexes indicating optional variables. - (push (list :optional (svref vars ele)) res)) - (t - ;; Required arg at beginning of args array. - (push (svref vars ele) res)))) - (incf i)) - (values (nreverse res) t)))))) - -;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST-VAR -- Internal -;;; -;;; Used in COMPILED-DEBUG-FUNCTION-LAMBDA-LIST. -;;; -(defun compiled-debug-function-lambda-list-var (args i vars) - (declare (type (simple-array * (*)) args) - (simple-vector vars)) - (let ((ele (aref args i))) - (cond ((not (symbolp ele)) (svref vars ele)) - ((eq ele 'c::deleted) :deleted) - (t (error "Malformed arguments description."))))) - -;;; COMPILED-DEBUG-FUNCTION-DEBUG-INFO -- Internal. -;;; -(defun compiled-debug-function-debug-info (debug-fun) - (kernel:%code-debug-info (compiled-debug-function-component debug-fun))) - - - -;;;; Unpacking variable and basic block data. - -(defvar *parsing-buffer* - (make-array 20 :adjustable t :fill-pointer t)) -(defvar *other-parsing-buffer* - (make-array 20 :adjustable t :fill-pointer t)) -;;; -;;; WITH-PARSING-BUFFER -- Internal. -;;; -;;; PARSE-DEBUG-BLOCKS, PARSE-DEBUG-VARIABLES and UNCOMPACT-FUNCTION-MAP use -;;; this to unpack binary encoded information. It returns the values returned -;;; by the last form in body. -;;; -;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at element -;;; zero, and makes sure if we unwind, we nil out any set elements for GC -;;; purposes. -;;; -;;; This also binds other-var to *other-parsing-buffer* when it is supplied, -;;; making sure it starts at element zero and that we nil out any elements if -;;; we unwind. -;;; -;;; This defines the local macro RESULT that takes a buffer, copies its -;;; elements to a resulting simple-vector, nil's out elements, and restarts -;;; the buffer at element zero. RESULT returns the simple-vector. -;;; -(eval-when (compile eval) -(defmacro with-parsing-buffer ((buffer-var &optional other-var) &body body) - (let ((len (gensym)) - (res (gensym))) - `(unwind-protect - (let ((,buffer-var *parsing-buffer*) - ,@(if other-var `((,other-var *other-parsing-buffer*)))) - (setf (fill-pointer ,buffer-var) 0) - ,@(if other-var `((setf (fill-pointer ,other-var) 0))) - (macrolet ((result (buf) - `(let* ((,',len (length ,buf)) - (,',res (make-array ,',len))) - (replace ,',res ,buf :end1 ,',len :end2 ,',len) - (fill ,buf nil :end ,',len) - (setf (fill-pointer ,buf) 0) - ,',res))) - ,@body)) - (fill *parsing-buffer* nil) - ,@(if other-var `((fill *other-parsing-buffer* nil)))))) -) ;eval-when - - -;;; DEBUG-FUNCTION-DEBUG-BLOCKS -- Internal. -;;; -;;; The argument is a debug internals structure. This returns the debug-blocks -;;; for debug-function, regardless of whether we have unpacked them yet. It -;;; signals a no-debug-blocks condition if it can't return the blocks. -;;; -(defun debug-function-debug-blocks (debug-function) - (let ((blocks (debug-function-blocks debug-function))) - (cond ((eq blocks :unparsed) - (setf (debug-function-blocks debug-function) - (parse-debug-blocks debug-function)) - (unless (debug-function-blocks debug-function) - (debug-signal 'no-debug-blocks - :debug-function debug-function)) - (debug-function-blocks debug-function)) - (blocks) - (t - (debug-signal 'no-debug-blocks - :debug-function debug-function))))) - -;;; PARSE-DEBUG-BLOCKS -- Internal. -;;; -;;; This returns a simple-vector of debug-blocks or nil. Nil indicates there -;;; was no basic block information. -;;; -(defun parse-debug-blocks (debug-function) - (etypecase debug-function - (compiled-debug-function - (parse-compiled-debug-blocks debug-function)) - (bogus-debug-function - (debug-signal 'no-debug-blocks :debug-function debug-function)) - (interpreted-debug-function - (parse-interpreted-debug-blocks debug-function)))) - - -;;; PARSE-COMPILED-DEBUG-BLOCKS -- Internal. -;;; -;;; This does some of the work of PARSE-DEBUG-BLOCKS. -;;; -(defun parse-compiled-debug-blocks (debug-function) - (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function)) - (var-count (length (debug-function-debug-variables debug-function))) - (blocks (c::compiled-debug-function-blocks debug-fun)) - ;; 8 is a hard-wired constant in the compiler for the element size of - ;; the packed binary representation of the blocks data. - (live-set-len (ceiling var-count 8)) - (tlf-number (c::compiled-debug-function-tlf-number debug-fun))) - (unless blocks (return-from parse-compiled-debug-blocks nil)) - (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i)))) - (with-parsing-buffer (blocks-buffer locations-buffer) - (let ((i 0) - (len (length blocks)) - (last-pc 0)) - (loop - (when (>= i len) (return)) - (let ((succ-and-flags (aref+ blocks i)) - (successors nil)) - (declare (type (unsigned-byte 8) succ-and-flags) - (list successors)) - (dotimes (k (ldb c::compiled-debug-block-nsucc-byte - succ-and-flags)) - (push (c::read-var-integer blocks i) successors)) - (let* ((locations - (dotimes (k (c::read-var-integer blocks i) - (result locations-buffer)) - (let ((kind (svref c::compiled-code-location-kinds - (aref+ blocks i))) - (pc (+ last-pc (c::read-var-integer blocks i))) - (tlf-offset (or tlf-number - (c::read-var-integer blocks i))) - (form-number (c::read-var-integer blocks i)) - (live-set (c::read-packed-bit-vector - live-set-len blocks i))) - (vector-push-extend (make-known-code-location - pc debug-function tlf-offset - form-number live-set kind) - locations-buffer) - (setf last-pc pc)))) - (block (make-compiled-debug-block - locations successors - (not (zerop (logand - c::compiled-debug-block-elsewhere-p - succ-and-flags)))))) - (vector-push-extend block blocks-buffer) - (dotimes (k (length locations)) - (setf (code-location-%debug-block (svref locations k)) - block)))))) - (let ((res (result blocks-buffer))) - (declare (simple-vector res)) - (dotimes (i (length res)) - (let* ((block (svref res i)) - (succs nil)) - (dolist (ele (debug-block-successors block)) - (push (svref res ele) succs)) - (setf (debug-block-successors block) succs))) - res))))) - -;;; PARSE-INTERPRETED-DEBUG-BLOCKS -- Internal. -;;; -;;; This does some of the work of PARSE-DEBUG-BLOCKS. -;;; -(defun parse-interpreted-debug-blocks (debug-function) - (let ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-function))) - (with-parsing-buffer (buffer) - (c::do-blocks (block (c::block-component - (c::node-block (c::lambda-bind ir1-lambda)))) - (when (eq ir1-lambda (c::block-home-lambda block)) - (vector-push-extend (make-interpreted-debug-block block) buffer))) - (result buffer)))) - - -;;; DEBUG-FUNCTION-DEBUG-VARIABLES -- Internal. -;;; -;;; The argument is a debug internals structure. This returns nil if there is -;;; no variable information. It returns an empty simple-vector if there were -;;; no locals in the function. Otherwise it returns a simple-vector of -;;; debug-variables. -;;; -(defun debug-function-debug-variables (debug-function) - (let ((vars (debug-function-debug-vars debug-function))) - (if (eq vars :unparsed) - (setf (debug-function-debug-vars debug-function) - (etypecase debug-function - (compiled-debug-function - (parse-compiled-debug-variables debug-function)) - (bogus-debug-function nil) - (interpreted-debug-function - (parse-interpreted-debug-variables debug-function)))) - vars))) - - -;;; PARSE-INTERPRETED-DEBUG-VARIABLES -- Internal. -;;; -;;; This grabs all the variables from debug-fun's ir1-lambda, from the IR1 -;;; lambda vars, and all of it's LET's. Each LET is an IR1 lambda. For each -;;; variable, we make an interpreted-debug-variable. We then SORT all the -;;; variables by name. Then we go through, and for any duplicated names we -;;; distinguish the interpreted-debug-variables by setting their id slots to a -;;; distinct number. -;;; -(defun parse-interpreted-debug-variables (debug-fun) - (let* ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-fun)) - (vars (flet ((frob (ir1-lambda buf) - (dolist (v (c::lambda-vars ir1-lambda)) - (vector-push-extend - (let* ((id (c::leaf-name v)) - (pkg (symbol-package id))) - (make-interpreted-debug-variable - (symbol-name id) - (when pkg (package-name pkg)) - v)) - buf)))) - (with-parsing-buffer (buf) - (frob ir1-lambda buf) - (dolist (let-lambda (c::lambda-lets ir1-lambda)) - (frob let-lambda buf)) - (result buf))))) - (declare (simple-vector vars)) - (sort vars #'string< :key #'debug-variable-name) - (let ((len (length vars))) - (when (> len 1) - (let ((i 0) - (j 1)) - (block PUNT - (loop - (let* ((var-i (svref vars i)) - (var-j (svref vars j)) - (name (debug-variable-name var-i))) - (when (string= name (debug-variable-name var-j)) - (let ((count 1)) - (loop - (setf (debug-variable-id var-j) count) - (when (= (incf j) len) (return-from PUNT)) - (setf var-j (svref vars j)) - (when (string/= name (debug-variable-name var-j)) - (return)) - (incf count)))) - (setf i j) - (incf j) - (when (= j len) (return)))))))) - vars)) - - -;;; ASSIGN-MINIMAL-VAR-NAMES -- Internal. -;;; -;;; Vars is the parsed variables for a minimal debug function. We need to -;;; assign names of the form ARG-NNN. We must pad with leading zeros, since -;;; the arguments must be in alphabetical order. -;;; -(defun assign-minimal-var-names (vars) - (declare (simple-vector vars)) - (let* ((len (length vars)) - (width (length (format nil "~D" (1- len))))) - (dotimes (i len) - (setf (compiled-debug-variable-name (svref vars i)) - (format nil "ARG-~V,'0D" width i))))) - - -;;; PARSE-COMPILED-DEBUG-VARIABLES -- Internal. -;;; -;;; This parses the packed binary representation of debug-variables from -;;; debug-function's c::compiled-debug-function. -;;; -(defun parse-compiled-debug-variables (debug-function) - (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function)) - (packed-vars (c::compiled-debug-function-variables debug-fun)) - (default-package (c::compiled-debug-info-package - (compiled-debug-function-debug-info debug-function))) - (args-minimal (eq (c::compiled-debug-function-arguments debug-fun) - :minimal))) - (unless packed-vars - (return-from parse-compiled-debug-variables nil)) - (when (zerop (length packed-vars)) - ;; Return a simple-vector not whatever packed-vars may be. - (return-from parse-compiled-debug-variables '#())) - (let ((i 0) - (len (length packed-vars))) - (with-parsing-buffer (buffer) - (loop - ;; The routines in the "C" package are macros that advance the - ;; index. - (let* ((flags (prog1 (aref packed-vars i) (incf i))) - (minimal (logtest c::compiled-debug-variable-minimal-p flags)) - (deleted (logtest c::compiled-debug-variable-deleted-p flags)) - (name (if minimal "" (c::read-var-string packed-vars i))) - (package (cond - (minimal default-package) - ((logtest c::compiled-debug-variable-packaged - flags) - (c::read-var-string packed-vars i)) - ((logtest c::compiled-debug-variable-uninterned - flags) - nil) - (t - default-package))) - (id (if (logtest c::compiled-debug-variable-id-p flags) - (c::read-var-integer packed-vars i) - 0)) - (sc-offset - (if deleted 0 (c::read-var-integer packed-vars i))) - (save-sc-offset - (if (logtest c::compiled-debug-variable-save-loc-p flags) - (c::read-var-integer packed-vars i) - nil))) - (assert (not (and args-minimal (not minimal)))) - (vector-push-extend - (make-compiled-debug-variable - name package id - (logtest c::compiled-debug-variable-environment-live flags) - sc-offset save-sc-offset) - buffer)) - (when (>= i len) (return))) - (let ((res (result buffer))) - (when args-minimal - (assign-minimal-var-names res)) - res))))) - - -;;;; Unpacking minimal debug functions. - -(eval-when (compile eval) - -;;; MAKE-UNCOMPACTED-DEBUG-FUN -- Internal. -;;; -;;; Sleazoid "macro" to keep our indentation sane in UNCOMPACT-FUNCTION-MAP. -;;; -(defmacro make-uncompacted-debug-fun () - '(c::make-compiled-debug-function - :name - (let ((base (ecase (ldb c::minimal-debug-function-name-style-byte - options) - (#.c::minimal-debug-function-name-symbol - (intern (c::read-var-string map i) - (c::compiled-debug-info-package info))) - (#.c::minimal-debug-function-name-packaged - (let ((pkg (c::read-var-string map i))) - (intern (c::read-var-string map i) pkg))) - (#.c::minimal-debug-function-name-uninterned - (make-symbol (c::read-var-string map i))) - (#.c::minimal-debug-function-name-component - (c::compiled-debug-info-name info))))) - (if (logtest flags c::minimal-debug-function-setf-bit) - `(setf ,base) - base)) - :kind (svref c::minimal-debug-function-kinds - (ldb c::minimal-debug-function-kind-byte options)) - :variables - (when vars-p - (let ((len (c::read-var-integer map i))) - (prog1 (subseq map i (+ i len)) - (incf i len)))) - :arguments (when vars-p :minimal) - :returns - (ecase (ldb c::minimal-debug-function-returns-byte options) - (#.c::minimal-debug-function-returns-standard - :standard) - (#.c::minimal-debug-function-returns-fixed - :fixed) - (#.c::minimal-debug-function-returns-specified - (with-parsing-buffer (buf) - (dotimes (idx (c::read-var-integer map i)) - (vector-push-extend (c::read-var-integer map i) buf)) - (result buf)))) - :return-pc (c::read-var-integer map i) - :old-fp (c::read-var-integer map i) - :nfp (when (logtest flags c::minimal-debug-function-nfp-bit) - (c::read-var-integer map i)) - :start-pc - (progn - (setq code-start-pc (+ code-start-pc (c::read-var-integer map i))) - (+ code-start-pc (c::read-var-integer map i))) - :elsewhere-pc - (setq elsewhere-pc (+ elsewhere-pc (c::read-var-integer map i))))) - -) ;EVAL-WHEN (compile eval) - -;;; UNCOMPACT-FUNCTION-MAP -- Internal -;;; -;;; Return a normal function map derived from a minimal debug info function -;;; map. This involves looping parsing minimal-debug-functions and then -;;; building a vector out of them. -;;; -(defun uncompact-function-map (info) - (declare (type c::compiled-debug-info info)) - (let* ((map (c::compiled-debug-info-function-map info)) - (i 0) - (len (length map)) - (code-start-pc 0) - (elsewhere-pc 0)) - (declare (type (simple-array (unsigned-byte 8) (*)) map)) - (ext:collect ((res)) - (loop - (when (= i len) (return)) - (let* ((options (prog1 (aref map i) (incf i))) - (flags (prog1 (aref map i) (incf i))) - (vars-p (logtest flags c::minimal-debug-function-variables-bit)) - (dfun (make-uncompacted-debug-fun))) - (res code-start-pc) - (res dfun))) - - (coerce (cdr (res)) 'simple-vector)))) - - -;;; This variable maps minimal debug-info function maps to an unpacked version -;;; thereof. -;;; -(defvar *uncompacted-function-maps* (make-hash-table :test #'eq)) - -;;; GET-DEBUG-INFO-FUNCTION-MAP -- Internal -;;; -;;; Return a function-map for a given compiled-debug-info object. If the -;;; info is minimal, and has not been parsed, then parse it. -;;; -(defun get-debug-info-function-map (info) - (declare (type c::compiled-debug-info info)) - (let ((map (c::compiled-debug-info-function-map info))) - (if (simple-vector-p map) - map - (or (gethash map *uncompacted-function-maps*) - (setf (gethash map *uncompacted-function-maps*) - (uncompact-function-map info)))))) - - -;;;; Code-locations. - -;;; CODE-LOCATION-UNKNOWN-P -- Public. -;;; -;;; If we're sure of whether code-location is known, return t or nil. If we're -;;; :unsure, then try to fill in the code-location's slots. This determines -;;; whether there is any debug-block information, and if code-location is -;;; known. -;;; -;;; ??? IF this conses closures every time it's called, then break off the -;;; :unsure part to get the HANDLER-CASE into another function. -;;; -(defun code-location-unknown-p (basic-code-location) - "Returns whether basic-code-location is unknown. It returns nil when the - code-location is known." - (ecase (code-location-%unknown-p basic-code-location) - ((t) t) - ((nil) nil) - (:unsure - (setf (code-location-%unknown-p basic-code-location) - (handler-case (not (fill-in-code-location basic-code-location)) - (no-debug-blocks () t)))))) - -;;; CODE-LOCATION-DEBUG-BLOCK -- Public. -;;; -(defun code-location-debug-block (basic-code-location) - "Returns the debug-block containing code-location if it is available. Some - debug policies inhibit debug-block information, and if none is available, - then this signals a no-debug-blocks condition." - (let ((block (code-location-%debug-block basic-code-location))) - (if (eq block :unparsed) - (etypecase basic-code-location - (compiled-code-location - (compute-compiled-code-location-debug-block basic-code-location)) - (interpreted-code-location - (setf (code-location-%debug-block basic-code-location) - (make-interpreted-debug-block - (c::node-block - (interpreted-code-location-ir1-node basic-code-location)))))) - block))) - -;;; COMPUTE-COMPILED-CODE-LOCATION-DEBUG-BLOCK -- Internal. -;;; -;;; This stores and returns basic-code-location's debug-block. It determines -;;; the correct one using the code-location's pc. This uses -;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information or -;;; signal a 'no-debug-blocks condition. The blocks are sorted by their first -;;; code-location's pc, in ascending order. Therefore, as soon as we find a -;;; block that starts with a pc greater than basic-code-location's pc, we know -;;; the previous block contains the pc. If we get to the last block, then the -;;; code-location is either in the second to last block or the last block, and -;;; we have to be careful in determining this since the last block could be -;;; random code at the end of the function. We have to check for the last -;;; block being random code first to see how to compare the code-location's pc. -;;; -(defun compute-compiled-code-location-debug-block (basic-code-location) - (let* ((pc (compiled-code-location-pc basic-code-location)) - (debug-function (code-location-debug-function - basic-code-location)) - (blocks (debug-function-debug-blocks debug-function)) - (len (length blocks))) - (declare (simple-vector blocks)) - (setf (code-location-%debug-block basic-code-location) - (if (= len 1) - (svref blocks 0) - (do ((i 1 (1+ i)) - (end (1- len))) - ((= i end) - (let ((last (svref blocks end))) - (cond - ((debug-block-elsewhere-p last) - (if (< pc - (c::compiled-debug-function-elsewhere-pc - (compiled-debug-function-compiler-debug-fun - debug-function))) - (svref blocks (1- end)) - last)) - ((< pc - (compiled-code-location-pc - (svref (compiled-debug-block-code-locations last) - 0))) - (svref blocks (1- end))) - (t last)))) - (declare (type c::index i end)) - (when (< pc - (compiled-code-location-pc - (svref (compiled-debug-block-code-locations - (svref blocks i)) - 0))) - (return (svref blocks (1- i))))))))) - -;;; CODE-LOCATION-DEBUG-SOURCE -- Public. -;;; -(defun code-location-debug-source (code-location) - "Returns the code-location's debug-source." - (etypecase code-location - (compiled-code-location - (let* ((info (compiled-debug-function-debug-info - (code-location-debug-function code-location))) - (sources (c::compiled-debug-info-source info)) - (len (length sources))) - (declare (list sources)) - (if (= len 1) - (car sources) - (do ((prev sources src) - (src (cdr sources) (cdr src)) - (offset (code-location-top-level-form-offset code-location))) - ((null src) (car prev)) - (when (< offset (c::debug-source-source-root (car src))) - (return (car prev))))))) - (interpreted-code-location - (first - (let ((c::*lexical-environment* (c::make-null-environment))) - (c::debug-source-for-info - (c::component-source-info - (c::block-component - (c::node-block - (interpreted-code-location-ir1-node code-location)))))))))) - - -;;; CODE-LOCATION-TOP-LEVEL-FORM-OFFSET -- Public. -;;; -(defun code-location-top-level-form-offset (code-location) - "Returns the number of top-level forms before the one containing - code-location as seen by the compiler in some compilation unit. A - compilation unit is not necessarily a single file, see the section on - debug-sources." - (when (code-location-unknown-p code-location) - (error 'unknown-code-location :code-location code-location)) - (let ((tlf-offset (code-location-%tlf-offset code-location))) - (cond ((eq tlf-offset :unparsed) - (etypecase code-location - (compiled-code-location - (unless (fill-in-code-location code-location) - ;; This check should be unnecessary. We're missing debug info - ;; the compiler should have dumped. - (error "Unknown code location? It should be known.")) - (code-location-%tlf-offset code-location)) - (interpreted-code-location - (setf (code-location-%tlf-offset code-location) - (c::source-path-tlf-number - (c::node-source-path - (interpreted-code-location-ir1-node code-location))))))) - (t tlf-offset)))) - -;;; CODE-LOCATION-FORM-NUMBER -- Public. -;;; -(defun code-location-form-number (code-location) - "Returns the number of the form corresponding to code-location. The form - number is derived by a walking the subforms of a top-level form in - depth-first order." - (when (code-location-unknown-p code-location) - (error 'unknown-code-location :code-location code-location)) - (let ((form-num (code-location-%form-number code-location))) - (cond ((eq form-num :unparsed) - (etypecase code-location - (compiled-code-location - (unless (fill-in-code-location code-location) - ;; This check should be unnecessary. We're missing debug info - ;; the compiler should have dumped. - (error "Unknown code location? It should be known.")) - (code-location-%form-number code-location)) - (interpreted-code-location - (setf (code-location-%form-number code-location) - (c::source-path-form-number - (c::node-source-path - (interpreted-code-location-ir1-node code-location))))))) - (t form-num)))) - -;;; CODE-LOCATION-KIND -- Public -;;; -(defun code-location-kind (code-location) - "Return the kind of CODE-LOCATION, one of: - :interpreted, :unknown-return, :known-return, :internal-error, - :non-local-exit, :block-start, :call-site, :single-value-return, - :non-local-entry" - (when (code-location-unknown-p code-location) - (error 'unknown-code-location :code-location code-location)) - (etypecase code-location - (compiled-code-location - (let ((kind (compiled-code-location-kind code-location))) - (cond ((not (eq kind :unparsed)) kind) - ((not (fill-in-code-location code-location)) - ;; This check should be unnecessary. We're missing - ;; debug info the compiler should have dumped. - (error "Unknown code location? It should be known.")) - (t - (compiled-code-location-kind code-location))))) - (interpreted-code-location - :interpreted))) - - -;;; COMPILED-CODE-LOCATION-LIVE-SET -- Internal. -;;; -;;; This returns the code-location's live-set if it is available. If there -;;; is no debug-block information, this returns nil. -;;; -(defun compiled-code-location-live-set (code-location) - (if (code-location-unknown-p code-location) - nil - (let ((live-set (compiled-code-location-%live-set code-location))) - (cond ((eq live-set :unparsed) - (unless (fill-in-code-location code-location) - ;; This check should be unnecessary. We're missing debug info - ;; the compiler should have dumped. - (error "Unknown code location? It should be known.")) - (compiled-code-location-%live-set code-location)) - (t live-set))))) - -;;; CODE-LOCATION= -- Public. -;;; -(defun code-location= (obj1 obj2) - "Returns whether obj1 and obj2 are the same place in the code." - (etypecase obj1 - (compiled-code-location - (etypecase obj2 - (compiled-code-location - (and (eq (code-location-debug-function obj1) - (code-location-debug-function obj2)) - (sub-compiled-code-location= obj1 obj2))) - (interpreted-code-location - nil))) - (interpreted-code-location - (etypecase obj2 - (compiled-code-location - nil) - (interpreted-code-location - (eq (interpreted-code-location-ir1-node obj1) - (interpreted-code-location-ir1-node obj2))))))) -;;; -(defun sub-compiled-code-location= (obj1 obj2) - (= (compiled-code-location-pc obj1) - (compiled-code-location-pc obj2))) - -;;; FILL-IN-CODE-LOCATION -- Internal. -;;; -;;; This fills in location's :unparsed slots. It returns t or nil depending on -;;; whether the code-location was known in its debug-function's debug-block -;;; information. This may signal a no-debug-blocks condition due to -;;; DEBUG-FUNCTION-DEBUG-BLOCKS, and it assumes the %unknown-p slot is already -;;; set or going to be set. -;;; -(defun fill-in-code-location (code-location) - (declare (type compiled-code-location code-location)) - (let* ((debug-function (code-location-debug-function code-location)) - (blocks (debug-function-debug-blocks debug-function))) - (declare (simple-vector blocks)) - (dotimes (i (length blocks) nil) - (let* ((block (svref blocks i)) - (locations (compiled-debug-block-code-locations block))) - (declare (simple-vector locations)) - (dotimes (j (length locations)) - (let ((loc (svref locations j))) - (when (sub-compiled-code-location= code-location loc) - (setf (code-location-%debug-block code-location) block) - (setf (code-location-%tlf-offset code-location) - (code-location-%tlf-offset loc)) - (setf (code-location-%form-number code-location) - (code-location-%form-number loc)) - (setf (compiled-code-location-%live-set code-location) - (compiled-code-location-%live-set loc)) - (setf (compiled-code-location-kind code-location) - (compiled-code-location-kind loc)) - (return-from fill-in-code-location t)))))))) - - - -;;;; Debug-blocks. - -;;; DO-DEBUG-BLOCK-LOCATIONS -- Public. -;;; -(defmacro do-debug-block-locations ((code-var debug-block &optional return) - &body body) - "Executes forms in a context with code-var bound to each code-location in - debug-block. This returns the value of executing result (defaults to nil)." - (let ((code-locations (gensym)) - (i (gensym))) - `(let ((,code-locations (debug-block-code-locations ,debug-block))) - (declare (simple-vector ,code-locations)) - (dotimes (,i (length ,code-locations) ,return) - (let ((,code-var (svref ,code-locations ,i))) - ,@body))))) - -;;; DEBUG-BLOCK-FUNCTION-NAME -- Internal. -;;; -(defun debug-block-function-name (debug-block) - "Returns the name of the function represented by debug-function. This may - be a string or a cons; do not assume it is a symbol." - (etypecase debug-block - (compiled-debug-block - (let ((code-locs (compiled-debug-block-code-locations debug-block))) - (declare (simple-vector code-locs)) - (if (zerop (length code-locs)) - "??? Can't get name of debug-block's function." - (debug-function-name - (code-location-debug-function (svref code-locs 0)))))) - (interpreted-debug-block - (c::lambda-name (c::block-home-lambda - (interpreted-debug-block-ir1-block debug-block)))))) - - -;;; DEBUG-BLOCK-CODE-LOCATIONS -- Internal. -;;; -(defun debug-block-code-locations (debug-block) - (etypecase debug-block - (compiled-debug-block - (compiled-debug-block-code-locations debug-block)) - (interpreted-debug-block - (interpreted-debug-block-code-locations debug-block)))) - -;;; INTERPRETED-DEBUG-BLOCK-CODE-LOCATIONS -- Internal. -;;; -(defun interpreted-debug-block-code-locations (debug-block) - (let ((code-locs (interpreted-debug-block-locations debug-block))) - (if (eq code-locs :unparsed) - (with-parsing-buffer (buf) - (c::do-nodes (node cont (interpreted-debug-block-ir1-block - debug-block)) - (vector-push-extend (make-interpreted-code-location - node - (make-interpreted-debug-function - (c::block-home-lambda (c::node-block node)))) - buf)) - (setf (interpreted-debug-block-locations debug-block) - (result buf))) - code-locs))) - - - -;;;; Variables. - -;;; DEBUG-VARIABLE-SYMBOL -- Public. -;;; -(defun debug-variable-symbol (debug-var) - "Returns the symbol from interning DEBUG-VARIABLE-NAME in the package named - by DEBUG-VARIABLE-PACKAGE." - (let ((package (debug-variable-package debug-var))) - (if package - (intern (debug-variable-name debug-var) package) - (make-symbol (debug-variable-name debug-var))))) - -;;; DEBUG-VARIABLE-VALID-VALUE -- Public. -;;; -(defun debug-variable-valid-value (debug-var frame) - "Returns the value stored for debug-variable in frame. If the value is not - :valid, then this signals an invalid-value error." - (unless (eq (debug-variable-validity debug-var (frame-code-location frame)) - :valid) - (error 'invalid-value :debug-variable debug-var :frame frame)) - (debug-variable-value debug-var frame)) - -;;; DEBUG-VARIABLE-VALUE -- Public. -;;; -(defun debug-variable-value (debug-var frame) - "Returns the value stored for debug-variable in frame. The value may be - invalid. This is SETF'able." - (etypecase debug-var - (compiled-debug-variable - (check-type frame compiled-frame) - (let ((res (access-compiled-debug-var-slot debug-var frame))) - (if (indirect-value-cell-p res) - (c:value-cell-ref res) - res))) - (interpreted-debug-variable - (check-type frame interpreted-frame) - (eval::leaf-value-lambda-var - (interpreted-code-location-ir1-node (frame-code-location frame)) - (interpreted-debug-variable-ir1-var debug-var) - (frame-pointer frame) - (interpreted-frame-closure frame))))) - - -;;; ACCESS-COMPILED-DEBUG-VAR-SLOT -- Internal. -;;; -;;; This returns what is stored for the variable represented by debug-var -;;; relative to the frame. This may be an indirect value cell if the -;;; variable is both closed over and set. -;;; -(defun access-compiled-debug-var-slot (debug-var frame) - (let ((escaped (compiled-frame-escaped frame))) - (if escaped - (sub-access-debug-var-slot - (frame-pointer frame) - (compiled-debug-variable-sc-offset debug-var) - escaped) - (sub-access-debug-var-slot - (frame-pointer frame) - (or (compiled-debug-variable-save-sc-offset debug-var) - (compiled-debug-variable-sc-offset debug-var)))))) - -;;; SUB-ACCESS-DEBUG-VAR-SLOT -- Internal. -;;; -(defun sub-access-debug-var-slot (fp sc-offset &optional escaped) - (macrolet ((with-escaped-value ((var) &body forms) - `(if escaped - (let ((,var (vm:sigcontext-register - escaped - (c::sc-offset-offset sc-offset)))) - ,@forms) - :invalid-value-for-unescaped-register-storage)) - (escaped-float-value (format) - `(if escaped - (vm:sigcontext-float-register - escaped - (c::sc-offset-offset sc-offset) - ',format) - :invalid-value-for-unescaped-register-storage)) - (with-nfp ((var) &body body) - `(let ((,var (if escaped - (system:int-sap - (vm:sigcontext-register escaped - vm::nfp-offset)) - (system:sap-ref-sap fp (* vm::nfp-save-offset - vm:word-bytes))))) - ,@body))) - (ecase (c::sc-offset-scn sc-offset) - ((#.vm:any-reg-sc-number - #.vm:descriptor-reg-sc-number - #+rt #.vm:word-pointer-reg-sc-number) - (system:without-gcing - (with-escaped-value (val) - (kernel:make-lisp-obj val)))) - (#.vm:base-char-reg-sc-number - (with-escaped-value (val) - (code-char val))) - (#.vm:sap-reg-sc-number - (with-escaped-value (val) - (system:int-sap val))) - (#.vm:signed-reg-sc-number - (with-escaped-value (val) - (if (logbitp (1- vm:word-bits) val) - (logior val (ash -1 vm:word-bits)) - val))) - (#.vm:unsigned-reg-sc-number - (with-escaped-value (val) - val)) - (#.vm:non-descriptor-reg-sc-number - (error "Local non-descriptor register access?")) - (#.vm:interior-reg-sc-number - (error "Local interior register access?")) - (#.vm:single-reg-sc-number - (escaped-float-value single-float)) - (#.vm:double-reg-sc-number - (escaped-float-value double-float)) - (#.vm:single-stack-sc-number - (with-nfp (nfp) - (system:sap-ref-single nfp (* (vm::sc-offset-offset sc-offset) - vm:word-bytes)))) - (#.vm:double-stack-sc-number - (with-nfp (nfp) - (system:sap-ref-double nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes)))) - (#.vm:control-stack-sc-number - (kernel:stack-ref fp (c::sc-offset-offset sc-offset))) - (#.vm:base-char-stack-sc-number - (with-nfp (nfp) - (code-char (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes))))) - (#.vm:unsigned-stack-sc-number - (with-nfp (nfp) - (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes)))) - (#.vm:signed-stack-sc-number - (with-nfp (nfp) - (system:signed-sap-ref-32 nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes)))) - (#.vm:sap-stack-sc-number - (with-nfp (nfp) - (system:sap-ref-sap nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes))))))) - - -;;; %SET-DEBUG-VARIABLE-VALUE -- Internal. -;;; -;;; This stores value as the value of debug-var in frame. In the -;;; compiled-debug-variable case, access the current value to determine if it -;;; is an indirect value cell. This occurs when the variable is both closed -;;; over and set. For interpreted-debug-variables just call -;;; EVAL::SET-LEAF-VALUE-LAMBDA-VAR with the right interpreter objects. -;;; -(defun %set-debug-variable-value (debug-var frame value) - (etypecase debug-var - (compiled-debug-variable - (check-type frame compiled-frame) - (let ((current-value (access-compiled-debug-var-slot debug-var frame))) - (if (indirect-value-cell-p current-value) - (c:value-cell-set current-value value) - (set-compiled-debug-variable-slot debug-var frame value)))) - (interpreted-debug-variable - (check-type frame interpreted-frame) - (eval::set-leaf-value-lambda-var - (interpreted-code-location-ir1-node (frame-code-location frame)) - (interpreted-debug-variable-ir1-var debug-var) - (frame-pointer frame) - (interpreted-frame-closure frame) - value))) - value) -;;; -(defsetf debug-variable-value %set-debug-variable-value) - -;;; SET-COMPILED-DEBUG-VARIABLE-SLOT -- Internal. -;;; -;;; This stores value for the variable represented by debug-var relative to the -;;; frame. This assumes the location directly contains the variable's value; -;;; that is, there is no indirect value cell currently there in case the -;;; variable is both closed over and set. -;;; -(defun set-compiled-debug-variable-slot (debug-var frame value) - (let ((escaped (compiled-frame-escaped frame))) - (if escaped - (sub-set-debug-var-slot (frame-pointer frame) - (compiled-debug-variable-sc-offset debug-var) - value escaped) - (sub-set-debug-var-slot - (frame-pointer frame) - (or (compiled-debug-variable-save-sc-offset debug-var) - (compiled-debug-variable-sc-offset debug-var)) - value)))) - -;;; SUB-SET-DEBUG-VAR-SLOT -- Internal. -;;; -(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) - (macrolet ((set-escaped-value (val) - `(if escaped - (setf (vm:sigcontext-register - escaped - (c::sc-offset-offset sc-offset)) - ,val) - value)) - (set-escaped-float-value (format val) - `(if escaped - (setf (vm:sigcontext-float-register - escaped - (c::sc-offset-offset sc-offset) - ',format) - ,val) - value)) - (with-nfp ((var) &body body) - `(let ((,var (if escaped - (system:int-sap - (vm:sigcontext-register escaped - vm::nfp-offset)) - (system:sap-ref-sap fp - (* vm::nfp-save-offset - vm:word-bytes))))) - ,@body))) - (ecase (c::sc-offset-scn sc-offset) - ((#.vm:any-reg-sc-number - #.vm:descriptor-reg-sc-number - #+rt #.vm:word-pointer-reg-sc-number) - (system:without-gcing - (set-escaped-value - (kernel:get-lisp-obj-address value)))) - (#.vm:base-char-reg-sc-number - (set-escaped-value (char-code value))) - (#.vm:sap-reg-sc-number - (set-escaped-value (system:sap-int value))) - (#.vm:signed-reg-sc-number - (set-escaped-value (logand value (1- (ash 1 vm:word-bits))))) - (#.vm:unsigned-reg-sc-number - (set-escaped-value value)) - (#.vm:non-descriptor-reg-sc-number - (error "Local non-descriptor register access?")) - (#.vm:interior-reg-sc-number - (error "Local interior register access?")) - (#.vm:single-reg-sc-number - (set-escaped-float-value single-float value)) - (#.vm:double-reg-sc-number - (set-escaped-float-value double-float value)) - (#.vm:single-stack-sc-number - (with-nfp (nfp) - (setf (system:sap-ref-single nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes)) - (the single-float value)))) - (#.vm:double-stack-sc-number - (with-nfp (nfp) - (setf (system:sap-ref-double nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes)) - (the double-float value)))) - (#.vm:control-stack-sc-number - (setf (kernel:stack-ref fp (c::sc-offset-offset sc-offset)) value)) - (#.vm:base-char-stack-sc-number - (with-nfp (nfp) - (setf (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes)) - (char-code (the character value))))) - (#.vm:unsigned-stack-sc-number - (with-nfp (nfp) - (setf (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes)) - (the (unsigned-byte 32) value)))) - (#.vm:signed-stack-sc-number - (with-nfp (nfp) - (setf (system:signed-sap-ref-32 nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes)) - (the (signed-byte 32) value)))) - (#.vm:sap-stack-sc-number - (with-nfp (nfp) - (setf (system:sap-ref-sap nfp (* (c::sc-offset-offset sc-offset) - vm:word-bytes)) - (the system:system-area-pointer value))))))) - -(defsetf debug-variable-value %set-debug-variable-value) - - -;;; INDIRECT-VALUE-CELL-P -- Internal. -;;; -;;; The method for setting and accessing compiled-debug-variable values use -;;; this to determine if the value stored is the actual value or an indirection -;;; cell. -;;; -(defun indirect-value-cell-p (x) - (and (= (kernel:get-lowtag x) vm:other-pointer-type) - (= (kernel:get-type x) vm:value-cell-header-type))) - - -;;; DEBUG-VARIABLE-VALIDITY -- Public. -;;; -;;; If the variable is always alive, then it is valid. If the code-location is -;;; unknown, then the variable's validity is :unknown. Once we've called -;;; CODE-LOCATION-UNKNOWN-P, we know the live-set information has been cached -;;; in the code-location. -;;; -(defun debug-variable-validity (debug-var basic-code-loc) - "Returns three values reflecting the validity of debug-variable's value - at basic-code-location: - :valid The value is known to be available. - :invalid The value is known to be unavailable. - :unknown The value's availability is unknown." - (etypecase debug-var - (compiled-debug-variable - (compiled-debug-variable-validity debug-var basic-code-loc)) - (interpreted-debug-variable - (check-type basic-code-loc interpreted-code-location) - (let ((validp (rassoc (interpreted-debug-variable-ir1-var debug-var) - (c::lexenv-variables - (c::node-lexenv - (interpreted-code-location-ir1-node - basic-code-loc)))))) - (if validp :valid :invalid))))) - -;;; COMPILED-DEBUG-VARIABLE-VALIDITY -- Internal. -;;; -;;; This is the method for DEBUG-VARIABLE-VALIDITY for compiled-debug-variables. -;;; For safety, make sure basic-code-loc is what we think. -;;; -(defun compiled-debug-variable-validity (debug-var basic-code-loc) - (check-type basic-code-loc compiled-code-location) - (cond ((debug-variable-alive-p debug-var) - (let ((debug-fun (code-location-debug-function basic-code-loc))) - (if (>= (compiled-code-location-pc basic-code-loc) - (c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun debug-fun))) - :valid - :invalid))) - ((code-location-unknown-p basic-code-loc) :unknown) - (t - (let ((pos (position debug-var - (debug-function-debug-variables - (code-location-debug-function basic-code-loc))))) - (unless pos - (error 'unknown-debug-variable - :debug-variable debug-var - :debug-function - (code-location-debug-function basic-code-loc))) - ;; There must be live-set info since basic-code-loc is known. - (if (zerop (sbit (compiled-code-location-live-set basic-code-loc) - pos)) - :invalid - :valid))))) - - - -;;;; Sources. - -;;; Written by Rob Maclachlan. -;;; Documented by Bill Chiles. -;;; -;;; This code produces and uses what we call source-paths. A source-path is a -;;; list whose first element is a form number as returned by -;;; CODE-LOCATION-FORM-NUMBER and whose last element is a top-level-form number -;;; as returned by CODE-LOCATION-TOP-LEVEL-FORM-NUMBER. The elements from the -;;; last to the first, exclusively, are the numbered subforms into which to -;;; descend. For example: -;;; (defun foo (x) -;;; (let ((a (aref x 3))) -;;; (cons a 3))) -;;; The call to AREF in this example is form number 5. Assuming this DEFUN is -;;; the 11'th top-level-form, the source-path for the AREF call is as follows: -;;; (5 1 0 1 3 11) -;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 gets the -;;; first binding, and 1 gets the AREF form. -;;; - - -;;; Temporary buffer used to build form-number => source-path translation in -;;; FORM-NUMBER-TRANSLATIONS. -;;; -(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t)) - -;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS. -;;; -(defvar *form-number-circularity-table* (make-hash-table :test #'eq)) - -;;; FORM-NUMBER-TRANSLATIONS -- Public. -;;; -;;; The vector elements are in the same format as the compiler's -;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last -;;; is the top-level-form number. -;;; -(defun form-number-translations (form tlf-number) - "This returns a table mapping form numbers to source-paths. A source-path - indicates a descent into the top-level-form form, going directly to the - subform corressponding to the form number." - (clrhash *form-number-circularity-table*) - (setf (fill-pointer *form-number-temp*) 0) - (sub-translate-form-numbers form (list tlf-number)) - (coerce *form-number-temp* 'simple-vector)) -;;; -(defun sub-translate-form-numbers (form path) - (unless (gethash form *form-number-circularity-table*) - (setf (gethash form *form-number-circularity-table*) t) - (vector-push-extend (cons (fill-pointer *form-number-temp*) path) - *form-number-temp*) - (let ((pos 0) - (subform form) - (trail form)) - (declare (fixnum pos)) - (macrolet ((frob () - '(progn - (when (atom subform) (return)) - (let ((fm (car subform))) - (when (consp fm) - (sub-translate-form-numbers fm (cons pos path))) - (incf pos)) - (setq subform (cdr subform)) - (when (eq subform trail) (return))))) - (loop - (frob) - (frob) - (setq trail (cdr trail))))))) - - -;;; SOURCE-PATH-CONTEXT -- Public. -;;; -(defun source-path-context (form path context) - "Form is a top-level form, and path is a source-path into it. This returns - the form indicated by the source-path. Context is the number of enclosing - forms to return instead of directly returning the source-path form. When - context is non-zero, the form returned contains a marker, #:****HERE****, - immediately before the form indicated by path." - (declare (type unsigned-byte context)) - ;; - ;; Get to the form indicated by path or the enclosing form indicated by - ;; context and path. - (let ((path (reverse (butlast (cdr path))))) - (dotimes (i (- (length path) context)) - (setq form (elt form (first path))) - (setq path (rest path))) - ;; - ;; Recursively rebuild the source form resulting from the above descent, - ;; copying the beginning of each subform up to the next subform we descend - ;; into according to path. At the bottom of the recursion, we return the - ;; form indicated by path preceded by our marker, and this gets spliced - ;; into the resulting list structure on the way back up. - (labels ((frob (form path level) - (if (or (zerop level) (null path)) - (if (zerop context) - form - `(#:***here*** ,form)) - (let* ((n (first path)) - (res (frob (elt form n) (rest path) (1- level)))) - (nconc (subseq form 0 n) - (cons res (nthcdr (1+ n) form))))))) - (frob form path context)))) - - -;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME. - -;;; PREPROCESS-FOR-EVAL -- Public. -;;; -;;; Create a SYMBOL-MACROLET for each variable valid at the location which -;;; accesses that variable from the frame argument. -;;; -(defun preprocess-for-eval (form loc) - "Return a function of one argument that evaluates form in the lexical - context of the basic-code-location loc. PREPROCESS-FOR-EVAL signals a - no-debug-variables condition when the loc's debug-function has no - debug-variable information available. The returned function takes the frame - to get values from as its argument, and it returns the values of form. - The returned function signals the following conditions: invalid-value, - ambiguous-variable-name, and frame-function-mismatch" - (declare (type code-location loc)) - (let ((n-frame (gensym)) - (fun (code-location-debug-function loc))) - (unless (debug-variable-info-available fun) - (debug-signal 'no-debug-variables :debug-function fun)) - (ext:collect ((binds) - (specs)) - (do-debug-function-variables (var fun) - (let ((validity (debug-variable-validity var loc))) - (unless (eq validity :invalid) - (let* ((sym (debug-variable-symbol var)) - (found (assoc sym (binds)))) - (if found - (setf (second found) :ambiguous) - (binds (list sym validity var))))))) - (dolist (bind (binds)) - (let ((name (first bind)) - (var (third bind))) - (ecase (second bind) - (:valid - (specs `(,name (debug-variable-value ',var ,n-frame)))) - (:unknown - (specs `(,name (debug-signal 'invalid-value :debug-variable ',var - :frame ,n-frame)))) - (:ambiguous - (specs `(,name (debug-signal 'ambiguous-variable-name :name ',name - :frame ,n-frame))))))) - (let ((res (coerce `(lambda (,n-frame) - (declare (ignorable ,n-frame)) - (symbol-macrolet ,(specs) ,form)) - 'function))) - #'(lambda (frame) - ;; This prevents these functions from use in any location other - ;; than a function return location, so maybe this should only - ;; check whether frame's debug-function is the same as loc's. - (unless (code-location= (frame-code-location frame) loc) - (debug-signal 'frame-function-mismatch - :code-location loc :form form :frame frame)) - (funcall res frame)))))) - - -;;; EVAL-IN-FRAME -- Public. -;;; -(defun eval-in-frame (frame form) - (declare (type frame frame)) - "Evaluate Form in the lexical context of Frame's current code location, - returning the results of the evaluation." - (funcall (preprocess-for-eval form (frame-code-location frame)) frame)) - - - -;;;; Breakpoints. - -;;; -;;; User visible interface. -;;; - -(defun make-breakpoint (hook-function what - &key (kind :code-location) info function-end-cookie) - "This creates and returns a breakpoint. When program execution encounters - the breakpoint, the system calls hook-function. Hook-function takes the - current frame for the function in which the program is running and the - breakpoint object. - What and kind determine where in a function the system invokes - hook-function. What is either a code-location or a debug-function. Kind is - one of :code-location, :function-start, or :function-end. Since the starts - and ends of functions may not have code-locations representing them, - designate these places by supplying what as a debug-function and kind - indicating the :function-start or :function-end. When what is a - debug-function and kind is :function-end, then hook-function must take two - additional arguments, a list of values returned by the function and a - function-end-cookie. - Info is information supplied by and used by the user. - Function-end-cookie is a function. To implement :function-end breakpoints, - the system uses starter breakpoints to establish the :function-end breakpoint - for each invocation of the function. Upon each entry, the system creates a - unique cookie to identify the invocation, and when the user supplies a - function for this argument, the system invokes it on the frame and the - cookie. The system later invokes the :function-end breakpoint hook on the - same cookie. The user may save the cookie for comparison in the hook - function. - This signals an error if what is an unknown code-location." - (etypecase what - (code-location - (when (code-location-unknown-p what) - (error "Cannot make a breakpoint at an unknown code location -- ~S." - what)) - (assert (eq kind :code-location)) - (let ((bpt (%make-breakpoint hook-function what kind info))) - (etypecase what - (interpreted-code-location - (error "Breakpoints in interpreted code are currently unsupported.")) - (compiled-code-location - ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P. - (when (eq (compiled-code-location-kind what) :unknown-return) - (let ((other-bpt (%make-breakpoint hook-function what - :unknown-return-partner - info))) - (setf (breakpoint-unknown-return-partner bpt) other-bpt) - (setf (breakpoint-unknown-return-partner other-bpt) bpt))))) - bpt)) - (compiled-debug-function - (ecase kind - (:function-start - (%make-breakpoint hook-function what kind info)) - (:function-end - (unless (eq (c::compiled-debug-function-returns - (compiled-debug-function-compiler-debug-fun what)) - :standard) - (error ":FUNCTION-END breakpoints are currently unsupported ~ - for the known return convention.")) - - (let* ((bpt (%make-breakpoint hook-function what kind info)) - (starter (compiled-debug-function-end-starter what))) - (unless starter - (setf starter (%make-breakpoint #'list what :function-start nil)) - (setf (breakpoint-hook-function starter) - (function-end-starter-hook starter what)) - (setf (compiled-debug-function-end-starter what) starter)) - (setf (breakpoint-start-helper bpt) starter) - (push bpt (breakpoint-%info starter)) - (setf (breakpoint-cookie-fun bpt) function-end-cookie) - bpt)))) - (interpreted-debug-function - (error ":function-end breakpoints are currently unsupported ~ - for interpreted-debug-functions.")))) - -;;; These are unique objects created upon entry into a function by a -;;; :function-end breakpoint's starter hook. These are only created when users -;;; supply :function-end-cookie to MAKE-BREAKPOINT. Also, the :function-end -;;; breakpoint's hook is called on the same cookie when it is created. -;;; -(defstruct (function-end-cookie - (:print-function (lambda (obj str n) - (declare (ignore obj n)) - (write-string "#<Function-End-Cookie>" str))) - (:constructor make-function-end-cookie (bogus-lra debug-fun))) - ;; This is a pointer to the bogus-lra created for :function-end bpts. - bogus-lra - ;; This is the debug-function associated with the cookie. - debug-fun) - -;;; This maps bogus-lra-components to cookies, so -;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the -;;; breakpoint hook. -;;; -(defvar *function-end-cookies* (make-hash-table :test #'eq)) - -;;; FUNCTION-END-STARTER-HOOK -- Internal. -;;; -;;; This returns a hook function for the start helper breakpoint associated -;;; with a :function-end breakpoint. The returned function makes a fake LRA -;;; that all returns go through, and this piece of fake code actually breaks. -;;; Upon return from the break, the code provides the returnee with any values. -;;; Since the returned function effectively activates fun-end-bpt on each entry -;;; to debug-fun's function, we must establish breakpoint-data about -;;; fun-end-bpt. -;;; -(defun function-end-starter-hook (starter-bpt debug-fun) - (declare (type breakpoint starter-bpt) - (type compiled-debug-function debug-fun)) - #'(lambda (frame breakpoint) - (declare (ignore breakpoint) - (type frame frame)) - (let ((lra-sc-offset - (c::compiled-debug-function-return-pc - (compiled-debug-function-compiler-debug-fun debug-fun)))) - (multiple-value-bind (lra component offset) - (make-bogus-lra - (get-context-value frame vm::lra-save-offset - lra-sc-offset)) - (setf (get-context-value frame vm::lra-save-offset lra-sc-offset) - lra) - (let ((end-bpts (breakpoint-%info starter-bpt))) - (let ((data (breakpoint-data component offset))) - (setf (breakpoint-data-breakpoints data) end-bpts) - (dolist (bpt end-bpts) - (setf (breakpoint-internal-data bpt) data))) - (let ((cookie (make-function-end-cookie lra debug-fun))) - (setf (gethash component *function-end-cookies*) cookie) - (dolist (bpt end-bpts) - (let ((fun (breakpoint-cookie-fun bpt))) - (when fun (funcall fun frame cookie)))))))))) - -;;; FUNCTION-END-COOKIE-VALID-P -- Public. -;;; -(defun function-end-cookie-valid-p (frame cookie) - "This takes a function-end-cookie and a frame, and it returns whether the - cookie is still valid. A cookie becomes invalid when the frame that - established the cookie has exited. Sometimes cookie holders are unaware - of cookie invalidation because their :function-end breakpoint hooks didn't - run due to THROW'ing. This takes a frame as an efficiency hack since the - user probably has a frame object in hand when using this routine, and it - saves repeated parsing of the stack and consing when asking whether a - series of cookies is valid." - (let ((lra (function-end-cookie-bogus-lra cookie)) - (lra-sc-offset (c::compiled-debug-function-return-pc - (compiled-debug-function-compiler-debug-fun - (function-end-cookie-debug-fun cookie))))) - (do ((frame frame (frame-down frame))) - ((not frame) nil) - (when (and (compiled-frame-p frame) - (eq lra - (get-context-value frame - vm::lra-save-offset - lra-sc-offset))) - (return t))))) - -;;; -;;; ACTIVATE-BREAKPOINT. -;;; - -;;; ACTIVATE-BREAKPOINT -- Public. -;;; -(defun activate-breakpoint (breakpoint) - "This causes the system to invoke the breakpoint's hook-function until the - next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The system invokes - breakpoint hook functions in the opposite order that you activate them." - (when (eq (breakpoint-status breakpoint) :deleted) - (error "Cannot activate a deleted breakpoint -- ~S." breakpoint)) - (unless (eq (breakpoint-status breakpoint) :active) - (ecase (breakpoint-kind breakpoint) - (:code-location - (let ((loc (breakpoint-what breakpoint))) - (etypecase loc - (interpreted-code-location - (error "Breakpoints in interpreted code are currently unsupported.")) - (compiled-code-location - (activate-compiled-code-location-breakpoint breakpoint) - (let ((other (breakpoint-unknown-return-partner breakpoint))) - (when other - (activate-compiled-code-location-breakpoint other))))))) - (:function-start - (etypecase (breakpoint-what breakpoint) - (compiled-debug-function - (activate-compiled-function-start-breakpoint breakpoint)) - (interpreted-debug-function - (error "I don't know how you made this, but they're unsupported -- ~S" - (breakpoint-what breakpoint))))) - (:function-end - (etypecase (breakpoint-what breakpoint) - (compiled-debug-function - (let ((starter (breakpoint-start-helper breakpoint))) - (unless (eq (breakpoint-status starter) :active) - ;; May already be active by some other :function-end breakpoint. - (activate-compiled-function-start-breakpoint starter))) - (setf (breakpoint-status breakpoint) :active)) - (interpreted-debug-function - (error "I don't know how you made this, but they're unsupported -- ~S" - (breakpoint-what breakpoint))))))) - breakpoint) - -;;; ACTIVATE-COMPILED-CODE-LOCATION-BREAKPOINT -- Internal. -;;; -(defun activate-compiled-code-location-breakpoint (breakpoint) - (declare (type breakpoint breakpoint)) - (let ((loc (breakpoint-what breakpoint))) - (declare (type compiled-code-location loc)) - (sub-activate-breakpoint - breakpoint - (breakpoint-data (compiled-debug-function-component - (code-location-debug-function loc)) - (+ (compiled-code-location-pc loc) - (if (or (eq (breakpoint-kind breakpoint) - :unknown-return-partner) - (eq (compiled-code-location-kind loc) - :single-value-return)) - vm:single-value-return-byte-offset - 0)))))) - -;;; ACTIVATE-COMPILED-FUNCTION-START-BREAKPOINT -- Internal. -;;; -(defun activate-compiled-function-start-breakpoint (breakpoint) - (declare (type breakpoint breakpoint)) - (let ((debug-fun (breakpoint-what breakpoint))) - (sub-activate-breakpoint - breakpoint - (breakpoint-data (compiled-debug-function-component debug-fun) - (c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun - debug-fun)))))) - -;;; SUB-ACTIVATE-BREAKPOINT -- Internal. -;;; -(defun sub-activate-breakpoint (breakpoint data) - (declare (type breakpoint breakpoint) - (type breakpoint-data data)) - (setf (breakpoint-status breakpoint) :active) - (system:without-interrupts - (unless (breakpoint-data-breakpoints data) - (setf (breakpoint-data-instruction data) - (system:without-gcing - (breakpoint-install (kernel:get-lisp-obj-address - (breakpoint-data-component data)) - (breakpoint-data-offset data))))) - (setf (breakpoint-data-breakpoints data) - (append (breakpoint-data-breakpoints data) (list breakpoint))) - (setf (breakpoint-internal-data breakpoint) data))) - -;;; -;;; DEACTIVATE-BREAKPOINT. -;;; - -;;; DEACTIVATE-BREAKPOINT -- Public. -;;; -(defun deactivate-breakpoint (breakpoint) - "This stops the system from invoking the breakpoint's hook-function." - (when (eq (breakpoint-status breakpoint) :active) - (system:without-interrupts - (let ((loc (breakpoint-what breakpoint))) - (etypecase loc - ((or interpreted-code-location interpreted-debug-function) - (error - "Breakpoints in interpreted code are currently unsupported.")) - ((or compiled-code-location compiled-debug-function) - (deactivate-compiled-breakpoint breakpoint) - (let ((other (breakpoint-unknown-return-partner breakpoint))) - (when other - (deactivate-compiled-breakpoint other)))))))) - breakpoint) - -(defun deactivate-compiled-breakpoint (breakpoint) - (if (eq (breakpoint-kind breakpoint) :function-end) - (let ((starter (breakpoint-start-helper breakpoint))) - (unless (find-if #'(lambda (bpt) - (and (not (eq bpt breakpoint)) - (eq (breakpoint-status bpt) :active))) - (breakpoint-%info starter)) - (deactivate-compiled-breakpoint starter))) - (let* ((data (breakpoint-internal-data breakpoint)) - (bpts (delete breakpoint (breakpoint-data-breakpoints data)))) - (setf (breakpoint-internal-data breakpoint) nil) - (setf (breakpoint-data-breakpoints data) bpts) - (unless bpts - (system:without-gcing - (breakpoint-remove (kernel:get-lisp-obj-address - (breakpoint-data-component data)) - (breakpoint-data-offset data) - (breakpoint-data-instruction data))) - (delete-breakpoint-data data)))) - (setf (breakpoint-status breakpoint) :inactive) - breakpoint) - -;;; -;;; BREAKPOINT-INFO. -;;; - -;;; BREAKPOINT-INFO -- Public. -;;; -(defun breakpoint-info (breakpoint) - "This returns the user maintained info associated with breakpoint. This - is SETF'able." - (breakpoint-%info breakpoint)) -;;; -(defun %set-breakpoint-info (breakpoint value) - (setf (breakpoint-%info breakpoint) value) - (let ((other (breakpoint-unknown-return-partner breakpoint))) - (when other - (setf (breakpoint-%info other) value)))) -;;; -(defsetf breakpoint-info %set-breakpoint-info) - -;;; -;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT. -;;; - -;;; BREAKPOINT-ACTIVE-P -- Public. -;;; -(defun breakpoint-active-p (breakpoint) - "This returns whether breakpoint is currently active." - (ecase (breakpoint-status breakpoint) - (:active t) - ((:inactive :deleted) nil))) - -;;; DELETE-BREAKPOINT -- Public. -;;; -(defun delete-breakpoint (breakpoint) - "This frees system storage and removes computational overhead associated with - breakpoint. After calling this, breakpoint is completely impotent and can - never become active again." - (let ((status (breakpoint-status breakpoint))) - (unless (eq status :deleted) - (when (eq status :active) - (deactivate-breakpoint breakpoint)) - (setf (breakpoint-status breakpoint) :deleted) - (let ((other (breakpoint-unknown-return-partner breakpoint))) - (when other - (setf (breakpoint-status other) :deleted))) - (when (eq (breakpoint-kind breakpoint) :function-end) - (let* ((starter (breakpoint-start-helper breakpoint)) - (breakpoints (delete breakpoint - (the list (breakpoint-info starter))))) - (setf (breakpoint-info starter) breakpoints) - (unless breakpoints - (delete-breakpoint starter) - (setf (compiled-debug-function-end-starter - (breakpoint-what breakpoint)) - nil)))))) - breakpoint) - -;;; -;;; C call out stubs. -;;; - -;;; BREAKPOINT-INSTALL -- Internal. -;;; -;;; This actually installs the break instruction in the component. It returns -;;; the overwritten bits. You must call this in a context in which GC is -;;; disabled, so Lisp doesn't move objects around that C is pointing to. -;;; -(alien:def-alien-routine "breakpoint_install" c-call:unsigned-long - (code-obj c-call:unsigned-long) - (pc-offset c-call:int)) - -;;; BREAKPOINT-REMOVE -- Internal. -;;; -;;; This removes the break instruction and replaces the original instruction. -;;; You must call this in a context in which GC is disabled, so Lisp doesn't -;;; move objects around that C is pointing to. -;;; -(alien:def-alien-routine "breakpoint_remove" c-call:void - (code-obj c-call:unsigned-long) - (pc-offset c-call:int) - (old-inst c-call:unsigned-long)) - -(alien:def-alien-routine "breakpoint_do_displaced_inst" c-call:void - (scp (* unix:sigcontext)) - (orig-inst c-call:unsigned-long)) - -;;; -;;; Breakpoint handlers (layer between C and exported interface). -;;; - -;;; This maps components to a mapping of offsets to breakpoint-datas. -;;; -(defvar *component-breakpoint-offsets* (make-hash-table :test #'eq)) - -;;; BREAKPOINT-DATA -- Internal. -;;; -;;; This returns the breakpoint-data associated with component cross offset. -;;; If none exists, this makes one, installs it, and returns it. -;;; -(defun breakpoint-data (component offset &optional (create t)) - (flet ((install-breakpoint-data () - (when create - (let ((data (make-breakpoint-data component offset))) - (push (cons offset data) - (gethash component *component-breakpoint-offsets*)) - data)))) - (let ((offsets (gethash component *component-breakpoint-offsets*))) - (if offsets - (let ((data (assoc offset offsets))) - (if data - (cdr data) - (install-breakpoint-data))) - (install-breakpoint-data))))) - -;;; DELETE-BREAKPOINT-DATA -- Internal. -;;; -;;; We use this when there are no longer any active breakpoints corresponding -;;; to data. -;;; -(defun delete-breakpoint-data (data) - (let* ((component (breakpoint-data-component data)) - (offsets (delete (breakpoint-data-offset data) - (gethash component *component-breakpoint-offsets*) - :key #'car))) - (if offsets - (setf (gethash component *component-breakpoint-offsets*) offsets) - (remhash component *component-breakpoint-offsets*))) - (ext:undefined-value)) - -;;; HANDLE-BREAKPOINT -- Internal Interface. -;;; -;;; The C handler for interrupts calls this when it has a debugging-tool break -;;; instruction. This does NOT handle all breaks; for example, it does not -;;; handle breaks for internal errors. -;;; -(defun handle-breakpoint (offset component signal-context) - (let ((data (breakpoint-data component offset nil))) - (unless data - (error "Unknown breakpoint in ~S at offset ~S." - (debug-function-name (debug-function-from-pc component offset)) - offset)) - (let ((breakpoints (breakpoint-data-breakpoints data))) - (unless breakpoints - (error "Breakpoint that nobody wants?")) - (if (eq (breakpoint-kind (car breakpoints)) :function-end) - (handle-function-end-breakpoint-aux breakpoints data signal-context) - (handle-breakpoint-aux breakpoints data - offset component signal-context))))) - -;;; This holds breakpoint-datas while invoking the breakpoint hooks associated -;;; with that particular component and location. While they are executing, if -;;; we hit the location again, we ignore the breakpoint to avoid infinite -;;; recursion. Function-end breakpoints must work differently since the -;;; breakpoint-data is unique for each invocation. -;;; -(defvar *executing-breakpoint-hooks* nil) - -;;; HANDLE-BREAKPOINT-AUX -- Internal. -;;; -;;; This handles code-location and debug-function :function-start breakpoints. -;;; -(defun handle-breakpoint-aux (breakpoints data offset component signal-context) - (unless (member data *executing-breakpoint-hooks*) - (let ((*executing-breakpoint-hooks* (cons data - *executing-breakpoint-hooks*))) - (invoke-breakpoint-hooks breakpoints component offset))) - ;; At this point breakpoints may not hold the same list as - ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed a - ;; breakpoint deactivation. In fact, if all breakpoints were deactivated - ;; then data is invalid since it was deleted and so the correct one must be - ;; looked up if it is to be used. If there are no more breakpoints active - ;; at this location, then the normal instruction has been put back, and we - ;; do not need to do-displaced-inst. - (let ((data (breakpoint-data component offset nil))) - (when (and data (breakpoint-data-breakpoints data)) - ;; There breakpoint is still active, so we need to execute the displaced - ;; instruction and leave the breakpoint instruction behind. The best - ;; way to do this is different on each machine, so we just leave it up - ;; to the C code. - (breakpoint-do-displaced-inst signal-context - (breakpoint-data-instruction data)) - (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) - -(defun invoke-breakpoint-hooks (breakpoints component offset) - (let* ((debug-fun (debug-function-from-pc component offset)) - (frame (do ((f (top-frame) (frame-down f))) - ((eq debug-fun (frame-debug-function f)) f)))) - (dolist (bpt breakpoints) - (funcall (breakpoint-hook-function bpt) - frame - ;; If this is an :unknown-return-partner, then pass the - ;; hook function the original breakpoint, so that users - ;; arn't forced to confront the fact that some breakpoints - ;; really are two. - (if (eq (breakpoint-kind bpt) :unknown-return-partner) - (breakpoint-unknown-return-partner bpt) - bpt))))) - -;;; HANDLE-FUNCTION-END-BREAKPOINT -- Internal Interface -;;; -(defun handle-function-end-breakpoint (offset component signal-context) - (let ((data (breakpoint-data component offset nil))) - (unless data - (error "Unknown breakpoint in ~S at offset ~S." - (debug-function-name (debug-function-from-pc component offset)) - offset)) - (let ((breakpoints (breakpoint-data-breakpoints data))) - (unless breakpoints - (error "Breakpoint that nobody wants?")) - (assert (eq (breakpoint-kind (car breakpoints)) :function-end)) - (handle-function-end-breakpoint-aux breakpoints data signal-context)))) - -;;; HANDLE-FUNCTION-END-BREAKPOINT-AUX -- Internal. -;;; -;;; Either HANDLE-BREAKPOINT calls this for :function-end breakpoints [old C -;;; code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly [new C code]. -;;; -(defun handle-function-end-breakpoint-aux (breakpoints data signal-context) - (delete-breakpoint-data data) - (let* ((scp (alien:sap-alien signal-context (* unix:sigcontext))) - (frame (do ((cfp (vm:sigcontext-register scp vm::cfp-offset)) - (f (top-frame) (frame-down f))) - ((= cfp (system:sap-int (frame-pointer f))) f) - (declare (type (unsigned-byte #.vm:word-bits) cfp)))) - (component (breakpoint-data-component data)) - (cookie (gethash component *function-end-cookies*))) - (remhash component *function-end-cookies*) - (dolist (bpt breakpoints) - (funcall (breakpoint-hook-function bpt) - frame bpt - (get-function-end-breakpoint-values scp) - cookie)))) - -(defun get-function-end-breakpoint-values (scp) - (let ((ocfp (system:int-sap (vm:sigcontext-register scp vm::ocfp-offset))) - (nargs (kernel:make-lisp-obj - (vm:sigcontext-register scp vm::nargs-offset))) - (reg-arg-offsets '#.vm::register-arg-offsets) - (results nil)) - (system:without-gcing - (dotimes (arg-num nargs) - (push (if reg-arg-offsets - (kernel:make-lisp-obj - (vm:sigcontext-register scp (pop reg-arg-offsets))) - (kernel:stack-ref ocfp arg-num)) - results))) - (nreverse results))) - -;;; -;;; MAKE-BOGUS-LRA (used for :function-end breakpoints) -;;; - -(defconstant bogus-lra-constants 2) -(defconstant known-return-p-slot (+ vm:code-constants-offset 1)) - -;;; MAKE-BOGUS-LRA -- Interface. -;;; -(defun make-bogus-lra (real-lra &optional known-return-p) - "Make a bogus LRA object that signals a breakpoint trap when returned to. If - the breakpoint trap handler returns, REAL-LRA is returned to. Three values - are returned: the bogus LRA object, the code component it is part of, and - the PC offset for the trap instruction." - (system:without-gcing - (let* ((src-start (system:foreign-symbol-address - "function_end_breakpoint_guts")) - (src-end (system:foreign-symbol-address - "function_end_breakpoint_end")) - (trap-loc (system:foreign-symbol-address - "function_end_breakpoint_trap")) - (length (system:sap- src-end src-start)) - (code-object (system:%primitive c:allocate-code-object - (1+ bogus-lra-constants) - length)) - (dst-start (kernel:code-instructions code-object))) - (declare (type system:system-area-pointer - src-start src-end dst-start trap-loc) - (type kernel:index length)) - (setf (kernel:%code-debug-info code-object) :bogus-lra) - (setf (kernel:code-header-ref code-object vm:code-trace-table-offset-slot) - length) - (setf (kernel:code-header-ref code-object real-lra-slot) real-lra) - (setf (kernel:code-header-ref code-object known-return-p-slot) - known-return-p) - (kernel:system-area-copy src-start 0 dst-start 0 (* length vm:byte-bits)) - (let ((new-lra (kernel:make-lisp-obj (+ (system:sap-int dst-start) - vm:other-pointer-type)))) - (kernel:set-header-data - new-lra - (logandc2 (+ vm:code-constants-offset bogus-lra-constants 1) - 1)) - (values new-lra code-object (system:sap- trap-loc src-start)))))) - - - -;;;; Editor support. - -;;; This holds breakpoints in the slave set on behalf of the editor. -;;; -;(defvar *editor-breakpoints* (make-hash-table :test #'equal)) - -;;; -;;; Setting breakpoints. -;;; - -;;; SET-BREAKPOINT-FOR-EDITOR -- Internal Interface. -;;; -(defun set-breakpoint-for-editor (package name-str path) - "The editor calls this remotely in the slave to set breakpoints. Package is - the string name of a package or nil, and name-str is a string representing a - function name (for example, \"foo\" or \"(setf foo)\"). After finding - package, this READs name-str with *package* bound appropriately. Path is - either a modified source-path or a symbol (:function-start or - :function-end). If it is a modified source-path, it has no top-level-form - offset or form-number component, and it is in descent order from the root of - the top-level form." - (let* ((name (let ((*package* (if package - (lisp::package-or-lose package) - *package*))) - (read-from-string name-str))) - (debug-fun (function-debug-function (fdefinition name)))) - (etypecase path - (symbol - (let* ((bpt (di:make-breakpoint - #'(lambda (frame bpt) - (declare (ignore frame bpt)) - (break "Editor installed breakpoint.")) - debug-fun :kind path)) - (remote-bpt (wire:make-remote-object bpt))) - (activate-breakpoint bpt) - ;;(push remote-bpt (gethash name *editor-breakpoints*)) - remote-bpt)) - (cons - (etypecase debug-fun - (compiled-debug-function - (compiled-debug-function-set-breakpoint-for-editor - debug-fun #|name|# path)) - (interpreted-debug-function - (error - "We don't currently support breakpoints in interpreted code."))))))) - -(defun compiled-debug-function-set-breakpoint-for-editor (debug-fun #|name|# path) - (let* ((source-paths (generate-component-source-paths - (compiled-debug-function-component debug-fun))) - (matches nil) - (matching-length 0)) - (declare (simple-vector source-paths) - (list matches) - (fixnum matching-length)) - ;; Build a list of paths that match path up to matching-length - ;; elements. - (macrolet ((maybe-store-match (path matched-len) - `(cond ((> ,matched-len matching-length) - (setf matches (list ,path)) - (setf matching-length ,matched-len)) - ((= ,matched-len matching-length) - (cons ,path matches))))) - (dotimes (i (length source-paths)) - (declare (fixnum i)) - (let ((sp (svref source-paths i))) - ;; Remember, first element of sp is a code-location. - (do ((path-ptr path (cdr path-ptr)) - (sp-ptr (cdr sp) (cdr sp-ptr)) - (count 0 (1+ count))) - ((or (null path-ptr) (null sp-ptr)) - (when (null sp-ptr) - (maybe-store-match sp count))) - (declare (list sp-ptr path-ptr) - (fixnum count)) - (unless (= (the fixnum (car path-ptr)) (the fixnum (car sp-ptr))) - (maybe-store-match sp count)))))) - ;; If there's just one, set it; otherwise, return the conflict set. - (cond ((and (= (length matches) 1) (equal path (cdar matches))) - (let* ((bpt (make-breakpoint - #'(lambda (frame bpt) - (declare (ignore frame bpt)) - (break "Editor installed breakpoint.")) - (wire:remote-object-value (caar matches)))) - (remote-bpt (wire:make-remote-object bpt))) - (activate-breakpoint bpt) - ;;(push remote-bpt (gethash name *editor-breakpoints*)) - remote-bpt)) - (t matches)))) - -;;; This maps components to vectors of modified source-paths. We assume users -;;; will set multiple breakpoints in a given function which entails computing -;;; this data repeatedly. Possibly the GC hook should free this cache. The -;;; source-paths are modified in the following ways: -;;; 1] The form number element (first) is clobbered with the code-location -;;; corresponding to the source-path. -;;; 2] The top-level-form offset element (last) is thrown away. -;;; 3] Everything after the first element is reversed, so the modified -;;; source-path actually portrays a descent into the form. -;;; -(defvar *component-source-locations* (make-hash-table :test #'eq)) - -;;; GENERATE-COMPONENT-SOURCE-PATHS -- Internal. -;;; -;;; This returns a vector of modified source-paths, one for every code-location -;;; in component. The source-paths are modified as described for -;;; *component-source-locations*. -;;; -(defun generate-component-source-paths (component) - (or (gethash component *component-source-locations*) - (setf (gethash component *component-source-locations*) - (sub-generate-component-source-paths component)))) - -;;; This maps source-infos to hashtables that map top-level-form offsets to -;;; modified form-number translations (as returned by -;;; FORM-NUMBER-TRANSLATIONS). These are modified as described for -;;; *component-source-locations*. -;;; -(defvar *source-info-offset-translations* (make-hash-table :test #'eq)) - -;;; This is a hacking space for SUB-GENERATE-COMPONENT-SOURCE-PATHS. We use -;;; this because we throw away many source-paths we accumulate in this buffer -;;; since they are not associated with code-locations. -;;; -(defvar *source-paths-buffer* (make-array 50 :fill-pointer t :adjustable t)) - -;;; SUB-GENERATE-COMPONENT-SOURCE-PATHS -- Internal. -;;; -;;; We iterate over the code-locations in component, fetching their -;;; source-infos and using the *source-info-offset-translations* cache. This -;;; computation often repeatedly sees the same source-info/tlf-offset pair, so -;;; we see many source-paths from one form-number-translation table. Because -;;; of this, when we add a form-number-translations table to this cache, we add -;;; all the source-paths in it to the result immediately. Then later if we see -;;; the same (not EQ though) source-info/tlf-offset form-number-translations, -;;; we can simply check if one of the source-paths is already in the result, -;;; and if it is, then all of them already are. We keep the cache around -;;; between invocations since we expect multiple breakpoints to be set in the -;;; same function, and this is why we must check if a form-number-translations -;;; has been added to the result; just its presence in the cache does not mean -;;; it is in the result vector. -;;; -(defun sub-generate-component-source-paths (component) - (let ((info (kernel:%code-debug-info component))) - (unless info (debug-signal 'no-debug-info)) - (let* ((function-map (get-debug-info-function-map info)) - (result *source-paths-buffer*)) - (declare (simple-vector function-map) - (vector result)) - (setf (fill-pointer result) 0) - (flet ((copy-stuff (form-num-trans result) - (declare (simple-vector form-num-trans) - (vector result)) - (dotimes (i (length form-num-trans)) - (declare (fixnum i)) - (vector-push-extend (svref form-num-trans i) result))) - (convert-paths (form-num-trans) - (declare (simple-vector form-num-trans)) - (dotimes (i (length form-num-trans) form-num-trans) - (declare (fixnum i)) - (let* ((source-path (svref form-num-trans i))) - (declare (list source-path)) - ;; Make the first cons point to the reversal of everything - ;; else, but throw away what was the last element before the - ;; reversal. - (setf (cdr source-path) - ;; Must copy the rest of the list, so REVERSE, but - ;; the first cons cell of each list is unique. - (cdr (reverse (cdr source-path)))))))) - ;; Get all possible source-paths, modifying any new additions to the - ;; cache. - (do ((i 0 (+ i 2)) - (len (length function-map))) - ((>= i len)) - (declare (type c::index i)) - (let ((d-fun (make-compiled-debug-function (svref function-map i) - component))) - (do-debug-function-blocks (d-block d-fun) - (do-debug-block-locations (loc d-block) - (let* ((d-source (code-location-debug-source loc)) - (translations (gethash d-source - *source-info-offset-translations*)) - (tlf-offset (code-location-top-level-form-offset loc)) - (loc-num (code-location-form-number loc))) - (cond - (translations - (let ((form-num-trans (gethash tlf-offset translations))) - (declare (type (or simple-vector null) form-num-trans)) - (cond - ((not form-num-trans) - (let ((form-num-trans (get-form-number-translations - d-source tlf-offset))) - (declare (simple-vector form-num-trans)) - (setf (gethash tlf-offset translations) form-num-trans) - (copy-stuff (convert-paths form-num-trans) result) - (setf (car (svref form-num-trans loc-num)) - (wire:make-remote-object loc)))) - ;; If one of these source-paths is in our result, then - ;; they all are. - ((find (svref form-num-trans 0) result :test #'eq) - (setf (car (svref form-num-trans loc-num)) - (wire:make-remote-object loc))) - ;; Otherwise, store these source-paths in the result. - (t - (copy-stuff form-num-trans result) - (setf (car (svref form-num-trans loc-num)) - (wire:make-remote-object loc)))))) - (t - (let ((translations (make-hash-table :test #'eq)) - (form-num-trans (get-form-number-translations - d-source tlf-offset))) - (declare (simple-vector form-num-trans)) - (setf (gethash d-source *source-info-offset-translations*) - translations) - (setf (gethash tlf-offset translations) form-num-trans) - (copy-stuff (convert-paths form-num-trans) result) - (setf (car (svref form-num-trans loc-num)) - (wire:make-remote-object loc))))))))))) - ;; Copy source-paths with code-locations from the result buffer to a - ;; real result vector. - (let* ((count (count-if #'(lambda (x) (wire:remote-object-p (car x))) - result)) - (the-real-thing (make-array count)) - (i -1)) - (declare (simple-vector the-real-thing) - (fixnum i count)) - (dotimes (j count) - (loop (when (wire:remote-object-p (car (aref result (incf i)))) - (return))) - (setf (svref the-real-thing j) (aref result i))) - the-real-thing)))) - -;;; GET-FORM-NUMBER-TRANSLATIONS -- Internal. -;;; -;;; This returns a vector of form-number translations to source-paths for -;;; d-source and the top-level-form indicated by the top-level-form offset. -;;; -(defun get-form-number-translations (d-source tlf-offset) - (let ((name (debug-source-name d-source))) - (ecase (debug-source-from d-source) - (:file - (cond - ((not (probe-file name)) - (format t "~%Cannot set breakpoints for editor when source file no ~ - longer exists:~% ~A." - (namestring name))) - (t - (let* ((local-tlf-offset (- tlf-offset - (debug-source-root-number d-source))) - (char-offset - (aref (or (debug-source-start-positions d-source) - (error "Cannot set breakpoints for editor when ~ - there is no start positions map.")) - local-tlf-offset))) - (with-open-file (f name) - (cond - ((= (debug-source-created d-source) (file-write-date name)) - (file-position f char-offset)) - (t - (format t - "~%While setting a breakpoint for the editor, noticed ~ - source file has been modified since compilation:~% ~A~@ - Using form offset instead of character position.~%" - (namestring name)) - (dotimes (i local-tlf-offset) (read f)))) - (form-number-translations (read f) tlf-offset)))))) - ((:lisp :stream) - (form-number-translations (svref name tlf-offset) tlf-offset))))) - -;;; SET-LOCATION-BREAKPOINT-FOR-EDITOR -- Internal Interface. -;;; -(defun set-location-breakpoint-for-editor (remote-obj-loc) - "The editor calls this in the slave with a remote-object representing a - code-location to set a breakpoint." - (let ((loc (wire:remote-object-value remote-obj-loc))) - (etypecase loc - (interpreted-code-location - (error "Breakpoints in interpreted code are currently unsupported.")) - (compiled-code-location - (let* ((bpt (make-breakpoint #'(lambda (frame bpt) - (declare (ignore frame bpt)) - (break "Editor installed breakpoint.")) - loc)) - (remote-bpt (wire:make-remote-object bpt))) - (activate-breakpoint bpt) - ;;(push remote-bpt (gethash name *editor-breakpoints*)) - remote-bpt))))) - -;;; -;;; Deleting breakpoints. -;;; - -;;; DELETE-BREAKPOINT-FOR-EDITOR -- Internal Interface. -;;; -(defun delete-breakpoint-for-editor (remote-obj-bpt) - "The editor calls this remotely in the slave to delete a breakpoint." - (delete-breakpoint (wire:remote-object-value remote-obj-bpt)) - (wire:forget-remote-translation remote-obj-bpt)) - - - -;;;; Miscellaneous - -;;; This appears here because it cannot go with the debug-function interface -;;; since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after the debug-function -;;; routines. -;;; - -;;; DEBUG-FUNCTION-START-LOCATION -- Public. -;;; -(defun debug-function-start-location (debug-fun) - "This returns a code-location before the body of a function and after all - the arguments are in place. If this cannot determine that location due to - a lack of debug information, it returns nil." - (etypecase debug-fun - (compiled-debug-function - (code-location-from-pc debug-fun - (c::compiled-debug-function-start-pc - (compiled-debug-function-compiler-debug-fun - debug-fun)) - nil)) - (interpreted-debug-function - ;; Return the first location if there are any, otherwise nil. - (handler-case (do-debug-function-blocks (block debug-fun nil) - (do-debug-block-locations (loc block nil) - (return-from debug-function-start-location loc))) - (no-debug-blocks (condx) - (declare (ignore condx)) - nil))))) - - - -(defun print-code-locations (function) - (let ((debug-fun (function-debug-function function))) - (do-debug-function-blocks (block debug-fun) - (do-debug-block-locations (loc block) - (fill-in-code-location loc) - (format t "~S code location at ~D" - (compiled-code-location-kind loc) - (compiled-code-location-pc loc)) - (debug::print-code-location-source-form loc 0) - (terpri))))) diff --git a/code/debug-vm.lisp b/code/debug-vm.lisp deleted file mode 100644 index b24d340ad1bc667408b86c02adc072bcc4d695f9..0000000000000000000000000000000000000000 --- a/code/debug-vm.lisp +++ /dev/null @@ -1,67 +0,0 @@ -;;; -*- Package: VM -*- -;;; -;;; ********************************************************************** -;;; 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/code/debug-vm.lisp,v 1.1 1991/08/12 08:12:18 chiles Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This is some very low-level support for the debugger :function-end -;;; breakpoints. -;;; -;;; Written by William Lott. -;;; - -(in-package "VM") - -(export '(make-bogus-lra)) - -(defconstant bogus-lra-constants 2) -(defconstant real-lra-slot (+ code-constants-offset 0)) -(defconstant known-return-p-slot (+ code-constants-offset 1)) - -;;; MAKE-BOGUS-LRA -- Interface. -;;; -(defun make-bogus-lra (real-lra &optional known-return-p) - "Make a bogus LRA object that signals a breakpoint trap when returned to. If - the breakpoint trap handler returns to the fake component, the fake code - template returns to real-lra. This returns three values: the bogus LRA - object, the code component it points to, and the pc-offset for the trap - instruction." - (system:without-gcing - (let* ((src-start (truly-the system-area-pointer - (%primitive foreign-symbol-address - "function_end_breakpoint_guts"))) - (src-end (truly-the system-area-pointer - (%primitive foreign-symbol-address - "function_end_breakpoint_end"))) - (trap-loc (truly-the system-area-pointer - (%primitive foreign-symbol-address - "function_end_breakpoint_trap"))) - (length (sap- src-end src-start)) - (code-object (%primitive allocate-code-object - (1+ bogus-lra-constants) - length)) - (dst-start (code-instructions code-object))) - (declare (type system-area-pointer src-start src-end dst-start trap-loc) - (type index length)) - (setf (code-header-ref code-object code-debug-info-slot) nil) - (setf (code-header-ref code-object code-trace-table-offset-slot) length) - (setf (code-header-ref code-object real-lra-slot) real-lra) - (setf (code-header-ref code-object known-return-p-slot) known-return-p) - (system-area-copy src-start 0 dst-start 0 (* length byte-bits)) - (let ((new-lra - (make-lisp-obj (+ (sap-int dst-start) other-pointer-type)))) - (kernel:set-header-data new-lra - (logandc2 (+ code-constants-offset - bogus-lra-constants - 1) - 1)) - (values new-lra - code-object - (sap- trap-loc src-start)))))) diff --git a/code/debug.lisp b/code/debug.lisp deleted file mode 100644 index a8150a7a7ac17752f1c0eaab0d70f0735a156914..0000000000000000000000000000000000000000 --- a/code/debug.lisp +++ /dev/null @@ -1,1621 +0,0 @@ -;;; -*- Mode: Lisp; Package: Debug; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/debug.lisp,v 1.33 1992/09/05 19:42:52 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; CMU Common Lisp Debugger. This includes a basic command-line oriented -;;; debugger interface as well as support for Hemlock to deliver debugger -;;; commands to a slave Lisp. -;;; -;;; Written by Bill Chiles. -;;; - -(in-package "DEBUG") - -(export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors* - *debug-print-level* *debug-print-length* *debug-prompt* - *help-line-scroll-count* *stack-top-hint* - - *auto-eval-in-frame* var arg - *only-block-start-locations* *print-location-kind* - - do-debug-command)) - -(in-package "LISP") -(export '(invoke-debugger *debugger-hook*)) - -(in-package "DEBUG") - -;;; -;;; Used to communicate to debug-loop that we are at a step breakpoint. -;;; -(define-condition step-condition (simple-condition)) - - -;;;; Variables, parameters, and constants. - -(defparameter *debug-print-level* 3 - "*PRINT-LEVEL* is bound to this value when debug prints a function call. If - null, use *PRINT-LEVEL*") - -(defparameter *debug-print-length* 5 - "*PRINT-LENGTH* is bound to this value when debug prints a function call. If - null, use *PRINT-LENGTH*.") - -(defvar *in-the-debugger* nil - "This is T while in the debugger.") - -(defvar *debug-command-level* 0 - "Pushes and pops/exits inside the debugger change this.") - -(defvar *stack-top-hint* nil - "If this is bound before the debugger is invoked, it is used as the stack - top by the debugger.") -(defvar *stack-top* nil) -(defvar *real-stack-top* nil) - -(defvar *current-frame* nil) - -;;; DEBUG-PROMPT -- Internal. -;;; -;;; This is the default for *debug-prompt*. -;;; -(defun debug-prompt () - (let ((*standard-output* *debug-io*)) - (terpri) - (prin1 (di:frame-number *current-frame*)) - (dotimes (i *debug-command-level*) (princ "]")) - (princ " ") - (force-output))) - -(defparameter *debug-prompt* #'debug-prompt - "This is a function of no arguments that prints the debugger prompt - on *debug-io*.") - -(defconstant debug-help-string -" -The prompt is right square brackets, the number indicating how many - recursive command loops you are in. -Debug commands do not affect * and friends, but evaluation in the debug loop - do affect these variables. -Any command may be uniquely abbreviated. - -Getting in and out of DEBUG: - Q throws to top level. - GO calls CONTINUE which tries to proceed with the restart 'continue. - RESTART invokes restart numbered as shown (prompt if not given). - ERROR prints the error condition and restart cases. - FLUSH toggles *flush-debug-errors*, which is initially t. - - The name of any restart, or its number, is a valid command, and is the same - as using RESTART to invoke that restart. - -Changing frames: - U up frame D down frame T top frame B bottom frame - - F n goes to frame n. - -Inspecting frames: - BACKTRACE [n] shows n frames going down the stack. - L lists locals in current function. - P, PP displays current function call. - SOURCE [n] displays frame's source form with n levels of enclosing forms. - VSOURCE [n] displays frame's source form without any ellipsis. - -Breakpoints and steps: - LIST-LOCATIONS [{function | :c}] list the locations for breakpoints. - Specify :c for the current frame. Abbreviation: LL - LIST-BREAKPOINTS list the active breakpoints. - Abbreviations: LB, LBP - DELETE-BREAKPOINT [n] remove breakpoint n or all breakpoints. - Abbreviations: DEL, DBP - BREAKPOINT {n | :end | :start} [:break form] [:function function] - [{:print form}*] [:condition form] set a breakpoint. - Abbreviations: BR, BP - STEP [n] step to the next location or step n times. - -Function and macro commands: - (DEBUG:DEBUG-RETURN expression) - returns expression's values from the current frame, exiting the debugger. - (DEBUG:ARG n) - returns the n'th argument, remaining in the debugger. - (DEBUG:VAR string-or-symbol [id]) - returns the specified variable's value, remaining in the debugger. - -See the CMU Common Lisp User's Manual for more information. -") - - -;;;; Breakpoint state: - -(defvar *only-block-start-locations* nil - "When true, the LIST-LOCATIONS command only displays block start locations. - Otherwise, all locations are displayed.") - -(defvar *print-location-kind* nil - "If true, list the code location type in the LIST-LOCATIONS command.") - -;;; A list of the types of code-locations that should not be stepped to and -;;; should not be listed when listing breakpoints. -;;; -(defvar *bad-code-location-types* '(:call-site :internal-error)) -(declaim (type list *bad-code-location-types*)) - -;;; Code locations of the possible breakpoints -;;; -(defvar *possible-breakpoints*) -(declaim (type list *possible-breakpoints*)) - -;;; A list of the made and active breakpoints, each is a breakpoint-info -;;; structure. -;;; -(defvar *breakpoints* nil) -(declaim (type list *breakpoints*)) - -;;; A list of breakpoint-info structures of the made and active step -;;; breakpoints. -;;; -(defvar *step-breakpoints* nil) -(declaim (type list *step-breakpoints*)) - -;;; Number of times left to step. -;;; -(defvar *number-of-steps* 1) -(declaim (type integer *number-of-steps*)) - -;;; Used when listing and setting breakpoints. -;;; -(defvar *default-breakpoint-debug-function* nil) -(declaim (type (or list di:debug-function) *default-breakpoint-debug-function*)) - - -;;;; Code location utilities: - -;;; FIRST-CODE-LOCATION -- Internal. -;;; -;;; Returns the first code-location in the passed debug block -;;; -(defun first-code-location (debug-block) - (let ((found nil) - (first-code-location nil)) - (di:do-debug-block-locations (code-location debug-block) - (unless found - (setf first-code-location code-location) - (setf found t))) - first-code-location)) - -;;; NEXT-CODE-LOCATIONS -- Internal. -;;; -;;; Returns a list of the next code-locations following the one passed. One of -;;; the *bad-code-location-types* will not be returned. -;;; -(defun next-code-locations (code-location) - (let ((debug-block (di:code-location-debug-block code-location)) - (block-code-locations nil)) - (di:do-debug-block-locations (block-code-location debug-block) - (unless (member (di:code-location-kind block-code-location) - *bad-code-location-types*) - (push block-code-location block-code-locations))) - (setf block-code-locations (nreverse block-code-locations)) - (let* ((code-loc-list (rest (member code-location block-code-locations - :test #'di:code-location=))) - (next-list (cond (code-loc-list - (list (first code-loc-list))) - ((map 'list #'first-code-location - (di:debug-block-successors debug-block))) - (t nil)))) - (when (and (= (length next-list) 1) - (di:code-location= (first next-list) code-location)) - (setf next-list (next-code-locations (first next-list)))) - next-list))) - -;;; POSSIBLE-BREAKPOINTS -- Internal. -;;; -;;; Returns a list of code-locations of the possible breakpoints of the -;;; debug-function passed. -;;; -(defun possible-breakpoints (debug-function) - (let ((possible-breakpoints nil)) - (di:do-debug-function-blocks (debug-block debug-function) - (unless (di:debug-block-elsewhere-p debug-block) - (if *only-block-start-locations* - (push (first-code-location debug-block) possible-breakpoints) - (di:do-debug-block-locations (code-location debug-block) - (when (not (member (di:code-location-kind code-location) - *bad-code-location-types*)) - (push code-location possible-breakpoints)))))) - (nreverse possible-breakpoints))) - -;;; LOCATION-IN-LIST -- Internal. -;;; -;;; Searches the info-list for the item passed (code-location, debug-function, -;;; or breakpoint-info). If the item passed is a debug function then kind will -;;; be compared if it was specified. The kind if also compared if a -;;; breakpoint-info is passed since it's in the breakpoint. The info structure -;;; is returned if found. -;;; -(defun location-in-list (place info-list &optional (kind nil)) - (when (breakpoint-info-p place) - (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place))) - (setf place (breakpoint-info-place place))) - (cond ((di:code-location-p place) - (find place info-list - :key #'breakpoint-info-place - :test #'(lambda (x y) (and (di:code-location-p y) - (di:code-location= x y))))) - (t - (find place info-list - :test #'(lambda (x-debug-function y-info) - (let ((y-place (breakpoint-info-place y-info)) - (y-breakpoint (breakpoint-info-breakpoint - y-info))) - (and (di:debug-function-p y-place) - (eq x-debug-function y-place) - (or (not kind) - (eq kind (di:breakpoint-kind - y-breakpoint)))))))))) - - -;;; MAYBE-BLOCK-START-LOCATION -- Internal. -;;; -;;; If Loc is an unknown location, then try to find the block start location. -;;; Used by source printing to some information instead of none for the user. -;;; -(defun maybe-block-start-location (loc) - (if (di:code-location-unknown-p loc) - (let* ((block (di:code-location-debug-block loc)) - (start (di:do-debug-block-locations (loc block) - (return loc)))) - (cond ((and (not (di:debug-block-elsewhere-p block)) - start) - (format t "~%Unknown location: using block start.~%") - start) - (t - loc))) - loc)) - - -;;;; The BREAKPOINT-INFO structure: - -;;; Hold info about made breakpoints -;;; -(defstruct breakpoint-info - ;; - ;; Where we are going to stop. - (place (required-argument) :type (or di:code-location di:debug-function)) - ;; - ;; The breakpoint returned by di:make-breakpoint. - (breakpoint (required-argument) :type di:breakpoint) - ;; - ;; Function returned from di:preprocess-for-eval. If result is non-nil, - ;; drop into the debugger. - (break #'identity :type function) - ;; - ;; Function returned from di:preprocess-for-eval. If result is non-nil, - ;; eval (each) print and print results. - (condition #'identity :type function) - ;; - ;; List of functions from di:preprocess-for-eval to evaluate, results are - ;; conditionally printed. Car of each element is the function, cdr is the - ;; form it goes with. - (print nil :type list) - ;; - ;; The number used when listing the possible breakpoints within a function. - ;; Could also be a symbol such as start or end. - (code-location-number (required-argument) :type (or symbol integer)) - ;; - ;; The number used when listing the breakpoints active and to delete - ;; breakpoints. - (breakpoint-number (required-argument) :type integer)) - - -;;; CREATE-BREAKPOINT-INFO -- Internal. -;;; -;;; Returns a new breakpoint-info structure with the info passed. -;;; -(defun create-breakpoint-info (place breakpoint code-location-number - &key (break #'identity) - (condition #'identity) (print nil)) - (setf *breakpoints* - (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number)) - (let ((breakpoint-number - (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints))) - ((or (> i (length *breakpoints*)) - (not (= i (breakpoint-info-breakpoint-number - (first breakpoints))))) - - i)))) - (make-breakpoint-info :place place :breakpoint breakpoint - :code-location-number code-location-number - :breakpoint-number breakpoint-number - :break break :condition condition :print print))) - -;;; PRINT-BREAKPOINT-INFO -- Internal. -;;; -;;; Prints the breakpoint info for the breakpoint-info structure passed. -;;; -(defun print-breakpoint-info (breakpoint-info) - (let ((place (breakpoint-info-place breakpoint-info)) - (bp-number (breakpoint-info-breakpoint-number breakpoint-info)) - (loc-number (breakpoint-info-code-location-number breakpoint-info))) - (case (di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info)) - (:code-location - (print-code-location-source-form place 0) - (format t "~&~S: ~S in ~S" - bp-number loc-number (di:debug-function-name - (di:code-location-debug-function place)))) - (:function-start - (format t "~&~S: FUNCTION-START in ~S" bp-number - (di:debug-function-name place))) - (:function-end - (format t "~&~S: FUNCTION-END in ~S" bp-number - (di:debug-function-name place)))))) - - - -;;;; Main-hook-function for steps and breakpoints - -;;; MAIN-HOOK-FUNCTION -- Internal. -;;; -;;; Must be passed as the hook function. Keeps track of where step -;;; breakpoints are. -;;; -(defun main-hook-function (current-frame breakpoint &optional return-vals - function-end-cookie) - (setf *default-breakpoint-debug-function* - (di:frame-debug-function current-frame)) - (dolist (step-info *step-breakpoints*) - (di:delete-breakpoint (breakpoint-info-breakpoint step-info)) - (let ((bp-info (location-in-list step-info *breakpoints*))) - (when bp-info - (di:activate-breakpoint (breakpoint-info-breakpoint bp-info))))) - (let ((*stack-top-hint* current-frame) - (step-hit-info - (location-in-list (di:breakpoint-what breakpoint) - *step-breakpoints* (di:breakpoint-kind breakpoint))) - (bp-hit-info - (location-in-list (di:breakpoint-what breakpoint) - *breakpoints* (di:breakpoint-kind breakpoint))) - (break) - (condition) - (string "")) - (setf *step-breakpoints* nil) - (labels ((build-string (str) - (setf string (concatenate 'string string str))) - (print-common-info () - (build-string - (with-output-to-string (*standard-output*) - (when function-end-cookie - (format t "~%Return values: ~S" return-vals)) - (when condition - (when (breakpoint-info-print bp-hit-info) - (format t "~%") - (print-frame-call current-frame)) - (dolist (print (breakpoint-info-print bp-hit-info)) - (format t "~& ~S = ~S" (rest print) - (funcall (first print) current-frame)))))))) - (when bp-hit-info - (setf break (funcall (breakpoint-info-break bp-hit-info) - current-frame)) - (setf condition (funcall (breakpoint-info-condition bp-hit-info) - current-frame))) - (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*)) - (build-string (format nil "~&*Step (to a breakpoint)*")) - (print-common-info) - (break string)) - ((and bp-hit-info step-hit-info break) - (build-string (format nil "~&*Step (to a breakpoint)*")) - (print-common-info) - (break string)) - ((and bp-hit-info step-hit-info) - (print-common-info) - (format t "~A" string) - (decf *number-of-steps*) - (step current-frame)) - ((and step-hit-info (= 1 *number-of-steps*)) - (build-string "*Step*") - (break (make-condition 'step-condition :format-string string))) - (step-hit-info - (decf *number-of-steps*) - (step current-frame)) - (bp-hit-info - (when break - (build-string (format nil "~&*Breakpoint hit*"))) - (print-common-info) - (if break - (break string) - (format t "~A" string))) - (t - (break "Error in main-hook-function: unknown breakpoint")))))) - - - -;;; STEP -- Internal. -;;; -;;; Sets breakpoints at the next possible code-locations. After calling -;;; this either (continue) if in the debugger or just let program flow -;;; return if in a hook function. -(defun step (frame) - (cond - ((di:debug-block-elsewhere-p (di:code-location-debug-block - (di:frame-code-location frame))) - (format t "Cannot step, in elsewhere code~%")) - (t - (let* ((code-location (di:frame-code-location frame)) - (next-code-locations (next-code-locations code-location))) - (cond - (next-code-locations - (dolist (code-location next-code-locations) - (let ((bp-info (location-in-list code-location *breakpoints*))) - (when bp-info - (di:deactivate-breakpoint (breakpoint-info-breakpoint bp-info)))) - (let ((bp (di:make-breakpoint #'main-hook-function code-location - :kind :code-location))) - (di:activate-breakpoint bp) - (push (create-breakpoint-info code-location bp 0) - *step-breakpoints*)))) - (t - (let* ((debug-function (di:frame-debug-function *current-frame*)) - (bp (di:make-breakpoint #'main-hook-function debug-function - :kind :function-end))) - (di:activate-breakpoint bp) - (push (create-breakpoint-info debug-function bp 0) - *step-breakpoints*)))))))) - - - -;;;; Backtrace: - -;;; BACKTRACE -- Public. -;;; -(defun backtrace (&optional (count most-positive-fixnum) - (*standard-output* *debug-io*)) - "Show a listing of the call stack going down from the current frame. In the - debugger, the current frame is indicated by the prompt. Count is how many - frames to show." - (let ((*print-length* (or *debug-print-length* *print-length*)) - (*print-level* (or *debug-print-level* *print-level*))) - (fresh-line *standard-output*) - (do ((frame (if *in-the-debugger* *current-frame* (di:top-frame)) - (di:frame-down frame)) - (count count (1- count))) - ((or (null frame) (zerop count)) - (values)) - (print-frame-call frame :number t)))) - - -;;;; Frame printing: - -(eval-when (compile eval) - -;;; LAMBDA-LIST-ELEMENT-DISPATCH -- Internal. -;;; -;;; This is a convenient way to express what to do for each type of lambda-list -;;; element. -;;; -(defmacro lambda-list-element-dispatch (element &key required optional rest - keyword deleted) - `(etypecase ,element - (di:debug-variable - ,@required) - (cons - (ecase (car ,element) - (:optional ,@optional) - (:rest ,@rest) - (:keyword ,@keyword))) - (symbol - (assert (eq ,element :deleted)) - ,@deleted))) - -(defmacro lambda-var-dispatch (variable location deleted valid other) - (let ((var (gensym))) - `(let ((,var ,variable)) - (cond ((eq ,var :deleted) ,deleted) - ((eq (di:debug-variable-validity ,var ,location) :valid) ,valid) - (t ,other))))) - -) ;EVAL-WHEN - - -;;; This is used in constructing arg lists for debugger printing when the arg -;;; list is unavailable, some arg is unavailable or unused, etc. -;;; -(defstruct (unprintable-object - (:constructor make-unprintable-object (string)) - (:print-function (lambda (x s d) - (declare (ignore d)) - (format s "#<~A>" - (unprintable-object-string x))))) - string) - -;;; PRINT-FRAME-CALL-1 -- Internal. -;;; -;;; This prints frame with verbosity level 1. If we hit a rest-arg, -;;; then print as many of the values as possible, -;;; punting the loop over lambda-list variables since any other arguments -;;; will be in the rest-arg's list of values. -;;; -(defun print-frame-call-1 (frame) - (let* ((d-fun (di:frame-debug-function frame)) - (loc (di:frame-code-location frame)) - (results (list (di:debug-function-name d-fun)))) - (handler-case - (dolist (ele (di:debug-function-lambda-list d-fun)) - (lambda-list-element-dispatch ele - :required ((push (frame-call-arg ele loc frame) results)) - :optional ((push (frame-call-arg (second ele) loc frame) results)) - :keyword ((push (second ele) results) - (push (frame-call-arg (third ele) loc frame) results)) - :deleted ((push (frame-call-arg ele loc frame) results)) - :rest ((lambda-var-dispatch (second ele) loc - nil - (progn - (setf results - (append (reverse (di:debug-variable-value - (second ele) frame)) - results)) - (return)) - (push (make-unprintable-object "unavaliable-rest-arg") - results))))) - (di:lambda-list-unavailable - () - (push (make-unprintable-object "lambda-list-unavailable") results))) - (prin1 (nreverse results)) - (when (di:debug-function-kind d-fun) - (write-char #\[) - (prin1 (di:debug-function-kind d-fun)) - (write-char #\])))) -;;; -(defun frame-call-arg (var location frame) - (lambda-var-dispatch var location - (make-unprintable-object "unused-arg") - (di:debug-variable-value var frame) - (make-unprintable-object "unavailable-arg"))) - -;;; PRINT-FRAME-CALL -- Interface -;;; -;;; This prints a representation of the function call causing frame to exist. -;;; Verbosity indicates the level of information to output; zero indicates just -;;; printing the debug-function's name, and one indicates displaying call-like, -;;; one-liner format with argument values. -;;; -(defun print-frame-call (frame &key - ((:print-length *print-length*) - (or *debug-print-length* *print-length*)) - ((:print-level *print-level*) - (or *debug-print-level* *print-level*)) - (verbosity 1) - (number nil)) - (cond - ((zerop verbosity) - (when number - (format t "~&~S: " (di:frame-number frame))) - (format t "~S" frame)) - (t - (when number - (format t "~&~S: " (di:frame-number frame))) - (print-frame-call-1 frame))) - (when (>= verbosity 2) - (let ((loc (di:frame-code-location frame))) - (handler-case - (progn - (di:code-location-debug-block loc) - (format t "~%Source: ") - (print-code-location-source-form loc 0)) - (di:debug-condition (ignore) ignore) - (error (cond) (format t "Error finding source: ~A" cond)))))) - - -;;;; Invoke-debugger. - -(defvar *debugger-hook* nil - "This is either nil or a function of two arguments, a condition and the value - of *debugger-hook*. This function can either handle the condition or return - which causes the standard debugger to execute. The system passes the value - of this variable to the function because it binds *debugger-hook* to nil - around the invocation.") - -;;; These are bound on each invocation of INVOKE-DEBUGGER. -;;; -(defvar *debug-restarts*) -(defvar *debug-condition*) - -;;; INVOKE-DEBUGGER -- Public. -;;; -(defun invoke-debugger (condition) - "The CMU Common Lisp debugger. Type h for help." - (when *debugger-hook* - (let ((hook *debugger-hook*) - (*debugger-hook* nil)) - (funcall hook condition hook))) - (unix:unix-sigsetmask 0) - (let* ((*debug-condition* condition) - (*debug-restarts* (compute-restarts)) - (*standard-input* *debug-io*) ;in case of setq - (*standard-output* *debug-io*) ;'' '' '' '' - (*error-output* *debug-io*) - ;; Rebind some printer control variables. - (kernel:*current-level* 0) - (*print-readably* nil) - (*read-eval* t)) - (format *error-output* "~2&~A~2&" *debug-condition*) - (unless (typep condition 'step-condition) - (show-restarts *debug-restarts* *error-output*)) - (internal-debug))) - -;;; SHOW-RESTARTS -- Internal. -;;; -(defun show-restarts (restarts &optional (s *error-output*)) - (when restarts - (format s "~&Restarts:~%") - (let ((count 0) - (names-used '(nil)) - (max-name-len 0)) - (dolist (restart restarts) - (let ((name (restart-name restart))) - (when name - (let ((len (length (princ-to-string name)))) - (when (> len max-name-len) - (setf max-name-len len)))))) - (unless (zerop max-name-len) - (incf max-name-len 3)) - (dolist (restart restarts) - (let ((name (restart-name restart))) - (cond ((member name names-used) - (format s "~& ~2D: ~@VT~A~%" count max-name-len restart)) - (t - (format s "~& ~2D: [~VA] ~A~%" - count (- max-name-len 3) name restart) - (push name names-used)))) - (incf count))))) - -;;; INTERNAL-DEBUG -- Internal Interface. -;;; -;;; This calls DEBUG-LOOP, performing some simple initializations before doing -;;; so. INVOKE-DEBUGGER calls this to actually get into the debugger. -;;; CONDITIONS::ERROR-ERROR calls this in emergencies to get into a debug -;;; prompt as quickly as possible with as little risk as possible for stepping -;;; on whatever is causing recursive errors. -;;; -(defun internal-debug () - (let ((*in-the-debugger* t) - (*read-suppress* nil)) - (unless (typep *debug-condition* 'step-condition) - (clear-input *debug-io*) - (format *debug-io* "~2&Debug (type H for help)~2%")) - (debug-loop))) - - - -;;;; Debug-loop. - -(defvar *flush-debug-errors* t - "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while - executing in the debugger. The 'flush' command toggles this.") - -(defun debug-loop () - (let* ((*debug-command-level* (1+ *debug-command-level*)) - (*real-stack-top* (di:top-frame)) - (*stack-top* (or *stack-top-hint* *real-stack-top*)) - (*stack-top-hint* nil) - (*current-frame* *stack-top*)) - (handler-bind ((di:debug-condition #'(lambda (condition) - (princ condition *debug-io*) - (throw 'debug-loop-catcher nil)))) - (fresh-line) - (print-frame-call *current-frame* :verbosity 2) - (loop - (catch 'debug-loop-catcher - (handler-bind ((error #'(lambda (condition) - (when *flush-debug-errors* - (clear-input *debug-io*) - (princ condition) - (format t "~&Error flushed ...") - (throw 'debug-loop-catcher nil))))) - ;; Must bind level for restart function created by - ;; WITH-SIMPLE-RESTART. - (let ((level *debug-command-level*) - (restart-commands (make-restart-commands))) - (with-simple-restart (abort "Return to debug level ~D." level) - (funcall *debug-prompt*) - (let ((input (ext:get-stream-command *debug-io*))) - (cond (input - (let ((cmd-fun (debug-command-p - (ext:stream-command-name input) - restart-commands))) - (cond - ((not cmd-fun) - (error "Unknown stream-command -- ~S." input)) - ((consp cmd-fun) - (error "Ambiguous debugger command: ~S." cmd-fun)) - (t - (apply cmd-fun (ext:stream-command-args input)))))) - (t - (let* ((exp (read)) - (cmd-fun (debug-command-p exp restart-commands))) - (cond ((not cmd-fun) - (debug-eval-print exp)) - ((consp cmd-fun) - (format t "~&Your command, ~S, is ambiguous:~%" - exp) - (dolist (ele cmd-fun) - (format t " ~A~%" ele))) - (t - (funcall cmd-fun))))))))))))))) - -(defvar *auto-eval-in-frame* t - "When set (the default), evaluations in the debugger's command loop occur - relative to the current frame's environment without the need of debugger - forms that explicitly control this kind of evaluation.") - -(defun debug-eval-print (exp) - (setq +++ ++ ++ + + - - exp) - (let* ((values (multiple-value-list - (if (and (fboundp 'eval:internal-eval) *auto-eval-in-frame*) - (di:eval-in-frame *current-frame* -) - (eval -)))) - (*standard-output* *debug-io*)) - (fresh-line) - (if values (prin1 (car values))) - (dolist (x (cdr values)) - (fresh-line) - (prin1 x)) - (setq /// // // / / values) - (setq *** ** ** * * (car values)) - ;; Make sure nobody passes back an unbound marker. - (unless (boundp '*) - (setq * nil) - (fresh-line) - (princ "Setting * to NIL -- was unbound marker.")))) - - - -;;;; Debug loop functions. - -;;; These commands are function, not really commands, so users can get their -;;; hands on the values returned. -;;; - -(eval-when (eval compile) - -(defmacro define-var-operation (ref-or-set &optional value-var) - `(let* ((temp (etypecase name - (symbol (di:debug-function-symbol-variables - (di:frame-debug-function *current-frame*) - name)) - (simple-string (di:ambiguous-debug-variables - (di:frame-debug-function *current-frame*) - name)))) - (location (di:frame-code-location *current-frame*)) - ;; Let's only deal with valid variables. - (vars (remove-if-not #'(lambda (v) - (eq (di:debug-variable-validity v location) - :valid)) - temp))) - (declare (list vars)) - (cond ((null vars) - (error "No known valid variables match ~S." name)) - ((= (length vars) 1) - ,(ecase ref-or-set - (:ref - '(di:debug-variable-value (car vars) *current-frame*)) - (:set - `(setf (di:debug-variable-value (car vars) *current-frame*) - ,value-var)))) - (t - ;; Since we have more than one, first see if we have any - ;; variables that exactly match the specification. - (let* ((name (etypecase name - (symbol (symbol-name name)) - (simple-string name))) - (exact (remove-if-not #'(lambda (v) - (string= (di:debug-variable-name v) - name)) - vars)) - (vars (or exact vars))) - (declare (simple-string name) - (list exact vars)) - (cond - ;; Check now for only having one variable. - ((= (length vars) 1) - ,(ecase ref-or-set - (:ref - '(di:debug-variable-value (car vars) *current-frame*)) - (:set - `(setf (di:debug-variable-value (car vars) *current-frame*) - ,value-var)))) - ;; If there weren't any exact matches, flame about ambiguity - ;; unless all the variables have the same name. - ((and (not exact) - (find-if-not - #'(lambda (v) - (string= (di:debug-variable-name v) - (di:debug-variable-name (car vars)))) - (cdr vars))) - (error "Specification ambiguous:~%~{ ~A~%~}" - (mapcar #'di:debug-variable-name - (delete-duplicates - vars :test #'string= - :key #'di:debug-variable-name)))) - ;; All names are the same, so see if the user ID'ed one of them. - (id-supplied - (let ((v (find id vars :key #'di:debug-variable-id))) - (unless v - (error "Invalid variable ID, ~D, should have been one of ~S." - id (mapcar #'di:debug-variable-id vars))) - ,(ecase ref-or-set - (:ref - '(di:debug-variable-value v *current-frame*)) - (:set - `(setf (di:debug-variable-value v *current-frame*) - ,value-var))))) - (t - (error "Specify variable ID to disambiguate ~S. Use one of ~S." - name (mapcar #'di:debug-variable-id vars))))))))) - -) ;EVAL-WHEN - -;;; VAR -- Public. -;;; -(defun var (name &optional (id 0 id-supplied)) - "Returns a variable's value if possible. Name is a simple-string or symbol. - If it is a simple-string, it is an initial substring of the variable's name. - If name is a symbol, it has the same name and package as the variable whose - value this function returns. If the symbol is uninterned, then the variable - has the same name as the symbol, but it has no package. - - If name is the initial substring of variables with different names, then - this return no values after displaying the ambiguous names. If name - determines multiple variables with the same name, then you must use the - optional id argument to specify which one you want. If you left id - unspecified, then this returns no values after displaying the distinguishing - id values. - - The result of this function is limited to the availability of variable - information. This is SETF'able." - (define-var-operation :ref)) -;;; -(defun (setf var) (value name &optional (id 0 id-supplied)) - (define-var-operation :set value)) - - - -;;; ARG -- Public. -;;; -(defun arg (n) - "Returns the n'th argument's value if possible. Argument zero is the first - argument in a frame's default printed representation. Count keyword/value - pairs as separate arguments." - (multiple-value-bind - (var lambda-var-p) - (nth-arg n (handler-case (di:debug-function-lambda-list - (di:frame-debug-function *current-frame*)) - (di:lambda-list-unavailable () - (error "No argument values are available.")))) - (if lambda-var-p - (lambda-var-dispatch var (di:frame-code-location *current-frame*) - (error "Unused arguments have no values.") - (di:debug-variable-value var *current-frame*) - (error "Invalid argument value.")) - var))) - -;;; NTH-ARG -- Internal. -;;; -;;; This returns the n'th arg as the user sees it from args, the result of -;;; DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a potential debug-variable -;;; from the lambda-list, then the second value is t. If this returns a -;;; keyword symbol or a value from a rest arg, then the second value is nil. -;;; -(defun nth-arg (count args) - (let ((n count)) - (dolist (ele args (error "Argument specification out of range -- ~S." n)) - (lambda-list-element-dispatch ele - :required ((if (zerop n) (return (values ele t)))) - :optional ((if (zerop n) (return (values (second ele) t)))) - :keyword ((cond ((zerop n) - (return (values (second ele) nil))) - ((zerop (decf n)) - (return (values (third ele) t))))) - :deleted ((if (zerop n) (return (values ele t)))) - :rest ((let ((var (second ele))) - (lambda-var-dispatch var - (di:frame-code-location *current-frame*) - (error "Unused rest-arg before n'th argument.") - (dolist (value - (di:debug-variable-value var *current-frame*) - (error "Argument specification out of range -- ~S." - n)) - (if (zerop n) - (return-from nth-arg (values value nil)) - (decf n))) - (error "Invalid rest-arg before n'th argument."))))) - (decf n)))) - - - -;;;; Debug loop command definition: - -(defvar *debug-commands* nil) - -;;; DEF-DEBUG-COMMAND -- Internal. -;;; -;;; Interface to *debug-commands*. No required arguments in args are -;;; permitted. -;;; -(defmacro def-debug-command (name args &rest body) - (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND")))) - `(progn - (when (assoc ,name *debug-commands* :test #'string=) - (warn "Redefining ~S debugger command." ,name) - (setf *debug-commands* - (remove ,name *debug-commands* :key #'car :test #'string=))) - (defun ,fun-name ,args - (unless *in-the-debugger* - (error "Invoking debugger command while outside the debugger.")) - ,@body) - (push (cons ,name #',fun-name) *debug-commands*) - ',fun-name))) - -;;; DEF-DEBUG-COMMAND-ALIAS -- Internal. -;;; -(defun def-debug-command-alias (new-name existing-name) - (let ((pair (assoc existing-name *debug-commands* :test #'string=))) - (unless pair (error "Unknown debug command name -- ~S" existing-name)) - (push (cons new-name (cdr pair)) *debug-commands*)) - new-name) - -;;; DEBUG-COMMAND-P -- Internal. -;;; -;;; This takes a symbol and uses its name to find a debugger command, using -;;; initial substring matching. It returns the command function if form -;;; identifies only one command, but if form is ambiguous, this returns a list -;;; of the command names. If there are no matches, this returns nil. Whenever -;;; the loop that looks for a set of possibilities encounters an exact name -;;; match, we return that command function immediately. -;;; -(defun debug-command-p (form &optional other-commands) - (if (or (symbolp form) (integerp form)) - (let* ((name - (if (symbolp form) - (symbol-name form) - (format nil "~d" form))) - (len (length name)) - (res nil)) - (declare (simple-string name) - (fixnum len) - (list res)) - ;; - ;; Find matching commands, punting if exact match. - (flet ((match-command (ele) - (let* ((str (car ele)) - (str-len (length str))) - (declare (simple-string str) - (fixnum str-len)) - (cond ((< str-len len)) - ((= str-len len) - (when (string= name str :end1 len :end2 len) - (return-from debug-command-p (cdr ele)))) - ((string= name str :end1 len :end2 len) - (push ele res)))))) - (mapc #'match-command *debug-commands*) - (mapc #'match-command other-commands)) - ;; - ;; Return the right value. - (cond ((not res) nil) - ((= (length res) 1) - (cdar res)) - (t ;Just return the names. - (do ((cmds res (cdr cmds))) - ((not cmds) res) - (setf (car cmds) (caar cmds)))))))) - - -;;; -;;; Returns a list of debug commands (in the same format as *debug-commands*) -;;; that invoke each active restart. -;;; -;;; Two commands are made for each restart: one for the number, and one for -;;; the restart name (unless it's been shadowed by an earlier restart of the -;;; same name. -;;; -(defun make-restart-commands (&optional (restarts *debug-restarts*)) - (let ((commands) - (num 0)) ; better be the same as show-restarts! - (dolist (restart restarts) - (let ((name (string (restart-name restart)))) - (unless (find name commands :key #'car :test #'string=) - (let ((restart-fun - #'(lambda () - (invoke-restart-interactively restart)))) - (push (cons name restart-fun) commands) - (push (cons (format nil "~d" num) restart-fun) commands)))) - (incf num)) - commands)) - - -;;; -;;; Frame changing commands. -;;; - -(def-debug-command "UP" () - (let ((next (di:frame-up *current-frame*))) - (cond (next - (setf *current-frame* next) - (print-frame-call next)) - (t - (format t "~&Top of stack."))))) - -(def-debug-command "DOWN" () - (let ((next (di:frame-down *current-frame*))) - (cond (next - (setf *current-frame* next) - (print-frame-call next)) - (t - (format t "~&Bottom of stack."))))) - -(def-debug-command-alias "D" "DOWN") - -(def-debug-command "TOP" () - (do ((prev *current-frame* lead) - (lead (di:frame-up *current-frame*) (di:frame-up lead))) - ((null lead) - (setf *current-frame* prev) - (print-frame-call prev)))) - -(def-debug-command "BOTTOM" () - (do ((prev *current-frame* lead) - (lead (di:frame-down *current-frame*) (di:frame-down lead))) - ((null lead) - (setf *current-frame* prev) - (print-frame-call prev)))) - - -(def-debug-command-alias "B" "BOTTOM") - -(def-debug-command "FRAME" (&optional - (n (read-prompting-maybe "Frame number: "))) - (let ((current (di:frame-number *current-frame*))) - (cond ((= n current) - (princ "You are here.")) - ((> n current) - (print-frame-call - (setf *current-frame* - (do ((prev *current-frame* lead) - (lead (di:frame-down *current-frame*) - (di:frame-down lead))) - ((null lead) - (princ "Bottom of stack encountered.") - prev) - (when (= n (di:frame-number prev)) - (return prev)))))) - (t - (print-frame-call - (setf *current-frame* - (do ((prev *current-frame* lead) - (lead (di:frame-up *current-frame*) - (di:frame-up lead))) - ((null lead) - (princ "Top of stack encountered.") - prev) - (when (= n (di:frame-number prev)) - (return prev))))))))) - -(def-debug-command-alias "F" "FRAME") - - -;;; -;;; In and Out commands. -;;; - -(def-debug-command "QUIT" () - (throw 'lisp::top-level-catcher nil)) - -(def-debug-command "GO" () - (continue) - (error "No restart named continue.")) - -(def-debug-command "RESTART" () - (let ((num (read-if-available :prompt))) - (when (eq num :prompt) - (show-restarts *debug-restarts*) - (write-string "Restart: ") - (force-output) - (setf num (read *standard-input*))) - (let ((restart (typecase num - (unsigned-byte - (nth num *debug-restarts*)) - (symbol - (find num *debug-restarts* :key #'restart-name - :test #'(lambda (sym1 sym2) - (string= (symbol-name sym1) - (symbol-name sym2))))) - (t - (format t "~S is invalid as a restart name.~%" num) - (return-from restart-debug-command nil))))) - (if restart - (invoke-restart-interactively restart) - (princ "No such restart."))))) - - -;;; -;;; Information commands. -;;; - -(defvar *help-line-scroll-count* 20 - "This controls how many lines the debugger's help command prints before - printing a prompting line to continue with output.") - -(def-debug-command "HELP" () - (let* ((end -1) - (len (length debug-help-string)) - (len-1 (1- len))) - (loop - (let ((start (1+ end)) - (count *help-line-scroll-count*)) - (loop - (setf end (position #\newline debug-help-string :start (1+ end))) - (cond ((or (not end) (= end len-1)) - (setf end len) - (return)) - ((or (zerop (decf count)) (= end len)) - (return)))) - (write-string debug-help-string *standard-output* - :start start :end end)) - (when (= end len) (return)) - (format t "~%[RETURN FOR MORE, Q TO QUIT HELP TEXT]: ") - (force-output) - (let ((res (read-line))) - (when (or (string= res "q") (string= res "Q")) - (return)))))) - -(def-debug-command-alias "?" "HELP") - -(def-debug-command "ERROR" () - (format t "~A~%" *debug-condition*) - (show-restarts *debug-restarts*)) - -(def-debug-command "BACKTRACE" () - (backtrace (read-if-available most-positive-fixnum))) - -(def-debug-command "PRINT" () - (print-frame-call *current-frame*)) - -(def-debug-command-alias "P" "PRINT") - -(def-debug-command "VPRINT" () - (print-frame-call *current-frame* :print-level nil :print-length nil - :verbosity (read-if-available 2))) - -(def-debug-command-alias "PP" "VPRINT") - -(def-debug-command "LIST-LOCALS" () - (let ((d-fun (di:frame-debug-function *current-frame*))) - (if (di:debug-variable-info-available d-fun) - (let ((*print-level* (or *debug-print-level* *print-level*)) - (*print-length* (or *debug-print-length* *print-length*)) - (*standard-output* *debug-io*) - (location (di:frame-code-location *current-frame*)) - (prefix (read-if-available nil)) - (any-p nil) - (any-valid-p nil)) - (dolist (v (di:ambiguous-debug-variables - d-fun - (if prefix (string prefix) ""))) - (setf any-p t) - (when (eq (di:debug-variable-validity v location) :valid) - (setf any-valid-p t) - (format t "~A~:[#~D~;~*~] = ~S~%" - (di:debug-variable-name v) - (zerop (di:debug-variable-id v)) - (di:debug-variable-id v) - (di:debug-variable-value v *current-frame*)))) - - (cond - ((not any-p) - (format t "No local variables ~@[starting with ~A ~]~ - in function." - prefix)) - ((not any-valid-p) - (format t "All variables ~@[starting with ~A ~]currently ~ - have invalid values." - prefix)))) - (write-line "No variable information available.")))) - -(def-debug-command-alias "L" "LIST-LOCALS") - -(def-debug-command "SOURCE" () - (fresh-line) - (print-code-location-source-form (di:frame-code-location *current-frame*) - (read-if-available 0))) - -(def-debug-command "VSOURCE" () - (fresh-line) - (print-code-location-source-form (di:frame-code-location *current-frame*) - (read-if-available 0) - t)) - - -;;;; Source location printing: - -;;; We cache a stream to the last valid file debug source so that we won't have -;;; to repeatedly open the file. -;;; -(defvar *cached-debug-source* nil) -(declaim (type (or di:debug-source null) *cached-debug-source*)) -(defvar *cached-source-stream* nil) -(declaim (type (or stream null) *cached-source-stream*)) - -(pushnew #'(lambda () - (setq *cached-debug-source* nil *cached-source-stream* nil)) - ext:*before-save-initializations*) - - -;;; We also cache the last top-level form that we printed a source for so that -;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS. -;;; -(defvar *cached-top-level-form-offset* nil) -(declaim (type (or kernel:index null) *cached-top-level-form-offset*)) -(defvar *cached-top-level-form*) -(defvar *cached-form-number-translations*) - - -;;; GET-TOP-LEVEL-FORM -- Internal -;;; -;;; Given a code location, return the associated form-number translations -;;; and the actual top-level form. We check our cache --- if there is a miss, -;;; we dispatch on the kind of the debug source. -;;; -(defun get-top-level-form (location) - (let ((d-source (di:code-location-debug-source location))) - (if (and (eq d-source *cached-debug-source*) - (eql (di:code-location-top-level-form-offset location) - *cached-top-level-form-offset*)) - (values *cached-form-number-translations* *cached-top-level-form*) - (let* ((offset (di:code-location-top-level-form-offset location)) - (res - (ecase (di:debug-source-from d-source) - (:file (get-file-top-level-form location)) - ((:lisp :stream) - (svref (di:debug-source-name d-source) offset))))) - (setq *cached-top-level-form-offset* offset) - (values (setq *cached-form-number-translations* - (di:form-number-translations res offset)) - (setq *cached-top-level-form* res)))))) - - -;;; GET-FILE-TOP-LEVEL-FORM -- Internal. -;;; -;;; Locates the source file (if it still exists) and grabs the top-level form. -;;; If the file is modified, we use the top-level-form offset instead of the -;;; recorded character offset. -;;; -(defun get-file-top-level-form (location) - (let* ((d-source (di:code-location-debug-source location)) - (tlf-offset (di:code-location-top-level-form-offset location)) - (local-tlf-offset (- tlf-offset - (di:debug-source-root-number d-source))) - (char-offset - (aref (or (di:debug-source-start-positions d-source) - (error "No start positions map.")) - local-tlf-offset)) - (name (di:debug-source-name d-source))) - (unless (eq d-source *cached-debug-source*) - (unless (and *cached-source-stream* - (equal (pathname *cached-source-stream*) - (pathname name))) - (when *cached-source-stream* (close *cached-source-stream*)) - (setq *cached-source-stream* (open name :if-does-not-exist nil)) - (unless *cached-source-stream* - (error "Source file no longer exists:~% ~A." (namestring name))) - (format t "~%; File: ~A~%" (namestring name))) - - (setq *cached-debug-source* - (if (= (di:debug-source-created d-source) (file-write-date name)) - d-source nil))) - - (cond - ((eq *cached-debug-source* d-source) - (file-position *cached-source-stream* char-offset)) - (t - (format t "~%; File has been modified since compilation:~%; ~A~@ - ; Using form offset instead of character position.~%" - (namestring name)) - (file-position *cached-source-stream* 0) - (let ((*read-suppress* t)) - (dotimes (i local-tlf-offset) - (read *cached-source-stream*))))) - (read *cached-source-stream*))) - - -;;; PRINT-CODE-LOCATION-SOURCE-FORM -- Internal. -;;; -(defun print-code-location-source-form (location context &optional verbose) - (let* ((location (maybe-block-start-location location)) - (*print-level* (if verbose - nil - (or *debug-print-level* *print-level*))) - (*print-length* (if verbose - nil - (or *debug-print-length* *print-length*)))) - (multiple-value-bind (translations form) - (get-top-level-form location) - - (prin1 (di:source-path-context - form - (svref translations - (di:code-location-form-number location)) - context))))) - - -;;; -;;; Breakpoint and step commands. -;;; - -;;; Steps to the next code-location -(def-debug-command "STEP" () - (setf *number-of-steps* (read-if-available 1)) - (step *current-frame*) - (continue) - (error "Couldn't continue.")) - -;;; Lists possible breakpoint locations, which are active, and where go will -;;; continue. Sets *possible-breakpoints* to the code-locations which can then -;;; be used by sbreakpoint. Takes a function as an optional argument. -(def-debug-command "LIST-LOCATIONS" () - (let ((df (read-if-available *default-breakpoint-debug-function*))) - (cond ((consp df) - (setf df (di:function-debug-function (eval df))) - (setf *default-breakpoint-debug-function* df)) - ((or (eq ':c df) - (not *default-breakpoint-debug-function*)) - (setf df (di:frame-debug-function *current-frame*)) - (setf *default-breakpoint-debug-function* df))) - (setf *possible-breakpoints* (possible-breakpoints df))) - (let ((continue-at (di:frame-code-location *current-frame*))) - (let ((active (location-in-list *default-breakpoint-debug-function* - *breakpoints* :function-start)) - (here (di:code-location= - (di:debug-function-start-location - *default-breakpoint-debug-function*) continue-at))) - (when (or active here) - (format t "::FUNCTION-START ") - (when active (format t " *Active*")) - (when here (format t " *Continue here*")))) - - (let ((prev-location nil) - (prev-num 0) - (this-num 0)) - (flet ((flush () - (when prev-location - (let ((this-num (1- this-num))) - (if (= prev-num this-num) - (format t "~&~D: " prev-num) - (format t "~&~D-~D: " prev-num this-num))) - (print-code-location-source-form prev-location 0) - (when *print-location-kind* - (format t "~S " (di:code-location-kind prev-location))) - (when (location-in-list prev-location *breakpoints*) - (format t " *Active*")) - (when (di:code-location= prev-location continue-at) - (format t " *Continue here*"))))) - - (dolist (code-location *possible-breakpoints*) - (when (or *print-location-kind* - (location-in-list code-location *breakpoints*) - (di:code-location= code-location continue-at) - (not prev-location) - (not (eq (di:code-location-debug-source code-location) - (di:code-location-debug-source prev-location))) - (not (eq (di:code-location-top-level-form-offset - code-location) - (di:code-location-top-level-form-offset - prev-location))) - (not (eq (di:code-location-form-number code-location) - (di:code-location-form-number prev-location)))) - (flush) - (setq prev-location code-location prev-num this-num)) - - (incf this-num)))) - - (when (location-in-list *default-breakpoint-debug-function* *breakpoints* - :function-end) - (format t "~&::FUNCTION-END *Active* ")))) - -(def-debug-command-alias "LL" "LIST-LOCATIONS") - -;;; set breakpoint at # given -(def-debug-command "BREAKPOINT" () - (let ((index (read-prompting-maybe "Location number, :start, or :end: ")) - (break t) - (condition t) - (print nil) - (print-functions nil) - (function nil) - (bp) - (place *default-breakpoint-debug-function*)) - (flet ((get-command-line () - (let ((command-line nil) - (unique '(nil))) - (loop - (let ((next-input (read-if-available unique))) - (when (eq next-input unique) (return)) - (push next-input command-line))) - (nreverse command-line))) - (set-vars-from-command-line (command-line) - (do ((arg (pop command-line) (pop command-line))) - ((not arg)) - (ecase arg - (:condition (setf condition (pop command-line))) - (:print (push (pop command-line) print)) - (:break (setf break (pop command-line))) - (:function - (setf function (eval (pop command-line))) - (setf *default-breakpoint-debug-function* - (di:function-debug-function function)) - (setf *possible-breakpoints* - (possible-breakpoints - *default-breakpoint-debug-function*)))))) - (setup-function-start () - (let ((code-loc (di:debug-function-start-location place))) - (setf bp (di:make-breakpoint #'main-hook-function place - :kind :function-start)) - (setf break (di:preprocess-for-eval break code-loc)) - (setf condition (di:preprocess-for-eval condition code-loc)) - (dolist (form print) - (push (cons (di:preprocess-for-eval form code-loc) form) - print-functions)))) - (setup-function-end () - (setf bp - (di:make-breakpoint #'main-hook-function place - :kind :function-end)) - (setf break - (coerce `(lambda (dummy) - (declare (ignore dummy)) ,break) - 'function)) - (setf condition (coerce `(lambda (dummy) - (declare (ignore dummy)) ,condition) - 'function)) - (dolist (form print) - (push (cons - (coerce `(lambda (dummy) - (declare (ignore dummy)) ,form) 'function) - form) - print-functions))) - (setup-code-location () - (setf place (nth index *possible-breakpoints*)) - (setf bp (di:make-breakpoint #'main-hook-function place - :kind :code-location)) - (dolist (form print) - (push (cons - (di:preprocess-for-eval form place) - form) - print-functions)) - (setf break (di:preprocess-for-eval break place)) - (setf condition (di:preprocess-for-eval condition place)))) - (set-vars-from-command-line (get-command-line)) - (cond - ((or (eq index :start) (eq index :s)) - (setup-function-start)) - ((or (eq index :end) (eq index :e)) - (setup-function-end)) - (t - (setup-code-location))) - (di:activate-breakpoint bp) - (let* ((new-bp-info (create-breakpoint-info place bp index - :break break - :print print-functions - :condition condition)) - (old-bp-info (location-in-list new-bp-info *breakpoints*))) - (when old-bp-info - (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info)) - (setf *breakpoints* (remove old-bp-info *breakpoints*)) - (format t "Note: previous breakpoint removed.~%")) - (push new-bp-info *breakpoints*)) - (print-breakpoint-info (first *breakpoints*)) - (format t "~&Added.")))) - -(def-debug-command-alias "BP" "BREAKPOINT") - -;;; list all breakpoints set -(def-debug-command "LIST-BREAKPOINTS" () - (setf *breakpoints* - (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number)) - (dolist (info *breakpoints*) - (print-breakpoint-info info))) - -(def-debug-command-alias "LB" "LIST-BREAKPOINTS") -(def-debug-command-alias "LBP" "LIST-BREAKPOINTS") - -;;; remove breakpoint n or all if none given -(def-debug-command "DELETE-BREAKPOINT" () - (let* ((index (read-if-available nil)) - (bp-info - (find index *breakpoints* :key #'breakpoint-info-breakpoint-number))) - (cond (bp-info - (di:delete-breakpoint (breakpoint-info-breakpoint bp-info)) - (setf *breakpoints* (remove bp-info *breakpoints*)) - (format t "Breakpoint ~S removed.~%" index)) - (index (format t "Breakpoint doesn't exist.")) - (t - (dolist (ele *breakpoints*) - (di:delete-breakpoint (breakpoint-info-breakpoint ele))) - (setf *breakpoints* nil) - (format t "All breakpoints deleted.~%"))))) - -(def-debug-command-alias "DBP" "DELETE-BREAKPOINT") - - -;;; -;;; Miscellaneous commands. -;;; - -(def-debug-command "FLUSH-ERRORS" () - (if (setf *flush-debug-errors* (not *flush-debug-errors*)) - (write-line "Errors now flushed.") - (write-line "Errors now create nested debug levels."))) - - -(def-debug-command "DESCRIBE" () - (let* ((curloc (di:frame-code-location *current-frame*)) - (debug-fun (di:code-location-debug-function curloc)) - (function (di:debug-function-function debug-fun))) - (if function - (describe function) - (format t "Can't figure out the function for this frame.")))) - - -;;; -;;; Editor commands. -;;; - -(def-debug-command "EDIT-SOURCE" () - (unless (typep *terminal-io* 'ed::ts-stream) - (error "The debugger's EDIT-SOURCE command only works in slave Lisps ~ - connected to a Hemlock editor.")) - (let* ((wire (ed::ts-stream-wire *terminal-io*)) - (location (maybe-block-start-location - (di:frame-code-location *current-frame*))) - (d-source (di:code-location-debug-source location)) - (name (di:debug-source-name d-source))) - (ecase (di:debug-source-from d-source) - (:file - (let* ((tlf-offset (di:code-location-top-level-form-offset location)) - (local-tlf-offset (- tlf-offset - (di:debug-source-root-number d-source))) - (char-offset (aref (or (di:debug-source-start-positions d-source) - (error "No start positions map.")) - local-tlf-offset))) - (wire:remote wire - (ed::edit-source-location (namestring name) - (di:debug-source-created d-source) - tlf-offset local-tlf-offset char-offset - (di:code-location-form-number location))) - (wire:wire-force-output wire))) - ((:lisp :stream) - (wire:remote wire - (ed::cannot-edit-source-location)) - (wire:wire-force-output wire))))) - - - -;;;; Debug loop command utilities. - -(defun read-prompting-maybe (prompt &optional (in *standard-input*) - (out *standard-output*)) - (unless (ext:listen-skip-whitespace in) - (princ prompt out) - (force-output out)) - (read in)) - -(defun read-if-available (default &optional (stream *standard-input*)) - (if (ext:listen-skip-whitespace stream) - (read stream) - default)) diff --git a/code/defmacro.lisp b/code/defmacro.lisp deleted file mode 100644 index 372e9b669f5b318e8028761d5d86f89f87eb0fd5..0000000000000000000000000000000000000000 --- a/code/defmacro.lisp +++ /dev/null @@ -1,417 +0,0 @@ -;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/defmacro.lisp,v 1.13 1992/08/12 18:56:32 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Written by Blaine Burks. -;;; -(in-package "LISP") - - -;;;; Some variable definitions. - -;;; Variables for amassing the results of parsing a defmacro. Declarations -;;; in DEFMACRO are the reason this isn't as easy as it sounds. -;;; -(defvar *arg-tests* () - "A list of tests that do argument counting at expansion time.") - -(defvar *system-lets* () - "Let bindings that are done to make lambda-list parsing possible.") - -(defvar *user-lets* () - "Let bindings that the user has explicitly supplied.") - -(defvar *default-default* nil - "Unsupplied optional and keyword arguments get this value defaultly.") - - -;;;; Stuff to parse DEFMACRO, MACROLET, DEFINE-SETF-METHOD, and DEFTYPE. - -;;; PARSE-DEFMACRO returns, as multiple-values, a body, possibly a declare -;;; form to put where this code is inserted, and the documentation for the -;;; parsed body. -;;; -(defun parse-defmacro (lambda-list arg-list-name code name error-kind - &key (annonymousp nil) - (doc-string-allowed t) - ((:environment env-arg-name)) - ((:default-default *default-default*)) - (error-fun 'error)) - "Returns as multiple-values a parsed body, any local-declarations that - should be made where this body is inserted, and a doc-string if there is - one." - (multiple-value-bind (body declarations documentation) - (parse-body code nil doc-string-allowed) - (let* ((*arg-tests* ()) - (*user-lets* ()) - (*system-lets* ())) - (multiple-value-bind - (env-arg-used minimum maximum) - (parse-defmacro-lambda-list lambda-list arg-list-name name - error-kind error-fun (not annonymousp) - nil env-arg-name) - (values - `(let* ,(nreverse *system-lets*) - ,@*arg-tests* - (let* ,(nreverse *user-lets*) - ,@declarations - ,@body)) - (if (and env-arg-name (not env-arg-used)) - `((declare (ignore ,env-arg-name))) - nil) - documentation - minimum - maximum))))) - - -(defun parse-defmacro-lambda-list - (lambda-list arg-list-name name error-kind error-fun - &optional top-level env-illegal env-arg-name) - (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name)) - (now-processing :required) - (maximum 0) - (minimum 0) - (keys ()) - rest-name restp allow-other-keys-p env-arg-used) - ;; This really strange way to test for '&whole is neccessary because member - ;; does not have to work on dotted lists, and dotted lists are legal - ;; in lambda-lists. - (when (and (do ((list lambda-list (cdr list))) - ((atom list) nil) - (when (eq (car list) '&whole) (return t))) - (not (eq (car lambda-list) '&whole))) - (error "&Whole must appear first in ~S lambda-list." error-kind)) - (do ((rest-of-args lambda-list (cdr rest-of-args))) - ((atom rest-of-args) - (cond ((null rest-of-args) nil) - ;; Varlist is dotted, treat as &rest arg and exit. - (t (push-let-binding rest-of-args path nil) - (setf restp t)))) - (let ((var (car rest-of-args))) - (cond ((eq var '&whole) - (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) - (setf rest-of-args (cdr rest-of-args)) - (push-let-binding (car rest-of-args) arg-list-name nil)) - (t - (defmacro-error "&WHOLE" error-kind name)))) - ((eq var '&environment) - (cond (env-illegal - (error "&Environment not valid with ~S." error-kind)) - ((not top-level) - (error "&Environment only valid at top level of ~ - lambda-list."))) - (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) - (setf rest-of-args (cdr rest-of-args)) - (push-let-binding (car rest-of-args) env-arg-name nil) - (setf env-arg-used t)) - (t - (defmacro-error "&ENVIRONMENT" error-kind name)))) - ((or (eq var '&rest) (eq var '&body)) - (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) - (setf rest-of-args (cdr rest-of-args)) - (setf restp t) - (push-let-binding (car rest-of-args) path nil)) - ;; - ;; This branch implements an incompatible extension to - ;; Common Lisp. In place of a symbol following &body, - ;; there may be a list of up to three elements which will - ;; be bound to the body, declarations, and doc-string of - ;; the body. - ((and (cdr rest-of-args) - (consp (cadr rest-of-args)) - (symbolp (caadr rest-of-args))) - (setf rest-of-args (cdr rest-of-args)) - (setf restp t) - (let ((body-name (caar rest-of-args)) - (declarations-name (cadar rest-of-args)) - (doc-string-name (caddar rest-of-args)) - (parse-body-values (gensym))) - (push-let-binding - parse-body-values - `(multiple-value-list - (parse-body ,path ,env-arg-name - ,(not (null doc-string-name)))) - t) - (setf env-arg-used t) - (when body-name - (push-let-binding body-name - `(car ,parse-body-values) nil)) - (when declarations-name - (push-let-binding declarations-name - `(cadr ,parse-body-values) nil)) - (when doc-string-name - (push-let-binding doc-string-name - `(caddr ,parse-body-values) nil)))) - (t - (defmacro-error (symbol-name var) error-kind name)))) - ((eq var '&optional) - (setf now-processing :optionals)) - ((eq var '&key) - (setf now-processing :keywords) - (setf rest-name (gensym "KEYWORDS-")) - (setf restp t) - (push-let-binding rest-name path t)) - ((eq var '&allow-other-keys) - (setf allow-other-keys-p t)) - ((eq var '&aux) - (setf now-processing :auxs)) - ((listp var) - (case now-processing - (:required - (let ((sub-list-name (gensym "SUBLIST-"))) - (push-sub-list-binding sub-list-name `(car ,path) var - name error-kind error-fun) - (parse-defmacro-lambda-list var sub-list-name name - error-kind error-fun)) - (setf path `(cdr ,path)) - (incf minimum) - (incf maximum)) - (:optionals - (when (> (length var) 3) - (cerror "Ignore extra noise." - "More than variable, initform, and suppliedp ~ - in &optional binding - ~S" - var)) - (push-optional-binding (car var) (cadr var) (caddr var) - `(not (null ,path)) `(car ,path) - name error-kind error-fun) - (setf path `(cdr ,path)) - (incf maximum)) - (:keywords - (let* ((keyword-given (consp (car var))) - (variable (if keyword-given - (cadar var) - (car var))) - (keyword (if keyword-given - (caar var) - (make-keyword variable))) - (supplied-p (caddr var))) - (push-optional-binding variable (cadr var) supplied-p - `(keyword-supplied-p ',keyword - ,rest-name) - `(lookup-keyword ',keyword - ,rest-name) - name error-kind error-fun) - (push keyword keys))) - (:auxs (push-let-binding (car var) (cadr var) nil)))) - ((symbolp var) - (case now-processing - (:required - (incf minimum) - (incf maximum) - (push-let-binding var `(car ,path) nil) - (setf path `(cdr ,path))) - (:optionals - (incf maximum) - (push-let-binding var `(car ,path) nil `(not (null ,path))) - (setf path `(cdr ,path))) - (:keywords - (let ((key (make-keyword var))) - (push-let-binding var `(lookup-keyword ,key ,rest-name) - nil) - (push key keys))) - (:auxs - (push-let-binding var nil nil)))) - (t - (error "Non-symbol in lambda-list - ~S." var))))) - (push `(unless (<= ,minimum - (length (the list ,(if top-level - `(cdr ,arg-list-name) - arg-list-name))) - ,@(unless restp - (list maximum))) - (,error-fun 'defmacro-ll-arg-count-error - :kind ',error-kind - ,@(when name `(:name ',name)) - :argument ,(if top-level - `(cdr ,arg-list-name) - arg-list-name) - :lambda-list ',lambda-list - :minimum ,minimum - ,@(unless restp `(:maximum ,maximum)))) - *arg-tests*) - (if keys - (let ((problem (gensym "KEY-PROBLEM-")) - (info (gensym "INFO-"))) - (push `(multiple-value-bind - (,problem ,info) - (verify-keywords ,rest-name ',keys ',allow-other-keys-p) - (when ,problem - (,error-fun - 'defmacro-ll-broken-key-list-error - :kind ',error-kind - ,@(when name `(:name ',name)) - :problem ,problem - :info ,info))) - *arg-tests*))) - (values env-arg-used minimum (if (null restp) maximum nil)))) - -(defun push-sub-list-binding (variable path object name error-kind error-fun) - (let ((var (gensym "TEMP-"))) - (push `(,variable - (let ((,var ,path)) - (if (listp ,var) - ,var - (,error-fun 'defmacro-bogus-sublist-error - :kind ',error-kind - ,@(when name `(:name ',name)) - :object ,var - :lambda-list ',object)))) - *system-lets*))) - -(defun push-let-binding (variable path systemp &optional condition - (init-form *default-default*)) - (let ((let-form (if condition - `(,variable (if ,condition ,path ,init-form)) - `(,variable ,path)))) - (if systemp - (push let-form *system-lets*) - (push let-form *user-lets*)))) - -(defun push-optional-binding (value-var init-form supplied-var condition path - name error-kind error-fun) - (unless supplied-var - (setf supplied-var (gensym "SUPLIEDP-"))) - (push-let-binding supplied-var condition t) - (cond ((consp value-var) - (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) - (push-sub-list-binding whole-thing - `(if ,supplied-var ,path ,init-form) - value-var name error-kind error-fun) - (parse-defmacro-lambda-list value-var whole-thing name - error-kind error-fun))) - ((symbolp value-var) - (push-let-binding value-var path nil supplied-var init-form)) - (t - (error "Illegal optional variable name: ~S" value-var)))) - -(defun make-keyword (symbol) - "Takes a non-keyword symbol, symbol, and returns the corresponding keyword." - (intern (symbol-name symbol) *keyword-package*)) - -(defun defmacro-error (problem kind name) - (error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]." - problem kind name)) - - - -;;;; Routines used at runtime by the resultant body. - -;;; VERIFY-KEYWORDS -- internal -;;; -;;; Determine if key-list is a valid list of keyword/value pairs. Do not -;;; signal the error directly, 'cause we don't know how it should be signaled. -;;; -(defun verify-keywords (key-list valid-keys allow-other-keys) - (do ((already-processed nil) - (unknown-keyword nil) - (remaining key-list (cddr remaining))) - ((null remaining) - (if (and unknown-keyword - (not allow-other-keys) - (not (lookup-keyword :allow-other-keys key-list))) - (values :unknown-keyword (list unknown-keyword valid-keys)) - (values nil nil))) - (cond ((not (and (consp remaining) (listp (cdr remaining)))) - (return (values :dotted-list key-list))) - ((null (cdr remaining)) - (return (values :odd-length key-list))) - ((member (car remaining) already-processed) - (return (values :duplicate (car remaining)))) - ((or (eq (car remaining) :allow-other-keys) - (member (car remaining) valid-keys)) - (push (car remaining) already-processed)) - (t - (setf unknown-keyword (car remaining)))))) - -(defun lookup-keyword (keyword key-list) - (do ((remaining key-list (cddr remaining))) - ((endp remaining)) - (when (eq keyword (car remaining)) - (return (cadr remaining))))) - -(defun keyword-supplied-p (keyword key-list) - (do ((remaining key-list (cddr remaining))) - ((endp remaining)) - (when (eq keyword (car remaining)) - (return t)))) - - - -;;;; Conditions signaled at runtime by the resultant body. - -(define-condition defmacro-lambda-list-bind-error (error) (kind name)) - -(defun print-defmacro-ll-bind-error-intro (condition stream) - (if (null (defmacro-lambda-list-bind-error-name condition)) - (format stream - "Error while parsing arguments to ~A in ~S:~%" - (defmacro-lambda-list-bind-error-kind condition) - (defmacro-lambda-list-bind-error-function-name condition)) - (format stream - "Error while parsing arguments to ~A ~S:~%" - (defmacro-lambda-list-bind-error-kind condition) - (defmacro-lambda-list-bind-error-name condition)))) - -(define-condition defmacro-bogus-sublist-error - (defmacro-lambda-list-bind-error) - (object lambda-list) - (:report - (lambda (condition stream) - (print-defmacro-ll-bind-error-intro condition stream) - (format stream - "Bogus sublist:~% ~S~%to satisfy lambda-list:~% ~:S~%" - (defmacro-bogus-sublist-error-object condition) - (defmacro-bogus-sublist-error-lambda-list condition))))) - -(define-condition defmacro-ll-arg-count-error (defmacro-lambda-list-bind-error) - (argument lambda-list minimum maximum) - (:report - (lambda (condition stream) - (print-defmacro-ll-bind-error-intro condition stream) - (format stream - "Invalid number of elements in:~% ~:S~%~ - to satisfy lambda-list:~% ~:S~%" - (defmacro-ll-arg-count-error-argument condition) - (defmacro-ll-arg-count-error-lambda-list condition)) - (cond ((null (defmacro-ll-arg-count-error-maximum condition)) - (format stream "Expected at least ~D" - (defmacro-ll-arg-count-error-minimum condition))) - ((= (defmacro-ll-arg-count-error-minimum condition) - (defmacro-ll-arg-count-error-maximum condition)) - (format stream "Expected exactly ~D" - (defmacro-ll-arg-count-error-minimum condition))) - (t - (format stream "Expected between ~D and ~D" - (defmacro-ll-arg-count-error-minimum condition) - (defmacro-ll-arg-count-error-maximum condition)))) - (format stream ", but got ~D." - (length (defmacro-ll-arg-count-error-argument condition)))))) - - -(define-condition defmacro-ll-broken-key-list-error - (defmacro-lambda-list-bind-error) - (problem info) - (:report (lambda (condition stream) - (print-defmacro-ll-bind-error-intro condition stream) - (format stream - (ecase - (defmacro-ll-broken-key-list-error-problem condition) - (:dotted-list - "Keyword/value list is dotted: ~S") - (:odd-length - "Odd number of elements in keyword/value list: ~S") - (:duplicate - "Duplicate keyword: ~S") - (:unknown-keyword - "~{Unknown keyword: ~S; expected one of ~{~S~^, ~}~}")) - (defmacro-ll-broken-key-list-error-info condition))))) diff --git a/code/dyncount.lisp b/code/dyncount.lisp deleted file mode 100644 index b86430183f26385cb5ca01d0493c6b57af628f97..0000000000000000000000000000000000000000 --- a/code/dyncount.lisp +++ /dev/null @@ -1,674 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/code/dyncount.lisp,v 1.4 1992/12/31 13:36:44 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Runtime support for dynamic VOP statistics collection. -;;; -(in-package "C") - -#| -Put *count-adjustments* back into VOP costs, and verify them. -Make sure multi-cycle instruction costs are plausible. -VOP classification. - Make tables of %cost for benchmark X class. - Could be represented as a sort of bar chart. -|# - -(eval-when (compile) - (when *collect-dynamic-statistics* - (error "Compiling this file with dynamic stat collection turn on would ~ - be a very bad idea."))) - -;;;; Hash utilities: - -(defun make-hash-table-like (table) - "Make a hash-table with the same test as table." - (declare (type hash-table table)) - (make-hash-table :test (lisp::hash-table-kind table))) - -(defun hash-difference (table1 table2) - "Return a hash-table containing only the entries in Table1 whose key is not - also a key in Table2." (declare (type hash-table table1 table2)) - (let ((res (make-hash-table-like table1))) - (do-hash (k v table1) - (unless (nth-value 1 (gethash k table2)) - (setf (gethash k res) v))) - res)) - -(defun hash-list (table) - "Return a list of the values in Table." - (declare (type hash-table table)) - (collect ((res)) - (do-hash (k v table) - (declare (ignore k)) - (res v)) - (res))) - -;;; READ-HASH-TABLE, WRITE-HASH-TABLE -- Public -;;; -;;; Read (or write) a hashtable from (or to) a file. -;;; -(defun read-hash-table (file) - (with-open-file (s file :direction :input) - (dotimes (i 3) - (format t "~%; ~A" (read-line s))) - (let* ((eof '(nil)) - (test (read s)) - (reader (read s)) - (res (make-hash-table :test test))) - (read s); Discard writer... - (loop - (let ((key (read s nil eof))) - (when (eq key eof) (return)) - (setf (gethash key res) - (funcall reader s key)))) - res))) -;;; -(defun write-hash-table (table file &key - (comment (format nil "Contents of ~S" table)) - (reader 'read) (writer 'prin1) (test 'equal)) - (with-open-file (s file :direction :output :if-exists :new-version) - (with-standard-io-syntax - (let ((*print-readably* nil)) - (format s "~A~%Version ~A on ~A~%" - comment (lisp-implementation-version) - (machine-instance)) - (format-universal-time s (get-universal-time)) - (terpri s) - (format s "~S ~S ~S~%" test reader writer) - (do-hash (k v table) - (prin1 k s) - (write-char #\space s) - (funcall writer v s) - (terpri s))))) - table) - - -;;;; Info accumulation: - -;;; Used to accumulate info about the usage of a single VOP. Cost and count -;;; are kept as double-floats, which lets us get more bits and avoid annoying -;;; overflows. -;;; -(deftype count-vector () '(simple-array double-float (2))) -;;; -(defstruct (vop-stats - (:constructor %make-vop-stats (name)) - (:constructor make-vop-stats-key)) - (name (required-argument) :type simple-string) - (data (make-array 2 :element-type 'double-float) :type count-vector)) - -(defmacro vop-stats-count (x) `(aref (vop-stats-data ,x) 0)) -(defmacro vop-stats-cost (x) `(aref (vop-stats-data ,x) 1)) - -(defun make-vop-stats (&key name count cost) - (let ((res (%make-vop-stats name))) - (setf (vop-stats-count res) count) - (setf (vop-stats-cost res) cost) - res)) - -(declaim (freeze-type dyncount-info vop-stats)) - - -;;; NOTE-DYNCOUNT-INFO -- Internal -;;; -;;; Add the Info into the cumulative result on the VOP name plist. We use -;;; plists so that we will touch minimal system code outside of this file -;;; (which may be compiled with profiling on.) -;;; -(defun note-dyncount-info (info) - (declare (type dyncount-info info) (inline get %put) - (optimize (speed 2))) - (let ((counts (dyncount-info-counts info)) - (vops (dyncount-info-vops info))) - (dotimes (index (length counts)) - (declare (type index index)) - (let ((count (coerce (the (unsigned-byte 31) - (aref counts index)) - 'double-float))) - (when (minusp count) - (warn "Oops: overflow.") - (return-from note-dyncount-info nil)) - (unless (zerop count) - (let* ((vop-info (svref vops index)) - (length (length vop-info))) - (declare (simple-vector vop-info)) - (do ((i 0 (+ i 4))) - ((>= i length)) - (declare (type index i)) - (let* ((name (svref vop-info i)) - (entry (or (get name 'vop-stats) - (setf (get name 'vop-stats) - (%make-vop-stats (symbol-name name)))))) - (incf (vop-stats-count entry) - (* (coerce (the index (svref vop-info (1+ i))) - 'double-float) - count)) - (incf (vop-stats-cost entry) - (* (coerce (the index (svref vop-info (+ i 2))) - 'double-float) - count)))))))))) - -(defun clear-dyncount-info (info) - (declare (type dyncount-info info)) - (declare (optimize (speed 3) (safety 0))) - (let ((counts (dyncount-info-counts info))) - (dotimes (i (length counts)) - (setf (aref counts i) 0)))) - - -;;; CLEAR-VOP-COUNTS -- Public -;;; -;;; Clear any VOP-COUNTS properties and the counts vectors for all code -;;; objects. The latter loop must not call any random functions. -;;; -(defun clear-vop-counts (&optional (spaces '(:dynamic))) - "Clear all dynamic VOP counts for code objects in the specified spaces." - (do-hash (k v (backend-template-names *backend*)) - (declare (ignore v)) - (remprop k 'vop-stats)) - - (locally - (declare (optimize (speed 3) (safety 0)) - (inline vm::map-allocated-objects)) - (without-gcing - (dolist (space spaces) - (vm::map-allocated-objects - #'(lambda (object type-code size) - (declare (ignore type-code size)) - (when (dyncount-info-p object) - (clear-dyncount-info object))) - space))))) - - -;;; GET-VOP-COUNTS -- Public -;;; -;;; Call NOTE-DYNCOUNT-INFO on all DYNCOUNT-INFO structure allocated in the -;;; specified spaces. Return a hashtable describing the counts. The initial -;;; loop must avoid calling any functions outside this file to prevent adding -;;; noise to the data, since other files may be compiled with profiling. -;;; -(defun get-vop-counts (&optional (spaces '(:dynamic)) &key (clear nil)) - "Return a hash-table mapping string VOP names to VOP-STATS structures - describing the VOPs executed. If clear is true, then reset all counts to - zero as a side-effect." - (locally - (declare (optimize (speed 3) (safety 0)) - (inline vm::map-allocated-objects)) - (without-gcing - (dolist (space spaces) - (vm::map-allocated-objects - #'(lambda (object type-code size) - (declare (ignore type-code size)) - (when (dyncount-info-p object) - (note-dyncount-info object) - (when clear - (clear-dyncount-info object)))) - space)))) - - (let ((counts (make-hash-table :test #'equal))) - (do-hash (k v (backend-template-names *backend*)) - (declare (ignore v)) - (let ((stats (get k 'vop-stats))) - (when stats - (setf (gethash (symbol-name k) counts) stats) - (when clear - (remprop k 'vop-stats))))) - counts)) - - -;;; FIND-INFO-FOR -- Interface -;;; -;;; Return the DYNCOUNT-INFO for FUNCTION. -;;; -(defun find-info-for (function) - (declare (type function function)) - (let* ((function (%primitive closure-function function)) - (component (di::function-code-header function))) - (do ((end (get-header-data component)) - (i vm:code-constants-offset (1+ i))) - ((= end i)) - (let ((constant (code-header-ref component i))) - (when (dyncount-info-p constant) - (return constant)))))) - - -(defun vop-counts-apply (function args &key (spaces '(:dynamic)) by-space) - "Apply Function to Args, collecting dynamic statistics on the running. - Spaces are the spaces to scan for counts. If By-Space is true, we return a - list of result tables, instead of a single table. In this case, specify - :READ-ONLY first." - (clear-vop-counts spaces) - (apply function args) - (if by-space - (mapcar #'(lambda (space) - (get-vop-counts (list space) :clear t)) - spaces) - (get-vop-counts spaces))) - -;;;; Adjustments: - -#| -(defparameter *count-adjustments* - '((return-multiple 152) - (tail-call-variable 88) - (unwind 92) - (throw 116) - (allocate-vector 72) - (sxhash-simple-string 248) - (sxhash-simple-substring 264) - (copy-to-system-area 1200) - (copy-from-system-area 1200) - (system-area-copy 1204) - (bit-bash-copy 1412) - (vm::generic-+ 72) - (vm::generic-- 72) - (vm::generic-* 184) - (vm::generic-< 68) - (vm::generic-> 68) - (vm::generic-eql 80) - (vm::generic-= 80) - (vm::generic-/= 104) - (%make-weak-pointer 60) - (make-value-cell 56) - (vm::make-funcallable-instance 76) - (make-closure 76) - (make-complex 60) - (make-ratio 60) - (%allocate-bignum 72) - (make-structure 72) - (cons 50))) -|# - -;;; GET-VOP-COSTS -- Public -;;; -(defun get-vop-costs () - "Return a hash-table mapping string VOP names to the cost recorded in the - generator for all VOPs which are also the names of assembly routines." - (let ((res (make-hash-table :test #'equal))) - (do-hash (name v lisp::*assembler-routines*) - (declare (ignore v)) - (let ((vop (gethash name (backend-template-names *backend*)))) - (when vop - (setf (gethash (symbol-name name) res) - (template-cost (template-or-lose name)))))) - res)) - -(defvar *native-costs* (get-vop-costs) - "Costs of assember routines on this machine.") - - -;;;; Classification: - -(defparameter *basic-classes* - '(("Integer multiplication" - "*/FIXNUM" "*/SIGNED" "*/UNSIGNED" "SIGNED-*" "FIXNUM-*" "GENERIC-*") - ("Integer division" "TRUNCATE") - ("Generic arithmetic" "GENERIC" "TWO-ARG") - ("Inline EQL" "EQL") - ("Inline compare less/greater" "</" ">/" "<-C/" ">-C/") - ("Inline arith" "*/" "//" "+/" "-/" "NEGATE" "ABS" "+-C" "--C") - ("Inline logic" "-ASH" "$ASH" "LOG") - ("CAR/CDR" "CAR" "CDR") - ("Array type test" "ARRAYP" "VECTORP" "ARRAY-HEADER-P") - ("Simple type predicate" "STRUCTUREP" "LISTP" "FIXNUMP") - ("Simple type check" "CHECK-LIST" "CHECK-FIXNUM" "CHECK-STRUCTURE") - ("Array bounds check" "CHECK-BOUND") - ("Complex type check" "$CHECK-" "COERCE-TO-FUNCTION") - ("Special read" "SYMBOL-VALUE") - ("Special bind" "BIND$") - ("Tagging" "MOVE-FROM") - ("Untagging" "MOVE-TO" "MAKE-FIXNUM") - ("Move" "MOVE") - ("Non-local exit" "CATCH" "THROW" "DYNAMIC-STATE" "NLX" "UNWIND") - ("Array write" "DATA-VECTOR-SET" "$SET-RAW-BITS$") - ("Array read" "DATA-VECTOR-REF" "$RAW-BITS$" "VECTOR-LENGTH" - "LENGTH/SIMPLE" "ARRAY-HEADER") - ("List/string utility" "LENGTH/LIST" "SXHASH" "BIT-BASH" "$LENGTH$") - ("Alien operations" "SAP" "ALLOC-NUMBER-STACK" "$CALL-OUT$") - ("Function call/return" "CALL" "RETURN" "ALLOCATE-FRAME" - "COPY-MORE-ARG" "LISTIFY-REST-ARG" "VERIFY-ARGUMENT-COUNT") - ("Allocation" "MAKE-" "ALLOC" "$CONS$" "$LIST$" "$LIST*$") - ("Float conversion" "%SINGLE-FLOAT" "%DOUBLE-FLOAT" "-BITS$") - ("Complex type predicate" "P$"))) - - -;;; MATCHES-PATTERN -- Internal -;;; -;;; Return true if Name patches a specified pattern. Pattern is a string -;;; (or symbol) or a list of strings (or symbols). If any specified string -;;; appears as a substring of name, the pattern is matched. #\$'s are wapped -;;; around name, allowing the use of $ to force a match at the beginning or -;;; end. -;;; -(defun matches-pattern (name pattern) - (declare (simple-string name)) - (let ((name (concatenate 'string "$" name "$"))) - (dolist (pat (if (listp pattern) pattern (list pattern)) nil) - (when (search (the simple-string (string pat)) - name :test #'char=) - (return t))))) - - -;;; FIND-MATCHES, WHAT-CLASS -- Interface -;;; -;;; Utilities for debugging classification rules. FIND-MATCHES returns a -;;; list of all the VOP names in Table that match Pattern. WHAT-CLASS returns -;;; the class that NAME would be placed in. -;;; -(defun find-matches (table pattern) - (collect ((res)) - (do-hash (key value table) - (declare (ignore value)) - (when (matches-pattern key pattern) (res key))) - (res))) -;;; -(defun what-class (name classes) - (dolist (class classes nil) - (when (matches-pattern name (rest class)) (return (first class))))) - - -;;; CLASSIFY-COSTS -- Interface -;;; -;;; Given a VOP-STATS hash-table, return a new one with VOPs in the same -;;; class merged into a single entry for that class. The classes are -;;; represented as a list of lists: (class-name pattern*). Each pattern is a -;;; string (or symbol) that can appear as a subsequence of the VOP name. A VOP -;;; is placed in the first class that it matches, or is left alone if it -;;; matches no class. -;;; -(defun classify-costs (table classes) - (let ((res (make-hash-table-like table))) - (do-hash (key value table) - (let ((class (dolist (class classes nil) - (when (matches-pattern key (rest class)) - (return (first class)))))) - (if class - (let ((found (or (gethash class res) - (setf (gethash class res) - (%make-vop-stats class))))) - (incf (vop-stats-count found) (vop-stats-count value)) - (incf (vop-stats-cost found) (vop-stats-cost value))) - (setf (gethash key res) value)))) - res)) - - -;;;; Analysis: - -;;; COST-SUMMARY -- Internal -;;; -;;; Sum the count and costs. -;;; -(defun cost-summary (table) - (let ((total-count 0d0) - (total-cost 0d0)) - (do-hash (k v table) - (declare (ignore k)) - (incf total-count (vop-stats-count v)) - (incf total-cost (vop-stats-cost v))) - (values total-count total-cost))) - - -;;; COMPENSATE-COSTS -- Internal -;;; -;;; Return a hashtable of DYNCOUNT-INFO structures, with cost adjustments -;;; according to the Costs table. Any VOPs in the list IGNORE are ignored. -;;; -(defun compensate-costs (table costs &optional ignore) - (let ((res (make-hash-table-like table))) - (do-hash (key value table) - (unless (or (string= key "COUNT-ME") - (member key ignore :test #'string=)) - (let ((cost (gethash key costs))) - (if cost - (let* ((count (vop-stats-count value)) - (sum (+ (* cost count) - (vop-stats-cost value)))) - (setf (gethash key res) - (make-vop-stats :name key :count count :cost sum))) - (setf (gethash key res) value))))) - res)) - - -;;; COMPARE-STATS -- Internal -;;; -;;; Take two tables of vop-stats and return a table of entries where the -;;; entries have been compared. The counts are normalized to Compared. The -;;; costs are the difference of the costs adjusted by the difference in counts: -;;; the cost for Original is modified to correspond to the count in Compared. -;;; -(defun compare-stats (original compared) - (declare (type hash-table original compared)) - (let ((res (make-hash-table-like original))) - (do-hash (k cv compared) - (let ((ov (gethash k original))) - (when ov - (let ((norm-cnt (/ (vop-stats-count ov) (vop-stats-count cv)))) - (setf (gethash k res) - (make-vop-stats - :name k - :count norm-cnt - :cost (- (/ (vop-stats-cost ov) norm-cnt) - (vop-stats-cost cv)))))))) - res)) - - -;;; COMBINE-STATS -- Public -;;; -(defun combine-stats (&rest tables) - "Sum the VOP stats for the specified tables, returning a new table with the - combined results." - (let ((res (make-hash-table-like (first tables)))) - (dolist (table tables) - (do-hash (k v table) - (let ((found (or (gethash k res) - (setf (gethash k res) (%make-vop-stats k))))) - (incf (vop-stats-count found) (vop-stats-count v)) - (incf (vop-stats-cost found) (vop-stats-cost v))))) - res)) - - -;;;; Report generation: - -;;; SORT-RESULT -- Internal -;;; -(defun sort-result (table by) - (sort (hash-list table) #'> - :key #'(lambda (x) - (abs (ecase by - (:count (vop-stats-count x)) - (:cost (vop-stats-cost x))))))) - - -;;; ENTRY-REPORT -- Internal -;;; -;;; Report about VOPs in the list of stats structures. -;;; -(defun entry-report (entries cut-off compensated compare total-cost) - (let ((counter (if (and cut-off (> (length entries) cut-off)) - cut-off - most-positive-fixnum))) - (dolist (entry entries) - (let* ((cost (vop-stats-cost entry)) - (name (vop-stats-name entry)) - (entry-count (vop-stats-count entry)) - (comp-entry (if compare (gethash name compare) entry)) - (count (vop-stats-count comp-entry))) - (format t "~30<~A~>: ~:[~13:D~;~13,2F~] ~9,2F ~5,2,2F%~%" - (vop-stats-name entry) - compare - (if compare entry-count (round entry-count)) - (/ cost count) - (/ (if compare - (- (vop-stats-cost (gethash name compensated)) - (vop-stats-cost comp-entry)) - cost) - total-cost)) - (when (zerop (decf counter)) - (format t "[End of top ~D]~%" cut-off)))))) - -;;; FIND-CUT-OFF -- Internal -;;; -;;; Divide Sorted into two lists, the first cut-off elements long. Any VOP -;;; names that match one of the report strings are moved into the report list -;;; even if they would otherwise fall below the cut-off. -;;; -(defun find-cut-off (sorted cut-off report) - (if (or (not cut-off) (<= (length sorted) cut-off)) - (values sorted ()) - (let ((not-cut (subseq sorted 0 cut-off))) - (collect ((select) - (reject)) - (dolist (el (nthcdr cut-off sorted)) - (let ((name (vop-stats-name el))) - (if (matches-pattern name report) - (select el) - (reject el)))) - (values (append not-cut (select)) (reject)))))) - - -;;; CUT-OFF-REPORT -- Internal -;;; -;;; Display information about entries that were not displayed due to the -;;; cut-off. Note: if compare, we find the total cost delta and the geometric -;; mean of the normalized counts. -;; -(defun cut-off-report (other compare total-cost) - (let ((rest-cost 0d0) - (rest-count 0d0) - (rest-entry-count (if compare 1d0 0d0))) - (dolist (entry other) - (incf rest-cost (vop-stats-cost entry)) - (incf rest-count - (vop-stats-count - (if compare - (gethash (vop-stats-name entry) compare) - entry))) - (if compare - (setq rest-entry-count - (* rest-entry-count (vop-stats-count entry))) - (incf rest-entry-count (vop-stats-count entry)))) - - (let ((count (if compare - (expt rest-entry-count - (/ (coerce (length other) 'double-float))) - (round rest-entry-count)))) - (format t "~30<Other~>: ~:[~13:D~;~13,2F~] ~9,2F ~@[~5,2,2F%~]~%" - compare count - (/ rest-cost rest-count) - (unless compare - (/ rest-cost total-cost)))))) - - -;;; COMPARE-REPORT -- Internal -;;; -;;; Report summary information about the difference between the comparison -;;; and base data sets. -;;; -(defun compare-report (total-count total-cost compare-total-count - compare-total-cost compensated compare) - (format t "~30<Relative total~>: ~13,2F ~9,2F~%" - (/ total-count compare-total-count) - (/ total-cost compare-total-cost)) - (flet ((frob (a b sign wot) - (multiple-value-bind - (cost count) (cost-summary (hash-difference a b)) - (unless (zerop count) - (format t "~30<~A~>: ~13:D ~9,2F ~5,2,2F%~%" - wot (* sign (round count)) - (* sign (/ cost count)) - (* sign (/ cost compare-total-cost))))))) - (frob compensated compare 1 "Not in comparison") - (frob compare compensated -1 "Only in comparison")) - (format t "~30<Comparison total~>: ~13,2E ~9,2E~%" - compare-total-count compare-total-cost)) - - -;;; The fraction of system time that we guess happened during GC. -;;; -(defparameter *gc-system-fraction* 2/3) - -;;; FIND-CPI -- Interface -;;; -;;; Estimate CPI from CPU time and cycles accounted in profiling -;;; information. -;;; -(defun find-cpi (total-cost user system gc clock) - (let ((adj-time (if (zerop gc) - user - (- user (- gc (* system *gc-system-fraction*)))))) - (/ (* adj-time clock) total-cost))) - - -;;; GENERATE-REPORT -- Public -;;; -;;; Generate a report from the specified table. -;;; -(defun generate-report (table &key (cut-off 15) (sort-by :cost) - (costs *native-costs*) - ((:compare uncomp-compare)) - (compare-costs costs) - ignore report - (classes *basic-classes*) - user (system 0d0) (gc 0d0) - (clock 25d6)) - (let* ((compensated - (classify-costs - (if costs - (compensate-costs table costs ignore) - table) - classes)) - (compare - (when uncomp-compare - (classify-costs - (if compare-costs - (compensate-costs uncomp-compare compare-costs ignore) - uncomp-compare) - classes))) - (compared (if compare - (compare-stats compensated compare) - compensated)) - (*gc-verbose* nil)) - (multiple-value-bind (total-count total-cost) - (cost-summary compensated) - (multiple-value-bind (compare-total-count compare-total-cost) - (when compare (cost-summary compare)) - (format t "~2&~30<Vop~> ~13<Count~> ~9<Cost~> ~6:@<Percent~>~%") - (let ((sorted (sort-result compared sort-by)) - (base-total (if compare compare-total-cost total-cost))) - (multiple-value-bind - (report other) - (find-cut-off sorted cut-off report) - (entry-report report cut-off compensated compare base-total) - (when other - (cut-off-report other compare base-total)))) - - (when compare - (compare-report total-count total-cost compare-total-count - compare-total-cost compensated compare)) - - (format t "~30<Total~>: ~13,2E ~9,2E~%" total-count total-cost) - (when user - (format t "~%Cycles per instruction = ~,2F~%" - (find-cpi total-cost user system gc clock)))))) - (values)) - - -;;; STATS-{READER,WRITER} -- Public -;;; -;;; Read & write VOP stats using hash IO utility. -;;; -(defun stats-reader (stream key) - (make-vop-stats :name key :count (read stream) :cost (read stream))) -;;; -(defun stats-writer (object stream) - (format stream "~S ~S" (vop-stats-count object) (vop-stats-cost object))) diff --git a/code/eval.lisp b/code/eval.lisp deleted file mode 100644 index 18838b1480f0896f40725917b7e3f530a22f63fc..0000000000000000000000000000000000000000 --- a/code/eval.lisp +++ /dev/null @@ -1,450 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/eval.lisp,v 1.21 1992/12/17 09:08:00 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -(in-package "LISP") -(export '(eval constantp quote proclaim - eval-when progn prog1 prog2 let let* - do do* dotimes dolist progv and or cond if the - macro-function special-form-p *macroexpand-hook* - macroexpand-1 macroexpand block return-from - compiler-macroexpand compiler-macroexpand-1 - compiler-macro-function - return function setq psetq apply funcall - compiler-let progv flet labels macrolet - mapcar maplist mapc mapl mapcan mapcon - tagbody prog prog* go - values multiple-values-limit - values-list multiple-value-list multiple-value-call - multiple-value-prog1 multiple-value-bind multiple-value-setq - catch unwind-protect throw defun - lambda-list-keywords call-arguments-limit lambda-parameters-limit - function-lambda-expression - ;; - ;; Declaration symbols referenced in the cold load. - declare special - ;; - ;; Magical markers... - lambda &optional &rest &key &aux &body &whole - &allow-other-keys &environment)) - -#| Not implemented: -*evalhook* *applyhook* evalhook applyhook -|# - -(export '(eval::interpreted-function-p - eval::interpreted-function-lambda-expression) - "EVAL") -(import '(eval::*eval-stack-top*)) - -(in-package "SYSTEM") -(export '(parse-body find-if-in-closure)) - -(in-package "EXTENSIONS") -(export '(*top-level-auto-declare*)) - -(in-package "KERNEL") -(export '(invoke-macroexpand-hook)) - -(in-package "LISP") - - -(defconstant lambda-list-keywords - '(&optional &rest &key &aux &body &whole &allow-other-keys &environment) - "Keywords that you can put in a lambda-list, supposing you should want - to do such a thing.") - -(defconstant call-arguments-limit most-positive-fixnum - "The exclusive upper bound on the number of arguments which may be passed - to a function, including rest args.") - -(defconstant lambda-parameters-limit most-positive-fixnum - "The exclusive upper bound on the number of parameters which may be specifed - in a given lambda list. This is actually the limit on required and optional - parameters. With &key and &aux you can get more.") - -(defconstant multiple-values-limit most-positive-fixnum - "The exclusive upper bound on the number of multiple-values that you can - have.") - - - -;;;; EVAL and friends. - -;;; -;;; This flag is used by EVAL-WHEN to keep track of when code has already been -;;; evaluated so that it can avoid multiple evaluation of nested EVAL-WHEN -;;; (COMPILE)s. -(defvar *already-evaled-this* nil) - -;;; -;;; This needs to be initialized in the cold load, since the top-level catcher -;;; will always restore the initial value. -(defvar *eval-stack-top* 0) - -(declaim (type (member :warn t nil) *top-level-auto-declare*)) - -(defvar *top-level-auto-declare* :warn - "This variable controls whether assignments to unknown variables at top-level - (or in any other call to EVAL of SETQ) will implicitly declare the variable - SPECIAL. These values are meaningful: - :WARN -- Print a warning, but declare the variable special (the default.) - T -- Quietly declare the variable special. - NIL -- Never declare the variable, giving warnings on each use.") - - -;;; EVAL -- Public -;;; -;;; Pick off a few easy cases, and call INTERNAL-EVAL for the rest. If -;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing a call -;;; so that the effect is confined to the lexical scope of the EVAL-WHEN. -;;; -(defun eval (original-exp) - "Evaluates its single arg in a null lexical environment, returns the - result or results." - (declare (optimize (safety 1))) - (let ((exp (macroexpand original-exp))) - (typecase exp - (symbol - (ecase (info variable kind exp) - (:constant - (values (info variable constant-value exp))) - ((:special :global) - (symbol-value exp)) - (:alien - (eval:internal-eval original-exp)))) - (list - (let ((name (first exp)) - (args (1- (length exp)))) - (case name - (function - (unless (= args 1) - (error "Wrong number of args to FUNCTION:~% ~S." exp)) - (let ((name (second exp))) - (if (or (atom name) - (and (consp name) - (eq (car name) 'setf))) - (fdefinition name) - (eval:make-interpreted-function name)))) - (quote - (unless (= args 1) - (error "Wrong number of args to QUOTE:~% ~S." exp)) - (second exp)) - (setq - (unless (evenp args) - (error "Odd number of args to SETQ:~% ~S." exp)) - (unless (zerop args) - (do ((name (cdr exp) (cddr name))) - ((null name) - (do ((args (cdr exp) (cddr args))) - ((null (cddr args)) - ;; We duplicate the call to SET so that the correct - ;; value gets returned. - (set (first args) (eval (second args)))) - (set (first args) (eval (second args))))) - (let ((symbol (first name))) - (case (info variable kind symbol) - (:special) - (:global - (case *top-level-auto-declare* - (:warn - (warn "Declaring ~S special." symbol)) - ((t)) - ((nil) - (return (eval:internal-eval original-exp)))) - (proclaim `(special ,symbol))) - (t - (return (eval:internal-eval original-exp)))))))) - ((progn) - (when (> args 0) - (dolist (x (butlast (rest exp)) (eval (car (last exp)))) - (eval x)))) - ((eval-when) - (if (and (> args 0) (member 'eval (second exp))) - (when (> args 1) - (dolist (x (butlast (cddr exp)) (eval (car (last exp)))) - (eval x))) - (eval:internal-eval original-exp))) - (t - (if (and (symbolp name) - (eq (info function kind name) :function)) - (collect ((args)) - (dolist (arg (rest exp)) - (args (eval arg))) - (if *already-evaled-this* - (let ((*already-evaled-this* nil)) - (apply (symbol-function name) (args))) - (apply (symbol-function name) (args)))) - (eval:internal-eval original-exp)))))) - (t - exp)))) - - -;;; INTERPRETED-FUNCTION-P -- Interface -;;; -;;; This is defined here so that the printer &c can call it before the full -;;; interpreter is loaded. -;;; -(defun eval:interpreted-function-p (x) - (and (functionp x) - (= (get-type x) vm:closure-header-type) - (fboundp 'eval::leaf-value) - (let ((code-component (di::function-code-header (%closure-function x)))) - (or (eq (di::function-code-header #'eval::leaf-value) - code-component) - (eq (di::function-code-header #'eval:make-interpreted-function) - code-component))))) - - -;;; FUNCTION-LAMBDA-EXPRESSION -- Public -;;; -;;; If interpreted, use the interpreter interface. Otherwise, see if it was -;;; compiled with COMPILE. If that fails, check for an inline expansion. -;;; -(defun function-lambda-expression (fun) - "Given a function, return three values: - 1] A lambda expression that could be used to define the function, or NIL if - the definition isn't available. - 2] NIL if the function was definitely defined in a null lexical environment, - and T otherwise. - 3] Some object that \"names\" the function. Although this is allowed to be - any object, CMU CL always returns a valid function name or a string." - (declare (type function fun)) - (if (eval:interpreted-function-p fun) - (eval:interpreted-function-lambda-expression fun) - (let* ((fun (%function-self fun)) - (name (%function-name fun)) - (code (di::function-code-header fun)) - (info (kernel:%code-debug-info code))) - (if info - (let ((source (first (c::compiled-debug-info-source info)))) - (cond ((and (eq (c::debug-source-from source) :lisp) - (eq (c::debug-source-info source) fun)) - (values (second (svref (c::debug-source-name source) 0)) - nil name)) - ((stringp name) - (values nil t name)) - (t - (let ((exp (info function inline-expansion name))) - (if exp - (values exp nil name) - (values nil t name)))))) - (values nil t name))))) - - -;;; FIND-IF-IN-CLOSURE -- Interface -;;; -;;; Like FIND-IF, only we do it on a compiled closure's environment. -;;; -(defun find-if-in-closure (test fun) - (dotimes (index (1- (get-closure-length fun))) - (let ((elt (%closure-index-ref fun index))) - (when (funcall test elt) - (return elt))))) - - -;;;; Syntactic environment access: - -(defun special-form-p (symbol) - "If the symbol globally names a special form, returns the definition in a - mysterious internal format (a FEXPR), else returns NIL." - (declare (symbol symbol)) - (eq (info function kind symbol) :special-form)) - -(defvar *macroexpand-hook* 'funcall - "The value of this variable must be a function that can take three - arguments, a macro expander function, the macro form to be expanded, - and the lexical environment to expand in. The function should - return the expanded form. This function is called by MACROEXPAND-1 - whenever a runtime expansion is needed. Initially this is set to - FUNCALL.") - -;;; INVOKE-MACROEXPAND-HOOK -- public. -;;; -;;; The X3J13 cleanup FUNCTION-TYPE:X3J13-MARCH-88 specifies that: -;;; -;;; "7. Clarify that the value of *MACROEXPAND-HOOK* is first coerced to a -;;; function before being called as the expansion interface hook by -;;; MACROEXPAND-1." -;;; -;;; This is a handy utility function that does just such a coercion. It also -;;; stores the result back in *macroexpand-hook* so we don't have to coerce -;;; it again. -;;; -(defun invoke-macroexpand-hook (fun form env) - "Invoke *MACROEXPAND-HOOK* on FUN, FORM, and ENV after coercing it to - a function." - (unless (functionp *macroexpand-hook*) - (setf *macroexpand-hook* - (coerce *macroexpand-hook* 'function))) - (funcall *macroexpand-hook* fun form env)) - -(defun macro-function (symbol &optional env) - "If SYMBOL names a macro in ENV, returns the expansion function, - else returns NIL. If ENV is unspecified or NIL, use the global - environment only." - (declare (symbol symbol)) - (let* ((fenv (when env (c::lexenv-functions env))) - (local-def (cdr (assoc symbol fenv)))) - (cond (local-def - (if (and (consp local-def) (eq (car local-def) 'MACRO)) - (cdr local-def) - nil)) - ((eq (info function kind symbol) :macro) - (values (info function macro-function symbol))) - (t - nil)))) - -(defun (setf macro-function) (function symbol) - (declare (symbol symbol) (type function function)) - - (when (eq (info function kind symbol) :special-form) - (error "~S names a special form." symbol)) - - (setf (info function kind symbol) :macro) - (setf (info function macro-function symbol) function) - (setf (symbol-function symbol) - #'(lambda (&rest args) (declare (ignore args)) - (error "Cannot funcall macro functions."))) - function) - -;;; Macroexpand-1 -- Public -;;; -;;; The Env is a LEXENV or NIL (the null environment.) -;;; -(defun macroexpand-1 (form &optional env) - "If form is a macro (or symbol macro), expands it once. Returns two values, - the expanded form and a T-or-NIL flag indicating whether the form was, in - fact, a macro. Env is the lexical environment to expand in, which defaults - to the null environment." - (cond ((and (consp form) (symbolp (car form))) - (let ((def (macro-function (car form) env))) - (if def - (values (invoke-macroexpand-hook def form env) t) - (values form nil)))) - ((symbolp form) - (let* ((venv (when env (c::lexenv-variables env))) - (local-def (cdr (assoc form venv)))) - (if (and (consp local-def) - (eq (car local-def) 'macro)) - (values (cdr local-def) t) - (values form nil)))) - (t - (values form nil)))) - -(defun macroexpand (form &optional env) - "Repetitively call MACROEXPAND-1 until the form can no longer be expanded. - Returns the final resultant form, and T if it was expanded. ENV is the - lexical environment to expand in, or NIL (the default) for the null - environment." - (labels ((frob (form expanded) - (multiple-value-bind - (new-form newly-expanded) - (macroexpand-1 form env) - (if newly-expanded - (frob new-form t) - (values new-form expanded))))) - (frob form nil))) - -(defun compiler-macro-function (name &optional env) - "If NAME names a compiler-macro, returns the expansion function, - else returns NIL. Note: if the name is shadowed in ENV by a local - definition, or declared NOTINLINE, NIL is returned. Can be - set with SETF." - (let ((found (and env - (cdr (assoc name (c::lexenv-functions env) - :test #'equal))))) - (unless (eq (cond ((c::defined-function-p found) - (c::defined-function-inlinep found)) - (found :notinline) - (t - (info function inlinep name))) - :notinline) - (values (info function compiler-macro-function name))))) - -(defun (setf compiler-macro-function) (function name) - (declare (type (or symbol list) name) - (type (or function null) function)) - (when (eq (info function kind name) :special-form) - (error "~S names a special form." name)) - (setf (info function compiler-macro-function name) function) - function) - -(defun compiler-macroexpand-1 (form &optional env) - "If FORM is a function call for which a compiler-macro has been defined, - invoke the expander function using *macroexpand-hook* and return the - results and T. Otherwise, return the original form and NIL." - (let ((fun (and (consp form) (compiler-macro-function (car form) env)))) - (if fun - (let ((result (invoke-macroexpand-hook fun form env))) - (values result (not (eq result form)))) - (values form nil)))) - -(defun compiler-macroexpand (form &optional env) - "Repetitively call COMPILER-MACROEXPAND-1 until the form can no longer be - expanded. ENV is the lexical environment to expand in, or NIL (the - default) for the null environment." - (labels ((frob (form expanded) - (multiple-value-bind - (new-form newly-expanded) - (compiler-macroexpand-1 form env) - (if newly-expanded - (frob new-form t) - (values new-form expanded))))) - (frob form env))) - - -(defun constantp (object) - "True of any Lisp object that has a constant value: types that eval to - themselves, keywords, constants, and list whose car is QUOTE." - (typecase object - (number t) - (character t) - (array t) - (symbol - (eq (info variable kind object) :constant)) - (list (eq (car object) 'quote)))) - - -;;; Function invocation: - -(defun apply (function arg &rest args) - "Applies FUNCTION to a list of arguments produced by evaluating ARGS in - the manner of LIST*. That is, a list is made of the values of all but the - last argument, appended to the value of the last argument, which must be a - list." - (cond ((atom args) - (apply function arg)) - ((atom (cdr args)) - (apply function (cons arg (car args)))) - (t (do* ((a1 args a2) - (a2 (cdr args) (cdr a2))) - ((atom (cdr a2)) - (rplacd a1 (car a2)) - (apply function (cons arg args))))))) - - -(defun funcall (function &rest arguments) - "Calls Function with the given Arguments." - (apply function arguments)) - - - -;;; Multiple-Value forms: - -(defun values (&rest values) - "Returns all of its arguments, in order, as values." - (values-list values)) - -(defun values-list (list) - "Returns all of the elements of List, in order, as values." - (values-list list)) diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp deleted file mode 100644 index 2f065e02a59ab7edff8899a878a88b5ade5d3e31..0000000000000000000000000000000000000000 --- a/code/fd-stream.lisp +++ /dev/null @@ -1,1504 +0,0 @@ -;;; -*- Log: code.log; Package: LISP -*- -;;; -;;; ********************************************************************** -;;; 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/code/fd-stream.lisp,v 1.22 1992/12/10 01:09:52 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Streams for UNIX file descriptors. -;;; -;;; Written by William Lott, July 1989 - January 1990. -;;; Some tuning by Rob MacLachlan. -;;; -;;; ********************************************************************** - - -(in-package "SYSTEM") - -(export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream - io-timeout beep *beep-function* output-raw-bytes - *tty* *stdin* *stdout* *stderr*)) - - -(in-package "EXTENSIONS") - -(export '(*backup-extension*)) - - -(in-package "LISP") - -(export '(file-stream)) -(deftype file-stream () 'fd-stream) - - -;;;; Buffer manipulation routines. - -(defvar *available-buffers* () - "List of available buffers. Each buffer is an sap pointing to - bytes-per-buffer of memory.") - -(defconstant bytes-per-buffer (* 4 1024) - "Number of bytes per buffer.") - -;;; NEXT-AVAILABLE-BUFFER -- Internal. -;;; -;;; Returns the next available buffer, creating one if necessary. -;;; -(proclaim '(inline next-available-buffer)) -;;; -(defun next-available-buffer () - (if *available-buffers* - (pop *available-buffers*) - (allocate-system-memory bytes-per-buffer))) - - -;;;; The FD-STREAM structure. - -(defstruct (fd-stream - (:print-function %print-fd-stream) - (:constructor %make-fd-stream) - (:include stream - (misc #'fd-stream-misc-routine))) - - (name nil) ; The name of this stream - (file nil) ; The file this stream is for - (original nil) ; The original file (for :if-exists :rename) - (delete-original nil) ; for :if-exists :rename-and-delete - ;; - ;;; Number of bytes per element. - (element-size 1 :type index) - (element-type 'base-char) ; The type of element being transfered. - (fd -1 :type fixnum) ; The file descriptor - ;; - ;; Controls when the output buffer is flushed. - (buffering :full :type (member :full :line :none)) - ;; - ;; Character position if known. - (char-pos nil :type (or index null)) - ;; - ;; T if input is waiting on FD. :EOF if we hit EOF. - (listen nil :type (member nil t :eof)) - ;; - ;; The input buffer. - (unread nil) - (ibuf-sap nil :type (or system-area-pointer null)) - (ibuf-length nil :type (or index null)) - (ibuf-head 0 :type index) - (ibuf-tail 0 :type index) - - ;; The output buffer. - (obuf-sap nil :type (or system-area-pointer null)) - (obuf-length nil :type (or index null)) - (obuf-tail 0 :type index) - - ;; Output flushed, but not written due to non-blocking io. - (output-later nil) - (handler nil) - ;; - ;; Timeout specified for this stream, or NIL if none. - (timeout nil :type (or index null))) - -(defun %print-fd-stream (fd-stream stream depth) - (declare (ignore depth) (stream stream)) - (format stream "#<Stream for ~A>" - (fd-stream-name fd-stream))) - - -(define-condition io-timeout (stream-error) (direction) - (:report - (lambda (condition stream) - (format stream "Timeout ~(~A~)ing ~S." - (io-timeout-direction condition) - (stream-error-stream condition))))) - - -;;;; Output routines and related noise. - -(defvar *output-routines* () - "List of all available output routines. Each element is a list of the - element-type output, the kind of buffering, the function name, and the number - of bytes per element.") - -;;; DO-OUTPUT-LATER -- internal -;;; -;;; Called by the server when we can write to the given file descriptor. -;;; Attemt to write the data again. If it worked, remove the data from the -;;; output-later list. If it didn't work, something is wrong. -;;; -(defun do-output-later (stream) - (let* ((stuff (pop (fd-stream-output-later stream))) - (base (car stuff)) - (start (cadr stuff)) - (end (caddr stuff)) - (reuse-sap (cadddr stuff)) - (length (- end start))) - (declare (type index start end length)) - (multiple-value-bind - (count errno) - (unix:unix-write (fd-stream-fd stream) - base - start - length) - (cond ((not count) - (if (= errno unix:ewouldblock) - (error "Write would have blocked, but SERVER told us to go.") - (error "While writing ~S: ~A" - stream (unix:get-unix-error-msg errno)))) - ((eql count length) ; Hot damn, it workded. - (when reuse-sap - (push base *available-buffers*))) - ((not (null count)) ; Sorta worked. - (push (list base - (+ start count) - end) - (fd-stream-output-later stream)))))) - (unless (fd-stream-output-later stream) - (system:remove-fd-handler (fd-stream-handler stream)) - (setf (fd-stream-handler stream) nil))) - -;;; OUTPUT-LATER -- internal -;;; -;;; Arange to output the string when we can write on the file descriptor. -;;; -(defun output-later (stream base start end reuse-sap) - (cond ((null (fd-stream-output-later stream)) - (setf (fd-stream-output-later stream) - (list (list base start end reuse-sap))) - (setf (fd-stream-handler stream) - (system:add-fd-handler (fd-stream-fd stream) - :output - #'(lambda (fd) - (declare (ignore fd)) - (do-output-later stream))))) - (t - (nconc (fd-stream-output-later stream) - (list (list base start end reuse-sap))))) - (when reuse-sap - (let ((new-buffer (next-available-buffer))) - (setf (fd-stream-obuf-sap stream) new-buffer) - (setf (fd-stream-obuf-length stream) bytes-per-buffer)))) - -;;; DO-OUTPUT -- internal -;;; -;;; Output the given noise. Check to see if there are any pending writes. If -;;; so, just queue this one. Otherwise, try to write it. If this would block, -;;; queue it. -;;; -(defun do-output (stream base start end reuse-sap) - (declare (type fd-stream stream) - (type (or system-area-pointer (simple-array * (*))) base) - (type index start end)) - (if (not (null (fd-stream-output-later stream))) ; something buffered. - (progn - (output-later stream base start end reuse-sap) - ;; ### check to see if any of this noise can be output - ) - (let ((length (- end start))) - (multiple-value-bind - (count errno) - (unix:unix-write (fd-stream-fd stream) base start length) - (cond ((not count) - (if (= errno unix:ewouldblock) - (output-later stream base start end reuse-sap) - (error "While writing ~S: ~A" - stream (unix:get-unix-error-msg errno)))) - ((not (eql count length)) - (output-later stream base (+ start count) end reuse-sap))))))) - - -;;; FLUSH-OUTPUT-BUFFER -- internal -;;; -;;; Flush any data in the output buffer. -;;; -(defun flush-output-buffer (stream) - (let ((length (fd-stream-obuf-tail stream))) - (unless (= length 0) - (do-output stream (fd-stream-obuf-sap stream) 0 length t) - (setf (fd-stream-obuf-tail stream) 0)))) - -;;; DEF-OUTPUT-ROUTINES -- internal -;;; -;;; Define output routines that output numbers size bytes long for the -;;; given bufferings. Use body to do the actual output. -;;; -(defmacro def-output-routines ((name size &rest bufferings) &body body) - (cons 'progn - (mapcar - #'(lambda (buffering) - (let ((function - (intern (let ((*print-case* :upcase)) - (format nil name (car buffering)))))) - `(progn - (defun ,function (stream byte) - ,(unless (eq (car buffering) :none) - `(when (< (fd-stream-obuf-length stream) - (+ (fd-stream-obuf-tail stream) - ,size)) - (flush-output-buffer stream))) - ,@body - (incf (fd-stream-obuf-tail stream) ,size) - ,(ecase (car buffering) - (:none - `(flush-output-buffer stream)) - (:line - `(when (eq (char-code byte) (char-code #\Newline)) - (flush-output-buffer stream))) - (:full - )) - (values)) - (setf *output-routines* - (nconc *output-routines* - ',(mapcar - #'(lambda (type) - (list type - (car buffering) - function - size)) - (cdr buffering))))))) - bufferings))) - -(def-output-routines ("OUTPUT-CHAR-~A-BUFFERED" - 1 - (:none character) - (:line character) - (:full character)) - (if (eq (char-code byte) - (char-code #\Newline)) - (setf (fd-stream-char-pos stream) 0) - (incf (fd-stream-char-pos stream))) - (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) - (char-code byte))) - -(def-output-routines ("OUTPUT-BYTE-~A-BUFFERED" - 1 - (:none (signed-byte 8) (unsigned-byte 8)) - (:full (signed-byte 8) (unsigned-byte 8))) - (when (characterp byte) - (if (eq (char-code byte) - (char-code #\Newline)) - (setf (fd-stream-char-pos stream) 0) - (incf (fd-stream-char-pos stream)))) - (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) - byte)) - -(def-output-routines ("OUTPUT-SHORT-~A-BUFFERED" - 2 - (:none (signed-byte 16) (unsigned-byte 16)) - (:full (signed-byte 16) (unsigned-byte 16))) - (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) - byte)) - -(def-output-routines ("OUTPUT-LONG-~A-BUFFERED" - 4 - (:none (signed-byte 32) (unsigned-byte 32)) - (:full (signed-byte 32) (unsigned-byte 32))) - (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) - byte)) - -;;; OUTPUT-RAW-BYTES -- public -;;; -;;; Does the actual output. If there is space to buffer the string, buffer -;;; it. If the string would normally fit in the buffer, but doesn't because -;;; of other stuff in the buffer, flush the old noise out of the buffer and -;;; put the string in it. Otherwise we have a very long string, so just -;;; send it directly (after flushing the buffer, of course). -;;; -(defun output-raw-bytes (stream thing &optional start end) - "Output THING to stream. THING can be any kind of vector or a sap. If THING - is a SAP, END must be supplied (as length won't work)." - (let ((start (or start 0)) - (end (or end (length (the (simple-array * (*)) thing))))) - (declare (type index start end)) - (let* ((len (fd-stream-obuf-length stream)) - (tail (fd-stream-obuf-tail stream)) - (space (- len tail)) - (bytes (- end start)) - (newtail (+ tail bytes))) - (cond ((minusp bytes) ; Error case - (cerror "Just go on as if nothing happened..." - "~S called with :END before :START!" - 'output-raw-bytes)) - ((zerop bytes)) ; Easy case - ((<= bytes space) - (if (system-area-pointer-p thing) - (system-area-copy thing - (* start vm:byte-bits) - (fd-stream-obuf-sap stream) - (* tail vm:byte-bits) - (* bytes vm:byte-bits)) - (copy-to-system-area thing - (+ (* start vm:byte-bits) - (* vm:vector-data-offset vm:word-bits)) - (fd-stream-obuf-sap stream) - (* tail vm:byte-bits) - (* bytes vm:byte-bits))) - (setf (fd-stream-obuf-tail stream) newtail)) - ((<= bytes len) - (flush-output-buffer stream) - (if (system-area-pointer-p thing) - (system-area-copy thing - (* start vm:byte-bits) - (fd-stream-obuf-sap stream) - 0 - (* bytes vm:byte-bits)) - (copy-to-system-area thing - (+ (* start vm:byte-bits) - (* vm:vector-data-offset vm:word-bits)) - (fd-stream-obuf-sap stream) - 0 - (* bytes vm:byte-bits))) - (setf (fd-stream-obuf-tail stream) bytes)) - (t - (flush-output-buffer stream) - (do-output stream thing start end nil)))))) - -;;; FD-SOUT -- internal -;;; -;;; Routine to use to output a string. If the stream is unbuffered, slam -;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to -;;; buffer the string. Update charpos by checking to see where the last newline -;;; was. -;;; -;;; Note: some bozos (the FASL dumper) call write-string with things other -;;; than strings. Therefore, we must make sure we have a string before calling -;;; position on it. -;;; -(defun fd-sout (stream thing start end) - (let ((start (or start 0)) - (end (or end (length (the vector thing))))) - (declare (fixnum start end)) - (if (stringp thing) - (let ((last-newline (and (find #\newline (the simple-string thing) - :start start :end end) - (position #\newline (the simple-string thing) - :from-end t - :start start - :end end)))) - (ecase (fd-stream-buffering stream) - (:full - (output-raw-bytes stream thing start end)) - (:line - (output-raw-bytes stream thing start end) - (when last-newline - (flush-output-buffer stream))) - (:none - (do-output stream thing start end nil))) - (if last-newline - (setf (fd-stream-char-pos stream) - (- end last-newline 1)) - (incf (fd-stream-char-pos stream) - (- end start)))) - (ecase (fd-stream-buffering stream) - ((:line :full) - (output-raw-bytes stream thing start end)) - (:none - (do-output stream thing start end nil)))))) - -;;; PICK-OUTPUT-ROUTINE -- internal -;;; -;;; Find an output routine to use given the type and buffering. Return as -;;; multiple values the routine, the real type transfered, and the number of -;;; bytes per element. -;;; -(defun pick-output-routine (type buffering) - (dolist (entry *output-routines*) - (when (and (subtypep type (car entry)) - (eq buffering (cadr entry))) - (return (values (symbol-function (caddr entry)) - (car entry) - (cadddr entry)))))) - - -;;;; Input routines and related noise. - -(defvar *input-routines* () - "List of all available input routines. Each element is a list of the - element-type input, the function name, and the number of bytes per element.") - -;;; DO-INPUT -- internal -;;; -;;; Fills the input buffer, and returns the first character. Throws to -;;; eof-input-catcher if the eof was reached. Drops into system:server if -;;; necessary. -;;; -(defun do-input (stream) - (let ((fd (fd-stream-fd stream)) - (ibuf-sap (fd-stream-ibuf-sap stream)) - (buflen (fd-stream-ibuf-length stream)) - (head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream))) - (declare (type index head tail)) - (unless (zerop head) - (cond ((eql head tail) - (setf head 0) - (setf tail 0) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0)) - (t - (decf tail head) - (system-area-copy ibuf-sap (* head vm:byte-bits) - ibuf-sap 0 (* tail vm:byte-bits)) - (setf head 0) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) tail)))) - (setf (fd-stream-listen stream) nil) - (multiple-value-bind - (count errno) - (unix:unix-select (1+ fd) (ash 1 fd) 0 0 0) - (case count - (1) - (0 - (unless (system:wait-until-fd-usable - fd :input (fd-stream-timeout stream)) - (error 'io-timeout :stream stream :direction :read))) - (t - (error "Problem checking to see if ~S is readable: ~A" - stream - (unix:get-unix-error-msg errno))))) - (multiple-value-bind - (count errno) - (unix:unix-read fd - (system:int-sap (+ (system:sap-int ibuf-sap) tail)) - (- buflen tail)) - (cond ((null count) - (if (eql errno unix:ewouldblock) - (progn - (unless (system:wait-until-fd-usable - fd :input (fd-stream-timeout stream)) - (error 'io-timeout :stream stream :direction :read)) - (do-input stream)) - (error "Error reading ~S: ~A" - stream - (unix:get-unix-error-msg errno)))) - ((zerop count) - (setf (fd-stream-listen stream) :eof) - (throw 'eof-input-catcher nil)) - (t - (incf (fd-stream-ibuf-tail stream) count)))))) - -;;; INPUT-AT-LEAST -- internal -;;; -;;; Makes sure there are at least ``bytes'' number of bytes in the input -;;; buffer. Keeps calling do-input until that condition is met. -;;; -(defmacro input-at-least (stream bytes) - (let ((stream-var (gensym)) - (bytes-var (gensym))) - `(let ((,stream-var ,stream) - (,bytes-var ,bytes)) - (loop - (when (>= (- (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var)) - ,bytes-var) - (return)) - (do-input ,stream-var))))) - -;;; INPUT-WRAPPER -- intenal -;;; -;;; Macro to wrap around all input routines to handle eof-error noise. This -;;; should make provisions for filling stream-in-buffer. -;;; -(defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms) - (let ((stream-var (gensym)) - (element-var (gensym))) - `(let ((,stream-var ,stream)) - (if (fd-stream-unread ,stream) - (prog1 - (fd-stream-unread ,stream) - (setf (fd-stream-unread ,stream) nil) - (setf (fd-stream-listen ,stream) nil)) - (let ((,element-var - (catch 'eof-input-catcher - (input-at-least ,stream-var ,bytes) - ,@read-forms))) - (cond (,element-var - (incf (fd-stream-ibuf-head ,stream-var) ,bytes) - ,element-var) - (,eof-error - (error "EOF while reading ~S" stream)) - (t - ,eof-value))))))) - -;;; DEF-INPUT-ROUTINE -- internal -;;; -;;; Defines an input routine. -;;; -(defmacro def-input-routine (name - (type size sap head) - &rest body) - `(progn - (defun ,name (stream eof-error eof-value) - (input-wrapper (stream ,size eof-error eof-value) - (let ((,sap (fd-stream-ibuf-sap stream)) - (,head (fd-stream-ibuf-head stream))) - ,@body))) - (setf *input-routines* - (nconc *input-routines* - (list (list ',type ',name ',size)))))) - -;;; INPUT-CHARACTER -- internal -;;; -;;; Routine to use in stream-in slot for reading string chars. -;;; -(def-input-routine input-character - (character 1 sap head) - (code-char (sap-ref-8 sap head))) - -;;; INPUT-UNSIGNED-8BIT-BYTE -- internal -;;; -;;; Routine to read in an unsigned 8 bit number. -;;; -(def-input-routine input-unsigned-8bit-byte - ((unsigned-byte 8) 1 sap head) - (sap-ref-8 sap head)) - -;;; INPUT-SIGNED-8BIT-BYTE -- internal -;;; -;;; Routine to read in a signed 8 bit number. -;;; -(def-input-routine input-signed-8bit-number - ((signed-byte 8) 1 sap head) - (signed-sap-ref-8 sap head)) - -;;; INPUT-UNSIGNED-16BIT-BYTE -- internal -;;; -;;; Routine to read in an unsigned 16 bit number. -;;; -(def-input-routine input-unsigned-16bit-byte - ((unsigned-byte 16) 2 sap head) - (sap-ref-16 sap head)) - -;;; INPUT-SIGNED-16BIT-BYTE -- internal -;;; -;;; Routine to read in a signed 16 bit number. -;;; -(def-input-routine input-signed-16bit-byte - ((signed-byte 16) 2 sap head) - (signed-sap-ref-16 sap head)) - -;;; INPUT-UNSIGNED-32BIT-BYTE -- internal -;;; -;;; Routine to read in a unsigned 32 bit number. -;;; -(def-input-routine input-unsigned-32bit-byte - ((unsigned-byte 32) 4 sap head) - (sap-ref-32 sap head)) - -;;; INPUT-SIGNED-32BIT-BYTE -- internal -;;; -;;; Routine to read in a signed 32 bit number. -;;; -(def-input-routine input-signed-32bit-byte - ((signed-byte 32) 4 sap head) - (signed-sap-ref-32 sap head)) - -;;; PICK-INPUT-ROUTINE -- internal -;;; -;;; Find an input routine to use given the type. Return as multiple values -;;; the routine, the real type transfered, and the number of bytes per element. -;;; -(defun pick-input-routine (type) - (dolist (entry *input-routines*) - (when (subtypep type (car entry)) - (return (values (symbol-function (cadr entry)) - (car entry) - (caddr entry)))))) - -;;; STRING-FROM-SAP -- internal -;;; -;;; Returns a string constructed from the sap, start, and end. -;;; -(defun string-from-sap (sap start end) - (declare (type index start end)) - (let* ((length (- end start)) - (string (make-string length))) - (copy-from-system-area sap (* start vm:byte-bits) - string (* vm:vector-data-offset vm:word-bits) - (* length vm:byte-bits)) - string)) - -;;; FD-STREAM-READ-LINE -- internal -;;; -;;; Reads a line, returning a simple string. Note: this relies on the fact -;;; that the input buffer does not change during do-input. -;;; -(defun fd-stream-read-line (stream eof-error-p eof-value) - (let ((eof t)) - (values - (or (let ((sap (fd-stream-ibuf-sap stream)) - (results (when (fd-stream-unread stream) - (prog1 - (list (string (fd-stream-unread stream))) - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-listen stream) nil))))) - (catch 'eof-input-catcher - (loop - (input-at-least stream 1) - (let* ((head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (newline (do ((index head (1+ index))) - ((= index tail) nil) - (when (= (sap-ref-8 sap index) - (char-code #\newline)) - (return index)))) - (end (or newline tail))) - (push (string-from-sap sap head end) - results) - - (when newline - (setf eof nil) - (setf (fd-stream-ibuf-head stream) - (1+ newline)) - (return)) - (setf (fd-stream-ibuf-head stream) end)))) - (cond ((null results) - nil) - ((null (cdr results)) - (car results)) - (t - (apply #'concatenate 'simple-string (nreverse results))))) - (if eof-error-p - (error "EOF while reading ~S" stream) - eof-value)) - eof))) - -#| -This version waits using server. I changed to the non-server version because -it allows this method to be used by CLX w/o confusing serve-event. The -non-server method is also significantly more efficient for large reads. - -- Ram - -;;; FD-STREAM-READ-N-BYTES -- internal -;;; -;;; The n-bin routine. -;;; -(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p) - (let* ((sap (fd-stream-ibuf-sap stream)) - (elsize (fd-stream-element-size stream)) - (offset (* elsize start)) - (bytes (* elsize requested)) - (result - (catch 'eof-input-catcher - (loop - (input-at-least stream 1) - (let* ((head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (available (- tail head)) - (copy (min available bytes))) - (if (typep buffer 'system-area-pointer) - (system-area-copy sap (* head vm:byte-bits) - buffer (* offset vm:byte-bits) - (* copy vm:byte-bits)) - (copy-from-system-area sap (* head vm:byte-bits) - buffer (+ (* offset vm:byte-bits) - (* vm:vector-data-offset - vm:word-bits)) - (* copy vm:byte-bits))) - (incf (fd-stream-ibuf-head stream) copy) - (incf offset copy) - (decf bytes copy)) - (when (zerop bytes) - (return requested)))))) - (cond (result) - ((not eof-error-p) - (- requested (/ bytes elsize))) - (t - (error "Hit eof on ~S after reading ~D ~D~2:*-bit byte~P~*, ~ - but ~D~2:* ~D-bit byte~P~:* ~[were~;was~:;were~] requested." - stream - (- requested (/ bytes elsize)) - (* elsize 8) - requested))))) -|# - - -;;; FD-STREAM-READ-N-BYTES -- internal -;;; -;;; The N-Bin method for FD-STREAMs. This doesn't using SERVER; it blocks -;;; in UNIX-READ. This allows the method to be used to implementing reading -;;; for CLX. It is generally used where there is a definite amount of reading -;;; to be done, so blocking isn't too problematical. -;;; -;;; We copy buffered data into the buffer. If there is enough, just return. -;;; Otherwise, we see if the amount of additional data needed will fit in the -;;; stream buffer. If not, inhibit GCing (so we can have a SAP into the Buffer -;;; argument), and read directly into the user supplied buffer. Otherwise, -;;; read a buffer-full into the stream buffer and then copy the amount we need -;;; out. -;;; -;;; We loop doing the reads until we either get enough bytes or hit EOF. We -;;; must loop because some streams (like pipes) may return a partial amount -;;; without hitting EOF. -;;; -(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p) - (declare (type stream stream) (type index start requested)) - (let* ((sap (fd-stream-ibuf-sap stream)) - (elsize (fd-stream-element-size stream)) - (offset (* elsize start)) - (requested-bytes (* elsize requested)) - (head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (available (- tail head)) - (copy (min requested-bytes available))) - (declare (type index elsize offset requested-bytes head tail available - copy)) - (unless (zerop copy) - (if (typep buffer 'system-area-pointer) - (system-area-copy sap (* head vm:byte-bits) - buffer (* offset vm:byte-bits) - (* copy vm:byte-bits)) - (copy-from-system-area sap (* head vm:byte-bits) - buffer (+ (* offset vm:byte-bits) - (* vm:vector-data-offset - vm:word-bits)) - (* copy vm:byte-bits))) - (incf (fd-stream-ibuf-head stream) copy)) - (cond - ((> requested-bytes available) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0) - (setf (fd-stream-listen stream) nil) - (let ((now-needed (- requested-bytes copy)) - (len (fd-stream-ibuf-length stream))) - (declare (type index now-needed len)) - (cond - ((> now-needed len) - (system:without-gcing - (loop - (multiple-value-bind - (count err) - (unix:unix-read (fd-stream-fd stream) - (sap+ (if (typep buffer 'system-area-pointer) - buffer - (vector-sap buffer)) - (+ offset copy)) - now-needed) - (declare (type (or index null) count)) - (unless count - (error "Error reading ~S: ~A" stream - (unix:get-unix-error-msg err))) - (when (zerop count) - (if eof-error-p - (error "Unexpected eof on ~S." stream) - (return (- requested (truncate now-needed elsize))))) - (decf now-needed count) - (when (zerop now-needed) (return requested)) - (incf offset count))))) - (t - (loop - (multiple-value-bind - (count err) - (unix:unix-read (fd-stream-fd stream) sap len) - (declare (type (or index null) count)) - (unless count - (error "Error reading ~S: ~A" stream - (unix:get-unix-error-msg err))) - (incf (fd-stream-ibuf-tail stream) count) - (when (zerop count) - (if eof-error-p - (error "Unexpected eof on ~S." stream) - (return (- requested (truncate now-needed elsize))))) - (let* ((copy (min now-needed count)) - (copy-bits (* copy vm:byte-bits)) - (buffer-start-bits - (* (+ offset available) vm:byte-bits))) - (declare (type index copy copy-bits buffer-start-bits)) - (if (typep buffer 'system-area-pointer) - (system-area-copy sap 0 - buffer buffer-start-bits - copy-bits) - (copy-from-system-area sap 0 - buffer (+ buffer-start-bits - (* vm:vector-data-offset - vm:word-bits)) - copy-bits)) - (incf (fd-stream-ibuf-head stream) copy) - (decf now-needed copy) - (when (zerop now-needed) (return requested)) - (incf offset copy)))))))) - (t - requested)))) - - -;;;; Utility functions (misc routines, etc) - -;;; SET-ROUTINES -- internal -;;; -;;; Fill in the various routine slots for the given type. Input-p and output-p -;;; indicate what slots to fill. The buffering slot must be set prior to -;;; calling this routine. -;;; -(defun set-routines (stream type input-p output-p) - (let ((target-type (case type - ((:default unsigned-byte) - '(unsigned-byte 8)) - (signed-byte - '(signed-byte 8)) - (t - type))) - (input-type nil) - (output-type nil) - (input-size nil) - (output-size nil)) - - (when (fd-stream-obuf-sap stream) - (push (fd-stream-obuf-sap stream) *available-buffers*) - (setf (fd-stream-obuf-sap stream) nil)) - (when (fd-stream-ibuf-sap stream) - (push (fd-stream-ibuf-sap stream) *available-buffers*) - (setf (fd-stream-ibuf-sap stream) nil)) - - (when input-p - (multiple-value-bind - (routine type size) - (pick-input-routine target-type) - (unless routine - (error "Could not find any input routine for ~S" target-type)) - (setf (fd-stream-ibuf-sap stream) (next-available-buffer)) - (setf (fd-stream-ibuf-length stream) bytes-per-buffer) - (setf (fd-stream-ibuf-tail stream) 0) - (if (subtypep type 'character) - (setf (fd-stream-in stream) routine - (fd-stream-bin stream) #'ill-bin - (fd-stream-n-bin stream) #'ill-bin) - (setf (fd-stream-in stream) #'ill-in - (fd-stream-bin stream) routine - (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)) - (setf input-size size) - (setf input-type type))) - - (when output-p - (multiple-value-bind - (routine type size) - (pick-output-routine target-type (fd-stream-buffering stream)) - (unless routine - (error "Could not find any output routine for ~S buffered ~S." - (fd-stream-buffering stream) - target-type)) - (setf (fd-stream-obuf-sap stream) (next-available-buffer)) - (setf (fd-stream-obuf-length stream) bytes-per-buffer) - (setf (fd-stream-obuf-tail stream) 0) - (if (subtypep type 'character) - (setf (fd-stream-out stream) routine - (fd-stream-bout stream) #'ill-bout) - (setf (fd-stream-out stream) - (or (if (eql size 1) - (pick-output-routine 'base-char - (fd-stream-buffering stream))) - #'ill-out) - (fd-stream-bout stream) routine)) - (setf (fd-stream-sout stream) - (if (eql size 1) #'fd-sout #'ill-out)) - (setf (fd-stream-char-pos stream) 0) - (setf output-size size) - (setf output-type type))) - - (when (and input-size output-size - (not (eq input-size output-size))) - (error "Element sizes for input (~S:~S) and output (~S:~S) differ?" - input-type input-size - output-type output-size)) - (setf (fd-stream-element-size stream) - (or input-size output-size)) - - (setf (fd-stream-element-type stream) - (cond ((equal input-type output-type) - input-type) - ((or (null output-type) (subtypep input-type output-type)) - input-type) - ((subtypep output-type input-type) - output-type) - (t - (error "Input type (~S) and output type (~S) are unrelated?" - input-type - output-type)))))) - -;;; FD-STREAM-MISC-ROUTINE -- input -;;; -;;; Handle the various misc operations on fd-stream. -;;; -(defun fd-stream-misc-routine (stream operation &optional arg1 arg2) - (case operation - (:read-line - (fd-stream-read-line stream arg1 arg2)) - (:listen - (or (not (eql (fd-stream-ibuf-head stream) - (fd-stream-ibuf-tail stream))) - (fd-stream-listen stream) - (setf (fd-stream-listen stream) - (eql (unix:unix-select (1+ (fd-stream-fd stream)) - (ash 1 (fd-stream-fd stream)) - 0 - 0 - 0) - 1)))) - (:unread - (setf (fd-stream-unread stream) arg1) - (setf (fd-stream-listen stream) t)) - (:close - (cond (arg1 - ;; We got us an abort on our hands. - (when (and (fd-stream-file stream) - (fd-stream-obuf-sap stream)) - ;; Can't do anything unless we know what file were dealing with, - ;; and we don't want to do anything strange unless we were - ;; writing to the file. - (if (fd-stream-original stream) - ;; Have an handle on the original, just revert. - (multiple-value-bind - (okay err) - (unix:unix-rename (fd-stream-original stream) - (fd-stream-file stream)) - (unless okay - (cerror "Go on as if nothing bad happened." - "Could not restore ~S to it's original contents: ~A" - (fd-stream-file stream) - (unix:get-unix-error-msg err)))) - ;; Can't restore the orignal, so nuke that puppy. - (multiple-value-bind - (okay err) - (unix:unix-unlink (fd-stream-file stream)) - (unless okay - (cerror "Go on as if nothing bad happened." - "Could not remove ~S: ~A" - (fd-stream-file stream) - (unix:get-unix-error-msg err))))))) - (t - (fd-stream-misc-routine stream :finish-output) - (when (and (fd-stream-original stream) - (fd-stream-delete-original stream)) - (multiple-value-bind - (okay err) - (unix:unix-unlink (fd-stream-original stream)) - (unless okay - (cerror "Go on as if nothing bad happened." - "Could not delete ~S during close of ~S: ~A" - (fd-stream-original stream) - stream - (unix:get-unix-error-msg err))))))) - (when (fboundp 'cancel-finalization) - (cancel-finalization stream)) - (unix:unix-close (fd-stream-fd stream)) - (when (fd-stream-obuf-sap stream) - (push (fd-stream-obuf-sap stream) *available-buffers*) - (setf (fd-stream-obuf-sap stream) nil)) - (when (fd-stream-ibuf-sap stream) - (push (fd-stream-ibuf-sap stream) *available-buffers*) - (setf (fd-stream-ibuf-sap stream) nil)) - (lisp::set-closed-flame stream)) - (:clear-input - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0) - (loop - (let ((count (unix:unix-select (1+ (fd-stream-fd stream)) - (ash 1 (fd-stream-fd stream)) - 0 0 0))) - (cond ((eql count 1) - (do-input stream) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0)) - (t - (return)))))) - (:force-output - (flush-output-buffer stream)) - (:finish-output - (flush-output-buffer stream) - (do () - ((null (fd-stream-output-later stream))) - (system:serve-all-events))) - (:element-type - (fd-stream-element-type stream)) - (:interactive-p - (unix:unix-isatty (fd-stream-fd stream))) - (:line-length - 80) - (:charpos - (fd-stream-char-pos stream)) - (:file-length - (multiple-value-bind - (okay dev ino mode nlink uid gid rdev size - atime mtime ctime blksize blocks) - (unix:unix-fstat (fd-stream-fd stream)) - (declare (ignore ino nlink uid gid rdev - atime mtime ctime blksize blocks)) - (unless okay - (error "Error fstating ~S: ~A" - stream - (unix:get-unix-error-msg dev))) - (if (zerop mode) - nil - (truncate size (fd-stream-element-size stream))))) - (:file-position - (fd-stream-file-position stream arg1)) - (:file-name - (fd-stream-file stream)))) - -;;; FD-STREAM-FILE-POSITION -- internal. -;;; -(defun fd-stream-file-position (stream &optional newpos) - (declare (type fd-stream stream) - (type (or index (member nil :start :end)) newpos)) - (if (null newpos) - (system:without-interrupts - ;; First, find the position of the UNIX file descriptor in the - ;; file. - (multiple-value-bind - (posn errno) - (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr) - (declare (type (or index null) posn)) - (cond ((fixnump posn) - ;; Adjust for buffered output: - ;; If there is any output buffered, the *real* file position - ;; will be larger than reported by lseek because lseek - ;; obviously cannot take into account output we have not - ;; sent yet. - (dolist (later (fd-stream-output-later stream)) - (incf posn (- (the index (caddr later)) - (the index (cadr later))))) - (incf posn (fd-stream-obuf-tail stream)) - ;; Adjust for unread input: - ;; If there is any input read from UNIX but not supplied to - ;; the user of the stream, the *real* file position will - ;; smaller than reported, because we want to look like the - ;; unread stuff is still available. - (decf posn (- (fd-stream-ibuf-tail stream) - (fd-stream-ibuf-head stream))) - (when (fd-stream-unread stream) - (decf posn)) - ;; Divide bytes by element size. - (truncate posn (fd-stream-element-size stream))) - ((eq errno unix:espipe) - nil) - (t - (system:with-interrupts - (error "Error lseek'ing ~S: ~A" - stream - (unix:get-unix-error-msg errno))))))) - (let (offset origin) - ;; Make sure we don't have any output pending, because if we move the - ;; file pointer before writing this stuff, it will be written in the - ;; wrong location. - (flush-output-buffer stream) - (do () - ((null (fd-stream-output-later stream))) - (system:serve-all-events)) - ;; Clear out any pending input to force the next read to go to the - ;; disk. - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0) - ;; Trash cashed value for listen, so that we check next time. - (setf (fd-stream-listen stream) nil) - ;; Now move it. - (cond ((eq newpos :start) - (setf offset 0 origin unix:l_set)) - ((eq newpos :end) - (setf offset 0 origin unix:l_xtnd)) - ((typep newpos 'index) - (setf offset (* newpos (fd-stream-element-size stream)) - origin unix:l_set)) - (t - (error "Invalid position given to file-position: ~S" newpos))) - (multiple-value-bind - (posn errno) - (unix:unix-lseek (fd-stream-fd stream) offset origin) - (cond ((typep posn 'fixnum) - t) - ((eq errno unix:espipe) - nil) - (t - (error "Error lseek'ing ~S: ~A" - stream - (unix:get-unix-error-msg errno)))))))) - - - -;;;; Creation routines (MAKE-FD-STREAM and OPEN) - -;;; MAKE-FD-STREAM -- Public. -;;; -;;; Returns a FD-STREAM on the given file. -;;; -(defun make-fd-stream (fd - &key - (input nil input-p) - (output nil output-p) - (element-type 'base-char) - (buffering :full) - timeout - file - original - delete-original - (name (if file - (format nil "file ~S" file) - (format nil "descriptor ~D" fd))) - auto-close) - (declare (type index fd) (type (or index null) timeout) - (type (member :none :line :full) buffering)) - "Create a stream for the given unix file descriptor. - If input is non-nil, allow input operations. - If output is non-nil, allow output operations. - If neither input nor output are specified, default to allowing input. - Element-type indicates the element type to use (as for open). - Buffering indicates the kind of buffering to use. - Timeout (if true) is the number of seconds to wait for input. If NIL (the - default), then wait forever. When we time out, we signal IO-TIMEOUT. - File is the name of the file (will be returned by PATHNAME). - Name is used to identify the stream when printed." - (cond ((not (or input-p output-p)) - (setf input t)) - ((not (or input output)) - (error "File descriptor must be opened either for input or output."))) - (let ((stream (%make-fd-stream :fd fd - :name name - :file file - :original original - :delete-original delete-original - :buffering buffering - :timeout timeout))) - (set-routines stream element-type input output) - (when (and auto-close (fboundp 'finalize)) - (finalize stream - #'(lambda () - (unix:unix-close fd) - (format *terminal-io* "** Closed file descriptor ~D~%" - fd)))) - stream)) - -;;; PICK-PACKUP-NAME -- internal -;;; -;;; Pick a name to use for the backup file. -;;; -(defvar *backup-extension* ".BAK" - "This is a string that OPEN tacks on the end of a file namestring to produce - a name for the :if-exists :rename-and-delete and :rename options. Also, - this can be a function that takes a namestring and returns a complete - namestring.") -;;; -(defun pick-backup-name (name) - (declare (type simple-string name)) - (let ((ext *backup-extension*)) - (etypecase ext - (simple-string (concatenate 'simple-string name ext)) - (function (funcall ext name))))) - -;;; ASSURE-ONE-OF -- internal -;;; -;;; Assure that the given arg is one of the given list of valid things. -;;; Allow the user to fix any problems. -;;; -(defun assure-one-of (item list what) - (unless (member item list) - (loop - (cerror "Enter new value for ~*~S" - "~S is invalid for ~S. Must be one of~{ ~S~}" - item - what - list) - (format (the stream *query-io*) "Enter new value for ~S: " what) - (force-output *query-io*) - (setf item (read *query-io*)) - (when (member item list) - (return)))) - item) - -;;; DO-OLD-RENAME -- Internal -;;; -;;; Rename Namestring to Original. First, check if we have write access, -;;; since we don't want to trash unwritable files even if we technically can. -;;; We return true if we suceed in renaming. -;;; -(defun do-old-rename (namestring original) - (unless (unix:unix-access namestring unix:w_ok) - (cerror "Try to rename it anyway." "File ~S is not writable." namestring)) - (multiple-value-bind - (okay err) - (unix:unix-rename namestring original) - (cond (okay t) - (t - (cerror "Use :SUPERSEDE instead." - "Could not rename ~S to ~S: ~A." - namestring - original - (unix:get-unix-error-msg err)) - nil)))) - - -;;; OPEN -- public -;;; -;;; Open the given file. -;;; -(defun open (filename - &key - (direction :input) - (element-type 'base-char) - (if-exists nil if-exists-given) - (if-does-not-exist nil if-does-not-exist-given)) - "Return a stream which reads from or writes to Filename. - Defined keywords: - :direction - one of :input, :output, :io, or :probe - :element-type - Type of object to read or write, default BASE-CHAR - :if-exists - one of :error, :new-version, :rename, :rename-and-delete, - :overwrite, :append, :supersede or nil - :if-does-not-exist - one of :error, :create or nil - See the manual for details." - ;; First, make sure that DIRECTION is valid. Allow it to be changed if not. - (setf direction - (assure-one-of direction - '(:input :output :io :probe) - :direction)) - - ;; Calculate useful stuff. - (multiple-value-bind - (input output mask) - (case direction - (:input (values t nil unix:o_rdonly)) - (:output (values nil t unix:o_wronly)) - (:io (values t t unix:o_rdwr)) - (:probe (values t nil unix:o_rdonly))) - (declare (type index mask)) - (let* ((pathname (pathname filename)) - (namestring (unix-namestring pathname input))) - ;; Process if-exists argument if we are doing any output. - (cond (output - (unless if-exists-given - (setf if-exists - (if (eq (pathname-version pathname) :newest) - :new-version - :error))) - (setf if-exists - (assure-one-of if-exists - '(:error :new-version :rename - :rename-and-delete :overwrite - :append :supersede nil) - :if-exists)) - (case if-exists - ((:error nil) - (setf mask (logior mask unix:o_excl))) - ((:rename :rename-and-delete) - (setf mask (logior mask unix:o_creat))) - ((:new-version :supersede) - (setf mask (logior mask unix:o_trunc))) - (:append - (setf mask (logior mask unix:o_append))))) - (t - (setf if-exists :ignore-this-arg))) - - (unless if-does-not-exist-given - (setf if-does-not-exist - (cond ((eq direction :input) :error) - ((and output - (member if-exists '(:overwrite :append))) - :error) - ((eq direction :probe) - nil) - (t - :create)))) - (setf if-does-not-exist - (assure-one-of if-does-not-exist - '(:error :create nil) - :if-does-not-exist)) - (if (eq if-does-not-exist :create) - (setf mask (logior mask unix:o_creat))) - - (let ((original (if (member if-exists - '(:rename :rename-and-delete)) - (pick-backup-name namestring))) - (delete-original (eq if-exists :rename-and-delete)) - (mode #o666)) - (when original - ;; We are doing a :rename or :rename-and-delete. - ;; Determine if the file already exists, make sure the original - ;; file is not a directory and keep the mode - (let ((exists - (and namestring - (multiple-value-bind - (okay err/dev inode orig-mode) - (unix:unix-stat namestring) - (declare (ignore inode) - (type (or index null) orig-mode)) - (cond - (okay - (when (and output (= (logand orig-mode #o170000) - #o40000)) - (error "Cannot open ~S for output: Is a directory." - namestring)) - (setf mode (logand orig-mode #o777)) - t) - ((eql err/dev unix:enoent) - nil) - (t - (error "Cannot find ~S: ~A" - namestring - (unix:get-unix-error-msg err/dev)))))))) - (unless (and exists - (do-old-rename namestring original)) - (setf original nil) - (setf delete-original nil) - ;; In order to use SUPERSEDE instead, we have - ;; to make sure unix:o_creat corresponds to - ;; if-does-not-exist. unix:o_creat was set - ;; before because of if-exists being :rename. - (unless (eq if-does-not-exist :create) - (setf mask (logior (logandc2 mask unix:o_creat) unix:o_trunc))) - (setf if-exists :supersede)))) - - ;; Okay, now we can try the actual open. - (loop - (multiple-value-bind - (fd errno) - (if namestring - (unix:unix-open namestring mask mode) - (values nil unix:enoent)) - (cond ((numberp fd) - (return - (case direction - ((:input :output :io) - (make-fd-stream fd - :input input - :output output - :element-type element-type - :file namestring - :original original - :delete-original delete-original - :auto-close t)) - (:probe - (let ((stream - (%make-fd-stream :name namestring :fd fd - :element-type element-type))) - (close stream) - stream))))) - ((eql errno unix:enoent) - (case if-does-not-exist - (:error - (cerror "Return NIL." - "Error opening ~S, ~A." - pathname - (unix:get-unix-error-msg errno))) - (:create - (cerror "Return NIL." - "Error creating ~S, path does not exist." - pathname))) - (return nil)) - ((eql errno unix:eexist) - (unless (eq nil if-exists) - (cerror "Return NIL." - "Error opening ~S, ~A." - pathname - (unix:get-unix-error-msg errno))) - (return nil)) - ((eql errno unix:eacces) - (cerror "Try again." - "Error opening ~S, ~A." - pathname - (unix:get-unix-error-msg errno))) - (t - (cerror "Return NIL." - "Error opening ~S, ~A." - pathname - (unix:get-unix-error-msg errno)) - (return nil))))))))) - -;;;; Initialization. - -(defvar *tty* nil - "The stream connected to the controlling terminal or NIL if there is none.") -(defvar *stdin* nil - "The stream connected to the standard input (file descriptor 0).") -(defvar *stdout* nil - "The stream connected to the standard output (file descriptor 1).") -(defvar *stderr* nil - "The stream connected to the standard error output (file descriptor 2).") - -;;; STREAM-INIT -- internal interface -;;; -;;; Called when the cold load is first started up. -;;; -(defun stream-init () - (stream-reinit) - (setf *terminal-io* (make-synonym-stream '*tty*)) - (setf *standard-output* (make-synonym-stream '*stdout*)) - (setf *standard-input* - (make-two-way-stream (make-synonym-stream '*stdin*) - *standard-output*)) - (setf *error-output* (make-synonym-stream '*stderr*)) - (setf *query-io* (make-synonym-stream '*terminal-io*)) - (setf *debug-io* *query-io*) - (setf *trace-output* *standard-output*) - nil) - -;;; STREAM-REINIT -- internal interface -;;; -;;; Called whenever a saved core is restarted. -;;; -(defun stream-reinit () - (setf *available-buffers* nil) - (setf *stdin* - (make-fd-stream 0 :name "Standard Input" :input t :buffering :line)) - (setf *stdout* - (make-fd-stream 1 :name "Standard Output" :output t :buffering :line)) - (setf *stderr* - (make-fd-stream 2 :name "Standard Error" :output t :buffering :line)) - (let ((tty (unix:unix-open "/dev/tty" unix:o_rdwr #o666))) - (if tty - (setf *tty* - (make-fd-stream tty :name "the Terminal" :input t :output t - :buffering :line :auto-close t)) - (setf *tty* (make-two-way-stream *stdin* *stdout*)))) - nil) - - -;;;; Beeping. - -(defun default-beep-function (stream) - (write-char #\bell stream) - (finish-output stream)) - -(defvar *beep-function* #'default-beep-function - "This is called in BEEP to feep the user. It takes a stream.") - -(defun beep (&optional (stream *terminal-io*)) - (funcall *beep-function* stream)) - - -;;;; File position and file length. - -;;; File-Position -- Public -;;; -;;; Call the misc method with the :file-position operation. -;;; -(defun file-position (stream &optional position) - "With one argument returns the current position within the file - File-Stream is open to. If the second argument is supplied, then - this becomes the new file position. The second argument may also - be :start or :end for the start and end of the file, respectively." - (unless (streamp stream) - (error "Argument ~S is not a stream." stream)) - (funcall (stream-misc stream) stream :file-position position)) - -;;; File-Length -- Public -;;; -;;; Like File-Position, only use :file-length. -;;; -(defun file-length (stream) - "This function returns the length of the file that File-Stream is open to." - (unless (streamp stream) - (error "Argument ~S is not a stream." stream)) - (funcall (stream-misc stream) stream :file-length)) - -;;; File-Name -- internal interface -;;; -;;; Kind of like File-Position, but is an internal hack used by the filesys -;;; stuff to get and set the file name. -;;; -(defun file-name (stream &optional new-name) - (when (fd-stream-p stream) - (if new-name - (setf (fd-stream-file stream) new-name) - (fd-stream-file stream)))) diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp deleted file mode 100644 index 5c9bccda79bf5d1773998d1fd619e99e6a955f18..0000000000000000000000000000000000000000 --- a/code/fdefinition.lisp +++ /dev/null @@ -1,299 +0,0 @@ -;;; -*- Package: Lisp; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/fdefinition.lisp,v 1.14 1992/12/13 16:04:28 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Functions that hack on the global function namespace (primarily -;;; concerned with SETF functions here). Also, function encapsulation -;;; and routines that set and return definitions disregarding whether -;;; they might be encapsulated. -;;; -;;; Written by Rob MacLachlan -;;; Modified by Bill Chiles (wrote encapsulation stuff) -;;; Modified more by William Lott (added ``fdefn'' objects) -;;; - -(in-package "EXTENSIONS") - -(export '(encapsulate unencapsulate encapsulated-p - basic-definition argument-list *setf-fdefinition-hook*)) - - -(in-package "KERNEL") - -(export '(fdefn make-fdefn fdefn-p fdefn-name fdefn-function fdefn-makunbound - %coerce-to-function raw-definition)) - - -(in-package "LISP") - -(export '(fdefinition fboundp fmakunbound)) - - - -;;;; Fdefinition (fdefn) objects. - -(defun make-fdefn (name) - (make-fdefn name)) - -(defun fdefn-name (fdefn) - (declare (type fdefn fdefn)) - (fdefn-name fdefn)) - -(defun fdefn-function (fdefn) - (declare (type fdefn fdefn) - (values (or function null))) - (fdefn-function fdefn)) - -(defun (setf fdefn-function) (fun fdefn) - (declare (type function fun) - (type fdefn fdefn) - (values function)) - (setf (fdefn-function fdefn) fun)) - -(defun fdefn-makunbound (fdefn) - (declare (type fdefn fdefn)) - (fdefn-makunbound fdefn)) - - -;;; FDEFN-INIT -- internal interface. -;;; -;;; This function is called by %INITIAL-FUNCTION after the globaldb has been -;;; initialized, but before anything else. We need to install these fdefn -;;; objects into the globaldb *before* any top level forms run, or we will -;;; end up with two different fdefn objects being used for the same function -;;; name. *INITIAL-FDEFN-OBJECTS* is set up by GENESIS. -;;; -(defvar *initial-fdefn-objects*) -;;; -(defun fdefn-init () - (dolist (fdefn *initial-fdefn-objects*) - (setf (info function definition (fdefn-name fdefn)) fdefn)) - (makunbound '*initial-fdefn-objects*)) - -;;; FDEFINITION-OBJECT -- internal interface. -;;; -(defun fdefinition-object (name create) - "Return the fdefn object for NAME. If it doesn't already exist and CREATE - it non-NIL, create a new (unbound) one." - (declare (values (or fdefn null))) - (unless (or (symbolp name) - (and (consp name) - (eq (car name) 'setf) - (let ((cdr (cdr name))) - (and (consp cdr) - (symbolp (car cdr)) - (null (cdr cdr)))))) - (error "Invalid function name: ~S" name)) - (let ((fdefn (info function definition name))) - (if (and (null fdefn) create) - (setf (info function definition name) (make-fdefn name)) - fdefn))) - -;;; %COERCE-TO-FUNCTION -- public. -;;; -;;; The compiler emits calls to this when someone tries to funcall a symbol. -;;; -(defun %coerce-to-function (name) - "Returns the definition for name, including any encapsulations. Settable - with SETF." - (let ((fdefn (fdefinition-object name nil))) - (or (and fdefn (fdefn-function fdefn)) - (error 'undefined-function :name name)))) - -;;; RAW-DEFINITION -- public. -;;; -;;; Just another name for %coerce-to-function. -;;; -(declaim (inline raw-definition)) -(defun raw-definition (name) - (declare (optimize (inhibit-warnings 3))) - ;; We know that we are calling %coerce-to-function, so don't tell us about - ;; it. - (%coerce-to-function name)) -;;; -(defun (setf raw-definition) (function name) - (let ((fdefn (fdefinition-object name t))) - (setf (fdefn-function fdefn) function))) - - - -;;;; Definition Encapsulation. - -(defstruct (encapsulation-info (:print-function print-encapsulation-info) - (:constructor make-encapsulation-info - (type definition))) - ;; This is definition's encapsulation type. The encapsulated definition is - ;; in the previous encapsulation-info element or installed as the global - ;; definition of some function name. - type - ;; Previous definition. This used to be installed as a global definition - ;; for some function name, but it was replaced by an encapsulation of type - ;; type. - (definition nil :type function)) -;;; -(defun print-encapsulation-info (obj str n) - (declare (ignore n)) - (format str "#<Encapsulation-Info Definition: ~S Type: ~S>" - (%function-name (encapsulation-info-definition obj)) - (encapsulation-info-type obj))) - - -;;; ENCAPSULATE -- Public. -;;; -;;; We must bind and close over info. Consider the case where we encapsulate -;;; (the second) an encapsulated (the first) definition, and later someone -;;; unencapsulates the encapsulated (first) definition. We don't want our -;;; encapsulation (second) to bind basic-definition to the encapsulated (first) -;;; definition when it no longer exists. When unencapsulating, we make sure to -;;; clobber the appropriate info structure to allow basic-definition to be -;;; bound to the next definition instead of an encapsulation that no longer -;;; exists. -;;; -(defun encapsulate (name type body) - "Replaces the definition of NAME with a function that binds name's arguments - a variable named argument-list, binds name's definition to a variable named - basic-definition, and evaluates BODY in that context. TYPE is - whatever you would like to associate with this encapsulation for - identification in case you need multiple encapsuations of the same name." - (let ((fdefn (fdefinition-object name nil))) - (unless (and fdefn (fdefn-function fdefn)) - (error 'undefined-function :name name)) - (let ((info (make-encapsulation-info type (fdefn-function fdefn)))) - (setf (fdefn-function fdefn) - #'(lambda (&rest argument-list) - (declare (special argument-list)) - (let ((basic-definition (encapsulation-info-definition info))) - (declare (special basic-definition)) - (eval body))))))) - -;;; ENCAPSULATION-INFO -- internal. -;;; -;;; Finds the encapsulation info that has been closed over. -;;; -(defun encapsulation-info (fun) - (and (functionp fun) - (= (get-type fun) vm:closure-header-type) - (find-if-in-closure #'encapsulation-info-p fun))) - -;;; UNENCAPSULATE -- Public. -;;; -;;; When removing an encapsulation, we must remember that encapsulating -;;; definitions close over a reference to the encapsulation-info that describes -;;; the encapsulating definition. When you find an info with the target type, -;;; the previous info in the chain has the ensulating definition of that type. -;;; We take the encapsulated definition from the info with the target type, and -;;; we store it in the previous info structure whose encapsulating definition -;;; it describes looks to this previous info structure for a definition to -;;; bind (see ENCAPSULATE). When removing the first info structure, we do -;;; something conceptually equal, but mechanically it is different. -;;; -(defun unencapsulate (name type) - "Removes name's most recent encapsulation of the specified type." - (let* ((fdefn (fdefinition-object name nil)) - (encap-info (encapsulation-info (fdefn-function fdefn)))) - (declare (type (or encapsulation-info null) encap-info)) - (cond ((not encap-info) - ;; It disappeared on us, so don't worry about it. - ) - ((eq (encapsulation-info-type encap-info) type) - ;; It's the first one, so change the fdefn object. - (setf (fdefn-function fdefn) - (encapsulation-info-definition encap-info))) - (t - ;; It must be an interior one, so find it. - (loop - (let ((next-info (encapsulation-info - (encapsulation-info-definition encap-info)))) - (unless next-info - ;; Not there, so don't worry about it. - (return)) - (when (eq (encapsulation-info-type next-info) type) - ;; This is it, so unlink us. - (setf (encapsulation-info-definition encap-info) - (encapsulation-info-definition next-info)) - (return)) - (setf encap-info next-info)))))) - t) - -;;; ENCAPSULATED-P -- Public. -;;; -(defun encapsulated-p (name type) - "Returns t if name has an encapsulation of the given type, otherwise nil." - (let ((fdefn (fdefinition-object name nil))) - (do ((encap-info (encapsulation-info (fdefn-function fdefn)) - (encapsulation-info - (encapsulation-info-definition encap-info)))) - ((null encap-info) nil) - (declare (type (or encapsulation-info null) encap-info)) - (when (eq (encapsulation-info-type encap-info) type) - (return t))))) - - -;;;; FDEFINITION. - -(defun fdefinition (name) - "Return name's global function definition taking care to regard any - encapsulations and to return the innermost encapsulated definition. - This is SETF'able." - (let ((fun (raw-definition name))) - (loop - (let ((encap-info (encapsulation-info fun))) - (if encap-info - (setf fun (encapsulation-info-definition encap-info)) - (return fun)))))) - -(defvar *setf-fdefinition-hook* nil - "This holds functions that (SETF FDEFINITION) invokes before storing the - new value. These functions take the function name and the new value.") - -(defun %set-fdefinition (name new-value) - "Set name's global function definition." - (declare (type function new-value) (optimize (safety 1))) - (let ((fdefn (fdefinition-object name t))) - ;; *setf-fdefinition-hook* won't be bound when - ;; initially running top-level forms in the kernel - ;; core startup. - (when (boundp '*setf-fdefinition-hook*) - (dolist (f *setf-fdefinition-hook*) - (funcall f name new-value))) - - (let ((encap-info (encapsulation-info (fdefn-function fdefn)))) - (cond (encap-info - (loop - (let ((more-info - (encapsulation-info - (encapsulation-info-definition encap-info)))) - (if more-info - (setf encap-info more-info) - (return - (setf (encapsulation-info-definition encap-info) - new-value)))))) - (t - (setf (fdefn-function fdefn) new-value)))))) -;;; -(defsetf fdefinition %set-fdefinition) - - - -;;;; FBOUNDP and FMAKUNBOUND. - -(defun fboundp (name) - "Return true if name has a global function definition." - (let ((fdefn (fdefinition-object name nil))) - (and fdefn (fdefn-function fdefn) t))) - -(defun fmakunbound (name) - "Make Name have no global function definition." - (let ((fdefn (fdefinition-object name nil))) - (when fdefn - (fdefn-makunbound fdefn))) - name) diff --git a/code/filesys.lisp b/code/filesys.lisp deleted file mode 100644 index 8d2ce85243aba56fc31b8269a13bda563f430276..0000000000000000000000000000000000000000 --- a/code/filesys.lisp +++ /dev/null @@ -1,1156 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; ********************************************************************** -;;; 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/code/filesys.lisp,v 1.29 1992/09/04 15:22:16 phg Exp $") -;;; -;;; ********************************************************************** -;;; -;;; File system interface functions. This file is pretty UNIX specific. -;;; -;;; Written by William Lott -;;; -;;; ********************************************************************** - -(in-package "LISP") - -(export '(truename probe-file user-homedir-pathname directory - rename-file delete-file file-write-date file-author)) - -(use-package "EXTENSIONS") - -(in-package "EXTENSIONS") -(export '(print-directory complete-file ambiguous-files default-directory - file-writable unix-namestring)) -(in-package "LISP") - - -;;;; Unix pathname host support. - -;;; Unix namestrings have the following format: -;;; -;;; namestring := [ directory ] [ file [ type [ version ]]] -;;; directory := [ "/" | search-list ] { file "/" }* -;;; search-list := [^:/]*: -;;; file := [^/]* -;;; type := "." [^/.]* -;;; version := "." ([0-9]+ | "*") -;;; -;;; Note: this grammer is ambiguous. The string foo.bar.5 can be parsed -;;; as either just the file specified or as specifying the file, type, and -;;; version. Therefore, we use the following rules when confronted with -;;; an ambiguous file.type.version string: -;;; -;;; - If the first character is a dot, it's part of the file. It is not -;;; considered a dot in the following rules. -;;; -;;; - If there is only one dot, it seperates the file and the type. -;;; -;;; - If there are multiple dots and the stuff following the last dot -;;; is a valid version, then that is the version and the stuff between -;;; the second to last dot and the last dot is the type. -;;; -;;; Wildcard characters: -;;; -;;; If the directory, file, type components contain any of the following -;;; characters, it is considered part of a wildcard pattern and has the -;;; following meaning. -;;; -;;; ? - matches any character -;;; * - matches any zero or more characters. -;;; [abc] - matches any of a, b, or c. -;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn. -;;; -;;; Any of these special characters can be preceeded by a backslash to -;;; cause it to be treated as a regular character. -;;; - -(defun remove-backslashes (namestr start end) - "Remove and occurences of \\ from the string because we've already - checked for whatever they may have been backslashed." - (declare (type simple-base-string namestr) - (type index start end)) - (let* ((result (make-string (- end start))) - (dst 0) - (quoted nil)) - (do ((src start (1+ src))) - ((= src end)) - (cond (quoted - (setf (schar result dst) (schar namestr src)) - (setf quoted nil) - (incf dst)) - (t - (let ((char (schar namestr src))) - (cond ((char= char #\\) - (setq quoted t)) - (t - (setf (schar result dst) char) - (incf dst))))))) - (when quoted - (error 'namestring-parse-error - :complaint "Backslash in bad place." - :namestring namestr - :offset (1- end))) - (shrink-vector result dst))) - -(defvar *ignore-wildcards* nil) - -(defun maybe-make-pattern (namestr start end) - (declare (type simple-base-string namestr) - (type index start end)) - (if *ignore-wildcards* - (subseq namestr start end) - (collect ((pattern)) - (let ((quoted nil) - (any-quotes nil) - (last-regular-char nil) - (index start)) - (flet ((flush-pending-regulars () - (when last-regular-char - (pattern (if any-quotes - (remove-backslashes namestr - last-regular-char - index) - (subseq namestr last-regular-char index))) - (setf any-quotes nil) - (setf last-regular-char nil)))) - (loop - (when (>= index end) - (return)) - (let ((char (schar namestr index))) - (cond (quoted - (incf index) - (setf quoted nil)) - ((char= char #\\) - (setf quoted t) - (setf any-quotes t) - (unless last-regular-char - (setf last-regular-char index)) - (incf index)) - ((char= char #\?) - (flush-pending-regulars) - (pattern :single-char-wild) - (incf index)) - ((char= char #\*) - (flush-pending-regulars) - (pattern :multi-char-wild) - (incf index)) - ((char= char #\[) - (flush-pending-regulars) - (let ((close-bracket - (position #\] namestr :start index :end end))) - (unless close-bracket - (error 'namestring-parse-error - :complaint "``['' with no corresponding ``]''" - :namestring namestr - :offset index)) - (pattern (list :character-set - (subseq namestr - (1+ index) - close-bracket))) - (setf index (1+ close-bracket)))) - (t - (unless last-regular-char - (setf last-regular-char index)) - (incf index))))) - (flush-pending-regulars))) - (cond ((null (pattern)) - "") - ((and (null (cdr (pattern))) - (simple-string-p (car (pattern)))) - (car (pattern))) - (t - (make-pattern (pattern))))))) - -(defun extract-name-type-and-version (namestr start end) - (declare (type simple-base-string namestr) - (type index start end)) - (let* ((last-dot (position #\. namestr :start (1+ start) :end end - :from-end t)) - (second-to-last-dot (and last-dot - (position #\. namestr :start (1+ start) - :end last-dot :from-end t))) - (version :newest)) - ;; If there is a second-to-last dot, check to see if there is a valid - ;; version after the last dot. - (when second-to-last-dot - (cond ((and (= (+ last-dot 2) end) - (char= (schar namestr (1+ last-dot)) #\*)) - (setf version :wild)) - ((and (< (1+ last-dot) end) - (do ((index (1+ last-dot) (1+ index))) - ((= index end) t) - (unless (char<= #\0 (schar namestr index) #\9) - (return nil)))) - (setf version - (parse-integer namestr :start (1+ last-dot) :end end))) - (t - (setf second-to-last-dot nil)))) - (cond (second-to-last-dot - (values (maybe-make-pattern namestr start second-to-last-dot) - (maybe-make-pattern namestr - (1+ second-to-last-dot) - last-dot) - version)) - (last-dot - (values (maybe-make-pattern namestr start last-dot) - (maybe-make-pattern namestr (1+ last-dot) end) - version)) - (t - (values (maybe-make-pattern namestr start end) - nil - version))))) - -(defun split-at-slashes (namestr start end &optional (char #\/)) - "Take a string and return a list of cons cells that mark the char - separated subseq. The first value t if absolute directories location." - (declare (type simple-base-string namestr) - (type index start end)) - (let ((absolute (and (/= start end) - (char= (schar namestr start) char)))) - (when absolute - (incf start)) - ;; Next, split the remainder into ; separated chunks. - (collect ((pieces)) - (loop - (let ((char-pos (position char namestr :start start :end end))) - (pieces (cons start (or char-pos end))) - (unless char-pos - (return)) - (setf start (1+ char-pos)))) - (values absolute (pieces))))) - -(defun maybe-extract-search-list (namestr start end) - (declare (type simple-base-string namestr) - (type index start end)) - (let ((quoted nil)) - (do ((index start (1+ index))) - ((= index end) - (values nil start)) - (if quoted - (setf quoted nil) - (case (schar namestr index) - (#\\ - (setf quoted t)) - (#\: - (return (values (remove-backslashes namestr start index) - (1+ index))))))))) - -(defun parse-unix-namestring (namestr start end) - (declare (type simple-base-string namestr) - (type index start end)) - (multiple-value-bind - (absolute pieces) - (split-at-slashes namestr start end) - (let ((search-list - (if absolute - nil - (let ((first (car pieces))) - (multiple-value-bind - (search-list new-start) - (maybe-extract-search-list namestr - (car first) (cdr first)) - (when search-list - (setf absolute t) - (setf (car first) new-start)) - search-list))))) - (multiple-value-bind - (name type version) - (let* ((tail (car (last pieces))) - (tail-start (car tail)) - (tail-end (cdr tail))) - (unless (= tail-start tail-end) - (setf pieces (butlast pieces)) - (extract-name-type-and-version namestr tail-start tail-end))) - ;; Now we have everything we want. So return it. - (values nil ; no host for unix namestrings. - nil ; no devices for unix namestrings. - (collect ((dirs)) - (when search-list - (dirs (intern-search-list search-list))) - (dolist (piece pieces) - (let ((piece-start (car piece)) - (piece-end (cdr piece))) - (unless (= piece-start piece-end) - (let ((dir (maybe-make-pattern namestr - piece-start - piece-end))) - (if (and (simple-string-p dir) - (string= dir "..")) - (dirs :up) - (dirs dir)))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - (cons :relative (dirs))) - (t - nil))) - name - type - version))))) - -(defun unparse-unix-host (pathname) - (declare (type pathname pathname) - (ignore pathname)) - "Unix") - -(defun unparse-unix-piece (thing) - (etypecase thing - (keyword - (cond ((eq thing ':wild) "*") - ((eq thing ':wild-inferiors) "**") - (t (error "Invalid keyword piece: ~S~%" thing)))) - (simple-string - (let* ((srclen (length thing)) - (dstlen srclen)) - (dotimes (i srclen) - (case (schar thing i) - ((#\* #\? #\[) - (incf dstlen)))) - (let ((result (make-string dstlen)) - (dst 0)) - (dotimes (src srclen) - (let ((char (schar thing src))) - (case char - ((#\* #\? #\[) - (setf (schar result dst) #\\) - (incf dst))) - (setf (schar result dst) char) - (incf dst))) - result))) - (pattern - (collect ((strings)) - (dolist (piece (pattern-pieces thing)) - (etypecase piece - (simple-string - (strings piece)) - (symbol - (case piece - (:wild - (strings "*")) - (:multi-char-wild - (strings "*")) - (:single-char-wild - (strings "?")) - (t - (error "Invalid pattern piece: ~S" piece)))) - (cons - (case (car piece) - (:character-set - (strings "[") - (strings (cdr piece)) - (strings "]")) - (t - (error "Invalid pattern piece: ~S" piece)))))) - (apply #'concatenate - 'simple-string - (strings)))))) - -(defun unparse-unix-directory-list (directory) - (declare (type list directory)) - (collect ((pieces)) - (when directory - (ecase (pop directory) - (:absolute - (cond ((search-list-p (car directory)) - (pieces (search-list-name (pop directory))) - (pieces ":")) - (t - (pieces "/")))) - (:relative - ;; Nothing special. - )) - (dolist (dir directory) - (typecase dir - ((member :up) - (pieces "../")) - ((member :back) - (error ":BACK cannot be represented in namestrings.")) - ((or simple-string pattern) - (pieces (unparse-unix-piece dir)) - (pieces "/")) - (t - (error "Invalid directory component: ~S" dir))))) - (apply #'concatenate 'simple-string (pieces)))) - -(defun unparse-unix-directory (pathname) - (declare (type pathname pathname)) - (unparse-unix-directory-list (%pathname-directory pathname))) - -(defun unparse-unix-file (pathname) - (declare (type pathname pathname)) - (collect ((strings)) - (let* ((name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (type-supplied (not (or (null type) (eq type :unspecific)))) - (version (%pathname-version pathname)) - (version-supplied (not (or (null version) (eq version :newest))))) - (when name - (strings (unparse-unix-piece name))) - (when type-supplied - (unless name - (error "Cannot specify the type without a file: ~S" pathname)) - (strings ".") - (strings (unparse-unix-piece type))) - (when version-supplied - (unless type-supplied - (error "Cannot specify the version without a type: ~S" pathname)) - (strings (if (eq version :wild) - ".*" - (format nil ".~D" version))))) - (apply #'concatenate 'simple-string (strings)))) - -(defun unparse-unix-namestring (pathname) - (declare (type pathname pathname)) - (concatenate 'simple-string - (unparse-unix-directory pathname) - (unparse-unix-file pathname))) - -(defun unparse-unix-enough (pathname defaults) - (declare (type pathname pathname defaults)) - (flet ((lose () - (error "~S cannot be represented relative to ~S" - pathname defaults))) - (collect ((strings)) - (let* ((pathname-directory (%pathname-directory pathname)) - (defaults-directory (%pathname-directory defaults)) - (prefix-len (length defaults-directory)) - (result-dir - (cond ((and (> prefix-len 1) - (>= (length pathname-directory) prefix-len) - (compare-component (subseq pathname-directory - 0 prefix-len) - defaults-directory)) - ;; Pathname starts with a prefix of default. So just - ;; use a relative directory from then on out. - (cons :relative (nthcdr prefix-len pathname-directory))) - ((eq (car pathname-directory) :absolute) - ;; We are an absolute pathname, so we can just use it. - pathname-directory) - (t - ;; We are a relative directory. So we lose. - (lose))))) - (strings (unparse-unix-directory-list result-dir))) - (let* ((pathname-version (%pathname-version pathname)) - (version-needed (and pathname-version - (not (eq pathname-version :newest)))) - (pathname-type (%pathname-type pathname)) - (type-needed (or version-needed - (and pathname-type - (not (eq pathname-type :unspecific))))) - (pathname-name (%pathname-name pathname)) - (name-needed (or type-needed - (and pathname-name - (not (compare-component pathname-name - (%pathname-name - defaults))))))) - (when name-needed - (unless pathname-name (lose)) - (strings (unparse-unix-piece pathname-name))) - (when type-needed - (when (or (null pathname-type) (eq pathname-type :unspecific)) - (lose)) - (strings ".") - (strings (unparse-unix-piece pathname-type))) - (when version-needed - (typecase pathname-version - ((member :wild) - (strings ".*")) - (integer - (strings (format nil ".~D" pathname-version))) - (t - (lose))))) - (apply #'concatenate 'simple-string (strings))))) - - -(defstruct (unix-host - (:include host - (:parse #'parse-unix-namestring) - (:unparse #'unparse-unix-namestring) - (:unparse-host #'unparse-unix-host) - (:unparse-directory #'unparse-unix-directory) - (:unparse-file #'unparse-unix-file) - (:unparse-enough #'unparse-unix-enough) - (:customary-case :lower)) - (:make-load-form-fun make-unix-host-load-form)) - ) - -(defvar *unix-host* (make-unix-host)) - -(defun make-unix-host-load-form (host) - (declare (ignore host)) - '*unix-host*) - - -;;;; Wildcard matching stuff. - -(defmacro enumerate-matches ((var pathname &optional result - &key (verify-existance t)) - &body body) - (let ((body-name (gensym))) - `(block nil - (flet ((,body-name (,var) - ,@body)) - (%enumerate-matches (pathname ,pathname) - ,verify-existance - #',body-name) - ,result)))) - -(defun %enumerate-matches (pathname verify-existance function) - (when (pathname-type pathname) - (unless (pathname-name pathname) - (error "Cannot supply a type without a name:~% ~S" pathname))) - (when (and (integerp (pathname-version pathname)) - (member (pathname-type pathname) '(nil :unspecific))) - (error "Cannot supply a version without a type:~% ~S" pathname)) - (let ((directory (pathname-directory pathname))) - (if directory - (ecase (car directory) - (:absolute - (%enumerate-directories "/" (cdr directory) pathname - verify-existance function)) - (:relative - (%enumerate-directories "" (cdr directory) pathname - verify-existance function))) - (%enumerate-files "" pathname verify-existance function)))) - -(defun %enumerate-directories (head tail pathname verify-existance function) - (if tail - (let ((piece (car tail))) - (etypecase piece - (simple-string - (%enumerate-directories (concatenate 'string head piece "/") - (cdr tail) pathname verify-existance - function)) - (pattern - (let ((dir (unix:open-dir head))) - (when dir - (unwind-protect - (loop - (let ((name (unix:read-dir dir))) - (cond ((null name) - (return)) - ((string= name ".")) - ((string= name "..")) - ((pattern-matches piece name) - (let ((subdir (concatenate 'string - head name "/"))) - (when (eq (unix:unix-file-kind subdir) - :directory) - (%enumerate-directories - subdir (cdr tail) pathname verify-existance - function))))))) - (unix:close-dir dir))))) - ((member :up) - (%enumerate-directories (concatenate 'string head "../") - (cdr tail) pathname verify-existance - function)))) - (%enumerate-files head pathname verify-existance function))) - -(defun %enumerate-files (directory pathname verify-existance function) - (let ((name (pathname-name pathname)) - (type (pathname-type pathname)) - (version (pathname-version pathname))) - (cond ((null name) - (when (or (not verify-existance) - (unix:unix-file-kind directory)) - (funcall function directory))) - ((or (pattern-p name) - (pattern-p type) - (eq version :wild)) - (let ((dir (unix:open-dir directory))) - (when dir - (unwind-protect - (loop - (let ((file (unix:read-dir dir))) - (if file - (unless (or (string= file ".") - (string= file "..")) - (multiple-value-bind - (file-name file-type file-version) - (let ((*ignore-wildcards* t)) - (extract-name-type-and-version - file 0 (length file))) - (when (and (components-match file-name name) - (components-match file-type type) - (components-match file-version - version)) - (funcall function - (concatenate 'string - directory - file))))) - (return)))) - (unix:close-dir dir))))) - (t - (let ((file (concatenate 'string directory name))) - (unless (or (null type) (eq type :unspecific)) - (setf file (concatenate 'string file "." type))) - (unless (member version '(nil :newest :wild)) - (setf file (concatenate 'string file "." - (quick-integer-to-string version)))) - (when (or (not verify-existance) - (unix:unix-file-kind file)) - (funcall function file))))))) - -(defun quick-integer-to-string (n) - (declare (type integer n)) - (cond ((zerop n) "0") - ((eql n 1) "1") - ((minusp n) - (concatenate 'simple-string "-" - (the simple-string (quick-integer-to-string (- n))))) - (t - (do* ((len (1+ (truncate (integer-length n) 3))) - (res (make-string len)) - (i (1- len) (1- i)) - (q n) - (r 0)) - ((zerop q) - (incf i) - (replace res res :start2 i :end2 len) - (shrink-vector res (- len i))) - (declare (simple-string res) - (fixnum len i r)) - (multiple-value-setq (q r) (truncate q 10)) - (setf (schar res i) (schar "0123456789" r)))))) - - -;;;; UNIX-NAMESTRING -- public -;;; -(defun unix-namestring (pathname &optional (for-input t)) - "Convert PATHNAME into a string that can be used with UNIX system calls. - Search-lists and wild-cards are expanded." - (enumerate-search-list - (pathname pathname) - (collect ((names)) - (enumerate-matches (name pathname nil :verify-existance for-input) - (names name)) - (let ((names (names))) - (when names - (when (cdr names) - (error "~S is ambiguous:~{~% ~A~}" pathname names)) - (return (car names))))))) - - -;;;; TRUENAME and PROBE-FILE. - -;;; Truename -- Public -;;; -;;; Another silly file function trivially different from another function. -;;; -(defun truename (pathname) - "Return the pathname for the actual file described by the pathname - An error is signalled if no such file exists." - (let ((result (probe-file pathname))) - (unless result - (error "The file ~S does not exist." (namestring pathname))) - result)) - -;;; Probe-File -- Public -;;; -;;; If PATHNAME exists, return it's truename, otherwise NIL. -;;; -(defun probe-file (pathname) - "Return a pathname which is the truename of the file if it exists, NIL - otherwise." - (let ((namestring (unix-namestring pathname t))) - (when (and namestring (unix:unix-file-kind namestring)) - (let ((truename (unix:unix-resolve-links - (unix:unix-maybe-prepend-current-directory - namestring)))) - (when truename - (let ((*ignore-wildcards* t)) - (pathname (unix:unix-simplify-pathname truename)))))))) - - -;;;; Other random operations. - -;;; Rename-File -- Public -;;; -(defun rename-file (file new-name) - "Rename File to have the specified New-Name. If file is a stream open to a - file, then the associated file is renamed. If the file does not yet exist - then the file is created with the New-Name when the stream is closed." - (let* ((original (truename file)) - (original-namestring (unix-namestring original t)) - (new-name (merge-pathnames new-name original)) - (new-namestring (unix-namestring new-name nil))) - (unless original-namestring - (error "~S doesn't exist." file)) - (unless new-namestring - (error "~S can't be created." new-name)) - (multiple-value-bind (res error) - (unix:unix-rename original-namestring - new-namestring) - (unless res - (error "Failed to rename ~A to ~A: ~A" - original new-name (unix:get-unix-error-msg error))) - (when (streamp file) - (file-name file new-namestring)) - (values new-name original (truename new-name))))) - -;;; Delete-File -- Public -;;; -;;; Delete the file, Man. -;;; -(defun delete-file (file) - "Delete the specified file." - (let ((namestring (unix-namestring file t))) - (when (streamp file) - (close file :abort t)) - (unless namestring - (error "~S doesn't exist." file)) - - (multiple-value-bind (res err) (unix:unix-unlink namestring) - (unless res - (error "Could not delete ~A: ~A." - namestring - (unix:get-unix-error-msg err))))) - t) - - -;;; User-Homedir-Pathname -- Public -;;; -;;; Return Home:, which is set up for us at initialization time. -;;; -(defun user-homedir-pathname (&optional host) - "Returns the home directory of the logged in user as a pathname. - This is obtained from the logical name \"home:\"." - (declare (ignore host)) - #p"home:") - -;;; File-Write-Date -- Public -;;; -(defun file-write-date (file) - "Return file's creation date, or NIL if it doesn't exist." - (let ((name (unix-namestring file t))) - (when name - (multiple-value-bind - (res dev ino mode nlink uid gid rdev size atime mtime) - (unix:unix-stat name) - (declare (ignore dev ino mode nlink uid gid rdev size atime)) - (when res - (+ unix-to-universal-time mtime)))))) - -;;; File-Author -- Public -;;; -(defun file-author (file) - "Returns the file author as a string, or nil if the author cannot be - determined. Signals an error if file doesn't exist." - (let ((name (unix-namestring (pathname file) t))) - (unless name - (error "~S doesn't exist." file)) - (multiple-value-bind (winp dev ino mode nlink uid) - (unix:unix-stat file) - (declare (ignore dev ino mode nlink)) - (if winp (lookup-login-name uid))))) - - - -;;;; DIRECTORY. - -;;; DIRECTORY -- public. -;;; -(defun directory (pathname &key (all t) (check-for-subdirs t) - (follow-links t)) - "Returns a list of pathnames, one for each file that matches the given - pathname. Supplying :ALL as nil causes this to ignore Unix dot files. This - never includes Unix dot and dot-dot in the result. If :FOLLOW-LINKS is NIL, - then symblolic links in the result are not expanded. This is not the - default because TRUENAME does follow links, and the result pathnames are - defined to be the TRUENAME of the pathname (the truename of a link may well - be in another directory.)" - (let ((results nil)) - (enumerate-search-list - (pathname (merge-pathnames pathname - (make-pathname :name :wild - :type :wild - :version :wild))) - (enumerate-matches (name pathname) - (when (or all - (let ((slash (position #\/ name :from-end t))) - (or (null slash) - (= (1+ slash) (length name)) - (char/= (schar name (1+ slash)) #\.)))) - (push name results)))) - (let ((*ignore-wildcards* t)) - (mapcar #'(lambda (name) - (let ((name (if (and check-for-subdirs - (eq (unix:unix-file-kind name) - :directory)) - (concatenate 'string name "/") - name))) - (if follow-links (truename name) (pathname name)))) - (sort (delete-duplicates results :test #'string=) #'string<))))) - - -;;;; Printing directories. - -;;; PRINT-DIRECTORY is exported from the EXTENSIONS package. -;;; -(defun print-directory (pathname &optional stream &key all verbose return-list) - "Like Directory, but prints a terse, multi-coloumn directory listing - instead of returning a list of pathnames. When :all is supplied and - non-nil, then Unix dot files are included too (as ls -a). When :vervose - is supplied and non-nil, then a long listing of miscellaneous - information is output one file per line." - (let ((*standard-output* (out-synonym-of stream)) - (pathname pathname)) - (if verbose - (print-directory-verbose pathname all return-list) - (print-directory-formatted pathname all return-list)))) - -(defun print-directory-verbose (pathname all return-list) - (let ((contents (directory pathname :all all :check-for-subdirs nil - :follow-links nil)) - (result nil)) - (format t "Directory of ~A :~%" (namestring pathname)) - (dolist (file contents) - (let* ((namestring (unix-namestring file)) - (tail (subseq namestring - (1+ (or (position #\/ namestring - :from-end t - :test #'char=) - -1))))) - (multiple-value-bind - (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime) - (unix:unix-stat namestring) - (declare (ignore ino gid rdev atime) - (fixnum uid mode)) - (cond (reslt - ;; - ;; Print characters for file modes. - (macrolet ((frob (bit name &optional sbit sname negate) - `(if ,(if negate - `(not (logbitp ,bit mode)) - `(logbitp ,bit mode)) - ,(if sbit - `(if (logbitp ,sbit mode) - (write-char ,sname) - (write-char ,name)) - `(write-char ,name)) - (write-char #\-)))) - (frob 15 #\d nil nil t) - (frob 8 #\r) - (frob 7 #\w) - (frob 6 #\x 11 #\s) - (frob 5 #\r) - (frob 4 #\w) - (frob 3 #\x 10 #\s) - (frob 2 #\r) - (frob 1 #\w) - (frob 0 #\x)) - ;; - ;; Print the rest. - (multiple-value-bind (sec min hour date month year) - (get-decoded-time) - (declare (ignore sec min hour date month)) - (format t "~2D ~8A ~8D ~12A ~A~@[/~]~%" - nlink - (or (lookup-login-name uid) uid) - size - (decode-universal-time-for-files mtime year) - tail - (= (logand mode unix:s-ifmt) unix:s-ifdir)))) - (t (format t "Couldn't stat ~A -- ~A.~%" - tail - (unix:get-unix-error-msg dev-or-err)))) - (when return-list - (push (if (= (logand mode unix:s-ifmt) unix:s-ifdir) - (pathname (concatenate 'string namestring "/")) - file) - result))))) - (nreverse result))) - -(defun decode-universal-time-for-files (time current-year) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time (+ time unix-to-universal-time)) - (declare (ignore sec)) - (format nil "~A ~2,' D ~:[ ~D~;~*~2,'0D:~2,'0D~]" - (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" - "Sep" "Oct" "Nov" "Dec") - (1- month)) - day (= current-year year) year hour min))) - -(defun print-directory-formatted (pathname all return-list) - (let ((width (or (line-length *standard-output*) 80)) - (names ()) - (cnt 0) - (max-len 0) - (result (directory pathname :all all :follow-links nil))) - (declare (list names) (fixnum max-len cnt)) - ;; - ;; Get the data. - (dolist (file result) - (let* ((name (unix-namestring file)) - (length (length name)) - (end (if (and (plusp length) - (char= (schar name (1- length)) #\/)) - (1- length) - length)) - (slash-name (subseq name - (1+ (or (position #\/ name - :from-end t - :end end - :test #'char=) - -1)))) - (len (length slash-name))) - (declare (simple-string slash-name) - (fixnum len)) - (if (> len max-len) (setq max-len len)) - (incf cnt) - (push slash-name names))) - (setq names (nreverse names)) - ;; - ;; Do the output. - (let* ((col-width (1+ max-len)) - (cols (max (truncate width col-width) 1)) - (lines (ceiling cnt cols))) - (declare (fixnum cols lines)) - (format t "Directory of ~A :~%" (namestring pathname)) - (dotimes (i lines) - (declare (fixnum i)) - (dotimes (j cols) - (declare (fixnum j)) - (let ((name (nth (+ i (the fixnum (* j lines))) names))) - (when name - (write-string name) - (unless (eql j (1- cols)) - (dotimes (i (- col-width (length (the simple-string name)))) - (write-char #\space)))))) - (terpri))) - (when return-list - result))) - - - -;;;; Translating uid's and gid's. - -(defvar *uid-hash-table* (make-hash-table) - "Hash table for keeping track of uid's and login names.") - -;;; LOOKUP-LOGIN-NAME translates a user id into a login name. Previous -;;; lookups are cached in a hash table since groveling the passwd(s) files -;;; is somewhat expensive. The table may hold nil for id's that cannot -;;; be looked up since this means the files are searched in their entirety -;;; each time this id is translated. -;;; -(defun lookup-login-name (uid) - (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*) - (if foundp - login-name - (setf (gethash uid *uid-hash-table*) - (get-group-or-user-name :user uid))))) - -(defvar *gid-hash-table* (make-hash-table) - "Hash table for keeping track of gid's and group names.") - -;;; LOOKUP-GROUP-NAME translates a group id into a group name. Previous -;;; lookups are cached in a hash table since groveling the group(s) files -;;; is somewhat expensive. The table may hold nil for id's that cannot -;;; be looked up since this means the files are searched in their entirety -;;; each time this id is translated. -;;; -(defun lookup-group-name (gid) - (multiple-value-bind (group-name foundp) (gethash gid *gid-hash-table*) - (if foundp - group-name - (setf (gethash gid *gid-hash-table*) - (get-group-or-user-name :group gid))))) - - -;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group") since it is -;;; a much smaller file, contains all the local id's, and most uses probably -;;; involve id's on machines one would login into. Then if necessary, we look -;;; in "/etc/passwds" ("/etc/groups") which is really long and has to be -;;; fetched over the net. -;;; -(defun get-group-or-user-name (group-or-user id) - "Returns the simple-string user or group name of the user whose uid or gid - is id, or NIL if no such user or group exists. Group-or-user is either - :group or :user." - (let ((id-string (let ((*print-base* 10)) (prin1-to-string id)))) - (declare (simple-string id-string)) - (multiple-value-bind (file1 file2) - (ecase group-or-user - (:group (values "/etc/group" "/etc/groups")) - (:user (values "/etc/passwd" "/etc/passwd"))) - (or (get-group-or-user-name-aux id-string file1) - (get-group-or-user-name-aux id-string file2))))) - -(defun get-group-or-user-name-aux (id-string passwd-file) - (with-open-file (stream passwd-file) - (loop - (let ((entry (read-line stream nil))) - (unless entry (return nil)) - (let ((name-end (position #\: (the simple-string entry) - :test #'char=))) - (when name-end - (let ((id-start (position #\: (the simple-string entry) - :start (1+ name-end) :test #'char=))) - (when id-start - (incf id-start) - (let ((id-end (position #\: (the simple-string entry) - :start id-start :test #'char=))) - (when (and id-end - (string= id-string entry - :start2 id-start :end2 id-end)) - (return (subseq entry 0 name-end)))))))))))) - - -;;;; File completion. - -;;; COMPLETE-FILE -- Public -;;; -(defun complete-file (pathname &key (defaults *default-pathname-defaults*) - ignore-types) - (let ((files (directory (complete-file-directory-arg pathname defaults) - :check-for-subdirs nil - :follow-links nil))) - (cond ((null files) - (values nil nil)) - ((null (cdr files)) - (values (merge-pathnames (file-namestring (car files)) - pathname) - t)) - (t - (let ((good-files - (delete-if #'(lambda (pathname) - (and (simple-string-p - (pathname-type pathname)) - (member (pathname-type pathname) - ignore-types - :test #'string=))) - files))) - (cond ((null good-files)) - ((null (cdr good-files)) - (return-from complete-file - (values (merge-pathnames (file-namestring - (car good-files)) - pathname) - t))) - (t - (setf files good-files))) - (let ((common (file-namestring (car files)))) - (dolist (file (cdr files)) - (let ((name (file-namestring file))) - (dotimes (i (min (length common) (length name)) - (when (< (length name) (length common)) - (setf common name))) - (unless (char= (schar common i) (schar name i)) - (setf common (subseq common 0 i)) - (return))))) - (values (merge-pathnames common pathname) - nil))))))) - -;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal. -;;; -(defun complete-file-directory-arg (pathname defaults) - (let* ((pathname (merge-pathnames pathname (directory-namestring defaults))) - (type (pathname-type pathname))) - (flet ((append-multi-char-wild (thing) - (etypecase thing - (null :wild) - (pattern - (make-pattern (append (pattern-pieces thing) - (list :multi-char-wild)))) - (simple-string - (make-pattern (list thing :multi-char-wild)))))) - (if (or (null type) (eq type :unspecific)) - ;; There is no type. - (make-pathname :defaults pathname - :name (append-multi-char-wild (pathname-name pathname)) - :type :wild) - ;; There already is a type, so just extend it. - (make-pathname :defaults pathname - :name (pathname-name pathname) - :type (append-multi-char-wild (pathname-type pathname))))))) - -;;; Ambiguous-Files -- Public -;;; -(defun ambiguous-files (pathname - &optional (defaults *default-pathname-defaults*)) - "Return a list of all files which are possible completions of Pathname. - We look in the directory specified by Defaults as well as looking down - the search list." - (directory (complete-file-directory-arg pathname defaults) - :follow-links nil - :check-for-subdirs nil)) - - - -;;; File-writable -- exported from extensions. -;;; -;;; Determines whether the single argument (which should be a pathname) -;;; can be written by the the current task. -;;; -(defun file-writable (name) - "File-writable accepts a pathname and returns T if the current - process can write it, and NIL otherwise." - (let ((name (unix-namestring name nil))) - (cond ((null name) - nil) - ((unix:unix-file-kind name) - (values (unix:unix-access name unix:w_ok))) - (t - (values - (unix:unix-access (subseq name - 0 - (or (position #\/ name :from-end t) - 0)) - (logior unix:w_ok unix:x_ok))))))) - - -;;; Pathname-Order -- Internal -;;; -;;; Predicate to order pathnames by. Goes by name. -;;; -(defun pathname-order (x y) - (let ((xn (%pathname-name x)) - (yn (%pathname-name y))) - (if (and xn yn) - (let ((res (string-lessp xn yn))) - (cond ((not res) nil) - ((= res (length (the simple-string xn))) t) - ((= res (length (the simple-string yn))) nil) - (t t))) - xn))) - - -;;; Default-Directory -- Public -;;; -(defun default-directory () - "Returns the pathname for the default directory. This is the place where - a file will be written if no directory is specified. This may be changed - with setf." - (multiple-value-bind (gr dir-or-error) - (unix:unix-current-directory) - (if gr - (let ((*ignore-wildcards* t)) - (pathname (concatenate 'simple-string dir-or-error "/"))) - (error dir-or-error)))) - -;;; %Set-Default-Directory -- Internal -;;; -(defun %set-default-directory (new-val) - (let ((namestring (unix-namestring new-val t))) - (unless namestring - (error "~S doesn't exist." new-val)) - (multiple-value-bind (gr error) - (unix:unix-chdir namestring) - (if gr - (setf (search-list "default:") (default-directory)) - (error (unix:get-unix-error-msg error)))) - new-val)) -;;; -(defsetf default-directory %set-default-directory) - -(defun filesys-init () - (setf *default-pathname-defaults* - (%make-pathname *unix-host* nil nil nil nil :newest)) - (setf (search-list "default:") (default-directory)) - nil) diff --git a/code/final.lisp b/code/final.lisp deleted file mode 100644 index aa3aeac4861eed585aec58bd7c023c0dfc9ec9da..0000000000000000000000000000000000000000 --- a/code/final.lisp +++ /dev/null @@ -1,60 +0,0 @@ -;;; -*- Package: EXTENSIONS -*- -;;; -;;; ********************************************************************** -;;; 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/code/final.lisp,v 1.1 1991/11/16 01:59:18 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Finalization based on weak pointers. Written by William Lott, but -;;; the idea really was Chris Hoover's. -;;; - -(in-package "EXTENSIONS") - -(export '(finalize cancel-finalization)) - -(defvar *objects-pending-finalization* nil) - -(defun finalize (object function) - "Arrage for FUNCTION to be called when there are no more references to - OBJECT." - (declare (type function function)) - (system:without-gcing - (push (cons (make-weak-pointer object) function) - *objects-pending-finalization*)) - object) - -(defun cancel-finalization (object) - "Cancel any finalization registers for OBJECT." - (when object - ;; We check to make sure object isn't nil because if there are any - ;; broken weak pointers, their value will show up as nil. Therefore, - ;; they would be deleted from the list, but not finalized. Broken - ;; weak pointers shouldn't be left in the list, but why take chances? - (system:without-gcing - (setf *objects-pending-finalization* - (delete object *objects-pending-finalization* - :key #'(lambda (pair) - (values (weak-pointer-value (car pair)))))))) - nil) - -(defun finalize-corpses () - (setf *objects-pending-finalization* - (delete-if #'(lambda (pair) - (multiple-value-bind - (object valid) - (weak-pointer-value (car pair)) - (declare (ignore object)) - (unless valid - (funcall (cdr pair)) - t))) - *objects-pending-finalization*)) - nil) - -(pushnew 'finalize-corpses *after-gc-hooks*) diff --git a/code/float-trap.lisp b/code/float-trap.lisp deleted file mode 100644 index 093f64ce58e5cdfc771a524389a87a540d2f06cc..0000000000000000000000000000000000000000 --- a/code/float-trap.lisp +++ /dev/null @@ -1,175 +0,0 @@ -;;; -*- Package: VM -*- -;;; -;;; ********************************************************************** -;;; 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/code/float-trap.lisp,v 1.7 1992/12/10 01:26:41 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains stuff for controlling floating point traps. It is -;;; IEEE float specific, but should work for pretty much any FPU where the -;;; state fits in one word and exceptions are represented by bits being set. -;;; -;;; Author: Rob MacLachlan -;;; -(in-package "VM") -(export '(current-float-trap floating-point-modes sigfpe-handler)) -(in-package "EXTENSIONS") -(export '(set-floating-point-modes get-floating-point-modes)) -(in-package "VM") - -(eval-when (compile load eval) - -(defconstant float-trap-alist - (list (cons :underflow float-underflow-trap-bit) - (cons :overflow float-overflow-trap-bit) - (cons :inexact float-inexact-trap-bit) - (cons :invalid float-invalid-trap-bit) - (cons :divide-by-zero float-divide-by-zero-trap-bit))) - -;;; FLOAT-TRAP-MASK -- Internal -;;; -;;; Return a mask with all the specified float trap bits set. -;;; -(defun float-trap-mask (names) - (reduce #'logior - (mapcar #'(lambda (x) - (or (cdr (assoc x float-trap-alist)) - (error "Unknown float trap kind: ~S." x))) - names))) - -(defconstant rounding-mode-alist - (list (cons :nearest float-round-to-nearest) - (cons :zero float-round-to-zero) - (cons :positive-infinity float-round-to-positive) - (cons :negative-infinity float-round-to-negative))) - -); Eval-When (Compile Load Eval) - - -;;; Interpreter stubs. -;;; -(defun floating-point-modes () (floating-point-modes)) -(defun (setf floating-point-modes) (new) (setf (floating-point-modes) new)) - - -;;; SET-FLOATING-POINT-MODES -- Public -;;; -(defun set-floating-point-modes (&key (traps nil traps-p) - (rounding-mode nil round-p) - (current-exceptions nil current-x-p) - (accrued-exceptions nil accrued-x-p) - (fast-mode nil fast-mode-p)) - "This function sets options controlling the floating-point hardware. If a - keyword is not supplied, then the current value is preserved. Possible - keywords: - - :TRAPS - A list of the exception conditions that should cause traps. Possible - exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and - :DIVIDE-BY-ZERO. Initially all traps except :INEXACT are enabled. - - :ROUNDING-MODE - The rounding mode to use when the result is not exact. Possible values - are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO. - Initially, the rounding mode is :NEAREST. - - :CURRENT-EXCEPTIONS - :ACCRUED-EXCEPTIONS - These arguments allow setting of the exception flags. The main use is - setting the accrued exceptions to NIL to clear them. - - :FAST-MODE - Set the hardware's \"fast mode\" flag, if any. When set, IEEE - conformance or debuggability may be impaired. Some machines may not - have this feature, in which case the value is always NIL. - - GET-FLOATING-POINT-MODES may be used to find the floating point modes - currently in effect." - (let ((modes (floating-point-modes))) - (when traps-p - (setf (ldb float-traps-byte modes) (float-trap-mask traps))) - (when round-p - (setf (ldb float-rounding-mode modes) - (or (cdr (assoc rounding-mode rounding-mode-alist)) - (error "Unknown rounding mode: ~S." rounding-mode)))) - (when current-x-p - (setf (ldb float-exceptions-byte modes) - (float-trap-mask current-exceptions))) - (when accrued-x-p - (setf (ldb float-sticky-bits modes) - (float-trap-mask accrued-exceptions))) - (when fast-mode-p - (if fast-mode - (setq modes (logior float-fast-bit modes)) - (setq modes (logand (lognot float-fast-bit) modes)))) - (setf (floating-point-modes) modes)) - - (values)) - - -;;; GET-FLOATING-POINT-MODES -- Public -;;; -(defun get-floating-point-modes () - "This function returns a list representing the state of the floating point - modes. The list is in the same format as the keyword arguments to - SET-FLOATING-POINT-MODES, i.e. - (apply #'set-floating-point-modes (get-floating-point-modes)) - - sets the floating point modes to their current values (and thus is a no-op)." - (flet ((exc-keys (bits) - (macrolet ((frob () - `(collect ((res)) - ,@(mapcar #'(lambda (x) - `(when (logtest bits ,(cdr x)) - (res ',(car x)))) - float-trap-alist) - (res)))) - (frob)))) - (let ((modes (floating-point-modes))) - `(:traps ,(exc-keys (ldb float-traps-byte modes)) - :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes) - rounding-mode-alist)) - :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes)) - :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes)) - :fast-mode ,(logtest float-fast-bit modes))))) - - -;;; CURRENT-FLOAT-TRAP -- Interface -;;; -(defmacro current-float-trap (&rest traps) - "Current-Float-Trap Trap-Name* - Return true if any of the named traps are currently trapped, false - otherwise." - `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0) - (floating-point-modes))))) - - -;;; SIGFPE-HANDLER -- Interface -;;; -;;; Signal the appropriate condition when we get a floating-point error. -;;; -(defun sigfpe-handler (signal code scp) - (declare (ignore signal code) - (type system-area-pointer scp)) - (let* ((modes (sigcontext-floating-point-modes - (alien:sap-alien scp (* unix:sigcontext)))) - (traps (logand (ldb float-exceptions-byte modes) - (ldb float-traps-byte modes)))) - (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) - (error 'division-by-zero)) - ((not (zerop (logand float-invalid-trap-bit traps))) - (error 'floating-point-invalid-operation)) - ((not (zerop (logand float-overflow-trap-bit traps))) - (error 'floating-point-overflow)) - ((not (zerop (logand float-underflow-trap-bit traps))) - (error 'floating-point-underflow)) - ((not (zerop (logand float-inexact-trap-bit traps))) - (error 'ext:floating-point-inexact)) - (t - (error "SIGFPE with no exceptions currently enabled?"))))) diff --git a/code/float.lisp b/code/float.lisp deleted file mode 100644 index 69fd9298591879b58ca4c448019e00d1283eca0b..0000000000000000000000000000000000000000 --- a/code/float.lisp +++ /dev/null @@ -1,844 +0,0 @@ -;;; -*- Mode: Lisp; Package: KERNEL; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/float.lisp,v 1.10 1992/12/10 01:28:22 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the definitions of float specific number support -;;; (other than irrational stuff, which is in irrat.) There is code in here -;;; that assumes there are only two float formats: IEEE single and double. -;;; -;;; Author: Rob MacLachlan -;;; -(in-package "KERNEL") -(export '(%unary-truncate %unary-round)) - -(in-package "LISP") -(export '(least-positive-normalized-short-float - least-positive-normalized-single-float - least-positive-normalized-double-float - least-positive-normalized-long-float - least-negative-normalized-short-float - least-negative-normalized-single-float - least-negative-normalized-double-float - least-negative-normalized-long-float - least-positive-single-float - least-positive-short-float - least-negative-single-float - least-negative-short-float - least-positive-double-float - least-positive-long-float - least-negative-double-float - least-negative-long-float - most-positive-single-float - most-positive-short-float - most-negative-single-float - most-negative-short-float - most-positive-double-float - most-positive-long-float - most-negative-double-float - most-negative-long-float)) - -(in-package "EXTENSIONS") -(export '(single-float-positive-infinity short-float-positive-infinity - double-float-positive-infinity long-float-positive-infinity - single-float-negative-infinity short-float-negative-infinity - double-float-negative-infinity long-float-negative-infinity - set-floating-point-modes float-denormalized-p float-nan-p - float-trapping-nan-p float-infinity-p)) - -(in-package "KERNEL") - - -;;;; Utilities: - -;;; SINGLE-FROM-BITS, DOUBLE-FROM-BITS -- Internal -;;; -;;; These functions let us create floats from bits with the significand -;;; uniformly represented as an integer. This is less efficient for double -;;; floats, but is more convenient when making special values, etc. -;;; -(defun single-from-bits (sign exp sig) - (declare (type bit sign) (type (unsigned-byte 24) sig) - (type (unsigned-byte 8) exp)) - (make-single-float - (dpb exp vm:single-float-exponent-byte - (dpb sig vm:single-float-significand-byte - (if (zerop sign) 0 -1))))) -;;; -(defun double-from-bits (sign exp sig) - (declare (type bit sign) (type (unsigned-byte 53) sig) - (type (unsigned-byte 11) exp)) - (make-double-float (dpb exp vm:double-float-exponent-byte - (dpb (ash sig -32) vm:double-float-significand-byte - (if (zerop sign) 0 -1))) - (ldb (byte 32 0) sig))) - - -;;;; Float parameters: - -(defconstant least-positive-single-float (single-from-bits 0 0 1)) -(defconstant least-positive-short-float least-positive-single-float) -(defconstant least-negative-single-float (single-from-bits 1 0 1)) -(defconstant least-negative-short-float least-negative-single-float) -(defconstant least-positive-double-float (double-from-bits 0 0 1)) -(defconstant least-positive-long-float least-positive-double-float) -(defconstant least-negative-double-float (double-from-bits 1 0 1)) -(defconstant least-negative-long-float least-negative-double-float) - -(defconstant least-positive-normalized-single-float - (single-from-bits 0 vm:single-float-normal-exponent-min 0)) -(defconstant least-positive-normalized-short-float - least-positive-normalized-single-float) -(defconstant least-negative-normalized-single-float - (single-from-bits 1 vm:single-float-normal-exponent-min 0)) -(defconstant least-negative-normalized-short-float - least-negative-normalized-single-float) -(defconstant least-positive-normalized-double-float - (double-from-bits 0 vm:double-float-normal-exponent-min 0)) -(defconstant least-positive-normalized-long-float - least-positive-normalized-double-float) -(defconstant least-negative-normalized-double-float - (double-from-bits 1 vm:double-float-normal-exponent-min 0)) -(defconstant least-negative-normalized-long-float - least-negative-normalized-double-float) - -(defconstant most-positive-single-float - (single-from-bits 0 vm:single-float-normal-exponent-max - (ldb vm:single-float-significand-byte -1))) -(defconstant most-positive-short-float most-positive-single-float) -(defconstant most-negative-single-float - (single-from-bits 1 vm:single-float-normal-exponent-max - (ldb vm:single-float-significand-byte -1))) -(defconstant most-negative-short-float most-negative-single-float) -(defconstant most-positive-double-float - (double-from-bits 0 vm:double-float-normal-exponent-max - (ldb vm:double-float-significand-byte -1))) -(defconstant most-positive-long-float most-positive-double-float) -(defconstant most-negative-double-float - (double-from-bits 1 vm:double-float-normal-exponent-max - (ldb vm:double-float-significand-byte -1))) -(defconstant most-negative-long-float most-negative-double-float) - -(defconstant single-float-positive-infinity - (single-from-bits 0 (1+ vm:single-float-normal-exponent-max) 0)) -(defconstant short-float-positive-infinity single-float-positive-infinity) -(defconstant single-float-negative-infinity - (single-from-bits 1 (1+ vm:single-float-normal-exponent-max) 0)) -(defconstant short-float-negative-infinity single-float-negative-infinity) -(defconstant double-float-positive-infinity - (double-from-bits 0 (1+ vm:double-float-normal-exponent-max) 0)) -(defconstant long-float-positive-infinity double-float-positive-infinity) -(defconstant double-float-negative-infinity - (double-from-bits 1 (1+ vm:double-float-normal-exponent-max) 0)) -(defconstant long-float-negative-infinity double-float-negative-infinity) - -(defconstant single-float-epsilon - (single-from-bits 0 (- vm:single-float-bias (1- vm:single-float-digits)) 1)) -(defconstant short-float-epsilon single-float-epsilon) -(defconstant single-float-negative-epsilon - (single-from-bits 0 (- vm:single-float-bias vm:single-float-digits) 1)) -(defconstant short-float-negative-epsilon single-float-negative-epsilon) -(defconstant double-float-epsilon - (double-from-bits 0 (- vm:double-float-bias (1- vm:double-float-digits)) 1)) -(defconstant long-float-epsilon double-float-epsilon) -(defconstant double-float-negative-epsilon - (double-from-bits 0 (- vm:double-float-bias vm:double-float-digits) 1)) -(defconstant long-float-negative-epsilon double-float-negative-epsilon) - - -;;;; Float predicates and environment query: - -(proclaim '(maybe-inline float-denormalized-p float-infinity-p float-nan-p - float-trapping-nan-p)) - -;;; FLOAT-DENORMALIZED-P -- Public -;;; -(defun float-denormalized-p (x) - "Return true if the float X is denormalized." - (number-dispatch ((x float)) - ((single-float) - (and (zerop (ldb vm:single-float-exponent-byte (single-float-bits x))) - (not (zerop x)))) - ((double-float) - (and (zerop (ldb vm:double-float-exponent-byte - (double-float-high-bits x))) - (not (zerop x)))))) - -(macrolet ((frob (name doc single double) - `(defun ,name (x) - ,doc - (number-dispatch ((x float)) - ((single-float) - (let ((bits (single-float-bits x))) - (and (> (ldb vm:single-float-exponent-byte bits) - vm:single-float-normal-exponent-max) - ,single))) - ((double-float) - (let ((hi (double-float-high-bits x)) - (lo (double-float-low-bits x))) - (and (> (ldb vm:double-float-exponent-byte hi) - vm:double-float-normal-exponent-max) - ,double))))))) - - (frob float-infinity-p "Return true if the float X is an infinity (+ or -)." - (zerop (ldb vm:single-float-significand-byte bits)) - (and (zerop (ldb vm:double-float-significand-byte hi)) - (zerop lo))) - - (frob float-nan-p "Return true if the float X is a NaN (Not a Number)." - (not (zerop (ldb vm:single-float-significand-byte bits))) - (or (not (zerop (ldb vm:double-float-significand-byte hi))) - (not (zerop lo)))) - - (frob float-trapping-nan-p - "Return true if the float X is a trapping NaN (Not a Number)." - (not (zerop (logand (ldb vm:single-float-significand-byte bits) - vm:single-float-trapping-nan-bit))) - (progn - lo; ignore - (not (zerop (logand (ldb vm:double-float-significand-byte hi) - vm:double-float-trapping-nan-bit)))))) - - -;;; FLOAT-PRECISION -- Public -;;; -;;; If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the -;;; actual exponent (and hence how denormalized it is), otherwise we just -;;; return the number of digits or 0. -;;; -(proclaim '(maybe-inline float-precision)) -(defun float-precision (f) - "Returns a non-negative number of significant digits in it's float argument. - Will be less than FLOAT-DIGITS if denormalized or zero." - (macrolet ((frob (digits bias decode) - `(cond ((zerop f) 0) - ((float-denormalized-p f) - (multiple-value-bind (ignore exp) - (,decode f) - (declare (ignore ignore)) - (truly-the fixnum - (+ ,digits (1- ,digits) ,bias exp)))) - (t - ,digits)))) - (number-dispatch ((f float)) - ((single-float) - (frob vm:single-float-digits vm:single-float-bias - integer-decode-single-denorm)) - ((double-float) - (frob vm:double-float-digits vm:double-float-bias - integer-decode-double-denorm))))) - - -(defun float-sign (float1 &optional (float2 (float 1 float1))) - "Returns a floating-point number that has the same sign as - float1 and, if float2 is given, has the same absolute value - as float2." - (declare (float float1 float2)) - (float-sign float1 float2)) - -(defun float-format-digits (format) - (ecase format - ((short-float single-float) vm:single-float-digits) - ((double-float long-float) vm:double-float-digits))) - -(proclaim '(inline float-digits float-radix)) - -(defun float-digits (f) - "Returns a non-negative number of radix-b digits used in the - representation of it's argument. See Common Lisp: The Language - by Guy Steele for more details." - (number-dispatch ((f float)) - ((single-float) vm:single-float-digits) - ((double-float) vm:double-float-digits))) - -(defun float-radix (f) - "Returns (as an integer) the radix b of its floating-point - argument." - (declare (ignore f)) - 2) - - - -;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT: - -(proclaim '(maybe-inline integer-decode-single-float - integer-decode-double-float)) - -;;; INTEGER-DECODE-SINGLE-DENORM -- Internal -;;; -;;; Handle the denormalized case of INTEGER-DECODE-FLOAT for SINGLE-FLOAT. -;;; -(defun integer-decode-single-denorm (x) - (declare (type single-float x)) - (let* ((bits (single-float-bits (abs x))) - (sig (ash (ldb vm:single-float-significand-byte bits) 1)) - (extra-bias 0)) - (declare (type (unsigned-byte 24) sig) - (type (integer 0 23) extra-bias)) - (loop - (unless (zerop (logand sig vm:single-float-hidden-bit)) - (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values sig - (- (- vm:single-float-bias) vm:single-float-digits extra-bias) - (if (minusp (float-sign x)) -1 1)))) - - -;;; INTEGER-DECODE-SINGLE-FLOAT -- Internal -;;; -;;; Handle the single-float case of INTEGER-DECODE-FLOAT. If an infinity or -;;; NAN, error. If a denorm, call i-d-s-DENORM to handle it. -;;; -(defun integer-decode-single-float (x) - (declare (single-float x)) - (let* ((bits (single-float-bits (abs x))) - (exp (ldb vm:single-float-exponent-byte bits)) - (sig (ldb vm:single-float-significand-byte bits)) - (sign (if (minusp (float-sign x)) -1 1)) - (biased (- exp vm:single-float-bias vm:single-float-digits))) - (declare (fixnum biased)) - (unless (<= exp vm:single-float-normal-exponent-max) - (error "Can't decode NAN or infinity: ~S." x)) - (cond ((and (zerop exp) (zerop sig)) - (values 0 biased sign)) - ((< exp vm:single-float-normal-exponent-min) - (integer-decode-single-denorm x)) - (t - (values (logior sig vm:single-float-hidden-bit) biased sign))))) - - -;;; INTEGER-DECODE-DOUBLE-DENORM -- Internal -;;; -;;; Like INTEGER-DECODE-SINGLE-DENORM, only doubly so. -;;; -(defun integer-decode-double-denorm (x) - (declare (type double-float x)) - (let* ((high-bits (double-float-high-bits (abs x))) - (sig-high (ldb vm:double-float-significand-byte high-bits)) - (low-bits (double-float-low-bits x)) - (sign (if (minusp (float-sign x)) -1 1)) - (biased (- (- vm:double-float-bias) vm:double-float-digits))) - (if (zerop sig-high) - (let ((sig low-bits) - (extra-bias (- vm:double-float-digits 33)) - (bit (ash 1 31))) - (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) - (loop - (unless (zerop (logand sig bit)) (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values (ash sig (- vm:double-float-digits 32)) - (truly-the fixnum (- biased extra-bias)) - sign)) - (let ((sig (ash sig-high 1)) - (extra-bias 0)) - (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) - (loop - (unless (zerop (logand sig vm:double-float-hidden-bit)) - (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values (logior (ash sig 32) (ash low-bits (1- extra-bias))) - (truly-the fixnum (- biased extra-bias)) - sign))))) - - -;;; INTEGER-DECODE-DOUBLE-FLOAT -- Internal -;;; -;;; Like INTEGER-DECODE-SINGLE-FLOAT, only doubly so. -;;; -(defun integer-decode-double-float (x) - (declare (double-float x)) - (let* ((abs (abs x)) - (hi (double-float-high-bits abs)) - (lo (double-float-low-bits abs)) - (exp (ldb vm:double-float-exponent-byte hi)) - (sig (ldb vm:double-float-significand-byte hi)) - (sign (if (minusp (float-sign x)) -1 1)) - (biased (- exp vm:double-float-bias vm:double-float-digits))) - (declare (fixnum biased)) - (unless (<= exp vm:double-float-normal-exponent-max) - (error "Can't decode NAN or infinity: ~S." x)) - (cond ((and (zerop exp) (zerop sig) (zerop lo)) - (values 0 biased sign)) - ((< exp vm:double-float-normal-exponent-min) - (integer-decode-double-denorm x)) - (t - (values - (logior (ash (logior (ldb vm:double-float-significand-byte hi) - vm:double-float-hidden-bit) - 32) - lo) - biased sign))))) - - -;;; INTEGER-DECODE-FLOAT -- Public -;;; -;;; Dispatch to the correct type-specific i-d-f function. -;;; -(defun integer-decode-float (x) - "Returns three values: - 1) an integer representation of the significand. - 2) the exponent for the power of 2 that the significand must be multiplied - by to get the actual value. This differs from the DECODE-FLOAT exponent - by FLOAT-DIGITS, since the significand has been scaled to have all its - digits before the radix point. - 3) -1 or 1 (i.e. the sign of the argument.)" - (number-dispatch ((x float)) - ((single-float) - (integer-decode-single-float x)) - ((double-float) - (integer-decode-double-float x)))) - - -(proclaim '(maybe-inline decode-single-float decode-double-float)) - -;;; DECODE-SINGLE-DENORM -- Internal -;;; -;;; Handle the denormalized case of DECODE-SINGLE-FLOAT. We call -;;; INTEGER-DECODE-SINGLE-DENORM and then make the result into a float. -;;; -(defun decode-single-denorm (x) - (declare (type single-float x)) - (multiple-value-bind (sig exp sign) - (integer-decode-single-denorm x) - (values (make-single-float - (dpb sig vm:single-float-significand-byte - (dpb vm:single-float-bias vm:single-float-exponent-byte 0))) - (truly-the fixnum (+ exp vm:single-float-digits)) - (float sign x)))) - - -;;; DECODE-SINGLE-FLOAT -- Internal -;;; -;;; Handle the single-float case of DECODE-FLOAT. If an infinity or NAN, -;;; error. If a denorm, call d-s-DENORM to handle it. -;;; -(defun decode-single-float (x) - (declare (single-float x)) - (let* ((bits (single-float-bits (abs x))) - (exp (ldb vm:single-float-exponent-byte bits)) - (sign (float-sign x)) - (biased (truly-the single-float-exponent - (- exp vm:single-float-bias)))) - (unless (<= exp vm:single-float-normal-exponent-max) - (error "Can't decode NAN or infinity: ~S." x)) - (cond ((zerop x) - (values 0.0f0 biased sign)) - ((< exp vm:single-float-normal-exponent-min) - (decode-single-denorm x)) - (t - (values (make-single-float - (dpb vm:single-float-bias - vm:single-float-exponent-byte - bits)) - biased sign))))) - - -;;; DECODE-DOUBLE-DENORM -- Internal -;;; -;;; Like DECODE-SINGLE-DENORM, only doubly so. -;;; -(defun decode-double-denorm (x) - (declare (double-float x)) - (multiple-value-bind (sig exp sign) - (integer-decode-double-denorm x) - (values (make-double-float - (dpb (logand (ash sig -32) (lognot vm:double-float-hidden-bit)) - vm:double-float-significand-byte - (dpb vm:double-float-bias vm:double-float-exponent-byte 0)) - (ldb (byte 32 0) sig)) - (truly-the fixnum (+ exp vm:double-float-digits)) - (float sign x)))) - - -;;; DECODE-DOUBLE-FLOAT -- Public -;;; -;;; Like DECODE-SINGLE-FLOAT, only doubly so. -;;; -(defun decode-double-float (x) - (declare (double-float x)) - (let* ((abs (abs x)) - (hi (double-float-high-bits abs)) - (lo (double-float-low-bits abs)) - (exp (ldb vm:double-float-exponent-byte hi)) - (sign (float-sign x)) - (biased (truly-the double-float-exponent - (- exp vm:double-float-bias)))) - (unless (<= exp vm:double-float-normal-exponent-max) - (error "Can't decode NAN or infinity: ~S." x)) - (cond ((zerop x) - (values 0.0d0 biased sign)) - ((< exp vm:double-float-normal-exponent-min) - (decode-double-denorm x)) - (t - (values (make-double-float - (dpb vm:double-float-bias vm:double-float-exponent-byte hi) - lo) - biased sign))))) - - -;;; DECODE-FLOAT -- Public -;;; -;;; Dispatch to the appropriate type-specific function. -;;; -(defun decode-float (f) - "Returns three values: - 1) a floating-point number representing the significand. This is always - between 0.5 (inclusive) and 1.0 (exclusive). - 2) an integer representing the exponent. - 3) -1.0 or 1.0 (i.e. the sign of the argument.)" - (number-dispatch ((f float)) - ((single-float) - (decode-single-float f)) - ((double-float) - (decode-double-float f)))) - - -;;;; SCALE-FLOAT: - -(proclaim '(maybe-inline scale-single-float scale-double-float)) - -;;; SCALE-FLOAT-MAYBE-UNDERFLOW -- Internal -;;; -;;; Handle float scaling where the X is denormalized or the result is -;;; denormalized or underflows to 0. -;;; -(defun scale-float-maybe-underflow (x exp) - (multiple-value-bind (sig old-exp) - (integer-decode-float x) - (let* ((digits (float-digits x)) - (new-exp (+ exp old-exp digits - (etypecase x - (single-float vm:single-float-bias) - (double-float vm:double-float-bias)))) - (sign (if (minusp (float-sign x)) 1 0))) - (cond - ((< new-exp - (etypecase x - (single-float vm:single-float-normal-exponent-min) - (double-float vm:double-float-normal-exponent-min))) - (when (vm:current-float-trap :inexact) - (error 'floating-point-inexact :operation 'scale-float - :operands (list x exp))) - (when (vm:current-float-trap :underflow) - (error 'floating-point-underflow :operation 'scale-float - :operands (list x exp))) - (let ((shift (1- new-exp))) - (if (< shift (- (1- digits))) - (float-sign x 0.0) - (etypecase x - (single-float (single-from-bits sign 0 (ash sig shift))) - (double-float (double-from-bits sign 0 (ash sig shift))))))) - (t - (etypecase x - (single-float (single-from-bits sign new-exp sig)) - (double-float (double-from-bits sign new-exp sig)))))))) - - -;;; SCALE-FLOAT-MAYBE-OVERFLOW -- Internal -;;; -;;; Called when scaling a float overflows, or the oringinal float was a NaN -;;; or infinity. If overflow errors are trapped, then error, otherwise return -;;; the appropriate infinity. If a NaN, signal or not as appropriate. -;;; -(defun scale-float-maybe-overflow (x exp) - (cond - ((float-infinity-p x) - ;; Infinity is infinity, no matter how small... - x) - ((float-nan-p x) - (when (and (float-trapping-nan-p x) - (vm:current-float-trap :invalid)) - (error 'floating-point-invalid-operation :operation 'scale-float - :operands (list x exp))) - x) - (t - (when (vm:current-float-trap :overflow) - (error 'floating-point-overflow :operation 'scale-float - :operands (list x exp))) - (when (vm:current-float-trap :inexact) - (error 'floating-point-inexact :operation 'scale-float - :operands (list x exp))) - (* (float-sign x) - (etypecase x - (single-float single-float-positive-infinity) - (double-float double-float-positive-infinity)))))) - - -;;; SCALE-SINGLE-FLOAT, SCALE-DOUBLE-FLOAT -- Internal -;;; -;;; Scale a single or double float, calling the correct over/underflow -;;; functions. -;;; -(defun scale-single-float (x exp) - (declare (single-float x) (fixnum exp)) - (let* ((bits (single-float-bits x)) - (old-exp (ldb vm:single-float-exponent-byte bits)) - (new-exp (+ old-exp exp))) - (cond - ((zerop x) x) - ((or (< old-exp vm:single-float-normal-exponent-min) - (< new-exp vm:single-float-normal-exponent-min)) - (scale-float-maybe-underflow x exp)) - ((or (> old-exp vm:single-float-normal-exponent-max) - (> new-exp vm:single-float-normal-exponent-max)) - (scale-float-maybe-overflow x exp)) - (t - (make-single-float (dpb new-exp vm:single-float-exponent-byte bits)))))) -;;; -(defun scale-double-float (x exp) - (declare (double-float x) (fixnum exp)) - (let* ((hi (double-float-high-bits x)) - (lo (double-float-low-bits x)) - (old-exp (ldb vm:double-float-exponent-byte hi)) - (new-exp (+ old-exp exp))) - (cond - ((zerop x) x) - ((or (< old-exp vm:double-float-normal-exponent-min) - (< new-exp vm:double-float-normal-exponent-min)) - (scale-float-maybe-underflow x exp)) - ((or (> old-exp vm:double-float-normal-exponent-max) - (> new-exp vm:double-float-normal-exponent-max)) - (scale-float-maybe-overflow x exp)) - (t - (make-double-float (dpb new-exp vm:double-float-exponent-byte hi) - lo))))) - - -;;; SCALE-FLOAT -- Public -;;; -;;; Dispatch to the correct type-specific scale-float function. -;;; -(defun scale-float (f ex) - "Returns the value (* f (expt (float 2 f) ex)), but with no unnecessary loss - of precision or overflow." - (number-dispatch ((f float)) - ((single-float) - (scale-single-float f ex)) - ((double-float) - (scale-double-float f ex)))) - - -;;;; Converting to/from floats: - -(defun float (number &optional (other () otherp)) - "Converts any REAL to a float. If OTHER is not provided, it returns a - SINGLE-FLOAT if NUMBER is not already a FLOAT. If OTHER is provided, the - result is the same float format as OTHER." - (if otherp - (number-dispatch ((number real) (other float)) - (((foreach rational single-float double-float) - (foreach single-float double-float)) - (coerce number '(dispatch-type other)))) - (if (floatp number) - number - (coerce number 'single-float)))) - - -(macrolet ((frob (name type) - `(defun ,name (x) - (number-dispatch ((x real)) - (((foreach single-float double-float fixnum)) - (coerce x ',type)) - ((bignum) - (bignum-to-float x ',type)) - ((ratio) - (let ((num (numerator x)) - (den (denominator x))) - (if (and (fixnump num) (fixnump den)) - (/ (coerce num ',type) (coerce den ',type)) - (float-bignum-ratio x ',type)))))))) - (frob %single-float single-float) - (frob %double-float double-float)) - - -#| -These might be useful if we ever have a machine w/o float/integer conversion -hardware. For now, we'll use special ops that uninterruptibly frob the -rounding modes & do ieee round-to-integer. - -;;; %UNARY-TRUNCATE-SINGLE-FLOAT/FIXNUM -- Interface -;;; -;;; The compiler compiles a call to this when we are doing %UNARY-TRUNCATE -;;; and the result is known to be a fixnum. We can avoid some generic -;;; arithmetic in this case. -;;; -(defun %unary-truncate-single-float/fixnum (x) - (declare (single-float x) (values fixnum)) - (locally (declare (optimize (speed 3) (safety 0))) - (let* ((bits (single-float-bits x)) - (exp (ldb vm:single-float-exponent-byte bits)) - (frac (logior (ldb vm:single-float-significand-byte bits) - vm:single-float-hidden-bit)) - (shift (- exp vm:single-float-digits vm:single-float-bias))) - (when (> exp vm:single-float-normal-exponent-max) - (error 'floating-point-invalid-operation :operator 'truncate - :operands (list x))) - (if (<= shift (- vm:single-float-digits)) - 0 - (let ((res (ash frac shift))) - (declare (type (unsigned-byte 31) res)) - (if (minusp bits) - (- res) - res)))))) - - -;;; %UNARY-TRUNCATE-DOUBLE-FLOAT/FIXNUM -- Interface -;;; -;;; Double-float version of this operation (see above single op). -;;; -(defun %unary-truncate-double-float/fixnum (x) - (declare (double-float x) (values fixnum)) - (locally (declare (optimize (speed 3) (safety 0))) - (let* ((hi-bits (double-float-high-bits x)) - (exp (ldb vm:double-float-exponent-byte hi-bits)) - (frac (logior (ldb vm:double-float-significand-byte hi-bits) - vm:double-float-hidden-bit)) - (shift (- exp (- vm:double-float-digits vm:word-bits) - vm:double-float-bias))) - (when (> exp vm:double-float-normal-exponent-max) - (error 'floating-point-invalid-operation :operator 'truncate - :operands (list x))) - (if (<= shift (- vm:word-bits vm:double-float-digits)) - 0 - (let* ((res-hi (ash frac shift)) - (res (if (plusp shift) - (logior res-hi - (the fixnum - (ash (double-float-low-bits x) - (- shift vm:word-bits)))) - res-hi))) - (declare (type (unsigned-byte 31) res-hi res)) - (if (minusp hi-bits) - (- res) - res)))))) -|# - - -;;; %UNARY-TRUNCATE -- Interface -;;; -;;; This function is called when we are doing a truncate without any funky -;;; divisor, i.e. converting a float or ratio to an integer. Note that we do -;;; *not* return the second value of truncate, so it must be computed by the -;;; caller if needed. -;;; -;;; In the float case, we pick off small arguments so that compiler can use -;;; special-case operations. We use an exclusive test, since (due to round-off -;;; error), (float most-positive-fixnum) may be greater than -;;; most-positive-fixnum. -;;; -(defun %unary-truncate (number) - (number-dispatch ((number real)) - ((integer) number) - ((ratio) (values (truncate (numerator number) (denominator number)))) - (((foreach single-float double-float)) - (if (< (float most-negative-fixnum number) - number - (float most-positive-fixnum number)) - (truly-the fixnum (%unary-truncate number)) - (multiple-value-bind (bits exp) - (integer-decode-float number) - (let ((res (ash bits exp))) - (if (minusp number) - (- res) - res))))))) - - -;;; %UNARY-ROUND -- Interface -;;; -;;; Similar to %UNARY-TRUNCATE, but rounds to the nearest integer. If we -;;; can't use the round primitive, then we do our own round-to-nearest on the -;;; result of i-d-f. [Note that this rounding will really only happen with -;;; double floats, since the whole single-float fraction will fit in a fixnum, -;;; so all single-floats larger than most-positive-fixnum can be precisely -;;; represented by an integer.] -;;; -(defun %unary-round (number) - (number-dispatch ((number real)) - ((integer) number) - ((ratio) (values (round (numerator number) (denominator number)))) - (((foreach single-float double-float)) - (if (< (float most-negative-fixnum number) - number - (float most-positive-fixnum number)) - (truly-the fixnum (%unary-round number)) - (multiple-value-bind (bits exp) - (integer-decode-float number) - (let* ((shifted (ash bits exp)) - (rounded (if (and (minusp exp) - (oddp shifted) - (eql (logand bits - (lognot (ash -1 (- exp)))) - (ash 1 (- -1 exp)))) - (1+ shifted) - shifted))) - (if (minusp number) - (- rounded) - rounded))))))) - - -(defun rational (x) - "RATIONAL produces a rational number for any real numeric argument. This is - more efficient than RATIONALIZE, but it assumes that floating-point is - completely accurate, giving a result that isn't as pretty." - (number-dispatch ((x real)) - (((foreach single-float double-float)) - (multiple-value-bind (bits exp) - (integer-decode-float x) - (if (eql bits 0) - 0 - (let* ((int (if (minusp x) (- bits) bits)) - (digits (float-digits x)) - (ex (+ exp digits))) - (if (minusp ex) - (integer-/-integer int (ash 1 (+ digits (- ex)))) - (integer-/-integer (ash int ex) (ash 1 digits))))))) - ((rational) x))) - - -(defun rationalize (x) - "Converts any REAL to a RATIONAL. Floats are converted to a simple rational - representation exploiting the assumption that floats are only accurate to - their precision. RATIONALIZE (and also RATIONAL) preserve the invariant: - (= x (float (rationalize x) x))" - (number-dispatch ((x real)) - (((foreach single-float double-float)) - ;; Thanks to Kim Fateman, who stole this function rationalize-float - ;; from macsyma's rational. Macsyma'a rationalize was written - ;; by the legendary Gosper (rwg). Gosper is now working for Symbolics. - ;; Guy Steele said about Gosper, "He has been called the - ;; only living 17th century mathematician and is also the best - ;; pdp-10 hacker I know." So, if you can understand or debug this - ;; code you win big. - (cond ((minusp x) (- (rationalize (- x)))) - ((zerop x) 0) - (t - (let ((eps (if (typep x 'single-float) - single-float-epsilon - double-float-epsilon)) - (y ()) - (a ())) - (do ((xx x (setq y (/ (float 1.0 x) (- xx (float a x))))) - (num (setq a (truncate x)) - (+ (* (setq a (truncate y)) num) onum)) - (den 1 (+ (* a den) oden)) - (onum 1 num) - (oden 0 den)) - ((and (not (zerop den)) - (not (> (abs (/ (- x (/ (float num x) - (float den x))) - x)) - eps))) - (integer-/-integer num den)) - (declare ((dispatch-type x) xx))))))) - ((rational) x))) diff --git a/code/foreign.lisp b/code/foreign.lisp deleted file mode 100644 index 57245c217af3a26d5c975819b2b686c1eed151e7..0000000000000000000000000000000000000000 --- a/code/foreign.lisp +++ /dev/null @@ -1,216 +0,0 @@ -;;; -*- Package: SYSTEM -*- -;;; -;;; ********************************************************************** -;;; 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/code/foreign.lisp,v 1.12 1992/07/17 16:03:41 ram Exp $") -;;; -;;; ********************************************************************** -;;; -(in-package "SYSTEM") - -(in-package "ALIEN") -(export '(load-foreign)) -(in-package "SYSTEM") -(import 'alien:load-foreign) - -(defvar *previous-linked-object-file* nil) -(defvar *foreign-segment-free-pointer* foreign-segment-start) - -(defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C")) - (let ((code (char-code #\A))) - (loop - (let ((name (format nil base (unix:unix-getpid) (code-char code)))) - (multiple-value-bind - (fd errno) - (unix:unix-open name - (logior unix:o_wronly unix:o_creat unix:o_excl) - #o666) - (cond ((not (null fd)) - (unix:unix-close fd) - (return name)) - ((not (= errno unix:eexist)) - (error "Could not create temporary file ~S: ~A" - name (unix:get-unix-error-msg errno))) - - ((= code (char-code #\Z)) - (setf code (char-code #\a))) - ((= code (char-code #\z)) - (return nil)) - (t - (incf code)))))))) - -#+sparc -(alien:def-alien-type exec - (alien:struct nil - (magic c-call:unsigned-long) - (text c-call:unsigned-long) - (data c-call:unsigned-long) - (bss c-call:unsigned-long) - (syms c-call:unsigned-long) - (entry c-call:unsigned-long) - (trsize c-call:unsigned-long) - (drsize c-call:unsigned-long))) - -(defun allocate-space-in-foreign-segment (bytes) - (let* ((pagesize-1 (1- (get-page-size))) - (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1)) - (addr (int-sap *foreign-segment-free-pointer*)) - (new-ptr (+ *foreign-segment-free-pointer* bytes))) - (when (> new-ptr (+ foreign-segment-start foreign-segment-size)) - (error "Not enough memory left.")) - (setf *foreign-segment-free-pointer* new-ptr) - (allocate-system-memory-at addr memory-needed) - addr)) - -#+sparc -(defun load-object-file (name) - (format t ";;; Loading object file...~%") - (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0) - (unless fd - (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno))) - (unwind-protect - (alien:with-alien ((header exec)) - (unix:unix-read fd - (alien:alien-sap header) - (alien:alien-size exec :bytes)) - (let* ((len-of-text-and-data - (+ (alien:slot header 'text) (alien:slot header 'data))) - (memory-needed - (+ len-of-text-and-data (alien:slot header 'bss))) - (addr (allocate-space-in-foreign-segment memory-needed))) - (unix:unix-read fd addr len-of-text-and-data))) - (unix:unix-close fd)))) - -#+pmax -(alien:def-alien-type filehdr - (alien:struct nil - (magic c-call:unsigned-short) - (nscns c-call:unsigned-short) - (timdat c-call:long) - (symptr c-call:long) - (nsyms c-call:long) - (opthdr c-call:unsigned-short) - (flags c-call:unsigned-short))) - -#+pmax -(alien:def-alien-type aouthdr - (alien:struct nil - (magic c-call:short) - (vstamp c-call:short) - (tsize c-call:long) - (dsize c-call:long) - (bsize c-call:long) - (entry c-call:long) - (text_start c-call:long) - (data_start c-call:long))) - -#+pmax -(defconstant filhsz 20) -#+pmax -(defconstant aouthsz 56) -#+pmax -(defconstant scnhsz 40) - -#+pmax -(defun load-object-file (name) - (format t ";;; Loading object file...~%") - (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0) - (unless fd - (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno))) - (unwind-protect - (alien:with-alien ((filehdr filehdr) - (aouthdr aouthdr)) - (unix:unix-read fd - (alien:alien-sap filehdr) - (alien:alien-size filehdr :bytes)) - (unix:unix-read fd - (alien:alien-sap aouthdr) - (alien:alien-size aouthdr :bytes)) - (let* ((len-of-text-and-data - (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize))) - (memory-needed - (+ len-of-text-and-data (alien:slot aouthdr 'bsize))) - (addr (allocate-space-in-foreign-segment memory-needed)) - (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15))) - (unix:unix-lseek fd - (logandc2 (+ filhsz aouthsz - (* scnhsz - (alien:slot filehdr 'nscns)) - pad-size-1) - pad-size-1) - unix:l_set) - (unix:unix-read fd addr len-of-text-and-data))) - (unix:unix-close fd)))) - -(defun parse-symbol-table (name) - (format t ";;; Parsing symbol table...~%") - (let ((symbol-table (make-hash-table :test #'equal))) - (with-open-file (file name) - (loop - (let ((line (read-line file nil nil))) - (unless line - (return)) - (let* ((symbol (subseq line 11)) - (address (parse-integer line :end 8 :radix 16)) - (old-address (gethash symbol lisp::*foreign-symbols*))) - (unless (or (null old-address) (= address old-address)) - (warn "~S moved from #x~8,'0X to #x~8,'0X.~%" - symbol old-address address)) - (setf (gethash symbol symbol-table) address))))) - (setf lisp::*foreign-symbols* symbol-table))) - -(defun load-foreign (files &key - (libraries '("-lc")) - (base-file - (merge-pathnames *command-line-utility-name* - "path:")) - (env ext:*environment-list*)) - "Load-foreign loads a list of C object files into a running Lisp. The files - argument should be a single file or a list of files. The files may be - specified as namestrings or as pathnames. The libraries argument should be a - list of library files as would be specified to ld. They will be searched in - the order given. The default is just \"-lc\", i.e., the C library. The - base-file argument is used to specify a file to use as the starting place for - defined symbols. The default is the C start up code for Lisp. The env - argument is the Unix environment variable definitions for the invocation of - the linker. The default is the environment passed to Lisp." - (let ((output-file (pick-temporary-file-name)) - (symbol-table-file (pick-temporary-file-name)) - (error-output (make-string-output-stream))) - - (format t ";;; Running library:load-foreign.csh...~%") - (force-output) - (let ((proc (ext:run-program "library:load-foreign.csh" - (list* (or *previous-linked-object-file* - (namestring (truename base-file))) - (format nil "~X" - *foreign-segment-free-pointer*) - output-file - symbol-table-file - (append (if (atom files) - (list files) - files) - libraries)) - :env env - :input nil - :output error-output - :error :output))) - (unless proc - (error "Could not run library:load-foreign.csh")) - (unless (zerop (ext:process-exit-code proc)) - (system:serve-all-events 0) - (error "library:load-foreign.csh failed:~%~A" - (get-output-stream-string error-output))) - (load-object-file output-file) - (parse-symbol-table symbol-table-file) - (unix:unix-unlink symbol-table-file) - (let ((old-file *previous-linked-object-file*)) - (setf *previous-linked-object-file* output-file) - (when old-file - (unix:unix-unlink old-file))))) - (format t ";;; Done.~%")) diff --git a/code/format-time.lisp b/code/format-time.lisp deleted file mode 100644 index c3670fc497474b0457d01a204ee376d68f45b78c..0000000000000000000000000000000000000000 --- a/code/format-time.lisp +++ /dev/null @@ -1,194 +0,0 @@ -;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*- - -;;; ********************************************************************** -;;; 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/code/format-time.lisp,v 1.3 1991/02/08 13:32:55 ram Exp $") -;;; -;;; ********************************************************************** - -;;; Really slick time printing routines built upon the Common Lisp -;;; format function. - -;;; Written by Jim Healy, September 1987. - -;;; ********************************************************************** - -(in-package "EXTENSIONS" :use '("LISP")) - -(export '(format-universal-time format-decoded-time)) - -(defconstant abbrev-weekday-table - '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) - -(defconstant long-weekday-table - '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" - "Sunday")) - -(defconstant abbrev-month-table - '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" - "Dec")) - -(defconstant long-month-table - '#("January" "February" "March" "April" "May" "June" "July" "August" - "September" "October" "November" "December")) - -;;; The timezone-table is incomplete but workable. - -(defconstant timezone-table - '#("GMT" "" "" "" "" "EST" "CST" "MST" "PST")) - -;;; Valid-Destination-P ensures the destination stream is okay -;;; for the Format function. - -(defun valid-destination-p (destination) - (or (not destination) - (eq destination 't) - (streamp destination) - (and (stringp destination) - (array-has-fill-pointer-p destination)))) - -;;; Format-Universal-Time - External. - -(defun format-universal-time (destination universal-time - &key (timezone nil) - (style :short) - (date-first t) - (print-seconds t) - (print-meridian t) - (print-timezone t) - (print-weekday t)) - "Format-Universal-Time formats a string containing the time and date - given by universal-time in a common manner. The destination is any - destination which can be accepted by the Format function. The - timezone keyword is an integer specifying hours west of Greenwich. - The style keyword can be :short (numeric date), :long (months and - weekdays expressed as words), :abbreviated (like :long but words are - abbreviated), or :government (of the form \"XX Mon XX XX:XX:XX\") - The keyword date-first, if nil, will print the time first instead - of the date (the default). The print- keywords, if nil, inhibit - the printing of the obvious part of the time/date." - (unless (valid-destination-p destination) - (error "~A: Not a valid format destination." destination)) - (unless (integerp universal-time) - (error "~A: Universal-Time should be an integer." universal-time)) - (when timezone - (unless (and (rationalp timezone) (<= -24 timezone 24)) - (error "~A: Timezone should be a rational between -24 and 24." timezone)) - (unless (zerop (rem timezone 1/3600)) - (error "~A: Timezone is not a second (1/3600) multiple." timezone))) - - (multiple-value-bind (secs mins hours day month year dow dst tz) - (if timezone - (decode-universal-time universal-time timezone) - (decode-universal-time universal-time)) - (declare (ignore dst) (fixnum secs mins hours day month year dow)) - (let ((time-string "~2,'0D:~2,'0D") - (date-string - (case style - (:short "~D/~D/~2,'0D") ;; MM/DD/YY - ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, YYYY - (:government "~2,'0D ~:@(~A~) ~D") ;; DD MON YY - (t - (error "~A: Unrecognized :style keyword value." style)))) - (time-args - (list mins (max (mod hours 12) (1+ (mod (1- hours) 12))))) - (date-args (case style - (:short - (list month day (mod year 100))) - (:abbreviated - (list (svref abbrev-month-table (1- month)) day year)) - (:long - (list (svref long-month-table (1- month)) day year)) - (:government - (list day (svref abbrev-month-table (1- month)) - (mod year 100)))))) - (declare (simple-string time-string date-string)) - (when print-weekday - (push (case style - ((:short :long) (svref long-weekday-table dow)) - (:abbreviated (svref abbrev-weekday-table dow)) - (:government (svref abbrev-weekday-table dow))) - date-args) - (setq date-string - (concatenate 'simple-string "~A, " date-string))) - (when (or print-seconds (eq style :government)) - (push secs time-args) - (setq time-string - (concatenate 'simple-string time-string ":~2,'0D"))) - (when print-meridian - (push (signum (floor hours 12)) time-args) - (setq time-string - (concatenate 'simple-string time-string " ~[am~;pm~]"))) - (apply #'format destination - (if date-first - (concatenate 'simple-string date-string " " time-string - (if print-timezone " ~A")) - (concatenate 'simple-string time-string " " date-string - (if print-timezone " ~A"))) - (if date-first - (nconc date-args (nreverse time-args) - (if print-timezone - (list - (let ((which-zone (or timezone tz))) - (if (or (= 0 which-zone) (<= 5 which-zone 8)) - (svref timezone-table which-zone) - (format nil "[~D]" which-zone)))))) - (nconc (nreverse time-args) date-args - (if print-timezone - (list - (let ((which-zone (or timezone tz))) - (if (or (= 0 which-zone) (< 5 which-zone 8)) - (svref timezone-table which-zone) - (format nil "[~D]" which-zone))))))))))) - -;;; Format-Decoded-Time - External. - -(defun format-decoded-time (destination seconds minutes hours - day month year - &key (timezone nil) - (style :short) - (date-first t) - (print-seconds t) - (print-meridian t) - (print-timezone t) - (print-weekday t)) - "Format-Decoded-Time formats a string containing decoded-time - expressed in a humanly-readable manner. The destination is any - destination which can be accepted by the Format function. The - timezone keyword is an integer specifying hours west of Greenwich. - The style keyword can be :short (numeric date), :long (months and - weekdays expressed as words), or :abbreviated (like :long but words are - abbreviated). The keyword date-first, if nil, will cause the time - to be printed first instead of the date (the default). The print- - keywords, if nil, inhibit the printing of certain semi-obvious - parts of the string." - (unless (valid-destination-p destination) - (error "~A: Not a valid format destination." destination)) - (unless (and (integerp seconds) (<= 0 seconds 59)) - (error "~A: Seconds should be an integer between 0 and 59." seconds)) - (unless (and (integerp minutes) (<= 0 minutes 59)) - (error "~A: Minutes should be an integer between 0 and 59." minutes)) - (unless (and (integerp hours) (<= 0 hours 23)) - (error "~A: Hours should be an integer between 0 and 23." hours)) - (unless (and (integerp day) (<= 1 day 31)) - (error "~A: Day should be an integer between 1 and 31." day)) - (unless (and (integerp month) (<= 1 month 12)) - (error "~A: Month should be an integer between 1 and 12." month)) - (unless (and (integerp year) (plusp year)) - (error "~A: Hours should be an non-negative integer." year)) - (when timezone - (unless (and (integerp timezone) (<= 0 timezone 32)) - (error "~A: Timezone should be an integer between 0 and 32." - timezone))) - (format-universal-time destination - (encode-universal-time seconds minutes hours day month year) - :timezone timezone :style style :date-first date-first - :print-seconds print-seconds :print-meridian print-meridian - :print-timezone print-timezone :print-weekday print-weekday)) - - diff --git a/code/format.lisp b/code/format.lisp deleted file mode 100644 index 1f9f272b03992f8b26bd9e64aa98e867135e9825..0000000000000000000000000000000000000000 --- a/code/format.lisp +++ /dev/null @@ -1,2371 +0,0 @@ -;;; -*- Package: FORMAT -*- -;;; -;;; ********************************************************************** -;;; 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/code/format.lisp,v 1.25 1992/11/06 04:15:56 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp. -;;; -;;; Written by William Lott, with lots of stuff stolen from the previous -;;; version by David Adam and later rewritten by Bill Maddox. -;;; - -(in-package "FORMAT") -(use-package "EXT") -(use-package "KERNEL") - -(in-package "LISP") -(export '(format formatter)) - -(in-package "FORMAT") - -(defstruct (format-directive - (:print-function %print-format-directive)) - (string (required-argument) :type simple-string) - (start (required-argument) :type (and unsigned-byte fixnum)) - (end (required-argument) :type (and unsigned-byte fixnum)) - (character (required-argument) :type base-character) - (colonp nil :type (member t nil)) - (atsignp nil :type (member t nil)) - (params nil :type list)) - -(defun %print-format-directive (struct stream depth) - (declare (ignore depth)) - (print-unreadable-object (struct stream) - (write-string (format-directive-string struct) stream - :start (format-directive-start struct) - :end (format-directive-end struct)))) - -(defvar *format-directive-expanders* - (make-array char-code-limit :initial-element nil)) -(defvar *format-directive-interpreters* - (make-array char-code-limit :initial-element nil)) - -(defun %print-format-error (condition stream) - (cl:format stream - "~:[~;Error in format: ~]~ - ~?~@[~% ~A~% ~V@T^~]" - (format-error-print-banner condition) - (format-error-complaint condition) - (format-error-arguments condition) - (format-error-control-string condition) - (format-error-offset condition))) - -(defvar *default-format-error-control-string* nil) -(defvar *default-format-error-offset* nil) - -(define-condition format-error (error) - ((complaint) - (arguments :init-form nil) - (control-string :init-form *default-format-error-control-string*) - (offset :init-form *default-format-error-offset*) - (print-banner :init-form t)) - (:report %print-format-error)) - - - -;;;; TOKENIZE-CONTROL-STRING - -(defun tokenize-control-string (string) - (declare (simple-string string)) - (let ((index 0) - (end (length string)) - (result nil)) - (loop - (let ((next-directive (or (position #\~ string :start index) end))) - (when (> next-directive index) - (push (subseq string index next-directive) result)) - (when (= next-directive end) - (return)) - (let ((directive (parse-directive string next-directive))) - (push directive result) - (setf index (format-directive-end directive))))) - (nreverse result))) - -(defun parse-directive (string start) - (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil) - (end (length string))) - (flet ((get-char () - (if (= posn end) - (error 'format-error - :complaint "String ended before directive was found." - :control-string string - :offset start) - (schar string posn)))) - (loop - (let ((char (get-char))) - (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) - (multiple-value-bind - (param new-posn) - (parse-integer string :start posn :junk-allowed t) - (push (cons posn param) params) - (setf posn new-posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return))))) - ((or (char= char #\v) (char= char #\V)) - (push (cons posn :arg) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((char= char #\#) - (push (cons posn :remaining) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((char= char #\') - (incf posn) - (push (cons posn (get-char)) params)) - ((char= char #\,) - (push (cons (1- posn) nil) params)) - ((char= char #\:) - (if colonp - (error 'format-error - :complaint "Too many colons supplied." - :control-string string - :offset posn) - (setf colonp t))) - ((char= char #\@) - (if atsignp - (error 'format-error - :complaint "Too many at-signs supplied." - :control-string string - :offset posn) - (setf atsignp t))) - (t - (when (char= (schar string (1- posn)) #\,) - (push (cons (1- posn) nil) params)) - (return)))) - (incf posn)) - (let ((char (get-char))) - (when (char= char #\/) - (let ((closing-slash (position #\/ string :start (1+ posn)))) - (if closing-slash - (setf posn closing-slash) - (error 'format-error - :complaint "No matching closing slash." - :control-string string - :offset posn)))) - (make-format-directive - :string string :start start :end (1+ posn) - :character (char-upcase char) - :colonp colonp :atsignp atsignp - :params (nreverse params)))))) - - -;;;; Specials used to communicate information. - -;;; *UP-UP-AND-OUT-ALLOWED* -- internal. -;;; -;;; Used both by the expansion stuff and the interpreter stuff. When it is -;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed. -;;; -(defvar *up-up-and-out-allowed* nil) - -;;; *LOGICAL-BLOCK-POPPER* -- internal. -;;; -;;; Used by the interpreter stuff. When it non-NIL, its a function that will -;;; invoke PPRINT-POP in the right lexical environemnt. -;;; -(defvar *logical-block-popper* nil) - -;;; *EXPANDER-NEXT-ARG-MACRO* -- internal. -;;; -;;; Used by the expander stuff. This is bindable so that ~<...~:> -;;; can change it. -;;; -(defvar *expander-next-arg-macro* 'expander-next-arg) - -;;; *ONLY-SIMPLE-ARGS* -- internal. -;;; -;;; Used by the expander stuff. Initially starts as T, and gets set to NIL -;;; if someone needs to do something strange with the arg list (like use -;;; the rest, or something). -;;; -(defvar *only-simple-args*) - -;;; *ORIG-ARGS-AVAILABLE* -- internal. -;;; -;;; Used by the expander stuff. We do an initial pass with this as NIL. -;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try -;;; again with it bound to T. If this is T, we don't try to do anything -;;; fancy with args. -;;; -(defvar *orig-args-available* nil) - -;;; *SIMPLE-ARGS* -- internal. -;;; -;;; Used by the expander stuff. List of (symbol . offset) for simple args. -;;; -(defvar *simple-args*) - - - - -;;;; FORMAT - -(defun format (destination control-string &rest format-arguments) - "Provides various facilities for formatting output. - CONTROL-STRING contains a string to be output, possibly with embedded - directives, which are flagged with the escape character \"~\". Directives - generally expand into additional text to be output, usually consuming one - or more of the FORMAT-ARGUMENTS in the process. A few useful directives - are: - ~A or ~nA Prints one argument as if by PRINC - ~S or ~nS Prints one argument as if by PRIN1 - ~D or ~nD Prints one argument as a decimal integer - ~% Does a TERPRI - ~& Does a FRESH-LINE - - where n is the width of the field in which the object is printed. - - DESTINATION controls where the result will go. If DESTINATION is T, then - the output is sent to the standard output stream. If it is NIL, then the - output is returned in a string as the value of the call. Otherwise, - DESTINATION must be a stream to which the output will be sent. - - Example: (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\" - - FORMAT has many additional capabilities not described here. Consult the - manual for details." - (etypecase destination - (null - (with-output-to-string (stream) - (%format stream control-string format-arguments))) - (string - (with-output-to-string (stream destination) - (%format stream control-string format-arguments))) - ((member t) - (%format *standard-output* control-string format-arguments) - nil) - (stream - (%format destination control-string format-arguments) - nil))) - -(defun %format (stream string-or-fun orig-args &optional (args orig-args)) - (if (functionp string-or-fun) - (apply string-or-fun stream args) - (catch 'up-and-out - (let* ((string (etypecase string-or-fun - (simple-string - string-or-fun) - (string - (coerce string-or-fun 'simple-string)))) - (*default-format-error-control-string* string) - (*logical-block-popper* nil)) - (interpret-directive-list stream (tokenize-control-string string) - orig-args args))))) - -(defun interpret-directive-list (stream directives orig-args args) - (if directives - (let ((directive (car directives))) - (etypecase directive - (simple-string - (write-string directive stream) - (interpret-directive-list stream (cdr directives) orig-args args)) - (format-directive - (multiple-value-bind - (new-directives new-args) - (let ((function - (svref *format-directive-interpreters* - (char-code (format-directive-character - directive)))) - (*default-format-error-offset* - (1- (format-directive-end directive)))) - (unless function - (error 'format-error - :complaint "Unknown format directive.")) - (multiple-value-bind - (new-directives new-args) - (funcall function stream directive - (cdr directives) orig-args args) - (values new-directives new-args))) - (interpret-directive-list stream new-directives - orig-args new-args))))) - args)) - - -;;;; FORMATTER - -(defmacro formatter (control-string) - `#',(%formatter control-string)) - -(defun %formatter (control-string) - (block nil - (catch 'need-orig-args - (let* ((*simple-args* nil) - (*only-simple-args* t) - (guts (expand-control-string control-string)) - (args nil)) - (dolist (arg *simple-args*) - (push `(,(car arg) - (error - 'format-error - :complaint "Required argument missing" - :control-string ,control-string - :offset ,(cdr arg))) - args)) - (return `(lambda (stream &optional ,@args &rest args) - ,guts - args)))) - (let ((*orig-args-available* t) - (*only-simple-args* nil)) - `(lambda (stream &rest orig-args) - (let ((args orig-args)) - ,(expand-control-string control-string) - args))))) - -(defun expand-control-string (string) - (let* ((string (etypecase string - (simple-string - string) - (string - (coerce string 'simple-string)))) - (*default-format-error-control-string* string) - (directives (tokenize-control-string string))) - `(block nil - ,@(expand-directive-list directives)))) - -(defun expand-directive-list (directives) - (let ((results nil) - (remaining-directives directives)) - (loop - (unless remaining-directives - (return)) - (multiple-value-bind - (form new-directives) - (expand-directive (car remaining-directives) - (cdr remaining-directives)) - (push form results) - (setf remaining-directives new-directives))) - (reverse results))) - -(defun expand-directive (directive more-directives) - (etypecase directive - (format-directive - (let ((expander - (aref *format-directive-expanders* - (char-code (format-directive-character directive)))) - (*default-format-error-offset* - (1- (format-directive-end directive)))) - (if expander - (funcall expander directive more-directives) - (error 'format-error - :complaint "Unknown directive.")))) - (simple-string - (values `(write-string ,directive stream) - more-directives)))) - -(defun expand-next-arg (&optional offset) - (if (or *orig-args-available* (not *only-simple-args*)) - `(,*expander-next-arg-macro* - ,*default-format-error-control-string* - ,(or offset *default-format-error-offset*)) - (let ((symbol (gensym "FORMAT-ARG-"))) - (push (cons symbol (or offset *default-format-error-offset*)) - *simple-args*) - symbol))) - -(defun need-hairy-args () - (when *only-simple-args* - )) - - -;;;; Format directive definition macros and runtime support. - -(defmacro expander-next-arg (string offset) - `(if args - (pop args) - (error 'format-error - :complaint "No more arguments." - :control-string ,string - :offset ,offset))) - -(defmacro expander-pprint-next-arg (string offset) - `(progn - (when (null args) - (error 'format-error - :complaint "No more arguments." - :control-string ,string - :offset ,offset)) - (pprint-pop) - (pop args))) - -(eval-when (compile eval) - -;;; NEXT-ARG -- internal. -;;; -;;; This macro is used to extract the next argument from the current arg list. -;;; This is the version used by format directive interpreters. -;;; -(defmacro next-arg (&optional offset) - `(progn - (when (null args) - (error 'format-error - :complaint "No more arguments." - ,@(when offset - `(:offset ,offset)))) - (when *logical-block-popper* - (funcall *logical-block-popper*)) - (pop args))) - -(defmacro def-complex-format-directive (char lambda-list &body body) - (let ((defun-name (intern (cl:format nil - "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER" - char))) - (directive (gensym)) - (directives (if lambda-list (car (last lambda-list)) (gensym)))) - `(progn - (defun ,defun-name (,directive ,directives) - ,@(if lambda-list - `((let ,(mapcar #'(lambda (var) - `(,var - (,(intern (concatenate - 'string - "FORMAT-DIRECTIVE-" - (symbol-name var)) - (symbol-package 'foo)) - ,directive))) - (butlast lambda-list)) - ,@body)) - `((declare (ignore ,directive ,directives)) - ,@body))) - (%set-format-directive-expander ,char #',defun-name)))) - -(defmacro def-format-directive (char lambda-list &body body) - (let ((directives (gensym)) - (declarations nil) - (body-without-decls body)) - (loop - (let ((form (car body-without-decls))) - (unless (and (consp form) (eq (car form) 'declare)) - (return)) - (push (pop body-without-decls) declarations))) - (setf declarations (reverse declarations)) - `(def-complex-format-directive ,char (,@lambda-list ,directives) - ,@declarations - (values (progn ,@body-without-decls) - ,directives)))) - -(defmacro expand-bind-defaults (specs params &body body) - (once-only ((params params)) - (if specs - (collect ((expander-bindings) (runtime-bindings)) - (dolist (spec specs) - (destructuring-bind (var default) spec - (let ((symbol (gensym))) - (expander-bindings - `(,var ',symbol)) - (runtime-bindings - `(list ',symbol - (let* ((param-and-offset (pop ,params)) - (offset (car param-and-offset)) - (param (cdr param-and-offset))) - (case param - (:arg `(or ,(expand-next-arg offset) - ,,default)) - (:remaining - (setf *only-simple-args* nil) - '(length args)) - ((nil) ,default) - (t param)))))))) - `(let ,(expander-bindings) - `(let ,(list ,@(runtime-bindings)) - ,@(if ,params - (error 'format-error - :complaint - "Too many parameters, expected no more than ~D" - :arguments (list ,(length specs)) - :offset (caar ,params))) - ,,@body))) - `(progn - (when ,params - (error 'format-error - :complaint "Too many parameters, expected no more than 0" - :offset (caar ,params))) - ,@body)))) - -(defmacro def-complex-format-interpreter (char lambda-list &body body) - (let ((defun-name - (intern (cl:format nil "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER" - char))) - (directive (gensym)) - (directives (if lambda-list (car (last lambda-list)) (gensym)))) - `(progn - (defun ,defun-name (stream ,directive ,directives orig-args args) - (declare (ignorable stream orig-args args)) - ,@(if lambda-list - `((let ,(mapcar #'(lambda (var) - `(,var - (,(intern (concatenate - 'string - "FORMAT-DIRECTIVE-" - (symbol-name var)) - (symbol-package 'foo)) - ,directive))) - (butlast lambda-list)) - (values (progn ,@body) args))) - `((declare (ignore ,directive ,directives)) - ,@body))) - (%set-format-directive-interpreter ,char #',defun-name)))) - -(defmacro def-format-interpreter (char lambda-list &body body) - (let ((directives (gensym))) - `(def-complex-format-interpreter ,char (,@lambda-list ,directives) - ,@body - ,directives))) - -(defmacro interpret-bind-defaults (specs params &body body) - (once-only ((params params)) - (collect ((bindings)) - (dolist (spec specs) - (destructuring-bind (var default) spec - (bindings `(,var (let* ((param-and-offset (pop ,params)) - (offset (car param-and-offset)) - (param (cdr param-and-offset))) - (case param - (:arg (next-arg offset)) - (:remaining (length args)) - ((nil) ,default) - (t param))))))) - `(let* ,(bindings) - (when ,params - (error 'format-error - :complaint - "Too many parameters, expected no more than ~D" - :arguments (list ,(length specs)) - :offset (caar ,params))) - ,@body)))) - -); eval-when - -(defun %set-format-directive-expander (char fn) - (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn) - char) - -(defun %set-format-directive-interpreter (char fn) - (setf (aref *format-directive-interpreters* - (char-code (char-upcase char))) - fn) - char) - -(defun find-directive (directives kind stop-at-semi) - (if directives - (let ((next (car directives))) - (if (format-directive-p next) - (let ((char (format-directive-character next))) - (if (or (char= kind char) - (and stop-at-semi (char= char #\;))) - (car directives) - (find-directive - (cdr (flet ((after (char) - (member (find-directive (cdr directives) - char - nil) - directives))) - (case char - (#\( (after #\))) - (#\< (after #\>)) - (#\[ (after #\])) - (#\{ (after #\})) - (t directives)))) - kind stop-at-semi))) - (find-directive (cdr directives) kind stop-at-semi))))) - - -;;;; Simple outputting noise. - -(defun format-write-field (stream string mincol colinc minpad padchar padleft) - (unless padleft - (write-string string stream)) - (dotimes (i minpad) - (write-char padchar stream)) - (do ((chars (+ (length string) minpad) (+ chars colinc))) - ((>= chars mincol)) - (dotimes (i colinc) - (write-char padchar stream))) - (when padleft - (write-string string stream))) - -(defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar) - (format-write-field stream - (if (or arg (not colonp)) - (princ-to-string arg) - "()") - mincol colinc minpad padchar atsignp)) - -(def-format-directive #\A (colonp atsignp params) - (if params - (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp - ,mincol ,colinc ,minpad ,padchar)) - `(princ ,(if colonp - `(or ,(expand-next-arg) "()") - (expand-next-arg)) - stream))) - -(def-format-interpreter #\A (colonp atsignp params) - (if params - (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - (format-princ stream (next-arg) colonp atsignp - mincol colinc minpad padchar)) - (princ (if colonp (or (next-arg) "()") (next-arg)) stream))) - -(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar) - (format-write-field stream - (if (or arg (not colonp)) - (prin1-to-string arg) - "()") - mincol colinc minpad padchar atsignp)) - -(def-format-directive #\S (colonp atsignp params) - (cond (params - (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp - ,mincol ,colinc ,minpad ,padchar))) - (colonp - `(let ((arg ,(expand-next-arg))) - (if arg - (prin1 arg stream) - (princ "()" stream)))) - (t - `(prin1 ,(expand-next-arg) stream)))) - -(def-format-interpreter #\S (colonp atsignp params) - (cond (params - (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - (format-prin1 stream (next-arg) colonp atsignp - mincol colinc minpad padchar))) - (colonp - (let ((arg (next-arg))) - (if arg - (prin1 arg stream) - (princ "()" stream)))) - (t - (prin1 (next-arg) stream)))) - -(def-format-directive #\C (colonp atsignp params) - (expand-bind-defaults () params - (if colonp - `(format-print-named-character ,(expand-next-arg) stream) - (if atsignp - `(prin1 ,(expand-next-arg) stream) - `(write-char ,(expand-next-arg) stream))))) - -(def-format-interpreter #\C (colonp atsignp params) - (interpret-bind-defaults () params - (if colonp - (format-print-named-character (next-arg) stream) - (if atsignp - (prin1 (next-arg) stream) - (write-char (next-arg) stream))))) - -(defun format-print-named-character (char stream) - (let* ((name (char-name char))) - (cond (name - (write-string (string-capitalize name) stream)) - ((<= 0 (char-code char) 31) - ;; Print control characters as "^"<char> - (write-char #\^ stream) - (write-char (code-char (+ 64 (char-code char))) stream)) - (t - (write-char char stream))))) - -(def-format-directive #\W (colonp atsignp params) - (expand-bind-defaults () params - (if (or colonp atsignp) - `(let (,@(when colonp - '((*print-pretty* t))) - ,@(when atsignp - '((*print-level* nil) - (*print-length* nil)))) - (output-object ,(expand-next-arg) stream)) - `(output-object ,(expand-next-arg) stream)))) - -(def-format-interpreter #\W (colonp atsignp params) - (interpret-bind-defaults () params - (let ((*print-pretty* (or colonp *print-pretty*)) - (*print-level* (and atsignp *print-level*)) - (*print-length* (and atsignp *print-length*))) - (output-object (next-arg) stream)))) - - -;;;; Integer outputting. - -;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing -;;; directives. The parameters are interpreted as defined for ~D. -;;; -(defun format-print-integer (stream number print-commas-p print-sign-p - radix mincol padchar commachar commainterval) - (let ((*print-base* radix) - (*print-radix* nil)) - (if (integerp number) - (let* ((text (princ-to-string (abs number))) - (commaed (if print-commas-p - (format-add-commas text commachar commainterval) - text)) - (signed (cond ((minusp number) - (concatenate 'string "-" commaed)) - (print-sign-p - (concatenate 'string "+" commaed)) - (t commaed)))) - ;; colinc = 1, minpad = 0, padleft = t - (format-write-field stream signed mincol 1 0 padchar t)) - (princ number)))) - -(defun format-add-commas (string commachar commainterval) - (let ((length (length string))) - (multiple-value-bind (commas extra) - (truncate (1- length) commainterval) - (let ((new-string (make-string (+ length commas))) - (first-comma (1+ extra))) - (replace new-string string :end1 first-comma :end2 first-comma) - (do ((src first-comma (+ src commainterval)) - (dst first-comma (+ dst commainterval 1))) - ((= src length)) - (setf (schar new-string dst) commachar) - (replace new-string string :start1 (1+ dst) - :start2 src :end2 (+ src commainterval))) - new-string)))) - -(defun expand-format-integer (base colonp atsignp params) - (if (or colonp atsignp params) - (expand-bind-defaults - ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) - params - `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp - ,base ,mincol ,padchar ,commachar - ,commainterval)) - `(write ,(expand-next-arg) :stream stream :base ,base :radix nil - :escape nil))) - -(defmacro interpret-format-integer (base) - `(if (or colonp atsignp params) - (interpret-bind-defaults - ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) - params - (format-print-integer stream (next-arg) colonp atsignp ,base mincol - padchar commachar commainterval)) - (write (next-arg) :stream stream :base ,base :radix nil :escape nil))) - -(def-format-directive #\D (colonp atsignp params) - (expand-format-integer 10 colonp atsignp params)) - -(def-format-interpreter #\D (colonp atsignp params) - (interpret-format-integer 10)) - -(def-format-directive #\B (colonp atsignp params) - (expand-format-integer 2 colonp atsignp params)) - -(def-format-interpreter #\B (colonp atsignp params) - (interpret-format-integer 2)) - -(def-format-directive #\O (colonp atsignp params) - (expand-format-integer 8 colonp atsignp params)) - -(def-format-interpreter #\O (colonp atsignp params) - (interpret-format-integer 8)) - -(def-format-directive #\X (colonp atsignp params) - (expand-format-integer 16 colonp atsignp params)) - -(def-format-interpreter #\X (colonp atsignp params) - (interpret-format-integer 16)) - -(def-format-directive #\R (colonp atsignp params) - (if params - (expand-bind-defaults - ((base 10) (mincol 0) (padchar #\space) (commachar #\,) - (commainterval 3)) - params - `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp - ,base ,mincol - ,padchar ,commachar ,commainterval)) - (if atsignp - (if colonp - `(format-print-old-roman stream ,(expand-next-arg)) - `(format-print-roman stream ,(expand-next-arg))) - (if colonp - `(format-print-ordinal stream ,(expand-next-arg)) - `(format-print-cardinal stream ,(expand-next-arg)))))) - -(def-format-interpreter #\R (colonp atsignp params) - (if params - (interpret-bind-defaults - ((base 10) (mincol 0) (padchar #\space) (commachar #\,) - (commainterval 3)) - params - (format-print-integer stream (next-arg) colonp atsignp base mincol - padchar commachar commainterval)) - (if atsignp - (if colonp - (format-print-old-roman stream (next-arg)) - (format-print-roman stream (next-arg))) - (if colonp - (format-print-ordinal stream (next-arg)) - (format-print-cardinal stream (next-arg)))))) - - -(defconstant cardinal-ones - #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) - -(defconstant cardinal-tens - #(nil nil "twenty" "thirty" "forty" - "fifty" "sixty" "seventy" "eighty" "ninety")) - -(defconstant cardinal-teens - #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD - "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) - -(defconstant cardinal-periods - #("" " thousand" " million" " billion" " trillion" " quadrillion" - " quintillion" " sextillion" " septillion" " octillion" " nonillion" - " decillion")) - -(defconstant ordinal-ones - #(nil "first" "second" "third" "fourth" - "fifth" "sixth" "seventh" "eighth" "ninth") - "Table of ordinal ones-place digits in English") - -(defconstant ordinal-tens - #(nil "tenth" "twentieth" "thirtieth" "fortieth" - "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth") - "Table of ordinal tens-place digits in English") - -(defun format-print-small-cardinal (stream n) - (multiple-value-bind - (hundreds rem) (truncate n 100) - (when (plusp hundreds) - (write-string (svref cardinal-ones hundreds) stream) - (write-string " hundred" stream) - (when (plusp rem) - (write-char #\space stream))) - (when (plusp rem) - (multiple-value-bind (tens ones) - (truncate rem 10) - (cond ((< 1 tens) - (write-string (svref cardinal-tens tens) stream) - (when (plusp ones) - (write-char #\- stream) - (write-string (svref cardinal-ones ones) stream))) - ((= tens 1) - (write-string (svref cardinal-teens ones) stream)) - ((plusp ones) - (write-string (svref cardinal-ones ones) stream))))))) - -(defun format-print-cardinal (stream n) - (cond ((minusp n) - (write-string "negative " stream) - (format-print-cardinal-aux stream (- n) 0 n)) - ((zerop n) - (write-string "zero" stream)) - (t - (format-print-cardinal-aux stream n 0 n)))) - -(defun format-print-cardinal-aux (stream n period err) - (multiple-value-bind (beyond here) (truncate n 1000) - (unless (<= period 10) - (error "Number too large to print in English: ~:D" err)) - (unless (zerop beyond) - (format-print-cardinal-aux stream beyond (1+ period) err)) - (unless (zerop here) - (unless (zerop beyond) - (write-char #\space stream)) - (format-print-small-cardinal stream here) - (write-string (svref cardinal-periods period) stream)))) - -(defun format-print-ordinal (stream n) - (when (minusp n) - (write-string "negative " stream)) - (let ((number (abs n))) - (multiple-value-bind - (top bot) (truncate number 100) - (unless (zerop top) - (format-print-cardinal stream (- number bot))) - (when (and (plusp top) (plusp bot)) - (write-char #\space stream)) - (multiple-value-bind - (tens ones) (truncate bot 10) - (cond ((= bot 12) (write-string "twelfth" stream)) - ((= tens 1) - (write-string (svref cardinal-teens ones) stream);;;RAD - (write-string "th" stream)) - ((and (zerop tens) (plusp ones)) - (write-string (svref ordinal-ones ones) stream)) - ((and (zerop ones)(plusp tens)) - (write-string (svref ordinal-tens tens) stream)) - ((plusp bot) - (write-string (svref cardinal-tens tens) stream) - (write-char #\- stream) - (write-string (svref ordinal-ones ones) stream)) - ((plusp number) - (write-string "th" stream)) - (t - (write-string "zeroeth" stream))))))) - -;;; Print Roman numerals - -(defun format-print-old-roman (stream n) - (unless (< 0 n 5000) - (error "Number too large to print in old Roman numerals: ~:D" n)) - (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) - (val-list '(500 100 50 10 5 1) (cdr val-list)) - (cur-char #\M (car char-list)) - (cur-val 1000 (car val-list)) - (start n (do ((i start (progn - (write-char cur-char stream) - (- i cur-val)))) - ((< i cur-val) i)))) - ((zerop start)))) - -(defun format-print-roman (stream n) - (unless (< 0 n 4000) - (error "Number too large to print in Roman numerals: ~:D" n)) - (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) - (val-list '(500 100 50 10 5 1) (cdr val-list)) - (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars)) - (sub-val '(100 10 10 1 1 0) (cdr sub-val)) - (cur-char #\M (car char-list)) - (cur-val 1000 (car val-list)) - (cur-sub-char #\C (car sub-chars)) - (cur-sub-val 100 (car sub-val)) - (start n (do ((i start (progn - (write-char cur-char stream) - (- i cur-val)))) - ((< i cur-val) - (cond ((<= (- cur-val cur-sub-val) i) - (write-char cur-sub-char stream) - (write-char cur-char stream) - (- i (- cur-val cur-sub-val))) - (t i)))))) - ((zerop start)))) - - -;;;; Plural. - -(def-format-directive #\P (colonp atsignp params end) - (expand-bind-defaults () params - (let ((arg (cond - ((not colonp) - (expand-next-arg)) - (*orig-args-available* - `(if (eq orig-args args) - (error 'format-error - :complaint "No previous argument." - :offset ,(1- end)) - (do ((arg-ptr orig-args (cdr arg-ptr))) - ((eq (cdr arg-ptr) args) - (car arg-ptr))))) - (*only-simple-args* - (unless *simple-args* - (error 'format-error - :complaint "No previous argument.")) - (caar *simple-args*)) - (t - (throw 'need-orig-args nil))))) - (if atsignp - `(write-string (if (eql ,arg 1) "y" "ies") stream) - `(unless (eql ,arg 1) (write-char #\s stream)))))) - -(def-format-interpreter #\P (colonp atsignp params) - (interpret-bind-defaults () params - (let ((arg (if colonp - (if (eq orig-args args) - (error 'format-error - :complaint "No previous argument.") - (do ((arg-ptr orig-args (cdr arg-ptr))) - ((eq (cdr arg-ptr) args) - (car arg-ptr)))) - (next-arg)))) - (if atsignp - (write-string (if (eql arg 1) "y" "ies") stream) - (unless (eql arg 1) (write-char #\s stream)))))) - - -;;;; Floating point noise. - -(defun decimal-string (n) - (write-to-string n :base 10 :radix nil :escape nil)) - -(def-format-directive #\F (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params - `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp))) - -(def-format-interpreter #\F (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) - params - (format-fixed stream (next-arg) w d k ovf pad atsignp))) - -(defun format-fixed (stream number w d k ovf pad atsign) - (if (floatp number) - (format-fixed-aux stream number w d k ovf pad atsign) - (if (rationalp number) - (format-fixed-aux stream - (coerce number 'single-float) - w d k ovf pad atsign) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t)))) - -;;; We return true if we overflowed, so that ~G can output the overflow char -;;; instead of spaces. -;;; -(defun format-fixed-aux (stream number w d k ovf pad atsign) - (cond - ((not (or w d)) - (prin1 number stream) - nil) - (t - (let ((spaceleft w)) - (when (and w (or atsign (minusp number))) (decf spaceleft)) - (multiple-value-bind - (str len lpoint tpoint) - (lisp::flonum-to-string (abs number) spaceleft d k) - ;;if caller specifically requested no fraction digits, suppress the - ;;optional trailing zero - (when (and d (zerop d)) (setq tpoint nil)) - (when w - (decf spaceleft len) - ;;optional leading zero - (when lpoint - (if (or (> spaceleft 0) tpoint) ;force at least one digit - (decf spaceleft) - (setq lpoint nil))) - ;;optional trailing zero - (when tpoint - (if (> spaceleft 0) - (decf spaceleft) - (setq tpoint nil)))) - (cond ((and w (< spaceleft 0) ovf) - ;;field width overflow - (dotimes (i w) (write-char ovf stream)) - t) - (t - (when w (dotimes (i spaceleft) (write-char pad stream))) - (if (minusp number) - (write-char #\- stream) - (if atsign (write-char #\+ stream))) - (when lpoint (write-char #\0 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - nil))))))) - -(def-format-directive #\E (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (expand-bind-defaults - ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) - params - `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark - ,atsignp))) - -(def-format-interpreter #\E (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (interpret-bind-defaults - ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) - params - (format-exponential stream (next-arg) w d e k ovf pad mark atsignp))) - -(defun format-exponential (stream number w d e k ovf pad marker atsign) - (if (floatp number) - (format-exp-aux stream number w d e k ovf pad marker atsign) - (if (rationalp number) - (format-exp-aux stream - (coerce number 'single-float) - w d e k ovf pad marker atsign) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t)))) - -(defun format-exponent-marker (number) - (if (typep number *read-default-float-format*) - #\e - (typecase number - (single-float #\f) - (double-float #\d) - (short-float #\s) - (long-float #\l)))) - -;;;Here we prevent the scale factor from shifting all significance out of -;;;a number to the right. We allow insignificant zeroes to be shifted in -;;;to the left right, athough it is an error to specify k and d such that this -;;;occurs. Perhaps we should detect both these condtions and flag them as -;;;errors. As for now, we let the user get away with it, and merely guarantee -;;;that at least one significant digit will appear. - -(defun format-exp-aux (stream number w d e k ovf pad marker atsign) - (if (not (or w d)) - (prin1 number stream) - (multiple-value-bind (num expt) - (lisp::scale-exponent (abs number)) - (let* ((expt (- expt k)) - (estr (decimal-string (abs expt))) - (elen (if e (max (length estr) e) (length estr))) - (fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) - (fmin (if (minusp k) (- 1 k) nil)) - (spaceleft (if w (- w 2 elen) nil))) - (when (or atsign (minusp number)) (decf spaceleft)) - (if (and w ovf e (> elen e)) ;exponent overflow - (dotimes (i w) (write-char ovf stream)) - (multiple-value-bind - (fstr flen lpoint) - (lisp::flonum-to-string num spaceleft fdig k fmin) - (when w - (decf spaceleft flen) - (when lpoint - (if (> spaceleft 0) - (decf spaceleft) - (setq lpoint nil)))) - (cond ((and w (< spaceleft 0) ovf) - ;;significand overflow - (dotimes (i w) (write-char ovf stream))) - (t (when w - (dotimes (i spaceleft) (write-char pad stream))) - (if (minusp number) - (write-char #\- stream) - (if atsign (write-char #\+ stream))) - (when lpoint (write-char #\0 stream)) - (write-string fstr stream) - (write-char (if marker - marker - (format-exponent-marker number)) - stream) - (write-char (if (minusp expt) #\- #\+) stream) - (when e - ;;zero-fill before exponent if necessary - (dotimes (i (- e (length estr))) - (write-char #\0 stream))) - (write-string estr stream))))))))) - -(def-format-directive #\G (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (expand-bind-defaults - ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) - params - `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) - -(def-format-interpreter #\G (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (interpret-bind-defaults - ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) - params - (format-general stream (next-arg) w d e k ovf pad mark atsignp))) - -(defun format-general (stream number w d e k ovf pad marker atsign) - ;;The Excelsior edition does not say what to do if - ;;the argument is not a float. Here, we adopt the - ;;conventions used by ~F and ~E. - (if (floatp number) - (format-general-aux stream number w d e k ovf pad marker atsign) - (if (rationalp number) - (format-general-aux stream - (coerce number 'single-float) - w d e k ovf pad marker atsign) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t)))) - -(defun format-general-aux (stream number w d e k ovf pad marker atsign) - (multiple-value-bind (ignore n) - (lisp::scale-exponent (abs number)) - (declare (ignore ignore)) - ;;Default d if omitted. The procedure is taken directly - ;;from the definition given in the manual, and is not - ;;very efficient, since we generate the digits twice. - ;;Future maintainers are encouraged to improve on this. - (unless d - (multiple-value-bind (str len) - (lisp::flonum-to-string (abs number)) - (declare (ignore str)) - (let ((q (if (= len 1) 1 (1- len)))) - (setq d (max q (min n 7)))))) - (let* ((ee (if e (+ e 2) 4)) - (ww (if w (- w ee) nil)) - (dd (- d n))) - (cond ((<= 0 dd d) - (let ((char (if (format-fixed-aux stream number ww dd nil - ovf pad atsign) - ovf - #\space))) - (dotimes (i ee) (write-char char stream)))) - (t - (format-exp-aux stream number w d e (or k 1) - ovf pad marker atsign)))))) - -(def-format-directive #\$ (colonp atsignp params) - (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params - `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp - ,atsignp))) - -(def-format-interpreter #\$ (colonp atsignp params) - (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params - (format-dollars stream (next-arg) d n w pad colonp atsignp))) - -(defun format-dollars (stream number d n w pad colon atsign) - (if (rationalp number) (setq number (coerce number 'single-float))) - (if (floatp number) - (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) - (signlen (length signstr))) - (multiple-value-bind (str strlen ig2 ig3 pointplace) - (lisp::flonum-to-string number nil d nil) - (declare (ignore ig2 ig3)) - (when colon (write-string signstr stream)) - (dotimes (i (- w signlen (- n pointplace) strlen)) - (write-char pad stream)) - (unless colon (write-string signstr stream)) - (dotimes (i (- n pointplace)) (write-char #\0 stream)) - (write-string str stream))) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t))) - - -;;;; line/page breaks and other stuff like that. - -(def-format-directive #\% (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (if params - (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (terpri stream))) - '(terpri stream))) - -(def-format-interpreter #\% (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (interpret-bind-defaults ((count 1)) params - (dotimes (i count) - (terpri stream)))) - -(def-format-directive #\& (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (if params - (expand-bind-defaults ((count 1)) params - `(progn - (fresh-line stream) - (dotimes (i (1- ,count)) - (terpri stream)))) - '(fresh-line stream))) - -(def-format-interpreter #\& (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (interpret-bind-defaults ((count 1)) params - (fresh-line stream) - (dotimes (i (1- count)) - (terpri stream)))) - -(def-format-directive #\| (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (if params - (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (write-char #\page stream))) - '(write-char #\page stream))) - -(def-format-interpreter #\| (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (interpret-bind-defaults ((count 1)) params - (dotimes (i count) - (write-char #\page stream)))) - -(def-format-directive #\~ (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (if params - (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (write-char #\~ stream))) - '(write-char #\~ stream))) - -(def-format-interpreter #\~ (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (interpret-bind-defaults ((count 1)) params - (dotimes (i count) - (write-char #\~ stream)))) - -(def-complex-format-directive #\newline (colonp atsignp params directives) - (when (and colonp atsignp) - (error 'format-error - :complaint - "Cannot specify both colon and atsign for this directive.")) - (values (expand-bind-defaults () params - (if atsignp - '(write-char #\newline stream) - nil)) - (if (and (not colonp) - directives - (simple-string-p (car directives))) - (cons (string-left-trim '(#\space #\newline #\tab) - (car directives)) - (cdr directives)) - directives))) - -(def-complex-format-interpreter #\newline (colonp atsignp params directives) - (when (and colonp atsignp) - (error 'format-error - :complaint - "Cannot specify both colon and atsign for this directive.")) - (interpret-bind-defaults () params - (when atsignp - (write-char #\newline stream))) - (if (and (not colonp) - directives - (simple-string-p (car directives))) - (cons (string-left-trim '(#\space #\newline #\tab) - (car directives)) - (cdr directives)) - directives)) - - -;;;; Tab and simple pretty-printing noise. - -(def-format-directive #\T (colonp atsignp params) - (if colonp - (expand-bind-defaults ((n 1) (m 1)) params - `(pprint-tab ,(if atsignp :section-relative :section) - ,n ,m stream)) - (if atsignp - (expand-bind-defaults ((colrel 1) (colinc 1)) params - `(format-relative-tab stream ,colrel ,colinc)) - (expand-bind-defaults ((colnum 1) (colinc 1)) params - `(format-absolute-tab stream ,colnum ,colinc))))) - -(def-format-interpreter #\T (colonp atsignp params) - (if colonp - (interpret-bind-defaults ((n 1) (m 1)) params - (pprint-tab (if atsignp :section-relative :section) n m stream)) - (if atsignp - (interpret-bind-defaults ((colrel 1) (colinc 1)) params - (format-relative-tab stream colrel colinc)) - (interpret-bind-defaults ((colnum 1) (colinc 1)) params - (format-absolute-tab stream colnum colinc))))) - -(defun output-spaces (stream n) - (let ((spaces #.(make-string 100 :initial-element #\space))) - (loop - (when (< n (length spaces)) - (return)) - (write-string spaces stream) - (decf n (length spaces))) - (write-string spaces stream :end n))) - -(defun format-relative-tab (stream colrel colinc) - (if (pp:pretty-stream-p stream) - (pprint-tab :line-relative colrel colinc stream) - (let* ((cur (lisp::charpos stream)) - (spaces (if (and cur (plusp colinc)) - (- (* (ceiling (+ cur colrel) colinc) colinc) cur) - colrel))) - (output-spaces stream spaces)))) - -(defun format-absolute-tab (stream colnum colinc) - (if (pp:pretty-stream-p stream) - (pprint-tab :line colnum colinc stream) - (let ((cur (lisp::charpos stream))) - (cond ((null cur) - (write-string " " stream)) - ((< cur colnum) - (output-spaces stream (- colnum cur))) - (t - (unless (zerop colinc) - (output-spaces stream (- colinc (rem cur colinc))))))))) - -(def-format-directive #\_ (colonp atsignp params) - (expand-bind-defaults () params - `(pprint-newline ,(if colonp - (if atsignp - :mandatory - :fill) - (if atsignp - :miser - :linear)) - stream))) - -(def-format-interpreter #\_ (colonp atsignp params) - (interpret-bind-defaults () params - (pprint-newline (if colonp - (if atsignp - :mandatory - :fill) - (if atsignp - :miser - :linear)) - stream))) - -(def-format-directive #\I (colonp atsignp params) - (when atsignp - (error 'format-error - :complaint "Cannot specify the at-sign modifier.")) - (expand-bind-defaults ((n 0)) params - `(pprint-indent ,(if colonp :current :block) ,n stream))) - -(def-format-interpreter #\I (colonp atsignp params) - (when atsignp - (error 'format-error - :complaint "Cannot specify the at-sign modifier.")) - (interpret-bind-defaults ((n 0)) params - (pprint-indent (if colonp :current :block) n stream))) - - -;;;; * - -(def-format-directive #\* (colonp atsignp params end) - (if atsignp - (if colonp - (error 'format-error - :complaint "Cannot specify both colon and at-sign.") - (expand-bind-defaults ((posn 0)) params - (unless *orig-args-available* - (throw 'need-orig-args nil)) - `(if (<= 0 ,posn (length orig-args)) - (setf args (nthcdr ,posn orig-args)) - (error 'format-error - :complaint "Index ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments (list ,posn (length orig-args)) - :offset ,(1- end))))) - (if colonp - (expand-bind-defaults ((n 1)) params - (unless *orig-args-available* - (throw 'need-orig-args nil)) - `(do ((cur-posn 0 (1+ cur-posn)) - (arg-ptr orig-args (cdr arg-ptr))) - ((eq arg-ptr args) - (let ((new-posn (- cur-posn ,n))) - (if (<= 0 new-posn (length orig-args)) - (setf args (nthcdr new-posn orig-args)) - (error 'format-error - :complaint - "Index ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments - (list new-posn (length orig-args)) - :offset ,(1- end))))))) - (if params - (expand-bind-defaults ((n 1)) params - (setf *only-simple-args* nil) - `(dotimes (i ,n) - ,(expand-next-arg))) - (expand-next-arg))))) - -(def-format-interpreter #\* (colonp atsignp params) - (if atsignp - (if colonp - (error 'format-error - :complaint "Cannot specify both colon and at-sign.") - (interpret-bind-defaults ((posn 0)) params - (if (<= 0 posn (length orig-args)) - (setf args (nthcdr posn orig-args)) - (error 'format-error - :complaint "Index ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments (list posn (length orig-args)))))) - (if colonp - (interpret-bind-defaults ((n 1)) params - (do ((cur-posn 0 (1+ cur-posn)) - (arg-ptr orig-args (cdr arg-ptr))) - ((eq arg-ptr args) - (let ((new-posn (- cur-posn n))) - (if (<= 0 new-posn (length orig-args)) - (setf args (nthcdr new-posn orig-args)) - (error 'format-error - :complaint - "Index ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments - (list new-posn (length orig-args)))))))) - (interpret-bind-defaults ((n 1)) params - (dotimes (i n) - (next-arg)))))) - - -;;;; Indirection. - -(def-format-directive #\? (colonp atsignp params string end) - (when colonp - (error 'format-error - :complaint "Cannot specify the colon modifier.")) - (expand-bind-defaults () params - `(handler-bind - ((format-error - #'(lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :arguments (list condition) - :print-banner nil - :control-string ,string - :offset ,(1- end))))) - ,(if atsignp - (if *orig-args-available* - `(setf args (%format stream ,(expand-next-arg) orig-args args)) - (throw 'need-orig-args nil)) - `(%format stream ,(expand-next-arg) ,(expand-next-arg)))))) - -(def-format-interpreter #\? (colonp atsignp params string end) - (when colonp - (error 'format-error - :complaint "Cannot specify the colon modifier.")) - (interpret-bind-defaults () params - (handler-bind - ((format-error - #'(lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :arguments (list condition) - :print-banner nil - :control-string string - :offset (1- end))))) - (if atsignp - (setf args (%format stream (next-arg) orig-args args)) - (%format stream (next-arg) (next-arg)))))) - - -;;;; Capitalization. - -(def-complex-format-directive #\( (colonp atsignp params directives) - (let ((close (find-directive directives #\) nil))) - (unless close - (error 'format-error - :complaint "No corresponding close paren.")) - (let* ((posn (position close directives)) - (before (subseq directives 0 posn)) - (after (nthcdr (1+ posn) directives))) - (values - (expand-bind-defaults () params - `(let ((stream (make-case-frob-stream stream - ,(if colonp - (if atsignp - :upcase - :capitalize) - (if atsignp - :capitalize-first - :downcase))))) - ,@(expand-directive-list before))) - after)))) - -(def-complex-format-interpreter #\( (colonp atsignp params directives) - (let ((close (find-directive directives #\) nil))) - (unless close - (error 'format-error - :complaint "No corresponding close paren.")) - (interpret-bind-defaults () params - (let* ((posn (position close directives)) - (before (subseq directives 0 posn)) - (after (nthcdr (1+ posn) directives)) - (stream (make-case-frob-stream stream - (if colonp - (if atsignp - :upcase - :capitalize) - (if atsignp - :capitalize-first - :downcase))))) - (setf args (interpret-directive-list stream before orig-args args)) - after)))) - -(def-complex-format-directive #\) () - (error 'format-error - :complaint "No corresponding open paren.")) - -(def-complex-format-interpreter #\) () - (error 'format-error - :complaint "No corresponding open paren.")) - - -;;;; Conditionals - -(defun parse-conditional-directive (directives) - (let ((sublists nil) - (last-semi-with-colon-p nil) - (remaining directives)) - (loop - (let ((close-or-semi (find-directive remaining #\] t))) - (unless close-or-semi - (error 'format-error - :complaint "No corresponding close bracket.")) - (let ((posn (position close-or-semi remaining))) - (push (subseq remaining 0 posn) sublists) - (setf remaining (nthcdr (1+ posn) remaining)) - (when (char= (format-directive-character close-or-semi) #\]) - (return)) - (setf last-semi-with-colon-p - (format-directive-colonp close-or-semi))))) - (values sublists last-semi-with-colon-p remaining))) - -(def-complex-format-directive #\[ (colonp atsignp params directives) - (multiple-value-bind - (sublists last-semi-with-colon-p remaining) - (parse-conditional-directive directives) - (values - (if atsignp - (if colonp - (error 'format-error - :complaint - "Cannot specify both the colon and at-sign modifiers.") - (if (cdr sublists) - (error 'format-error - :complaint - "Can only specify one section") - (expand-bind-defaults () params - (expand-maybe-conditional (car sublists))))) - (if colonp - (if (= (length sublists) 2) - (expand-bind-defaults () params - (expand-true-false-conditional (car sublists) - (cadr sublists))) - (error 'format-error - :complaint - "Must specify exactly two sections.")) - (expand-bind-defaults ((index (expand-next-arg))) params - (setf *only-simple-args* nil) - (let ((clauses nil)) - (when last-semi-with-colon-p - (push `(t ,@(expand-directive-list (pop sublists))) - clauses)) - (let ((count (length sublists))) - (dolist (sublist sublists) - (push `(,(decf count) - ,@(expand-directive-list sublist)) - clauses))) - `(case ,index ,@clauses))))) - remaining))) - -(defun expand-maybe-conditional (sublist) - (flet ((hairy () - `(let ((prev-args args) - (arg ,(expand-next-arg))) - (when arg - (setf args prev-args) - ,@(expand-directive-list sublist))))) - (if *only-simple-args* - (multiple-value-bind - (guts new-args) - (let ((*simple-args* *simple-args*)) - (values (expand-directive-list sublist) - *simple-args*)) - (cond ((eq *simple-args* (cdr new-args)) - (setf *simple-args* new-args) - `(when ,(caar new-args) - ,@guts)) - (t - (setf *only-simple-args* nil) - (hairy)))) - (hairy)))) - -(defun expand-true-false-conditional (true false) - (let ((arg (expand-next-arg))) - (flet ((hairy () - `(if ,arg - (progn - ,@(expand-directive-list true)) - (progn - ,@(expand-directive-list false))))) - (if *only-simple-args* - (multiple-value-bind - (true-guts true-args true-simple) - (let ((*simple-args* *simple-args*) - (*only-simple-args* t)) - (values (expand-directive-list true) - *simple-args* - *only-simple-args*)) - (multiple-value-bind - (false-guts false-args false-simple) - (let ((*simple-args* *simple-args*) - (*only-simple-args* t)) - (values (expand-directive-list false) - *simple-args* - *only-simple-args*)) - (if (= (length true-args) (length false-args)) - `(if ,arg - (progn - ,@true-guts) - ,(do ((false false-args (cdr false)) - (true true-args (cdr true)) - (bindings nil (cons `(,(caar false) ,(caar true)) - bindings))) - ((eq true *simple-args*) - (setf *simple-args* true-args) - (setf *only-simple-args* - (and true-simple false-simple)) - (if bindings - `(let ,bindings - ,@false-guts) - `(progn - ,@false-guts))))) - (progn - (setf *only-simple-args* nil) - (hairy))))) - (hairy))))) - - - -(def-complex-format-interpreter #\[ (colonp atsignp params directives) - (multiple-value-bind - (sublists last-semi-with-colon-p remaining) - (parse-conditional-directive directives) - (setf args - (if atsignp - (if colonp - (error 'format-error - :complaint - "Cannot specify both the colon and at-sign modifiers.") - (if (cdr sublists) - (error 'format-error - :complaint - "Can only specify one section") - (interpret-bind-defaults () params - (let ((prev-args args) - (arg (next-arg))) - (if arg - (interpret-directive-list stream - (car sublists) - orig-args - prev-args) - args))))) - (if colonp - (if (= (length sublists) 2) - (interpret-bind-defaults () params - (if (next-arg) - (interpret-directive-list stream (car sublists) - orig-args args) - (interpret-directive-list stream (cadr sublists) - orig-args args))) - (error 'format-error - :complaint - "Must specify exactly two sections.")) - (interpret-bind-defaults ((index (next-arg))) params - (let* ((default (and last-semi-with-colon-p - (pop sublists))) - (last (1- (length sublists))) - (sublist - (if (<= 0 index last) - (nth (- last index) sublists) - default))) - (interpret-directive-list stream sublist orig-args - args)))))) - remaining)) - -(def-complex-format-directive #\; () - (error 'format-error - :complaint - "~~; not contained within either ~~[...~~] or ~~<...~~>.")) - -(def-complex-format-interpreter #\; () - (error 'format-error - :complaint - "~~; not contained within either ~~[...~~] or ~~<...~~>.")) - -(def-complex-format-interpreter #\] () - (error 'format-error - :complaint - "No corresponding open bracket.")) - -(def-complex-format-directive #\] () - (error 'format-error - :complaint - "No corresponding open bracket.")) - - -;;;; Up-and-out. - -(defvar *outside-args*) - -(def-format-directive #\^ (colonp atsignp params) - (when atsignp - (error 'format-error - :complaint "Cannot specify the at-sign modifier.")) - (when (and colonp (not *up-up-and-out-allowed*)) - (error 'format-error - :complaint "Attempt to use ~~:^ outside a ~~:{...~~} construct.")) - `(when ,(case (length params) - (0 (if colonp - '(null outside-args) - (progn - (setf *only-simple-args* nil) - '(null args)))) - (1 (expand-bind-defaults ((count 0)) params - `(zerop ,count))) - (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params - `(= ,arg1 ,arg2))) - (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params - `(<= ,arg1 ,arg2 ,arg3)))) - ,(if colonp - '(return-from outside-loop nil) - '(return)))) - -(def-format-interpreter #\^ (colonp atsignp params) - (when atsignp - (error 'format-error - :complaint "Cannot specify the at-sign modifier.")) - (when (and colonp (not *up-up-and-out-allowed*)) - (error 'format-error - :complaint "Attempt to use ~~:^ outside a ~~:{...~~} construct.")) - (when (case (length params) - (0 (if colonp - (null *outside-args*) - (null args))) - (1 (interpret-bind-defaults ((count 0)) params - (zerop count))) - (2 (interpret-bind-defaults ((arg1 0) (arg2 0)) params - (= arg1 arg2))) - (t (interpret-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params - (<= arg1 arg2 arg3)))) - (throw (if colonp 'up-up-and-out 'up-and-out) - args))) - - -;;;; Iteration. - -(def-complex-format-directive #\{ (colonp atsignp params string end directives) - (let ((close (find-directive directives #\} nil))) - (unless close - (error 'format-error - :complaint - "No corresponding close brace.")) - (let* ((closed-with-colon (format-directive-colonp close)) - (posn (position close directives))) - (labels - ((compute-insides () - (if (zerop posn) - (if *orig-args-available* - `((handler-bind - ((format-error - #'(lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :arguments (list condition) - :print-banner nil - :control-string ,string - :offset ,(1- end))))) - (setf args - (%format stream inside-string orig-args args)))) - (throw 'need-orig-args nil)) - (let ((*up-up-and-out-allowed* colonp)) - (expand-directive-list (subseq directives 0 posn))))) - (compute-loop-aux (count) - (when atsignp - (setf *only-simple-args* nil)) - `(loop - ,@(unless closed-with-colon - '((when (null args) - (return)))) - ,@(when count - `((when (and ,count (minusp (decf ,count))) - (return)))) - ,@(if colonp - (let ((*expander-next-arg-macro* 'expander-next-arg) - (*only-simple-args* nil) - (*orig-args-available* t)) - `((let* ((orig-args ,(expand-next-arg)) - (outside-args args) - (args orig-args)) - (declare (ignorable orig-args outside-args args)) - (block nil - ,@(compute-insides))))) - (compute-insides)) - ,@(when closed-with-colon - '((when (null args) - (return)))))) - (compute-loop () - (if params - (expand-bind-defaults ((count nil)) params - (compute-loop-aux count)) - (compute-loop-aux nil))) - (compute-block () - (if colonp - `(block outside-loop - ,(compute-loop)) - (compute-loop))) - (compute-bindings () - (if atsignp - (compute-block) - `(let* ((orig-args ,(expand-next-arg)) - (args orig-args)) - (declare (ignorable orig-args args)) - ,(let ((*expander-next-arg-macro* 'expander-next-arg) - (*only-simple-args* nil) - (*orig-args-available* t)) - (compute-block)))))) - (values (if (zerop posn) - `(let ((inside-string ,(expand-next-arg))) - ,(compute-bindings)) - (compute-bindings)) - (nthcdr (1+ posn) directives)))))) - -(def-complex-format-interpreter #\{ - (colonp atsignp params string end directives) - (let ((close (find-directive directives #\} nil))) - (unless close - (error 'format-error - :complaint - "No corresponding close brace.")) - (interpret-bind-defaults ((max-count nil)) params - (let* ((closed-with-colon (format-directive-colonp close)) - (posn (position close directives)) - (insides (if (zerop posn) - (next-arg) - (subseq directives 0 posn))) - (*up-up-and-out-allowed* colonp)) - (labels - ((do-guts (orig-args args) - (if (zerop posn) - (handler-bind - ((format-error - #'(lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :arguments (list condition) - :print-banner nil - :control-string string - :offset (1- end))))) - (%format stream insides orig-args args)) - (interpret-directive-list stream insides - orig-args args))) - (bind-args (orig-args args) - (if colonp - (let* ((arg (next-arg)) - (*logical-block-popper* nil) - (*outside-args* args)) - (catch 'up-and-out - (do-guts arg arg) - args)) - (do-guts orig-args args))) - (do-loop (orig-args args) - (catch (if colonp 'up-up-and-out 'up-and-out) - (loop - (when (and (not closed-with-colon) (null args)) - (return)) - (when (and max-count (minusp (decf max-count))) - (return)) - (setf args (bind-args orig-args args)) - (when (and closed-with-colon (null args)) - (return))) - args))) - (if atsignp - (setf args (do-loop orig-args args)) - (let ((arg (next-arg)) - (*logical-block-popper* nil)) - (do-loop arg arg))) - (nthcdr (1+ posn) directives)))))) - -(def-complex-format-directive #\} () - (error 'format-error - :complaint "No corresponding open brace.")) - -(def-complex-format-interpreter #\} () - (error 'format-error - :complaint "No corresponding open brace.")) - - - -;;;; Justification. - -(def-complex-format-directive #\< (colonp atsignp params string end directives) - (multiple-value-bind - (segments first-semi close remaining) - (parse-format-justification directives) - (values - (if (format-directive-colonp close) - (multiple-value-bind - (prefix per-line-p insides suffix) - (parse-format-logical-block segments colonp first-semi - close params string end) - (expand-format-logical-block prefix per-line-p insides - suffix atsignp)) - (expand-format-justification segments colonp atsignp - first-semi params)) - remaining))) - -(def-complex-format-interpreter #\< - (colonp atsignp params string end directives) - (multiple-value-bind - (segments first-semi close remaining) - (parse-format-justification directives) - (setf args - (if (format-directive-colonp close) - (multiple-value-bind - (prefix per-line-p insides suffix) - (parse-format-logical-block segments colonp first-semi - close params string end) - (interpret-format-logical-block stream orig-args args - prefix per-line-p insides - suffix atsignp)) - (interpret-format-justification stream orig-args args - segments colonp atsignp - first-semi params))) - remaining)) - -(defun parse-format-justification (directives) - (let ((first-semi nil) - (close nil) - (remaining directives)) - (collect ((segments)) - (loop - (let ((close-or-semi (find-directive remaining #\> t))) - (unless close-or-semi - (error 'format-error - :complaint "No corresponding close bracket.")) - (let ((posn (position close-or-semi remaining))) - (segments (subseq remaining 0 posn)) - (setf remaining (nthcdr (1+ posn) remaining))) - (when (char= (format-directive-character close-or-semi) - #\>) - (setf close close-or-semi) - (return)) - (unless first-semi - (setf first-semi close-or-semi)))) - (values (segments) first-semi close remaining)))) - -(defun expand-format-justification (segments colonp atsignp first-semi params) - (let ((newline-segment-p - (and first-semi - (format-directive-colonp first-semi)))) - (expand-bind-defaults - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - params - `(let ((segments nil) - ,@(when newline-segment-p - '((newline-segment nil) - (extra-space 0) - (line-len 72)))) - (block nil - ,@(when newline-segment-p - `((setf newline-segment - (with-output-to-string (stream) - ,@(expand-directive-list (pop segments)))) - ,(expand-bind-defaults - ((extra 0) - (line-len '(or (lisp::line-length stream) 72))) - (format-directive-params first-semi) - `(setf extra-space ,extra line-len ,line-len)))) - ,@(mapcar #'(lambda (segment) - `(push (with-output-to-string (stream) - ,@(expand-directive-list segment)) - segments)) - segments)) - (format-justification stream - ,@(if newline-segment-p - '(newline-segment extra-space line-len) - '(nil 0 0)) - segments ,colonp ,atsignp - ,mincol ,colinc ,minpad ,padchar))))) - -(defun interpret-format-justification - (stream orig-args args segments colonp atsignp first-semi params) - (interpret-bind-defaults - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - params - (let ((newline-string nil) - (strings nil) - (extra-space 0) - (line-len 0)) - (setf args - (catch 'up-and-out - (when (and first-semi (format-directive-colonp first-semi)) - (interpret-bind-defaults - ((extra 0) - (len (or (lisp::line-length stream) 72))) - (format-directive-params first-semi) - (setf newline-string - (with-output-to-string (stream) - (setf args - (interpret-directive-list stream - (pop segments) - orig-args - args)))) - (setf extra-space extra) - (setf line-len len))) - (dolist (segment segments) - (push (with-output-to-string (stream) - (setf args - (interpret-directive-list stream segment - orig-args args))) - strings)) - args)) - (format-justification stream newline-string extra-space line-len strings - colonp atsignp mincol colinc minpad padchar))) - args) - -(defun format-justification (stream newline-prefix extra-space line-len strings - pad-left pad-right mincol colinc minpad padchar) - (setf strings (reverse strings)) - (when (and (not pad-left) (not pad-right) (null (cdr strings))) - (setf pad-left t)) - (let* ((num-gaps (+ (1- (length strings)) - (if pad-left 1 0) - (if pad-right 1 0))) - (chars (+ (* num-gaps minpad) - (loop - for string in strings - summing (length string)))) - (length (if (> chars mincol) - (+ mincol (* (ceiling (- chars mincol) colinc) colinc)) - mincol)) - (padding (- length chars))) - (when (and newline-prefix - (> (+ (or (lisp::charpos stream) 0) - length extra-space) - line-len)) - (write-string newline-prefix stream)) - (flet ((do-padding () - (let ((pad-len (truncate padding num-gaps))) - (decf padding pad-len) - (decf num-gaps) - (dotimes (i pad-len) (write-char padchar stream))))) - (when pad-left - (do-padding)) - (when strings - (write-string (car strings) stream) - (dolist (string (cdr strings)) - (do-padding) - (write-string string stream))) - (when pad-right - (do-padding))))) - -(defun parse-format-logical-block - (segments colonp first-semi close params string end) - (when params - (error 'format-error - :complaint "No parameters can be supplied with ~~<...~~:>." - :offset (caar params))) - (multiple-value-bind - (prefix insides suffix) - (multiple-value-bind (prefix-default suffix-default) - (if colonp (values "(" ")") (values nil nil)) - (flet ((extract-string (list prefix-p) - (let ((directive (find-if #'format-directive-p list))) - (if directive - (error 'format-error - :complaint - "Cannot include format directives inside the ~ - ~:[suffix~;prefix~] segment of ~~<...~~:>" - :arguments (list prefix-p) - :offset (1- (format-directive-end directive))) - (apply #'concatenate 'string list))))) - (case (length segments) - (0 (values prefix-default nil suffix-default)) - (1 (values prefix-default (car segments) suffix-default)) - (2 (values (extract-string (car segments) t) - (cadr segments) suffix-default)) - (3 (values (extract-string (car segments) t) - (cadr segments) - (extract-string (caddr segments) nil))) - (t - (error 'format-error - :complaint "Too many segments for ~~<...~~:>."))))) - (when (format-directive-atsignp close) - (setf insides - (add-fill-style-newlines insides - string - (if first-semi - (format-directive-end first-semi) - end)))) - (values prefix - (and first-semi (format-directive-atsignp first-semi)) - insides - suffix))) - -(defun add-fill-style-newlines (list string offset) - (if list - (let ((directive (car list))) - (if (simple-string-p directive) - (nconc (add-fill-style-newlines-aux directive string offset) - (add-fill-style-newlines (cdr list) - string - (+ offset (length directive)))) - (cons directive - (add-fill-style-newlines (cdr list) - string - (format-directive-end directive))))) - nil)) - -(defun add-fill-style-newlines-aux (literal string offset) - (let ((end (length literal)) - (posn 0)) - (collect ((results)) - (loop - (let ((blank (position #\space literal :start posn))) - (when (null blank) - (results (subseq literal posn)) - (return)) - (let ((non-blank (or (position #\space literal :start blank - :test #'char/=) - end))) - (results (subseq literal posn non-blank)) - (results (make-format-directive - :string string :character #\_ - :start (+ offset non-blank) :end (+ offset non-blank) - :colonp t :atsignp nil :params nil)) - (setf posn non-blank)) - (when (= posn end) - (return)))) - (results)))) - -(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp) - `(let ((arg ,(if atsignp 'args (expand-next-arg)))) - ,@(when atsignp - (setf *only-simple-args* nil) - '((setf args nil))) - (pprint-logical-block - (stream arg - ,(if per-line-p :per-line-prefix :prefix) ,prefix - :suffix ,suffix) - (let ((args arg) - ,@(unless atsignp - `((orig-args arg)))) - (declare (ignorable args ,@(unless atsignp '(orig-args)))) - (block nil - ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) - (*only-simple-args* nil) - (*orig-args-available* t)) - (expand-directive-list insides))))))) - -(defun interpret-format-logical-block - (stream orig-args args prefix per-line-p insides suffix atsignp) - (let ((arg (if atsignp args (next-arg)))) - (if per-line-p - (pprint-logical-block - (stream arg :per-line-prefix prefix :suffix suffix) - (let ((*logical-block-popper* #'(lambda () (pprint-pop)))) - (catch 'up-and-out - (interpret-directive-list stream insides - (if atsignp orig-args arg) - arg)))) - (pprint-logical-block (stream arg :prefix prefix :suffix suffix) - (let ((*logical-block-popper* #'(lambda () (pprint-pop)))) - (catch 'up-and-out - (interpret-directive-list stream insides - (if atsignp orig-args arg) - arg)))))) - (if atsignp nil args)) - -(def-complex-format-directive #\> () - (error 'format-error - :complaint "No corresponding open bracket.")) - - -;;;; User-defined method. - -(def-format-directive #\/ (string start end colonp atsignp params) - (let ((symbol (extract-user-function-name string start end))) - (collect ((param-names) (bindings)) - (dolist (param params) - (let ((param-name (gensym))) - (param-names param-name) - (bindings `(,param-name - ,(case param - (:arg (expand-next-arg)) - (:remaining '(length args)) - (t param)))))) - `(let ,(bindings) - (,symbol stream ,(expand-next-arg) ,colonp ,atsignp - ,@(param-names)))))) - -(def-format-interpreter #\/ (string start end colonp atsignp params) - (let ((symbol (extract-user-function-name string start end))) - (collect ((args)) - (dolist (param params) - (case param - (:arg (args (next-arg))) - (:remaining (args (length args))) - (t (args param)))) - (apply (fdefinition symbol) stream (next-arg) - colonp atsignp (args))))) - -(defun extract-user-function-name (string start end) - (let ((slash (position #\/ string :start start :end (1- end) - :from-end t))) - (unless slash - (error 'format-error - :complaint "Malformed ~~/ directive.")) - (let* ((name (string-upcase (let ((foo string)) - ;; Hack alert: This is to keep the compiler - ;; quit about deleting code inside the subseq - ;; expansion. - (subseq foo (1+ slash) (1- end))))) - (first-colon (position #\: name)) - (last-colon (if first-colon (position #\: name :from-end t))) - (package-name (if last-colon - (subseq name 0 first-colon) - "USER")) - (package (find-package package-name))) - (unless package - (error 'format-error - :complaint "No package named ``~A''." - :arguments (list package-name))) - (intern (if first-colon - (subseq name (1+ first-colon)) - name) - package)))) - diff --git a/code/generic-site.lisp b/code/generic-site.lisp deleted file mode 100644 index 0aba116ed32d3ce21cd4d67313dfa379951518ce..0000000000000000000000000000000000000000 --- a/code/generic-site.lisp +++ /dev/null @@ -1,57 +0,0 @@ -;;; -*- Mode: Lisp; Package: System -*- -;;; -;;; ********************************************************************** -;;; 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/code/generic-site.lisp,v 1.5 1992/05/30 12:56:53 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Generic site specific initialization for CMU CL. This can be used as a -;;; template for non-cmu "library:site-init" files. -;;; -(in-package "SYSTEM") - -;;; Put your site name here... -(setq *short-site-name* "Unknown") -(setq *long-site-name* "Site name not initialized") - -;;; We would appreciate it if each site establishes a local maintainer who can -;;; filter bug reports from novice users to make sure that they really have -;;; found a bug. Fill in the maintainer's address here.. -(setf (getf *herald-items* :bugs) - '("Send bug reports and questions to your local CMU CL maintainer, or to -cmucl-bugs@cs.cmu.edu. -Loaded subsystems:")) - -;;; The following Hemlock initializations will error if run in a core without -;;; hemlock. -#+hemlock (progn -;;; If you have sources installed on your system, un-comment the following form -;;; and change it to point to the source location. This will allow the Hemlock -;;; "Edit Definition" command to find sources for functions in the core. If -;;; this doesn't work, check that first part of the translation really does -;;; have the correct prefix. -;;; -#| -(ed::add-definition-dir-translation - "/afs/cs.cmu.edu/project/clisp-1/sun4c_41/15/" - "<your source location here>") -|# - -;;; Use standard X fonts for Hemlock, since the default ones may not work -;;; everywhere. By default, Hemlock used 8x13 and a non-standard underline -;;; font, 8x13u (which is part of the distribution.) Unfortunately, we don't -;;; have source for this font, since it was created by hand-editing the -;;; bitmaps. -;;; -(hi:setv ed::open-paren-highlighting-font "*-courier-bold-r-normal--*-120-*") -(hi:setv ed::default-font "*-courier-medium-r-normal--*-120-*") -(hi:setv ed::active-region-highlighting-font - "*-courier-medium-o-normal--*-120-*") - -); #+hemlock diff --git a/code/globals.lisp b/code/globals.lisp deleted file mode 100644 index 8f7df7151082c710f8ee6f6ce4c80346fcb1a906..0000000000000000000000000000000000000000 --- a/code/globals.lisp +++ /dev/null @@ -1,53 +0,0 @@ -;;; -*- Package: Lisp; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/globals.lisp,v 1.6 1992/03/03 18:59:53 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains special proclamations for variables that are -;;; referenced in the code sources before they are defined. There is also a -;;; function proclamation to make some common functions be known, avoiding -;;; large amounts of work in recording the calls that are done before the -;;; definition. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'lisp) - -(proclaim '(special *keyword-package* *lisp-package* *package* *query-io* - *terminal-io* *error-output* *trace-output* *debug-io* - *standard-input* *standard-output* *hemlock-version* - *evalhook* *applyhook* *task-self* *command-line-switches* - *command-switch-demons* ext::temporary-foreign-files - *display-event-handlers* original-lisp-environment - *environment-list* *read-default-float-format* - *read-suppress* *readtable* *print-base* *print-radix* - *print-length* *print-level* *print-pretty* *print-escape* - *print-case* *print-circle* *print-gensym* *print-array* - defmacro-error-string defsetf-error-string - std-lisp-readtable hi::*in-the-editor* - debug::*in-the-debugger* - conditions::*handler-clusters* - conditions::*restart-clusters* alloctable-address - *gc-inhibit* *need-to-collect-garbage* - defmacro-error-string deftype-error-string - defsetf-error-string %sp-interrupts-inhibited - *software-interrupt-vector* *load-verbose* - *load-print-stuff* *in-compilation-unit* - *aborted-compilation-units* char-name-alist - *default-pathname-defaults* *beep-function* - *gc-notify-before* *gc-notify-after*)) - - -(proclaim '(ftype (function (&rest t) *) - c::%%defun c::%%defmacro c::%%defconstant c::%defstruct - c::%%compiler-defstruct c::%proclaim c::get-info-value - c::set-info-value find-keyword keyword-test assert-error - assert-prompt check-type-error case-body-error)) diff --git a/code/hppa-vm.lisp b/code/hppa-vm.lisp deleted file mode 100644 index ce033fb51de6cbe209a8b96d03f06bfba97c4011..0000000000000000000000000000000000000000 --- a/code/hppa-vm.lisp +++ /dev/null @@ -1,232 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/code/hppa-vm.lisp,v 1.5 1992/10/08 22:10:02 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the HPPA specific runtime stuff. -;;; -(in-package "HPPA") -(use-package "SYSTEM") -(use-package "ALIEN") -(use-package "C-CALL") -(use-package "UNIX") - -(export '(fixup-code-object internal-error-arguments - sigcontext-program-counter sigcontext-register - sigcontext-float-register sigcontext-floating-point-modes - extern-alien-name sanctify-for-execution)) - - -;;;; The sigcontext structure. - -(def-alien-type save-state - (struct nil - (regs (array unsigned-long 32)) - (filler (array unsigned-long 32)) - (fpregs (array unsigned-long 32)))) - -(def-alien-type sigcontext - (struct nil - (sc-onstack unsigned-long) - (sc-mask unsigned-long) - (sc-sp system-area-pointer) - (sc-fp system-area-pointer) - (sc-ap (* save-state)) - (sc-pcsqh unsigned-long) - (sc-pcoqh unsigned-long) - (sc-pcsqt unsigned-long) - (sc-pcoqt unsigned-long) - (sc-ps unsigned-long))) - - -;;;; Add machine specific features to *features* - -(pushnew :hppa *features*) - - - -;;;; MACHINE-TYPE and MACHINE-VERSION - -(defun machine-type () - "Returns a string describing the type of the local machine." - "HPPA") - -(defun machine-version () - "Returns a string describing the version of the local machine." - "HPPA") - - - -;;; FIXUP-CODE-OBJECT -- Interface -;;; -(defun fixup-code-object (code offset value kind) - (unless (zerop (rem offset word-bytes)) - (error "Unaligned instruction? offset=#x~X." offset)) - (system:without-gcing - (let* ((sap (truly-the system-area-pointer - (%primitive c::code-instructions code))) - (inst (sap-ref-32 sap offset))) - (setf (sap-ref-32 sap offset) - (ecase kind - (:load - (logior (ash (ldb (byte 11 0) value) 1) - (logand inst #xffffc000))) - (:load-short - (let ((low-bits (ldb (byte 11 0) value))) - (assert (<= 0 low-bits (1- (ash 1 4)))) - (logior (ash low-bits 17) - (logand inst #xffe0ffff)))) - (:hi - (logior (ash (ldb (byte 5 13) value) 16) - (ash (ldb (byte 2 18) value) 14) - (ash (ldb (byte 2 11) value) 12) - (ash (ldb (byte 11 20) value) 1) - (ldb (byte 1 31) value) - (logand inst #xffe00000))) - (:branch - (let ((bits (ldb (byte 9 2) value))) - (assert (zerop (ldb (byte 2 0) value))) - (logior (ash bits 3) - (logand inst #xffe0e002))))))))) - - - -;;;; Internal-error-arguments. - -;;; INTERNAL-ERROR-ARGUMENTS -- interface. -;;; -;;; Given the sigcontext, extract the internal error arguments from the -;;; instruction stream. -;;; -(defun internal-error-arguments (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (let ((pc (sigcontext-program-counter scp))) - (declare (type system-area-pointer pc)) - (let* ((length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) - (declare (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) - (copy-from-system-area pc (* byte-bits 5) - vector (* word-bits - vector-data-offset) - (* length byte-bits)) - (let* ((index 0) - (error-number (c::read-var-integer vector index))) - (collect ((sc-offsets)) - (loop - (when (>= index length) - (return)) - (sc-offsets (c::read-var-integer vector index))) - (values error-number (sc-offsets)))))))) - - -;;;; Sigcontext access functions. - -;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface -;;; -(defun sigcontext-program-counter (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (int-sap (logandc2 (slot scp 'sc-pcoqh) 3)))) - -;;; SIGCONTEXT-REGISTER -- Interface -;;; -;;; An escape register saves the value of a register for a frame that someone -;;; interrupts. -;;; -(defun sigcontext-register (scp index) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (deref (slot (slot scp 'sc-ap) 'regs) index))) - -(defun %set-sigcontext-register (scp index new) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (setf (deref (slot (slot scp 'sc-ap) 'regs) index) new) - new)) - -(defsetf sigcontext-register %set-sigcontext-register) - - -;;; SIGCONTEXT-FLOAT-REGISTER -- Interface -;;; -;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. -;;; Format is the type of float to return. -;;; -(defun sigcontext-float-register (scp index format) - (declare (type (alien (* sigcontext)) scp)) - (error "sigcontext-float-register not implimented." scp index format) - #+nil - (with-alien ((scp (* sigcontext) scp)) - (let ((sap (alien-sap (slot scp 'sc-fpregs)))) - (ecase format - (single-float (system:sap-ref-single sap (* index vm:word-bytes))) - (double-float (system:sap-ref-double sap (* index vm:word-bytes))))))) -;;; -(defun %set-sigcontext-float-register (scp index format new-value) - (declare (type (alien (* sigcontext)) scp)) - (error "%set-sigcontext-float-register not implimented." - scp index format new-value) - #+nil - (with-alien ((scp (* sigcontext) scp)) - (let ((sap (alien-sap (slot scp 'sc-fpregs)))) - (ecase format - (single-float - (setf (sap-ref-single sap (* index vm:word-bytes)) new-value)) - (double-float - (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) -;;; -(defsetf sigcontext-float-register %set-sigcontext-float-register) - - -;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface -;;; -;;; Given a sigcontext pointer, return the floating point modes word in the -;;; same format as returned by FLOATING-POINT-MODES. -;;; -(defun sigcontext-floating-point-modes (scp) - (declare (type (alien (* sigcontext)) scp)) - (error "sigcontext-floating-point-modes not implimented." scp) - #+nil - (with-alien ((scp (* sigcontext) scp)) - (slot scp 'sc-fpc-csr))) - - - -;;; EXTERN-ALIEN-NAME -- interface. -;;; -;;; The loader uses this to convert alien names to the form they occure in -;;; the symbol table (for example, prepending an underscore). On the HPPA -;;; we just leave it alone. -;;; -(defun extern-alien-name (name) - (declare (type simple-base-string name)) - name) - - - -;;; SANCTIFY-FOR-EXECUTION -- Interface. -;;; -;;; Do whatever is necessary to make the given code component executable. -;;; On the PA-RISC, this means flushing the data cache and purging the -;;; inst cache. -;;; -(defun sanctify-for-execution (component) - (without-gcing - (alien-funcall (extern-alien "sanctify_for_execution" - (function void - system-area-pointer - unsigned-long)) - (code-instructions component) - (* (code-header-ref component code-code-size-slot) - word-bytes))) - nil) diff --git a/code/internet.lisp b/code/internet.lisp deleted file mode 100644 index 75ed417b3df0e5f73a28a823ef1fbaeff042bb44..0000000000000000000000000000000000000000 --- a/code/internet.lisp +++ /dev/null @@ -1,370 +0,0 @@ -;;; -*- Log: code.log; Package: extensions -*- -;;; -;;; ********************************************************************** -;;; 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/code/internet.lisp,v 1.12 1992/12/18 19:02:13 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains an interface to internet domain sockets. -;;; -;;; Written by William Lott. -;;; - -(in-package "EXTENSIONS") - -(use-package "ALIEN") -(use-package "C-CALL") - -(export '(htonl ntohl htons ntohs lookup-host-entry host-entry host-entry-name - host-entry-aliases host-entry-addr-list host-entry-addr - create-unix-socket connect-to-unix-socket create-inet-socket - connect-to-inet-socket create-inet-listener accept-tcp-connection - close-socket ipproto-tcp ipproto-udp inaddr-any add-oob-handler - remove-oob-handler remove-all-oob-handlers - send-character-out-of-band)) - - -(defconstant sock-stream 1) -(defconstant sock-dgram 2) -(defconstant sock-raw 3) - -(defconstant af-unix 1) -(defconstant af-inet 2) - -(defconstant msg-oob 1) -(defconstant msg-peek 2) -(defconstant msg-dontroute 4) - -(defvar *internet-protocols* - (list (list :stream 6 sock-stream) - (list :data-gram 17 sock-dgram)) - "AList of socket kinds and protocol values.") - -(defun internet-protocol (kind) - (let ((entry (assoc kind *internet-protocols*))) - (unless entry - (error "Invalid kind (~S) for internet domain sockets." kind)) - (values (cadr entry) - (caddr entry)))) - - -(defmacro maybe-byte-swap (var bytes) - (ecase (c:backend-byte-order c:*backend*) - (:big-endian - var) - (:little-endian - (let ((ldbs nil)) - (dotimes (i bytes `(logior ,@ldbs)) - (push `(ash (ldb (byte 8 ,(* i 8)) ,var) - ,(* (- bytes 1 i) 8)) - ldbs)))))) - -(proclaim '(inline htonl ntohl htons ntohs)) - -(defun htonl (x) - (maybe-byte-swap x 4)) -(defun ntohl (x) - (maybe-byte-swap x 4)) -(defun htons (x) - (maybe-byte-swap x 2)) -(defun ntohs (x) - (maybe-byte-swap x 2)) - - -;;;; Host entry operations. - -(defstruct host-entry - name - aliases - addr-type - addr-list) - -(defun host-entry-addr (host) - (declare (type host-entry host)) - (car (host-entry-addr-list host))) - -(def-alien-type unix-sockaddr - (struct nil - (family short) - (path (array char 108)))) - -(def-alien-type inet-sockaddr - (struct nil - (family short) - (port unsigned-short) - (addr unsigned-long) - (zero (array char 8)))) - -(def-alien-type hostent - (struct nil - (name c-string) - (aliases (* c-string)) - (addrtype int) - (length int) - (addr-list (* (* (unsigned 32)))))) - -(def-alien-routine "gethostbyname" (* hostent) - (name c-string)) - -(def-alien-routine "gethostbyaddr" (* hostent) - (addr unsigned-long :copy) - (len int) - (type int)) - -(defun lookup-host-entry (host) - (if (typep host 'host-entry) - host - (with-alien - ((hostent (* hostent) - (etypecase host - (string - (gethostbyname host)) - ((unsigned-byte 32) - (gethostbyaddr host 4 af-inet))))) - (unless (zerop (sap-int (alien-sap hostent))) - (make-host-entry - :name (slot hostent 'name) - :aliases - (collect ((results)) - (iterate repeat ((index 0)) - (declare (type kernel:index index)) - (cond ((zerop (deref (cast (slot hostent 'aliases) - (* (unsigned 32))) - index)) - (results)) - (t - (results (deref (slot hostent 'aliases) index)) - (repeat (1+ index)))))) - :addr-type (slot hostent 'addrtype) - :addr-list - (collect ((results)) - (iterate repeat ((index 0)) - (declare (type kernel:index index)) - (cond ((zerop (deref (cast (slot hostent 'addr-list) - (* (unsigned 32))) - index)) - (results)) - (t - (results (deref (deref (slot hostent 'addr-list) index))) - (repeat (1+ index))))))))))) - -(defun create-unix-socket (&optional (kind :stream)) - (multiple-value-bind (proto type) - (internet-protocol kind) - (declare (ignore proto)) - (let ((socket (unix:unix-socket af-unix type 0))) - (when (minusp socket) - (error "Error creating socket: ~A" (unix:get-unix-error-msg))) - socket))) - -(defun connect-to-unix-socket (path &optional (kind :stream)) - (declare (simple-string path)) - (let ((socket (create-unix-socket kind))) - (with-alien ((sockaddr unix-sockaddr)) - (setf (slot sockaddr 'family) af-unix) - (kernel:copy-to-system-area path - (* vm:vector-data-offset vm:word-bits) - (alien-sap (slot sockaddr 'path)) - 0 - (* (1+ (length path)) vm:byte-bits)) - (when (minusp (unix:unix-connect socket - (alien-sap sockaddr) - (alien-size unix-sockaddr :bytes))) - (unix:unix-close socket) - (error "Error connecting socket to [~A]: ~A" - path (unix:get-unix-error-msg))) - socket))) - -(defun create-inet-socket (&optional (kind :stream)) - (multiple-value-bind (proto type) - (internet-protocol kind) - (let ((socket (unix:unix-socket af-inet type proto))) - (when (minusp socket) - (error "Error creating socket: ~A" (unix:get-unix-error-msg))) - socket))) - -(defun connect-to-inet-socket (host port &optional (kind :stream)) - (let ((socket (create-inet-socket kind)) - (hostent (or (lookup-host-entry host) - (error "Unknown host: ~S." host)))) - (with-alien ((sockaddr inet-sockaddr)) - (setf (slot sockaddr 'family) af-inet) - (setf (slot sockaddr 'port) (htons port)) - (setf (slot sockaddr 'addr) (host-entry-addr hostent)) - (when (minusp (unix:unix-connect socket - (alien-sap sockaddr) - (alien-size inet-sockaddr :bytes))) - (unix:unix-close socket) - (error "Error connecting socket to [~A:~A]: ~A" - (host-entry-name hostent) - port - (unix:get-unix-error-msg))) - socket))) - -(defun create-inet-listener (port &optional (kind :stream)) - (let ((socket (create-inet-socket kind))) - (with-alien ((sockaddr inet-sockaddr)) - (setf (slot sockaddr 'family) af-inet) - (setf (slot sockaddr 'port) (htons port)) - (setf (slot sockaddr 'addr) 0) - (when (minusp (unix:unix-bind socket - (alien-sap sockaddr) - (alien-size inet-sockaddr :bytes))) - (unix:unix-close socket) - (error "Error binding socket to port ~a: ~a" - port - (unix:get-unix-error-msg)))) - (when (eq kind :stream) - (when (minusp (unix:unix-listen socket 5)) - (unix:unix-close socket) - (error "Error listening to socket: ~A" (unix:get-unix-error-msg)))) - socket)) - -(defun accept-tcp-connection (unconnected) - (declare (fixnum unconnected)) - (with-alien ((sockaddr inet-sockaddr)) - (let ((connected (unix:unix-accept unconnected - (alien-sap sockaddr) - (alien-size inet-sockaddr :bytes)))) - (when (minusp connected) - (error "Error accepting a connection: ~A" (unix:get-unix-error-msg))) - (values connected (slot sockaddr 'addr))))) - -(defun close-socket (socket) - (multiple-value-bind (ok err) - (unix:unix-close socket) - (unless ok - (error "Error closing socket: ~A" (unix:get-unix-error-msg err)))) - (undefined-value)) - - - -;;;; Out of Band Data. - -;;; Two level AList. First levels key is the file descriptor, second levels -;;; key is the character. The datum is the handler to call. - -(defvar *oob-handlers* nil) - -;;; SIGURG-HANDLER -- internal -;;; -;;; Routine that gets called whenever out-of-band data shows up. Checks each -;;; file descriptor for any oob data. If there is any, look for a handler for -;;; that character. If any are found, funcall them. - -(defun sigurg-handler (signo code scp) - (declare (ignore signo code scp)) - (let ((buffer (make-string 1)) - (handled nil)) - (declare (simple-string buffer)) - (dolist (handlers *oob-handlers*) - (declare (list handlers)) - (cond ((minusp (unix:unix-recv (car handlers) buffer 1 msg-oob)) - (cerror "Ignore it" - "Error recving oob data on ~A: ~A" - (car handlers) - (unix:get-unix-error-msg))) - (t - (setf handled t) - (let ((char (schar buffer 0)) - (handled nil)) - (declare (base-char char)) - (dolist (handler (cdr handlers)) - (declare (list handler)) - (when (eql (car handler) char) - (funcall (cdr handler)) - (setf handled t))) - (unless handled - (cerror "Ignore it" - "No oob handler defined for ~S on ~A" - char - (car handlers))))))) - (unless handled - (cerror "Ignore it" - "Got a SIGURG, but couldn't find any out-of-band data."))) - (undefined-value)) - -;;; ADD-OOB-HANDLER -- public -;;; -;;; First, check to see if we already have any handlers for this file -;;; descriptor. If so, just add this handler to them. If not, add this -;;; file descriptor to *oob-handlers*, make sure our interupt handler is -;;; installed, and that the given file descriptor is "owned" by us (so sigurg -;;; will be delivered.) - -(defun add-oob-handler (fd char handler) - "Arange to funcall HANDLER when CHAR shows up out-of-band on FD." - (declare (integer fd) - (base-char char)) - (let ((handlers (assoc fd *oob-handlers*))) - (declare (list handlers)) - (cond (handlers - (push (cons char handler) - (cdr handlers))) - (t - (push (list fd - (cons char - handler)) - *oob-handlers*) - (system:enable-interrupt unix:sigurg #'sigurg-handler) - (unix:unix-fcntl fd unix:f-setown (unix:unix-getpid))))) - (values)) - -;;; REMOVE-OOB-HANDLER -- public -;;; -;;; Delete any handlers for the given char from the list of handlers for the -;;; given file descriptor. If there are no more, nuke the entry for the file -;;; descriptor. - -(defun remove-oob-handler (fd char) - "Remove any handlers for CHAR on FD." - (declare (integer fd) - (base-char char)) - (let ((handlers (assoc fd *oob-handlers*))) - (declare (list handlers)) - (when handlers - (let ((remaining (delete char handlers - :test #'eql - :key #'car))) - (declare (list remaining)) - (if remaining - (setf (cdr handlers) remaining) - (setf *oob-handlers* - (delete fd *oob-handlers* - :test #'eql - :key #'car)))))) - (values)) - -;;; REMOVE-ALL-OOB-HANDLERS -- public -;;; -;;; Delete the entry for the given file descriptor. - -(defun remove-all-oob-handlers (fd) - "Remove all handlers for FD." - (declare (integer fd)) - (setf *oob-handlers* - (delete fd *oob-handlers* - :test #'eql - :key #'car)) - (values)) - -;;; SEND-CHARACTER-OUT-OF-BAND -- public -;;; -;;; Sends CHAR across FD out of band. - -(defun send-character-out-of-band (fd char) - (declare (integer fd) - (base-char char)) - (let ((buffer (make-string 1 :initial-element char))) - (declare (simple-string buffer)) - (when (minusp (unix:unix-send fd buffer 1 msg-oob)) - (error "Error sending ~S OOB to across ~A: ~A" - char - fd - (unix:get-unix-error-msg))))) diff --git a/code/irrat.lisp b/code/irrat.lisp deleted file mode 100644 index 9cdf62582e6613e2fe89d7f30d5c879ceb00db9e..0000000000000000000000000000000000000000 --- a/code/irrat.lisp +++ /dev/null @@ -1,394 +0,0 @@ -;;; -*- Mode: Lisp; Package: KERNEL; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/irrat.lisp,v 1.10 1992/02/14 23:45:06 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains all the irrational functions. Actually, most of the -;;; work is done by calling out to C... -;;; -;;; Author: William Lott. -;;; - -(in-package "KERNEL") - - -;;;; Random constants, utility functions, and macros. - -(defconstant pi 3.14159265358979323846264338327950288419716939937511L0) -;(defconstant e 2.71828182845904523536028747135266249775724709369996L0) - -;;; Make these INLINE, since the call to C is at least as compact as a Lisp -;;; call, and saves number consing to boot. -;;; -(defmacro def-math-rtn (name num-args) - (let ((function (intern (concatenate 'simple-string - "%" - (string-upcase name))))) - `(progn - (proclaim '(inline ,function)) - (export ',function) - (alien:def-alien-routine (,name ,function) double-float - ,@(let ((results nil)) - (dotimes (i num-args (nreverse results)) - (push (list (intern (format nil "ARG-~D" i)) - 'double-float) - results))))))) - -(eval-when (compile load eval) - -(defun handle-reals (function var) - `((((foreach fixnum single-float bignum ratio)) - (coerce (,function (coerce ,var 'double-float)) 'single-float)) - ((double-float) - (,function ,var)))) - -); eval-when (compile load eval) - - -;;;; Stubs for the Unix math library. - -;;; Please refer to the Unix man pages for details about these routines. - -;;; Trigonometric. -(def-math-rtn "sin" 1) -(def-math-rtn "cos" 1) -(def-math-rtn "tan" 1) -(def-math-rtn "asin" 1) -(def-math-rtn "acos" 1) -(def-math-rtn "atan" 1) -(def-math-rtn "atan2" 2) -(def-math-rtn "sinh" 1) -(def-math-rtn "cosh" 1) -(def-math-rtn "tanh" 1) -(def-math-rtn "asinh" 1) -(def-math-rtn "acosh" 1) -(def-math-rtn "atanh" 1) - -;;; Exponential and Logarithmic. -(def-math-rtn "exp" 1) -(def-math-rtn "expm1" 1) -(def-math-rtn "log" 1) -(def-math-rtn "log10" 1) -(def-math-rtn "log1p" 1) -(def-math-rtn "pow" 2) -(def-math-rtn "cbrt" 1) -(def-math-rtn "sqrt" 1) -(def-math-rtn "hypot" 2) - - -;;;; Power functions. - -(defun exp (number) - "Return e raised to the power NUMBER." - (number-dispatch ((number number)) - (handle-reals %exp number) - ((complex) - (* (exp (realpart number)) - (cis (imagpart number)))))) - -;;; INTEXP -- Handle the rational base, integer power case. - -(defparameter *intexp-maximum-exponent* 10000) - -;;; This function precisely calculates base raised to an integral power. It -;;; separates the cases by the sign of power, for efficiency reasons, as powers -;;; can be calculated more efficiently if power is a positive integer. Values -;;; of power are calculated as positive integers, and inverted if negative. -;;; -(defun intexp (base power) - (when (> (abs power) *intexp-maximum-exponent*) - (cerror "Continue with calculation." - "The absolute value of ~S exceeds ~S." - power '*intexp-maximum-exponent* base power)) - (cond ((minusp power) - (/ (intexp base (- power)))) - ((eql base 2) - (ash 1 power)) - (t - (do ((nextn (ash power -1) (ash power -1)) - (total (if (oddp power) base 1) - (if (oddp power) (* base total) total))) - ((zerop nextn) total) - (setq base (* base base)) - (setq power nextn))))) - - -;;; EXPT -- Public -;;; -;;; If an integer power of a rational, use INTEXP above. Otherwise, do -;;; floating point stuff. If both args are real, we try %POW right off, -;;; assuming it will return 0 if the result may be complex. If so, we call -;;; COMPLEX-POW which directly computes the complex result. We also separate -;;; the complex-real and real-complex cases from the general complex case. -;;; -(defun expt (base power) - "Returns BASE raised to the POWER." - (if (zerop power) - (1+ (* base power)) - (labels ((real-expt (base power rtype) - (let* ((fbase (coerce base 'double-float)) - (fpower (coerce power 'double-float)) - (res (coerce (%pow fbase fpower) rtype))) - (if (and (zerop res) (minusp fbase)) - (multiple-value-bind (re im) - (complex-pow fbase fpower) - (%make-complex (coerce re rtype) (coerce im rtype))) - res))) - (complex-pow (fbase fpower) - (let ((pow (%pow (- fbase) fpower)) - (fpower*pi (* fpower pi))) - (values (* pow (%cos fpower*pi)) - (* pow (%sin fpower*pi)))))) - (declare (inline real-expt)) - (number-dispatch ((base number) (power number)) - (((foreach fixnum (or bignum ratio) (complex rational)) integer) - (intexp base power)) - (((foreach single-float double-float) rational) - (real-expt base power '(dispatch-type base))) - (((foreach fixnum (or bignum ratio) single-float) - (foreach ratio single-float)) - (real-expt base power 'single-float)) - (((foreach fixnum (or bignum ratio) single-float double-float) - double-float) - (real-expt base power 'double-float)) - ((double-float single-float) - (real-expt base power 'double-float)) - (((foreach (complex rational) (complex float)) rational) - (* (expt (abs base) power) - (cis (* power (phase base))))) - (((foreach fixnum (or bignum ratio) single-float double-float) - complex) - (if (minusp base) - (/ (exp (* power (truly-the float (log (- base)))))) - (exp (* power (truly-the float (log base)))))) - (((foreach (complex float) (complex rational)) complex) - (exp (* power (log base)))))))) - -(defun log (number &optional (base nil base-p)) - "Return the logarithm of NUMBER in the base BASE, which defaults to e." - (if base-p - (/ (log number) (log base)) - (number-dispatch ((number number)) - (((foreach fixnum bignum ratio single-float)) - (if (minusp number) - (complex (log (- number)) (coerce pi 'single-float)) - (coerce (%log (coerce number 'double-float)) 'single-float))) - ((double-float) - (if (minusp number) - (complex (log (- number)) (coerce pi 'double-float)) - (%log number))) - ((complex) (complex (log (abs number)) (phase number)))))) - -(defun sqrt (number) - "Return the square root of NUMBER." - (number-dispatch ((number number)) - (((foreach fixnum bignum ratio single-float)) - (if (minusp number) - (exp (/ (log number) 2)) - (coerce (%sqrt (coerce number 'double-float)) 'single-float))) - ((double-float) - (if (minusp number) - (exp (/ (log number) 2)) - (%sqrt number))) - ((complex) (exp (/ (log number) 2))))) - -;;; ISQRT: Integer square root - isqrt(n)**2 <= n -;;; Upper and lower bounds on the result are estimated using integer-length. -;;; On each iteration, one of the bounds is replaced by their mean. -;;; The lower bound is returned when the bounds meet or differ by only 1. -;;; Initial bounds guarantee that lg(sqrt(n)) = lg(n)/2 iterations suffice. - -(defun isqrt (n) - "Returns the root of the nearest integer less than - n which is a perfect square." - (if (and (integerp n) (not (minusp n))) - (do* ((lg (integer-length n)) - (lo (ash 1 (ash (1- lg) -1))) - (hi (+ lo (ash lo (if (oddp lg) -1 0))))) ;tighten by 3/4 if possible. - ((<= (1- hi) lo) lo) - (let ((mid (ash (+ lo hi) -1))) - (if (<= (* mid mid) n) (setq lo mid) (setq hi mid)))) - (error "Isqrt: ~S argument must be a nonnegative integer" n))) - - - -;;;; Trigonometic and Related Functions - -(defun abs (number) - "Returns the absolute value of the number." - (number-dispatch ((number number)) - (((foreach single-float double-float fixnum rational)) - (abs number)) - ((complex) - (let ((rx (realpart number)) - (ix (imagpart number))) - (etypecase rx - (rational - (sqrt (+ (* rx rx) (* ix ix)))) - (single-float - (coerce (%hypot (coerce rx 'double-float) - (coerce ix 'double-float)) - 'single-float)) - (double-float - (%hypot rx ix))))))) - -(defun phase (number) - "Returns the angle part of the polar representation of a complex number. - For complex numbers, this is (atan (imagpart number) (realpart number)). - For non-complex positive numbers, this is 0. For non-complex negative - numbers this is PI." - (etypecase number - ((or rational single-float) - (if (minusp number) - (coerce pi 'single-float) - 0.0f0)) - (double-float - (if (minusp number) - (coerce pi 'double-float) - 0.0d0)) - (complex - (atan (imagpart number) (realpart number))))) - - -(defun sin (number) - "Return the sine of NUMBER." - (number-dispatch ((number number)) - (handle-reals %sin number) - ((complex) - (let ((x (realpart number)) - (y (imagpart number))) - (complex (* (sin x) (cosh y)) (* (cos x) (sinh y))))))) - -(defun cos (number) - "Return the cosine of NUMBER." - (number-dispatch ((number number)) - (handle-reals %cos number) - ((complex) - (let ((x (realpart number)) - (y (imagpart number))) - (complex (* (cos x) (cosh y)) (- (* (sin x) (sinh y)))))))) - -(defun tan (number) - "Return the tangent of NUMBER." - (number-dispatch ((number number)) - (handle-reals %tan number) - ((complex) - (let* ((num (sin number)) - (denom (cos number))) - (if (zerop denom) (error "~S undefined tangent." number) - (/ num denom)))))) - -(defun cis (theta) - "Return cos(Theta) + i sin(Theta), AKA exp(i Theta)." - (if (complexp theta) - (error "Argument to CIS is complex: ~S" theta) - (complex (cos theta) (sin theta)))) - -(proclaim '(inline mult-by-i)) -(defun mult-by-i (number) - (complex (imagpart number) - (- (realpart number)))) - -(defun complex-asin (number) - (- (mult-by-i (log (+ (mult-by-i number) (sqrt (- 1 (* number number)))))))) - -(defun asin (number) - "Return the arc sine of NUMBER." - (number-dispatch ((number number)) - ((rational) - (if (or (> number 1) (< number -1)) - (complex-asin number) - (coerce (%asin (coerce number 'double-float)) 'single-float))) - (((foreach single-float double-float)) - (if (or (> number (coerce 1 '(dispatch-type number))) - (< number (coerce -1 '(dispatch-type number)))) - (complex-asin number) - (coerce (%asin (coerce number 'double-float)) - '(dispatch-type number)))) - ((complex) - (complex-asin number)))) - -(defun complex-acos (number) - (- (mult-by-i (log (+ number (mult-by-i (sqrt (- (* number number))))))))) - -(defun acos (number) - "Return the arc cosine of NUMBER." - (number-dispatch ((number number)) - ((rational) - (if (or (> number 1) (< number -1)) - (complex-acos number) - (coerce (%acos (coerce number 'double-float)) 'single-float))) - (((foreach single-float double-float)) - (if (or (> number (coerce 1 '(dispatch-type number))) - (< number (coerce -1 '(dispatch-type number)))) - (complex-acos number) - (coerce (%acos (coerce number 'double-float)) - '(dispatch-type number)))) - ((complex) - (complex-acos number)))) - - -(defun atan (y &optional (x nil xp)) - "Return the arc tangent of Y if X is omitted or Y/X if X is supplied." - (if xp - (if (and (zerop x) (zerop y)) - (if (plusp (float-sign (float x))) - y - (if (minusp (float-sign (float y))) - (- pi) - pi)) - (number-dispatch ((y real) (x real)) - (((foreach fixnum bignum ratio single-float) - (foreach fixnum bignum ratio single-float)) - (coerce (%atan2 (coerce y 'double-float) - (coerce x 'double-float)) - 'single-float)) - ((double-float (foreach fixnum bignum ratio single-float)) - (%atan2 y (coerce x 'double-float))) - (((foreach fixnum bignum ratio single-float double-float) - double-float) - (%atan2 (coerce y 'double-float) x)))) - (number-dispatch ((y number)) - (handle-reals %atan y) - ((complex) - (let ((im (imagpart y)) - (re (realpart y))) - (/ (- (log (complex (- 1 im) re)) - (log (complex (+ 1 im) (- re)))) - (complex 0 2))))))) - - -(defun sinh (number) - "Return the hyperbolic sine of NUMBER." - (/ (- (exp number) (exp (- number))) 2)) - -(defun cosh (number) - "Return the hyperbolic cosine of NUMBER." - (/ (+ (exp number) (exp (- number))) 2)) - -(defun tanh (number) - "Return the hyperbolic tangent of NUMBER." - (/ (- (exp number) (exp (- number))) - (+ (exp number) (exp (- number))))) - - -(defun asinh (number) - "Return the hyperbolic arc sine of NUMBER." - (log (+ number (sqrt (1+ (* number number)))))) - -(defun acosh (number) - "Return the hyperbolic arc cosine of NUMBER." - (log (+ number (* (1+ number) (sqrt (/ (1- number) (1+ number))))))) - -(defun atanh (number) - "Return the hyperbolic arc tangent of NUMBER." - (log (* (1+ number) (sqrt (/ (- 1 (* number number))))))) - diff --git a/code/kernel.lisp b/code/kernel.lisp deleted file mode 100644 index 5130b273a049f57cb204b779b5a3f1c0d8eb6bf9..0000000000000000000000000000000000000000 --- a/code/kernel.lisp +++ /dev/null @@ -1,140 +0,0 @@ -;;; -*- Log: code.log; Package: KERNEL -*- -;;; -;;; ********************************************************************** -;;; 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/code/kernel.lisp,v 1.9 1992/12/13 16:04:30 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/kernel.lisp,v 1.9 1992/12/13 16:04:30 wlott Exp $ -;;; -(in-package "KERNEL") - -(export '(allocate-vector make-array-header function-subtype)) - - -(defun get-header-data (x) - "Return the 24 bits of data in the header of object X, which must be an - other-pointer object." - (get-header-data x)) - -(defun set-header-data (x val) - "Sets the 24 bits of data in the header of object X (which must be an - other-pointer object) to VAL." - (set-header-data x val)) - -(defun get-closure-length (x) - "Returns the length of the closure X. This is one more than the number - of variables closed over." - (get-closure-length x)) - -(defun get-lowtag (x) - "Returns the three-bit lowtag for the object X." - (get-lowtag x)) - -(defun get-type (x) - "Returns the 8-bit header type for the object X." - (get-type x)) - -(defun vector-sap (x) - "Return a System-Area-Pointer pointing to the data for the vector X, which - must be simple." - (declare (type (simple-unboxed-array (*)) x)) - (vector-sap x)) - - -(defun c::binding-stack-pointer-sap () - "Return a System-Area-Pointer pointing to the end of the binding stack." - (c::binding-stack-pointer-sap)) - -(defun c::dynamic-space-free-pointer () - "Returns a System-Area-Pointer pointing to the next free work of the current - dynamic space." - (c::dynamic-space-free-pointer)) - -(defun c::control-stack-pointer-sap () - "Return a System-Area-Pointer pointing to the end of the control stack." - (c::control-stack-pointer-sap)) - -(defun function-subtype (function) - "Return the header typecode for FUNCTION. Can be set with SETF." - (function-subtype function)) - -(defun (setf function-subtype) (type function) - (setf (function-subtype function) type)) - -(defun %function-arglist (func) - "Extracts the arglist from the function header FUNC." - (%function-arglist func)) - -(defun %function-name (func) - "Extracts the name from the function header FUNC." - (%function-name func)) - -(defun %function-type (func) - "Extracts the type from the function header FUNC." - (%function-type func)) - -(defun %closure-function (closure) - "Extracts the function from CLOSURE." - (%closure-function closure)) - -(defun c::vector-length (vector) - "Return the length of VECTOR. There is no reason to use this, 'cause - (length (the vector foo)) is the same." - (c::vector-length vector)) - -(defun %sxhash-simple-string (string) - "Return the SXHASH for the simple-string STRING." - (%sxhash-simple-string string)) - -(defun %sxhash-simple-substrubg (string length) - "Return the SXHASH for the first LENGTH characters of the simple-string - STRING." - (%sxhash-simple-substring string length)) - -(defun %closure-index-ref (closure index) - "Extract the INDEXth slot from CLOSURE." - (%closure-index-ref closure index)) - - -(defun allocate-vector (type length words) - "Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and - WORDS words long. Note: it is your responsibility to assure that the - relation between LENGTH and WORDS is correct." - (allocate-vector type length words)) - -(defun make-array-header (type rank) - "Allocate an array header with type code TYPE and rank RANK." - (make-array-header type rank)) - - -(defun code-instructions (code-obj) - "Return a SAP pointing to the instructions part of CODE-OBJ." - (code-instructions code-obj)) - -(defun code-header-ref (code-obj index) - "Extract the INDEXth element from the header of CODE-OBJ. Can be set with - setf." - (code-header-ref code-obj index)) - -(defun code-header-set (code-obj index new) - (code-header-set code-obj index new)) - -(defsetf code-header-ref code-header-set) - - -(defun %raw-bits (object offset) - (declare (type index offset)) - (kernel:%raw-bits object offset)) - -(defun %set-raw-bits (object offset value) - (declare (type index offset) (type (unsigned-byte #.vm:word-bits) value)) - (setf (kernel:%raw-bits object offset) value)) - -(defsetf %raw-bits %set-raw-bits) diff --git a/code/list.lisp b/code/list.lisp deleted file mode 100644 index 8350bb6ec6c8039f7901d807eb4e91eacb6ce8f8..0000000000000000000000000000000000000000 --- a/code/list.lisp +++ /dev/null @@ -1,980 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/list.lisp,v 1.12 1992/05/15 19:25:46 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Functions to implement lists for Spice Lisp. -;;; Written by Joe Ginder and Carl Ebeling. -;;; Rewritten and currently maintained by Skef Wholey. -;;; -;;; Nsublis, things at the beginning broken. -;;; -;;; The list functions are part of the standard Spice Lisp environment. -;;; -;;; ********************************************************************** -;;; -(in-package 'lisp) - -(export '(car cdr caar - cadr cdar cddr caaar caadr cadar caddr cdaar cdadr - cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr - caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr - cdddar cddddr cons tree-equal endp list-length nth first - second third fourth fifth sixth seventh eighth - ninth tenth rest nthcdr last list list* make-list - append copy-list copy-alist copy-tree revappend nconc - nreconc butlast nbutlast ldiff rplaca rplacd subst - subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis - member member-if member-if-not tailp adjoin union - nunion intersection nintersection set-difference - nset-difference set-exclusive-or nset-exclusive-or subsetp - acons pairlis - assoc assoc-if assoc-if-not - rassoc rassoc-if rassoc-if-not - complement constantly)) - -(proclaim '(maybe-inline - tree-equal list-length nth %setnth nthcdr last make-list append - copy-list copy-alist copy-tree revappend nconc nreconc butlast - nbutlast ldiff member member-if member-if-not tailp adjoin union - nunion intersection nintersection set-difference nset-difference - set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc - assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if - subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) - - -(in-package "EXTENSIONS") -(export '(assq memq delq)) -(proclaim '(inline assq memq)) -(proclaim '(maybe-inline delq)) -(in-package 'lisp) - - -;;; These functions perform basic list operations: - -(defun car (list) "Returns the 1st object in a list." (car list)) -(defun cdr (list) "Returns all but the first object." (cdr list)) -(defun cadr (list) "Returns the 2nd object in a list." (cadr list)) -(defun cdar (list) "Returns the cdr of the 1st sublist." (cdar list)) -(defun caar (list) "Returns the car of the 1st sublist." (caar list)) -(defun cddr (list) "Returns all but the 1st two objects of a list." (cddr list)) -(defun caddr (list) "Returns the 1st object in the cddr of a list." (caddr list)) -(defun caadr (list) "Returns the 1st object in the cadr of a list." (caadr list)) -(defun caaar (list) "Returns the 1st object in the caar of a list." (caaar list)) -(defun cdaar (list) "Returns the cdr of the caar of a list." (cdaar list)) -(defun cddar (list) "Returns the cdr of the cdar of a list." (cddar list)) -(defun cdddr (list) "Returns the cdr of the cddr of a list." (cdddr list)) -(defun cadar (list) "Returns the car of the cdar of a list." (cadar list)) -(defun cdadr (list) "Returns the cdr of the cadr of a list." (cdadr list)) -(defun caaaar (list) "Returns the car of the caaar of a list." (caaaar list)) -(defun caaadr (list) "Returns the car of the caadr of a list." (caaadr list)) -(defun caaddr (list) "Returns the car of the caddr of a list." (caaddr list)) -(defun cadddr (list) "Returns the car of the cdddr of a list." (cadddr list)) -(defun cddddr (list) "Returns the cdr of the cdddr of a list." (cddddr list)) -(defun cdaaar (list) "Returns the cdr of the caaar of a list." (cdaaar list)) -(defun cddaar (list) "Returns the cdr of the cdaar of a list." (cddaar list)) -(defun cdddar (list) "Returns the cdr of the cddar of a list." (cdddar list)) -(defun caadar (list) "Returns the car of the cadar of a list." (caadar list)) -(defun cadaar (list) "Returns the car of the cdaar of a list." (cadaar list)) -(defun cadadr (list) "Returns the car of the cdadr of a list." (cadadr list)) -(defun caddar (list) "Returns the car of the cddar of a list." (caddar list)) -(defun cdaadr (list) "Returns the cdr of the caadr of a list." (cdaadr list)) -(defun cdadar (list) "Returns the cdr of the cadar of a list." (cdadar list)) -(defun cdaddr (list) "Returns the cdr of the caddr of a list." (cdaddr list)) -(defun cddadr (list) "Returns the cdr of the cdadr of a list." (cddadr list)) -(defun cons (se1 se2) "Returns a list with se1 as the car and se2 as the cdr." - (cons se1 se2)) - - -(proclaim '(maybe-inline tree-equal-test tree-equal-test-not)) - -(defun tree-equal-test-not (x y test-not) - (cond ((not (funcall test-not x y)) t) - ((consp x) - (and (consp y) - (tree-equal-test-not (car x) (car y) test-not) - (tree-equal-test-not (cdr x) (cdr y) test-not))) - (t ()))) - -(defun tree-equal-test (x y test) - (cond ((funcall test x y) t) - ((consp x) - (and (consp y) - (tree-equal-test (car x) (car y) test) - (tree-equal-test (cdr x) (cdr y) test))) - (t ()))) - -(defun tree-equal (x y &key (test #'eql) test-not) - "Returns T if X and Y are isomorphic trees with identical leaves." - (if test-not - (tree-equal-test-not x y test-not) - (tree-equal-test x y test))) - - -(defun endp (object) - "The recommended way to test for the end of a list. True if Object is nil, - false if Object is a cons, and an error for any other types of arguments." - (endp object)) - -(defun list-length (list) - "Returns the length of the given List, or Nil if the List is circular." - (do ((n 0 (+ n 2)) - (y list (cddr y)) - (z list (cdr z))) - (()) - (declare (fixnum n) (list y z)) - (when (endp y) (return n)) - (when (endp (cdr y)) (return (+ n 1))) - (when (and (eq y z) (> n 0)) (return nil)))) - -(defun nth (n list) - "Returns the nth object in a list where the car is the zero-th element." - (car (nthcdr n list))) - -(defun first (list) - "Returns the 1st object in a list or NIL if the list is empty." - (car list)) -(defun second (list) - "Returns the 2nd object in a list or NIL if there is no 2nd object." - (cadr list)) -(defun third (list) - "Returns the 3rd object in a list or NIL if there is no 3rd object." - (caddr list)) -(defun fourth (list) - "Returns the 4th object in a list or NIL if there is no 4th object." - (cadddr list)) -(defun fifth (list) - "Returns the 5th object in a list or NIL if there is no 5th object." - (car (cddddr list))) -(defun sixth (list) - "Returns the 6th object in a list or NIL if there is no 6th object." - (cadr (cddddr list))) -(defun seventh (list) - "Returns the 7th object in a list or NIL if there is no 7th object." - (caddr (cddddr list))) -(defun eighth (list) - "Returns the 8th object in a list or NIL if there is no 8th object." - (cadddr (cddddr list))) -(defun ninth (list) - "Returns the 9th object in a list or NIL if there is no 9th object." - (car (cddddr (cddddr list)))) -(defun tenth (list) - "Returns the 10th object in a list or NIL if there is no 10th object." - (cadr (cddddr (cddddr list)))) -(defun rest (list) - "Means the same as the cdr of a list." - (cdr list)) - -(defun nthcdr (n list) - (declare (type index n)) - "Performs the cdr function n times on a list." - (do ((i n (1- i)) - (result list (cdr result))) - ((not (plusp i)) result) - (declare (type index i)))) - -(defun last (list &optional (n 1)) - "Returns the last N conses (not the last element!) of a list." - (declare (type index n)) - (do ((checked-list list (cdr checked-list)) - (returned-list list) - (index 0 (1+ index))) - ((atom checked-list) returned-list) - (declare (type index index)) - (if (>= index n) - (pop returned-list)))) - -(defun list (&rest args) - "Returns constructs and returns a list of its arguments." - args) - -;;; List* is done the same as list, except that the last cons is made a -;;; dotted pair - -(defun list* (arg &rest others) - "Returns a list of the arguments with last cons a dotted pair" - (cond ((atom others) arg) - ((atom (cdr others)) (cons arg (car others))) - (t (do ((x others (cdr x))) - ((null (cddr x)) (rplacd x (cadr x)))) - (cons arg others)))) - -(defun make-list (size &key initial-element) - "Constructs a list with size elements each set to value" - (declare (type index size)) - (do ((count size (1- count)) - (result '() (cons initial-element result))) - ((zerop count) result) - (declare (type index count)))) - - -;;; The outer loop finds the first non-null list and the result is started. -;;; The remaining lists in the arguments are tacked to the end of the result -;;; using splice which cdr's down the end of the new list - -(defun append (&rest lists) - "Construct a new list by concatenating the list arguments" - (do ((top lists (cdr top))) ;;Cdr to first non-null list. - ((atom top) '()) - (cond ((null (car top))) ; Nil -> Keep looping - ((not (consp (car top))) ; Non cons - (if (cdr top) - (error "~S is not a list." (car top)) - (return (car top)))) - (t ; Start appending - (return - (if (atom (cdr top)) - (car top) ;;Special case. - (let* ((result (cons (caar top) '())) - (splice result)) - (do ((x (cdar top) (cdr x))) ;;Copy first list - ((atom x)) - (setq splice - (cdr (rplacd splice (cons (car x) ()) ))) ) - (do ((y (cdr top) (cdr y))) ;;Copy rest of lists. - ((atom (cdr y)) - (setq splice (rplacd splice (car y))) - result) - (if (listp (car y)) - (do ((x (car y) (cdr x))) ;;Inner copy loop. - ((atom x)) - (setq - splice - (cdr (rplacd splice (cons (car x) ()))))) - (error "~S is not a list." (car y))))))))))) - - -;;; List Copying Functions - -;;; The list is copied correctly even if the list is not terminated by () -;;; The new list is built by cdr'ing splice which is always at the tail -;;; of the new list - -(defun copy-list (list) - "Returns a new list EQUAL but not EQ to list" - (if (atom list) - list - (let ((result (list (car list)))) - (do ((x (cdr list) (cdr x)) - (splice result - (cdr (rplacd splice (cons (car x) '() ))) )) - ((atom x) - (unless (null x) - (rplacd splice x)))) - result))) - -(defun copy-alist (alist) - "Returns a new association list equal to alist, constructed in space" - (if (atom alist) - alist - (let ((result - (cons (if (atom (car alist)) - (car alist) - (cons (caar alist) (cdar alist)) ) - nil))) - (do ((x (cdr alist) (cdr x)) - (splice result - (cdr (rplacd splice - (cons - (if (atom (car x)) - (car x) - (cons (caar x) (cdar x))) - nil))))) - ;; Non-null terminated alist done here. - ((atom x) - (unless (null x) - (rplacd splice x)))) - result))) - -(defun copy-tree (object) - "Copy-Tree recursively copys trees of conses." - (if (consp object) - (cons (copy-tree (car object)) (copy-tree (cdr object))) - object)) - - -;;; More Commonly-used List Functions - -(defun revappend (x y) - "Returns (append (reverse x) y)" - (do ((top x (cdr top)) - (result y (cons (car top) result))) - ((endp top) result))) - -;;; NCONC finds the first non-null list, so it can make splice point to a cons. -;;; After finding the first cons element, it holds it in a result variable -;;; while running down successive elements tacking them together. While -;;; tacking lists together, if we encounter a null list, we set the previous -;;; list's last cdr to nil just in case it wasn't already nil, and it could -;;; have been dotted while the null list was the last argument to NCONC. The -;;; manipulation of splice (that is starting it out on a first cons, setting -;;; LAST of splice, and setting splice to ele) inherently handles (nconc x x), -;;; and it avoids running down the last argument to NCONC which allows the last -;;; argument to be circular. -;;; -(defun nconc (&rest lists) - "Concatenates the lists given as arguments (by changing them)" - (do ((top lists (cdr top))) - ((null top) nil) - (let ((top-of-top (car top))) - (typecase top-of-top - (cons - (let* ((result top-of-top) - (splice result)) - (do ((elements (cdr top) (cdr elements))) - ((endp elements)) - (let ((ele (car elements))) - (typecase ele - (cons (rplacd (last splice) ele) - (setf splice ele)) - (null (rplacd (last splice) nil)) - (atom (if (cdr elements) - (error "Argument is not a list -- ~S." ele) - (rplacd (last splice) ele))) - (t (error "Argument is not a list -- ~S." ele))))) - (return result))) - (null) - (atom - (if (cdr top) - (error "Argument is not a list -- ~S." top-of-top) - (return top-of-top))) - (t (error "Argument is not a list -- ~S." top-of-top)))))) - -(defun nreconc (x y) - "Returns (nconc (nreverse x) y)" - (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st))) - (2nd x 1st) ;2nd follows first down the list. - (3rd y 2nd)) ;3rd follows 2nd down the list. - ((atom 2nd) 3rd) - (rplacd 2nd 3rd))) - -(defun butlast (list &optional (n 1)) - "Returns a new list the same as List without the N last elements." - (declare (list list) (type index n)) - (let ((length (1- (length list)))) - (declare (type index length)) - (if (< length n) - () - (do* ((top (cdr list) (cdr top)) - (result (list (car list))) - (splice result) - (count length (1- count))) - ((= count n) result) - (declare (type index count)) - (setq splice (cdr (rplacd splice (list (car top))))))))) - -(defun nbutlast (list &optional (n 1)) - "Modifies List to remove the last N elements." - (declare (list list) (type index n)) - (let ((length (1- (length list)))) - (declare (type index length)) - (if (< length n) () - (do ((1st (cdr list) (cdr 1st)) - (2nd list 1st) - (count length (1- count))) - ((= count n) - (rplacd 2nd ()) - list) - (declare (type index count)))))) - -(defun ldiff (list sublist) - "Returns a new list, whose elements are those of List that appear before - Sublist. If Sublist is not a tail of List, a copy of List is returned." - (do* ((list list (cdr list)) - (result (list ())) - (splice result)) - ((or (null list) (eq list sublist)) (cdr result)) - (setq splice (cdr (rplacd splice (list (car list))))))) - -;;; Functions to alter list structure - -(defun rplaca (x y) - "Changes the car of x to y and returns the new x." - (rplaca x y)) - -(defun rplacd (x y) - "Changes the cdr of x to y and returns the new x." - (rplacd x y)) - -;;; The following are for use by SETF. - -(defun %rplaca (x val) (rplaca x val) val) - -(defun %rplacd (x val) (rplacd x val) val) - -(defun %setnth (n list newval) - (declare (type index n)) - "Sets the Nth element of List (zero based) to Newval." - (do ((count n (1- count)) - (list list (cdr list))) - ((endp list) - (error "~S is too large an index for SETF of NTH." n)) - (declare (fixnum count)) - (when (<= count 0) - (rplaca list newval) - (return newval)))) - - -;;;; Macros for (&key (key #'identity) (test #'eql testp) (test-not nil notp)). -;;; Use these with the following keyword args: -;;; -(defmacro with-set-keys (funcall) - `(cond ((and testp notp) (error "Test and test-not both supplied.")) - (notp ,(append funcall '(:key key :test-not test-not))) - (t ,(append funcall '(:key key :test test))))) - -(defmacro satisfies-the-test (item elt) - `(cond (testp - (funcall test ,item (funcall key ,elt))) - (notp - (not (funcall test-not ,item (funcall key ,elt)))) - (t (funcall test ,item (funcall key ,elt))))) - - -;;; Substitution of expressions - - - -(defun subst (new old tree &key (key #'identity) - (test #'eql testp) (test-not nil notp)) - "Substitutes new for subtrees matching old." - (labels ((s (subtree) - (cond ((satisfies-the-test old subtree) new) - ((atom subtree) subtree) - (t (let ((car (s (car subtree))) - (cdr (s (cdr subtree)))) - (if (and (eq car (car subtree)) - (eq cdr (cdr subtree))) - subtree - (cons car cdr))))))) - (s tree))) - -(defun subst-if (new test tree &key (key #'identity)) - "Substitutes new for subtrees for which test is true." - (labels ((s (subtree) - (cond ((funcall test (funcall key subtree)) new) - ((atom subtree) subtree) - (t (let ((car (s (car subtree))) - (cdr (s (cdr subtree)))) - (if (and (eq car (car subtree)) - (eq cdr (cdr subtree))) - subtree - (cons car cdr))))))) - (s tree))) - -(defun subst-if-not (new test tree &key (key #'identity)) - "Substitutes new for subtrees for which test is false." - (labels ((s (subtree) - (cond ((not (funcall test (funcall key subtree))) new) - ((atom subtree) subtree) - (t (let ((car (s (car subtree))) - (cdr (s (cdr subtree)))) - (if (and (eq car (car subtree)) - (eq cdr (cdr subtree))) - subtree - (cons car cdr))))))) - (s tree))) - -(defun nsubst (new old tree &key (key #'identity) - (test #'eql testp) (test-not nil notp)) - "Substitutes new for subtrees matching old." - (labels ((s (subtree) - (cond ((satisfies-the-test old subtree) new) - ((atom subtree) subtree) - (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) - ((atom subtree) - (if (satisfies-the-test old subtree) - (setf (cdr last) new))) - (if (satisfies-the-test old subtree) - (return (setf (cdr last) new)) - (setf (car subtree) (s (car subtree))))) - subtree)))) - (s tree))) - -(defun nsubst-if (new test tree &key (key #'identity)) - "Substitutes new for subtrees of tree for which test is true." - (labels ((s (subtree) - (cond ((funcall test (funcall key subtree)) new) - ((atom subtree) subtree) - (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) - ((atom subtree) - (if (funcall test (funcall key subtree)) - (setf (cdr last) new))) - (if (funcall test (funcall key subtree)) - (return (setf (cdr last) new)) - (setf (car subtree) (s (car subtree))))) - subtree)))) - (s tree))) - -(defun nsubst-if-not (new test tree &key (key #'identity)) - "Substitutes new for subtrees of tree for which test is false." - (labels ((s (subtree) - (cond ((not (funcall test (funcall key subtree))) new) - ((atom subtree) subtree) - (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) - ((atom subtree) - (if (not (funcall test (funcall key subtree))) - (setf (cdr last) new))) - (if (not (funcall test (funcall key subtree))) - (return (setf (cdr last) new)) - (setf (car subtree) (s (car subtree))))) - subtree)))) - (s tree))) - - - - -(defun sublis (alist tree &key (key #'identity) - (test #'eql) (test-not nil notp)) - "Substitutes from alist into tree nondestructively." - (declare (inline assoc)) - (labels ((s (subtree) - (let ((assoc - (if notp - (assoc (funcall key subtree) alist :test-not test-not) - (assoc (funcall key subtree) alist :test test)))) - (cond (assoc (cdr assoc)) - ((atom subtree) subtree) - (t (let ((car (s (car subtree))) - (cdr (s (cdr subtree)))) - (if (and (eq car (car subtreE)) - (eq cdr (cdr subtree))) - subtree - (cons car cdr)))))))) - (s tree))) - -;;; In run-time env, since can be referenced in line expansions. -(defmacro nsublis-macro () - '(if notp - (assoc (funcall key subtree) alist :test-not test-not) - (assoc (funcall key subtree) alist :test test))) - -(defun nsublis (alist tree &key (key #'identity) - (test #'eql) (test-not nil notp)) - "Substitutes new for subtrees matching old." - (declare (inline assoc)) - (let (temp) - (labels ((s (subtree) - (cond ((Setq temp (nsublis-macro)) - (cdr temp)) - ((atom subtree) subtree) - (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) - ((atom subtree) - (if (setq temp (nsublis-macro)) - (setf (cdr last) (cdr temp)))) - (if (setq temp (nsublis-macro)) - (return (setf (Cdr last) (Cdr temp))) - (setf (car subtree) (s (car subtree))))) - subtree)))) - (s tree)))) - - -;;;; Functions for using lists as sets - -(defun member (item list &key (key #'identity) (test #'eql testp) - (test-not nil notp)) - "Returns tail of list beginning with first element satisfying EQLity, - :test, or :test-not with a given item." - (do ((list list (cdr list))) - ((null list) nil) - (let ((car (car list))) - (if (satisfies-the-test item car) - (return list))))) - -(defun member-if (test list &key (key #'identity)) - "Returns tail of list beginning with first element satisfying test(element)" - (do ((list list (Cdr list))) - ((endp list) nil) - (if (funcall test (funcall key (car list))) - (return list)))) - -(defun member-if-not (test list &key (key #'identity)) - "Returns tail of list beginning with first element not satisfying test(el)" - (do ((list list (cdr list))) - ((endp list) ()) - (if (not (funcall test (funcall key (car list)))) - (return list)))) - -(defun tailp (sublist list) - "Returns T if (EQL Sublist (NTHCDR <n> List)) for some value of <n>, NIL - otherwise." - (do ((list list (cdr list))) - ((atom list) (eql list sublist)) - (if (eql sublist list) - (return t)))) - -(defun adjoin (item list &key (key #'identity) (test #'eql) - (test-not nil notp)) - "Add item to list unless it is already a member" - (declare (inline member)) - (if (if notp (member (funcall key item) list :test-not test-not :key key) - (member (funcall key item) list :test test :key key)) - list - (cons item list))) - - -;;; UNION -- Public. -;;; -;;; This function assumes list2 is the result, adding to it from list1 as -;;; necessary. List2 must initialize the result value, so the call to MEMBER -;;; will apply the test to the elements from list1 and list2 in the correct -;;; order. -;;; -(defun union (list1 list2 &key - (key #'identity) (test #'eql testp) (test-not nil notp)) - "Returns the union of list1 and list2." - (declare (inline member)) - (when (and testp notp) (error "Test and test-not both supplied.")) - (let ((res list2)) - (dolist (elt list1) - (unless (with-set-keys (member (funcall key elt) list2)) - (push elt res))) - res)) - -;;; Destination and source are setf-able and many-evaluable. Sets the source -;;; to the cdr, and "conses" the 1st elt of source to destination. -;;; -(defmacro steve-splice (source destination) - `(let ((temp ,source)) - (setf ,source (cdr ,source) - (cdr temp) ,destination - ,destination temp))) - -(defun nunion (list1 list2 &key (key #'identity) - (test #'eql testp) (test-not nil notp)) - "Destructively returns the union list1 and list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res list2) - (list1 list1)) - (do () - ((endp list1)) - (if (not (with-set-keys (member (funcall key (car list1)) list2))) - (steve-splice list1 res) - (setf list1 (cdr list1)))) - res)) - - -(defun intersection (list1 list2 &key (key #'identity) - (test #'eql testp) (test-not nil notp)) - "Returns the intersection of list1 and list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res nil)) - (dolist (elt list1) - (if (with-set-keys (member (funcall key elt) list2)) - (push elt res))) - res)) - -(defun nintersection (list1 list2 &key (key #'identity) - (test #'eql testp) (test-not nil notp)) - "Destructively returns the intersection of list1 and list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (with-set-keys (member (funcall key (car list1)) list2)) - (steve-splice list1 res) - (setq list1 (Cdr list1)))) - res)) - -(defun set-difference (list1 list2 &key (key #'identity) - (test #'eql testp) (test-not nil notp)) - "Returns the elements of list1 which are not in list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (if (null list2) - list1 - (let ((res nil)) - (dolist (elt list1) - (if (not (with-set-keys (member (funcall key elt) list2))) - (push elt res))) - res))) - - -(defun nset-difference (list1 list2 &key (key #'identity) - (test #'eql testp) (test-not nil notp)) - "Destructively returns the elements of list1 which are not in list2." - (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (not (with-set-keys (member (funcall key (car list1)) list2))) - (steve-splice list1 res) - (setq list1 (cdr list1)))) - res)) - - -(defun set-exclusive-or (list1 list2 &key (key #'identity) - (test #'eql testp) (test-not nil notp)) - "Returns new list of elements appearing exactly once in list1 and list2." - (declare (inline member)) - (let ((result nil)) - (dolist (elt list1) - (unless (with-set-keys (member (funcall key elt) list2)) - (setq result (cons elt result)))) - (dolist (elt list2) - (unless (with-set-keys (member (funcall key elt) list1)) - (setq result (cons elt result)))) - result)) - - -;;; The outer loop examines list1 while the inner loop examines list2. If an -;;; element is found in list2 "equal" to the element in list1, both are -;;; spliced out. When the end of list1 is reached, what is left of list2 is -;;; tacked onto what is left of list1. The splicing operation ensures that -;;; the correct operation is performed depending on whether splice is at the -;;; top of the list or not - -(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) - (key #'identity)) - "Destructively return a list with elements which appear but once in list1 - and list2." - (do ((list1 list1) - (list2 list2) - (x list1 (cdr x)) - (splicex ())) - ((endp x) - (if (null splicex) - (setq list1 list2) - (rplacd splicex list2)) - list1) - (do ((y list2 (cdr y)) - (splicey ())) - ((endp y) (setq splicex x)) - (cond ((if notp - (not (funcall test-not (funcall key (car x)) - (funcall key (Car y)))) - (funcall test (funcall key (car x)) (funcall key (Car y)))) - (if (null splicex) - (setq list1 (cdr x)) - (rplacd splicex (cdr x))) - (if (null splicey) - (setq list2 (cdr y)) - (rplacd splicey (cdr y))) - (return ())) ; assume lists are really sets - (t (setq splicey y)))))) - -(defun subsetp (list1 list2 &key (key #'identity) - (test #'eql testp) (test-not nil notp)) - "Returns T if every element in list1 is also in list2." - (declare (inline member)) - (dolist (elt list1) - (unless (with-set-keys (member (funcall key elt) list2)) - (return-from subsetp nil))) - T) - - - -;;;; :key arg optimization to save funcall of IDENTITY. - -;;; We should move this earlier in this file and make other functions use it as -;;; well. -;;; - -;;; APPLY-KEY saves us a function call sometimes. -;;; This is not in and (eval-when (compile eval) ... -;;; because this is used in seq.lisp and sort.lisp. -;;; -(defmacro apply-key (key element) - `(if ,key - (funcall ,key ,element) - ,element)) - -(defun identity (thing) - "Returns what was passed to it." - thing) - - -(defun complement (function) - "Builds a new function that returns T whenever FUNCTION returns NIL and - NIL whenever FUNCTION returns T." - #'(lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p) - &rest more-args) - (not (cond (more-args (apply function arg0 arg1 arg2 more-args)) - (arg2-p (funcall function arg0 arg1 arg2)) - (arg1-p (funcall function arg0 arg1)) - (arg0-p (funcall function arg0)) - (t (funcall function)))))) - - -(defun constantly (value &optional (val1 nil val1-p) (val2 nil val2-p) - &rest more-values) - "Builds a function that always returns VALUE, and posisbly MORE-VALUES." - (cond (more-values - (let ((list (list* value val1 val2 more-values))) - #'(lambda () - (declare (optimize (speed 3) (safety 0))) - (values-list list)))) - (val2-p - #'(lambda () - (declare (optimize (speed 3) (safety 0))) - (values value val1 val2))) - (val1-p - #'(lambda () - (declare (optimize (speed 3) (safety 0))) - (values value val1))) - (t - #'(lambda () - (declare (optimize (speed 3) (safety 0))) - value)))) - - -;;; Functions that operate on association lists - -(defun acons (key datum alist) - "Construct a new alist by adding the pair (key . datum) to alist" - (cons (cons key datum) alist)) - -(defun pairlis (keys data &optional (alist '())) - "Construct an association list from keys and data (adding to alist)" - (do ((x keys (cdr x)) - (y data (cdr y))) - ((and (endp x) (endp y)) alist) - (if (or (endp x) (endp y)) - (error "The lists of keys and data are of unequal length.")) - (setq alist (acons (car x) (car y) alist)))) - -;;; In run-time environment, since these guys can be inline expanded. -(defmacro assoc-guts (test-guy) - `(do ((alist alist (cdr alist))) - ((endp alist)) - (if (car alist) - (if ,test-guy (return (car alist)))))) - -(defun assoc (item alist &key key test test-not) - "Returns the cons in alist whose car is equal (by a given test or EQL) to - the Item." - (cond (test (assoc-guts (funcall test item (apply-key key (caar alist))))) - (test-not (assoc-guts (not (funcall test-not item - (apply-key key (caar alist)))))) - (t (assoc-guts (eql item (apply-key key (caar alist))))))) - -(defun assoc-if (predicate alist &key key) - "Returns the first cons in alist whose car satisfies the Predicate. If - key is supplied, apply it to the car of each cons before testing." - (assoc-guts (funcall predicate (apply-key key (caar alist))))) - -(defun assoc-if-not (predicate alist &key key) - "Returns the first cons in alist whose car does not satisfiy the Predicate. - If key is supplied, apply it to the car of each cons before testing." - (assoc-guts (not (funcall predicate (apply-key key (caar alist)))))) - - -(defun rassoc (item alist &key key test test-not) - (declare (list alist)) - "Returns the cons in alist whose cdr is equal (by a given test or EQL) to - the Item." - (cond (test (assoc-guts (funcall test item (apply-key key (cdar alist))))) - (test-not (assoc-guts (not (funcall test-not item - (apply-key key (cdar alist)))))) - (t (assoc-guts (eql item (apply-key key (cdar alist))))))) - -(defun rassoc-if (predicate alist &key key) - "Returns the first cons in alist whose cdr satisfies the Predicate. If key - is supplied, apply it to the cdr of each cons before testing." - (assoc-guts (funcall predicate (apply-key key (cdar alist))))) - -(defun rassoc-if-not (predicate alist &key key) - "Returns the first cons in alist whose cdr does not satisfy the Predicate. - If key is supplied, apply it to the cdr of each cons before testing." - (assoc-guts (not (funcall predicate (apply-key key (cdar alist)))))) - - - -;;;; Mapping functions. - -(defun map1 (function original-arglists accumulate take-car) - "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon. - It Maps function over the arglists in the appropriate way. It is done when any - of the arglists runs out. Until then, it CDRs down the arglists calling the - function and accumulating results as desired." - - (let* ((arglists (copy-list original-arglists)) - (ret-list (list nil)) - (temp ret-list)) - (do ((res nil) - (args '() '())) - ((dolist (x arglists nil) (if (null x) (return t))) - (if accumulate - (cdr ret-list) - (car original-arglists))) - (do ((l arglists (cdr l))) - ((null l)) - (push (if take-car (caar l) (car l)) args) - (setf (car l) (cdar l))) - (setq res (apply function (nreverse args))) - (case accumulate - (:nconc (setq temp (last (nconc temp res)))) - (:list (rplacd temp (list res)) - (setq temp (cdr temp))))))) - - -(defun mapc (function list &rest more-lists) - "Applies fn to successive elements of lists, returns its second argument." - (map1 function (cons list more-lists) nil t)) - -(defun mapcar (function list &rest more-lists) - "Applies fn to successive elements of list, returns list of results." - (map1 function (cons list more-lists) :list t)) - -(defun mapcan (function list &rest more-lists) - "Applies fn to successive elements of list, returns NCONC of results." - (map1 function (cons list more-lists) :nconc t)) - -(defun mapl (function list &rest more-lists) - "Applies fn to successive CDRs of list, returns ()." - (map1 function (cons list more-lists) nil nil)) - -(defun maplist (function list &rest more-lists) - "Applies fn to successive CDRs of list, returns list of results." - (map1 function (cons list more-lists) :list nil)) - -(defun mapcon (function list &rest more-lists) - "Applies fn to successive CDRs of lists, returns NCONC of results." - (map1 function (cons list more-lists) :nconc nil)) - - -;;; Functions for compatibility sake: - -(defun memq (item list) - "Returns tail of list beginning with first element eq to item" - (member item list :test #'eq)) - -(defun assq (item alist) - "Return the first pair of alist where item EQ the key of pair" - (assoc item alist :test #'eq)) - -(defun delq (item list &optional (n 0 np)) - (declare (fixnum n)) - "Returns list with all (up to n) elements with all elements EQ to ITEM - deleted" - (do ((x list (cdr x)) - (splice '())) - ((or (endp x) - (and np (zerop n))) list) - (cond ((eq item (car x)) - (setq n (1- n)) - (if (null splice) - (setq list (cdr x)) - (rplacd splice (cdr x)))) - (T (setq splice x))))) ; move splice along to include element diff --git a/code/mach-os.lisp b/code/mach-os.lisp deleted file mode 100644 index c40f6bb923811f63ffeb88bfa10ff559f11011fe..0000000000000000000000000000000000000000 --- a/code/mach-os.lisp +++ /dev/null @@ -1,77 +0,0 @@ -;;; -*- Package: SYSTEM -*- -;;; -;;; ********************************************************************** -;;; 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/code/mach-os.lisp,v 1.9 1992/07/03 00:09:31 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; OS interface functions for CMU CL under Mach. -;;; -;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. -;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too. -;;; -(in-package "SYSTEM") -(use-package "EXTENSIONS") -(export '(get-system-info get-page-size os-init)) -(export '(*task-self* *task-data* *task-notify*)) - -(pushnew :mach *features*) -(setq *software-type* "MACH/4.3BSD") - -(defconstant foreign-segment-start #x00C00000) -(defconstant foreign-segment-size #x00400000) - -(defun software-version () - "Returns a string describing version of the supporting software." - (string-trim '(#\newline) - (with-output-to-string (stream) - (run-program "/usr/cs/etc/version" ; Site dependent??? - nil :output stream)))) - - -;;; OS-Init initializes our operating-system interface. It sets the values -;;; of the global port variables to what they should be and calls the functions -;;; that set up the argument blocks for the server interfaces. - -(defvar *task-self*) - -(defun os-init () - (setf *task-self* (mach:mach-task_self))) - - -;;; GET-SYSTEM-INFO -- Interface -;;; -;;; Return system time, user time and number of page faults. For -;;; page-faults, we add pagein and pageout, since that is a somewhat more -;;; interesting number than the total faults. -;;; -(defun get-system-info () - (multiple-value-bind (err? utime stime maxrss ixrss idrss - isrss minflt majflt) - (unix:unix-getrusage unix:rusage_self) - (declare (ignore maxrss ixrss idrss isrss minflt majflt)) - (unless err? - (error "Unix system call getrusage failed: ~A." - (unix:get-unix-error-msg utime))) - - (multiple-value-bind (gr ps fc ac ic wc zf ra in ot) - (mach:vm_statistics *task-self*) - (declare (ignore ps fc ac ic wc zf ra)) - (mach:gr-error 'mach:vm_statistics gr) - - (values utime stime (+ in ot))))) - - -;;; GET-PAGE-SIZE -- Interface -;;; -;;; Return the system page size. -;;; -(defun get-page-size () - (mach:gr-call* mach:vm_statistics *task-self*)) - diff --git a/code/mach.lisp b/code/mach.lisp deleted file mode 100644 index ae722d7915e49812b2fbfd5793b7841f1bf85627..0000000000000000000000000000000000000000 --- a/code/mach.lisp +++ /dev/null @@ -1,168 +0,0 @@ -;;; -*- Package: MACH -*- -;;; -;;; ********************************************************************** -;;; 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/code/mach.lisp,v 1.3 1992/02/15 13:00:05 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the low-level support for MACH features not found -;;; in UNIX. -;;; - -(in-package "MACH") -(use-package "ALIEN") -(use-package "C-CALL") -(use-package "SYSTEM") - -(export '(port mach-task_self mach-task_data mach-task_notify - kern-success get-mach-error-msg - gr-error gr-call gr-call* gr-bind - vm_allocate vm_copy vm_deallocate vm_statistics)) - - -;;;; Standard ports. - -(def-alien-type port int) - -(def-alien-routine ("task_self" mach-task_self) port) -(def-alien-routine ("thread_reply" mach-task_data) port) -(def-alien-routine ("task_notify" mach-task_notify) port) - - - -;;;; Return codes. - -(def-alien-type kern-return int) - -(defconstant kern-success 0) -(defconstant kern-invalid-address 1) -(defconstant kern-protection-failure 2) -(defconstant kern-no-space 3) -(defconstant kern-invalid-argument 4) -(defconstant kern-failure 5) -(defconstant kern-resource-shortage 6) -(defconstant kern-not-receiver 7) -(defconstant kern-no-access 8) -(defconstant kern-memory-failure 9) -(defconstant kern-memory-error 10) -(defconstant kern-already-in-set 11) -(defconstant kern-not-in-set 12) -(defconstant kern-name-exists 13) -(defconstant kern-aborted 14) -(defconstant kern-memory-present 23) - -(def-alien-routine ("mach_error_string" get-mach-error-msg) c-string - (errno kern-return)) - -;;; GR-Error -- Public -;;; -(defun gr-error (function gr &optional context) - "Signal an error indicating that Function returned code GR. If the code - is success, then do nothing." - (unless (eql gr kern-success) - (error "~S~@[ ~A~], ~(~A~)." function context (get-mach-error-msg gr)))) - -;;; GR-Call -- Public -;;; -(defmacro gr-call (fun &rest args) - "GR-Call Function {Arg}* - Call the function with the specified Args and signal an error if the - first value returned is not mach:kern-success. Nil is returned." - (let ((n-gr (gensym))) - `(let ((,n-gr (,fun ,@args))) - (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))))) - -;;; GR-Call* -- Public -;;; -(defmacro gr-call* (fun &rest args) - "GR-Call* Function {Arg}* - Call the function with the specified Args and signal an error if the - first value returned is not mach:kern-success. The second value is - returned." - (let ((n-gr (gensym)) - (n-res (gensym))) - `(multiple-value-bind (,n-gr ,n-res) (,fun ,@args) - (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr)) - ,n-res))) - -;;; GR-Bind -- Public -;;; -(defmacro gr-bind (vars (fun . args) &body (body decls)) - "GR-Bind ({Var}*) (Function {Arg}*) {Form}* - Call the function with the specified Args and signal an error if the - first value returned is not mach:Kern-Success. If the call succeeds, - the Forms are evaluated with remaining return values bound to the - Vars." - (let ((n-gr (gensym))) - `(multiple-value-bind (,n-gr ,@vars) (,fun ,@args) - ,@decls - (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr)) - ,@body))) - - - -;;;; VM routines. - -(export '(vm_allocate vm_copy vm_deallocate vm_statistics)) - -(def-alien-routine ("vm_allocate" vm_allocate) int - (task port) - (address system-area-pointer :in-out) - (size unsigned-long) - (anywhere boolean)) - -(def-alien-routine ("vm_copy" vm_copy) int - (task port) - (source system-area-pointer) - (count unsigned-long) - (dest system-area-pointer)) - -(def-alien-routine ("vm_deallocate" vm_deallocate) int - (task port) - (address system-area-pointer) - (size unsigned-long)) - - -(def-alien-type nil - (struct vm_statistics - (pagesize long) - (free_count long) - (active_count long) - (inactive_count long) - (wire_count long) - (zero_fill_count long) - (reactivations long) - (pageins long) - (pageouts long) - (faults long) - (cow_faults long) - (lookups long) - (hits long))) - -(defun vm_statistics (task) - (with-alien ((vm_stats (struct vm_statistics))) - (values - (alien-funcall (extern-alien "vm_statistics" - (function int - port - (* (struct vm_statistics)))) - task (alien-sap vm_stats)) - (slot vm_stats 'pagesize) - (slot vm_stats 'free_count) - (slot vm_stats 'active_count) - (slot vm_stats 'inactive_count) - (slot vm_stats 'wire_count) - (slot vm_stats 'zero_fill_count) - (slot vm_stats 'reactivations) - (slot vm_stats 'pageins) - (slot vm_stats 'pageouts) - (slot vm_stats 'faults) - (slot vm_stats 'cow_faults) - (slot vm_stats 'lookups) - (slot vm_stats 'hits)))) diff --git a/code/machdef.lisp b/code/machdef.lisp deleted file mode 100644 index 9f8766ff615ff96a1364984ec073835304179f35..0000000000000000000000000000000000000000 --- a/code/machdef.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*- Log: code.log; Package: Mach -*- -;;; -;;; ********************************************************************** -;;; 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/code/machdef.lisp,v 1.5 1991/02/08 13:34:05 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Record definitions needed for the interface to Mach. -;;; -(in-package 'mach) - -(export '(msg-simplemsg msg-msgsize msg-msgtype msg-localport msg-remoteport - msg-id sigmask with-trap-arg-block)) - -(export '(int-array int-array-ref)) - -(def-c-type c-string (pointer simple-base-string)) - -(defrecord Msg - (Reserved1 (unsigned-byte 8) 8) - (Reserved2 (unsigned-byte 8) 8) - (Reserved3 (unsigned-byte 8) 8) - (Reserved4 (unsigned-byte 7) 7) - (SimpleMsg boolean 1) - (MsgSize (signed-byte 32) 32) - (MsgType (signed-byte 32) 32) - (LocalPort port 32) - (RemotePort port 32) - (ID (signed-byte 32) 32)) - -(defrecord timeval - (seconds (unsigned-byte 32) (long-words 1)) - (useconds (signed-byte 32) (long-words 1))) - -(defrecord timezone - (minuteswest (signed-byte 32) (long-words 1)) - (dsttime (signed-byte 32) (long-words 1))) - -(def-c-array int-array unsigned-long 32) - -(eval-when (compile load eval) - -(defrecord tchars - (intrc (signed-byte 8) (bytes 1)) - (quitc (signed-byte 8) (bytes 1)) - (startc (signed-byte 8) (bytes 1)) - (stopc (signed-byte 8) (bytes 1)) - (eofc (signed-byte 8) (bytes 1)) - (brkc (signed-byte 8) (bytes 1))) - -(defrecord ltchars - (suspc (signed-byte 8) (bytes 1)) - (dsuspc (signed-byte 8) (bytes 1)) - (rprntc (signed-byte 8) (bytes 1)) - (flushc (signed-byte 8) (bytes 1)) - (werasc (signed-byte 8) (bytes 1)) - (lnextc (signed-byte 8) (bytes 1))) - -); eval-when (compile load eval) - - -(defmacro with-trap-arg-block (type var &body forms) - `(with-stack-alien (,var ,type (record-size ',type)) - ,@forms)) - -;;; SIGMASK -- Public -;;; -(defmacro sigmask (&rest signals) - "Returns a mask given a set of signals." - (apply #'logior - (mapcar #'(lambda (signal) - (ash 1 (1- (unix-signal-number signal)))) - signals))) - diff --git a/code/mipsstrops.lisp b/code/mipsstrops.lisp deleted file mode 100644 index ca01eeaaf1df0ead06e6c5b92e3bddabfcded727..0000000000000000000000000000000000000000 --- a/code/mipsstrops.lisp +++ /dev/null @@ -1,219 +0,0 @@ -;;; -*- Log: Code.Log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/mipsstrops.lisp,v 1.7 1992/03/14 02:18:07 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; String hacking functions that are stubs for things that might -;;; be microcoded someday. -;;; -;;; Written by Rob MacLachlan and Skef Wholey -;;; -(in-package "SYSTEM") -(export '(%sp-reverse-find-character-with-attribute)) - -(in-package "LISP") - -;(defun %sp-byte-blt (src-string src-start dst-string dst-start dst-end) -; "Moves bytes from Src-String into Dst-String between Dst-Start (inclusive) -;and Dst-End (exclusive) (Dst-Start - Dst-End bytes are moved). Overlap of the -;strings does not affect the result. This would be done on the Vax -;with MOVC3. The arguments do not need to be strings: 8-bit U-Vectors -;are also acceptable." -; (%primitive byte-blt src-string src-start dst-string dst-start dst-end)) - -(defun %sp-string-compare (string1 start1 end1 string2 start2 end2) - (declare (simple-string string1 string2)) - (declare (fixnum start1 end1 start2 end2)) - "Compares the substrings specified by String1 and String2 and returns -NIL if the strings are String=, or the lowest index of String1 in -which the two differ. If one string is longer than the other and the -shorter is a prefix of the longer, the length of the shorter + start1 is -returned. This would be done on the Vax with CMPC3. The arguments must -be simple strings." - (let ((len1 (- end1 start1)) - (len2 (- end2 start2))) - (declare (fixnum len1 len2)) - (cond - ((= len1 len2) - (do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2))) - ((= index1 end1) nil) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1)))) - ((> len1 len2) - (do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2))) - ((= index2 end2) index1) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1)))) - (t - (do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2))) - ((= index1 end1) index1) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1))))))) - -(defun %sp-reverse-string-compare (string1 start1 end1 string2 start2 end2) - (declare (simple-string string1 string2)) - (declare (fixnum start1 end1 start2 end2)) - "Like %sp-string-compare, only backwards." - (let ((len1 (- end1 start1)) - (len2 (- end2 start2))) - (declare (fixnum len1 len2)) - (cond - ((= len1 len2) - (do ((index1 (1- end1) (1- index1)) - (index2 (1- end2) (1- index2))) - ((< index1 start1) nil) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1)))) - ((> len1 len2) - (do ((index1 (1- end1) (1- index1)) - (index2 (1- end2) (1- index2))) - ((< index2 start2) index1) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1)))) - (t - (do ((index1 (1- end1) (1- index1)) - (index2 (1- end2) (1- index2))) - ((< index1 start1) index1) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1))))))) - -(defmacro maybe-sap-maybe-string ((var) &body body) - `(etypecase ,var - (system-area-pointer - (macrolet ((byte-ref (index) - `(sap-ref-8 ,',var ,index)) - (char-ref (index) - `(code-char (byte-ref ,index)))) - ,@body)) - (simple-string - (macrolet ((char-ref (index) - `(schar ,',var ,index)) - (byte-ref (index) - `(char-code (char-ref ,index)))) - ,@body)))) - -(defun %sp-find-character-with-attribute (string start end table mask) - (declare (type (simple-array (unsigned-byte 8) (256)) table) - (type (or simple-string system-area-pointer) string) - (fixnum start end mask)) - "%SP-Find-Character-With-Attribute String, Start, End, Table, Mask - The codes of the characters of String from Start to End are used as indices - into the Table, which is a U-Vector of 8-bit bytes. When the number picked - up from the table bitwise ANDed with Mask is non-zero, the current - index into the String is returned. The corresponds to SCANC on the Vax." - (maybe-sap-maybe-string (string) - (do ((index start (1+ index))) - ((>= index end) nil) - (declare (fixnum index)) - (unless (zerop (logand (aref table (byte-ref index)) mask)) - (return index))))) - -(defun %sp-reverse-find-character-with-attribute (string start end table mask) - "Like %SP-Find-Character-With-Attribute, only sdrawkcaB." - (declare (type (or simple-string system-area-pointer) string) - (fixnum start end mask) - (type (array (unsigned-byte 8) (256)) table)) - (maybe-sap-maybe-string (string) - (do ((index (1- end) (1- index))) - ((< index start) nil) - (declare (fixnum index)) - (unless (zerop (logand (aref table (byte-ref index)) mask)) - (return index))))) - -(defun %sp-find-character (string start end character) - "%SP-Find-Character String, Start, End, Character - Searches String for the Character from Start to End. If the character is - found, the corresponding index into String is returned, otherwise NIL is - returned." - (declare (fixnum start end) - (type (or simple-string system-area-pointer) string) - (base-char character)) - (maybe-sap-maybe-string (string) - (do ((index start (1+ index))) - ((>= index end) nil) - (declare (fixnum index)) - (when (char= (char-ref index) character) - (return index))))) - -(defun %sp-reverse-find-character (string start end character) - (declare (type (or simple-string system-area-pointer) string) - (fixnum start end) - (base-char character)) - "%SP-Reverse-Find-Character String, Start, End, Character - Searches String for Character from End to Start. If the character is - found, the corresponding index into String is returned, otherwise NIL is - returned." - (maybe-sap-maybe-string (string) - (do ((index (1- end) (1- index)) - (terminus (1- start))) - ((= index terminus) nil) - (declare (fixnum terminus index)) - (if (char= (char-ref index) character) - (return index))))) - -(defun %sp-skip-character (string start end character) - (declare (type (or simple-string system-area-pointer) string) - (fixnum start end) - (base-char character)) - "%SP-Skip-Character String, Start, End, Character - Returns the index of the first character between Start and End which - is not Char= to Character, or NIL if there is no such character." - (maybe-sap-maybe-string (string) - (do ((index start (1+ index))) - ((= index end) nil) - (declare (fixnum index)) - (if (char/= (char-ref index) character) - (return index))))) - -(defun %sp-reverse-skip-character (string start end character) - (declare (type (or simple-string system-area-pointer) string) - (fixnum start end) - (base-char character)) - "%SP-Skip-Character String, Start, End, Character - Returns the index of the last character between Start and End which - is not Char= to Character, or NIL if there is no such character." - (maybe-sap-maybe-string (string) - (do ((index (1- end) (1- index)) - (terminus (1- start))) - ((= index terminus) nil) - (declare (fixnum terminus index)) - (if (char/= (char-ref index) character) - (return index))))) - -(defun %sp-string-search (string1 start1 end1 string2 start2 end2) - "%SP-String-Search String1, Start1, End1, String2, Start2, End2 - Searches for the substring of String1 specified in String2. - Returns an index into String2 or NIL if the substring wasn't - found." - (declare (simple-string string1 string2)) - (do ((index2 start2 (1+ index2))) - ((= index2 end2) nil) - (declare (fixnum index2)) - (when (do ((index1 start1 (1+ index1)) - (index2 index2 (1+ index2))) - ((= index1 end1) t) - (declare (fixnum index1 index2)) - (when (= index2 end2) - (return-from %sp-string-search nil)) - (when (char/= (char string1 index1) (char string2 index2)) - (return nil))) - (return index2)))) - - diff --git a/code/misc.lisp b/code/misc.lisp deleted file mode 100644 index 5d0eeaf012bc557373d68b60a10a68828be33421..0000000000000000000000000000000000000000 --- a/code/misc.lisp +++ /dev/null @@ -1,169 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/misc.lisp,v 1.17 1993/01/13 17:33:21 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Environment query functions, documentation and dribble. -;;; -;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. -;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too. -;;; -(in-package "LISP") -(export '(documentation *features* common variable room - lisp-implementation-type lisp-implementation-version machine-type - machine-version machine-instance software-type software-version - short-site-name long-site-name dribble)) - -(in-package "SYSTEM") -(export '(*software-type* *short-site-name* *long-site-name*)) - -(in-package "EXT") -(export 'featurep) - -(in-package "LISP") - - -(defun documentation (name doc-type) - "Returns the documentation string of Doc-Type for Name, or NIL if - none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, - and SETF." - (values - (case doc-type - (variable (info variable documentation name)) - (function (info function documentation name)) - (structure - (when (eq (info type kind name) :structure) - (info type documentation name))) - (type - (info type documentation name)) - (setf (info setf documentation name)) - (t - (cdr (assoc doc-type (info random-documentation stuff name))))))) - -(defun %set-documentation (name doc-type string) - (case doc-type - (variable (setf (info variable documentation name) string)) - (function (setf (info function documentation name) string)) - (structure - (unless (eq (info type kind name) :structure) - (error "~S is not the name of a structure type." name)) - (setf (info type documentation name) string)) - (type (setf (info type documentation name) string)) - (setf (setf (info setf documentation name) string)) - (t - (let ((pair (assoc doc-type (info random-documentation stuff name)))) - (if pair - (setf (cdr pair) string) - (push (cons doc-type string) - (info random-documentation stuff name)))))) - string) - -(defvar *features* '(:common :cmu :cmu17 :new-compiler) - "Holds a list of symbols that describe features provided by the - implementation.") - -(defun featurep (x) - "If X is an atom, see if it is present in *FEATURES*. Also - handle arbitrary combinations of atoms using NOT, AND, OR." - (if (consp x) - (case (car x) - ((:not not) (not (featurep (cadr x)))) - ((:and and) (every #'featurep (cdr x))) - ((:or or) (some #'featurep (cdr x))) - (t - (error "Unknown operator in feature expression: ~S." x))) - (not (null (memq x *features*))))) - - -;;; Other Environment Inquiries. - -(defun lisp-implementation-type () - "Returns a string describing the implementation type." - "CMU Common Lisp") - -(defun lisp-implementation-version () - "Returns a string describing the implementation version." - *lisp-implementation-version*) - -(defun machine-instance () - "Returns a string giving the name of the local machine." - (unix:unix-gethostname)) - -(defvar *software-type* "Unix" - "The value of SOFTWARE-TYPE. Set in FOO-os.lisp.") - -(defun software-type () - "Returns a string describing the supporting software." - *software-type*) - -(defvar *short-site-name* "Unknown" - "The value of SHORT-SITE-NAME. Set in library:site-init.lisp.") - -(defun short-site-name () - "Returns a string with the abbreviated site name." - *short-site-name*) - -(defvar *long-site-name* "Site name not initialized" - "The value of LONG-SITE-NAME. Set in library:site-init.lisp.") - -(defun long-site-name () - "Returns a string with the long form of the site name." - *long-site-name*) - - -;;;; Dribble stuff: - -;;; Each time we start dribbling to a new stream, we put it in -;;; *dribble-stream*, and push a list of *dribble-stream*, *standard-input*, -;;; *standard-output* and *error-output* in *previous-streams*. -;;; *standard-output* and *error-output* is changed to a broadcast stream that -;;; broadcasts to *dribble-stream* and to the old values of the variables. -;;; *standard-input* is changed to an echo stream that echos input from the old -;;; value of standard input to *dribble-stream*. -;;; -;;; When dribble is called with no arguments, *dribble-stream* is closed, -;;; and the values of *dribble-stream*, *standard-input*, and -;;; *standard-output* are poped from *previous-streams*. - -(defvar *previous-streams* nil) -(defvar *dribble-stream* nil) - -(defun dribble (&optional pathname &key (if-exists :append)) - "With a file name as an argument, dribble opens the file and - sends a record of further I/O to that file. Without an - argument, it closes the dribble file, and quits logging." - (cond (pathname - (let* ((new-dribble-stream - (open pathname :direction :output :if-exists if-exists - :if-does-not-exist :create)) - (new-standard-output - (make-broadcast-stream *standard-output* new-dribble-stream)) - (new-error-output - (make-broadcast-stream *error-output* new-dribble-stream)) - (new-standard-input - (make-echo-stream *standard-input* new-dribble-stream))) - (push (list *dribble-stream* *standard-input* *standard-output* - *error-output*) - *previous-streams*) - (setf *dribble-stream* new-dribble-stream) - (setf *standard-input* new-standard-input) - (setf *standard-output* new-standard-output) - (setf *error-output* new-error-output))) - ((null *dribble-stream*) - (error "Not currently dribbling.")) - (t - (let ((old-streams (pop *previous-streams*))) - (close *dribble-stream*) - (setf *dribble-stream* (first old-streams)) - (setf *standard-input* (second old-streams)) - (setf *standard-output* (third old-streams)) - (setf *error-output* (fourth old-streams))))) - (values)) diff --git a/code/module.lisp b/code/module.lisp deleted file mode 100644 index 52fd1e86c6a3455687602c939735b7b6d160c5ee..0000000000000000000000000000000000000000 --- a/code/module.lisp +++ /dev/null @@ -1,99 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/module.lisp,v 1.2 1992/12/16 12:32:10 ram Exp $") -;;; -;;; ********************************************************************** - -;;; Code written by Jim Muller. -;;; Rewritten by Bill Chiles. -;;; -;;; Note that this module file is based on the old system, and is being -;;; spliced into the current sources to reflect the last minute deprecated -;;; addition of modules to the X3J13 ANSI standard. -;;; -(in-package 'lisp) - -(export '(*modules* provide require)) - - -(in-package "EXTENSIONS") -(export '(*require-verbose* defmodule)) -(in-package 'lisp) - - - -;;;; Exported specials. - -(defvar *modules* () - "This is a list of module names that have been loaded into Lisp so far. - It is used by PROVIDE and REQUIRE.") - -(defvar *require-verbose* t - "*load-verbose* is bound to this before loading files.") - -;;;; Defmodule. - -(defvar *module-file-translations* (make-hash-table :test #'equal)) -(defmacro defmodule (name &rest files) - "Defines a module by registering the files that need to be loaded when - the module is required. If name is a symbol, its print name is used - after downcasing it." - `(%define-module ,name ',files)) - -(defun %define-module (name files) - (setf (gethash (module-name-string name) *module-file-translations*) - files)) - -(defun module-files (name) - (gethash name *module-file-translations*)) - - - -;;;; Provide and Require. - -(defun provide (module-name) - "Adds a new module name to *modules* indicating that it has been loaded. - Module-name may be either a case-sensitive string or a symbol; if it is - a symbol, its print name is downcased and used." - (pushnew (module-name-string module-name) *modules* :test #'string=) - t) - -(defun require (module-name &optional pathname) - "Loads a module when it has not been already. Pathname, if supplied, - is a single pathname or list of pathnames to be loaded if the module - needs to be. If pathname is not supplied, then a list of files are - looked for that were registered by a EXT:DEFMODULE form. If the module - has not been defined, then a file will be loaded whose name is formed - by merging \"modules:\" and module-name (downcased if it is a symbol). - This merged name will be probed with both a .lisp and .fasl extensions, - calling LOAD - if it exists. While loading any files, *load-verbose* is bound to - *require-verbose* which defaults to nil." - (setf module-name (module-name-string module-name)) - (unless (member module-name *modules* :test #'string=) - (if pathname - (unless (listp pathname) (setf pathname (list pathname))) - (let ((files (module-files module-name))) - (if files - (setf pathname files) - (setf pathname (list (merge-pathnames "modules:" module-name)))))) (let ((*load-verbose* *require-verbose*)) - (dolist (ele pathname t) - (load ele))))) - - - -;;;; Misc. - -(defun module-name-string (name) - (typecase name - (string name) - (symbol (string-downcase (symbol-name name))) - (t (error "Module name must be a string or symbol -- ~S." - name)))) diff --git a/code/ntrace.lisp b/code/ntrace.lisp deleted file mode 100644 index 75cb55628217273212590d6402cc64305842cf68..0000000000000000000000000000000000000000 --- a/code/ntrace.lisp +++ /dev/null @@ -1,674 +0,0 @@ -;;; -*- Package: debug -*- -;;; -;;; ********************************************************************** -;;; 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/code/ntrace.lisp,v 1.10 1992/12/08 20:10:16 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This is a tracing facility based on breakpoints. -;;; -;;; Written by Rob MacLachlan and Bill Chiles. -;;; -;;; ********************************************************************** -;;; -(in-package "LISP") - -(export '(trace untrace)) - -(in-package "DEBUG") - -(export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*)) - -(defvar *trace-values* nil - "This is bound to the returned values when evaluating :BREAK-AFTER and - :PRINT-AFTER forms.") - -(defvar *max-trace-indentation* 40 - "If the trace indentation exceeds this value, then indentation restarts at - 0.") - -(defvar *trace-encapsulate-default* :default - "The default value for the :ENCAPSULATE option to trace.") - - -;;;; Internal state: - -;;; A hash-table that maps each traced function to the TRACE-INFO. The entry -;;; for a closure is the shared function-entry object. -;;; -(defvar *traced-functions* (make-hash-table :test #'eq)) - -;;; The TRACE-INFO structure represents all the information we need to trace a -;;; given function. -;;; -(defstruct (trace-info - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (print-unreadable-object (s stream) - (format stream "Trace-Info ~S" (trace-info-what s))))) - (:make-load-form-fun :just-dump-it-normally)) - ;; - ;; The original representation of the thing traced. - (what nil :type (or function cons symbol)) - ;; - ;; True if What is a function name whose definition we should track. - (named nil) - ;; - ;; True if tracing is to be done by encapsulation rather than breakpoints. - ;; T implies Named. - (encapsulated *trace-encapsulate-default*) - ;; - ;; True if this trace has been untraced. - (untraced nil) - ;; - ;; Breakpoints we set up to trigger tracing. - (start-breakpoint nil :type (or di:breakpoint null)) - (end-breakpoint nil :type (or di:breakpoint null)) - ;; - ;; The list of function names for wherein. NIL means unspecified. - (wherein nil :type list) - ;; - ;; The following slots represent the forms that we are supposed to evaluate - ;; on each iteration. Each form is represented by a cons (Form . Function), - ;; where the Function is the cached result of coercing Form to a function. - ;; Forms which use the current environment are converted with - ;; PREPROCESS-FOR-EVAL, which gives us a one-arg function. - ;; Null environment forms also have one-arg functions, but the argument is - ;; ignored. NIL means unspecified (the default.) - ;; - ;; Current environment forms: - (condition nil) - (break nil) - ;; - ;; List of current environment forms: - (print () :type list) - ;; - ;; Null environment forms. - (condition-after nil) - (break-after nil) - ;; - ;; List of null environment forms - (print-after () :type list)) - -;;; This is a list of conses (function-end-cookie . condition-satisfied), -;;; which we use to note distinct dynamic entries into functions. When we -;;; enter a traced function, we add a entry to this list holding the new -;;; end-cookie and whether the trace condition was statisfied. We must save -;;; the trace condition so that the after breakpoint knows whether to print. -;;; The length of this list tells us the indentation to use for printing TRACE -;;; messages. -;;; -;;; This list also helps us synchronize the TRACE facility dynamically for -;;; detecting non-local flow of control. Whenever execution hits a -;;; :function-end breakpoint used for TRACE'ing, we look for the -;;; function-end-cookie at the top of *traced-entries*. If it is not there, we -;;; discard any entries that come before our cookie. -;;; -;;; When we trace using encapsulation, we bind this variable and add -;;; (nil . condition-satisfied), so a NIL "cookie" marks an encapsulated -;;; tracing. -;;; -(defvar *traced-entries* ()) -(declaim (list *traced-entries*)) - -;;; This variable is used to discourage infinite recursions when some trace -;;; action invokes a function that is itself traced. In this case, we quietly -;;; ignore the inner tracing. -;;; -(defvar *in-trace* nil) - - -;;;; Utilities: - -;;; TRACE-FDEFINITION -- Internal -;;; -;;; Given a function name, a function or a macro name, return the raw -;;; definition and some information. "Raw" means that if the result is a -;;; closure, we strip off the closure and return the bare code. The second -;;; value is T if the argument was a function name. The third value is one of -;;; :COMPILED, :COMPILED-CLOSURE, :INTERPRETED, :INTERPRETED-CLOSURE and -;;; :FUNCALLABLE-INSTANCE. -;;; -(defun trace-fdefinition (x) - (multiple-value-bind - (res named-p) - (typecase x - (symbol - (cond ((special-form-p x) - (error "Can't trace special form ~S." x)) - ((macro-function x)) - (t - (values (fdefinition x) t)))) - (function x) - (t (values (fdefinition x) t))) - (if (eval:interpreted-function-p res) - (values res named-p (if (eval:interpreted-function-closure res) - :interpreted-closure :interpreted)) - (case (kernel:get-type res) - (#.vm:closure-header-type - (values (kernel:%closure-function res) named-p :compiled-closure)) - (#.vm:funcallable-instance-header-type - (values res named-p :funcallable-instance)) - (t (values res named-p :compiled)))))) - - -;;; TRACE-REDEFINED-UPDATE -- Internal -;;; -;;; When a function name is redefined, and we were tracing that name, then -;;; untrace the old definition and trace the new one. -;;; -(defun trace-redefined-update (fname new-value) - (when (fboundp fname) - (let* ((fun (trace-fdefinition fname)) - (info (gethash fun *traced-functions*))) - (when (and info (trace-info-named info)) - (untrace-1 fname) - (trace-1 fname info new-value))))) -;;; -(push #'trace-redefined-update ext:*setf-fdefinition-hook*) - - -;;; COERCE-FORM, COERCE-FORM-LIST -- Internal -;;; -;;; Annotate some forms to evaluate with pre-converted functions. Each form -;;; is really a cons (exp . function). Loc is the code location to use for -;;; the lexical environment. If Loc is NIL, evaluate in the null environment. -;;; If Form is NIL, just return NIL. -;;; -(defun coerce-form (form loc) - (when form - (let ((exp (car form))) - (if (di:code-location-p loc) - (let ((fun (di:preprocess-for-eval exp loc))) - (cons exp - #'(lambda (frame) - (let ((*current-frame* frame)) - (funcall fun frame))))) - (let* ((bod (ecase loc - ((nil) exp) - (:encapsulated - `(flet ((debug:arg (n) - (declare (special argument-list)) - (elt argument-list n))) - (declare (ignorable #'debug:arg)) - ,exp)))) - (fun (coerce `(lambda () ,bod) 'function))) - (cons exp - #'(lambda (frame) - (declare (ignore frame)) - (let ((*current-frame* nil)) - (funcall fun))))))))) -;;; -(defun coerce-form-list (forms loc) - (mapcar #'(lambda (x) (coerce-form x loc)) forms)) - - -;;; PRINT-TRACE-INDENTATION -- Internal -;;; -;;; Print indentation according to the number of trace entries. Entries -;;; whose condition was false don't count. -;;; -(defun print-trace-indentation () - (let ((depth 0)) - (dolist (entry *traced-entries*) - (when (cdr entry) (incf depth))) - (format t "~@V,0T~D: " - (+ (mod (* depth 2) (- *max-trace-indentation* 2)) 2) - depth))) - - -;;; TRACE-WHEREIN-P -- Internal. -;;; -;;; Return true if one of the Names appears on the stack below Frame. -;;; -(defun trace-wherein-p (frame names) - (do ((frame (di:frame-down frame) (di:frame-down frame))) - ((not frame) nil) - (when (member (di:debug-function-name (di:frame-debug-function frame)) - names :test #'equal) - (return t)))) - -;;; TRACE-PRINT -- Internal -;;; -;;; Handle print and print-after options. -;;; -(defun trace-print (frame forms) - (dolist (ele forms) - (fresh-line) - (print-trace-indentation) - (format t "~S = ~S" (car ele) (funcall (cdr ele) frame)))) - -;;; TRACE-MAYBE-BREAK -- Internal -;;; -;;; Test a break option, and break if true. -;;; -(defun trace-maybe-break (info break where frame) - (when (and break (funcall (cdr break) frame)) - (di:flush-frames-above frame) - (let ((*stack-top-hint* frame)) - (break "Breaking ~A traced call to ~S:" where - (trace-info-what info))))) - -;;; DISCARD-INVALID-ENTRIES -- Internal -;;; -;;; This function discards any invalid cookies on our simulated stack. -;;; Encapsulated entries are always valid, since we bind *traced-entries* in -;;; the encapsulation. -;;; -(defun discard-invalid-entries (frame) - (loop - (when (or (null *traced-entries*) - (let ((cookie (caar *traced-entries*))) - (or (not cookie) - (di:function-end-cookie-valid-p frame cookie)))) - (return)) - (pop *traced-entries*))) - - -;;;; Hook functions: - -;;; TRACE-START-BREAKPOINT-FUN -- Internal. -;;; -;;; Return a closure that can be used for a function start breakpoint hook -;;; function and a closure that can be used as the FUNCTION-END-COOKIE -;;; function. The first communicates the sense of the Condition to the second -;;; via a closure variable. -;;; -(defun trace-start-breakpoint-fun (info) - (let (conditionp) - (values - #'(lambda (frame bpt) - (declare (ignore bpt)) - (discard-invalid-entries frame) - (let ((condition (trace-info-condition info)) - (wherein (trace-info-wherein info))) - (setq conditionp - (and (not *in-trace*) - (or (not condition) - (funcall (cdr condition) frame)) - (or (not wherein) - (trace-wherein-p frame wherein))))) - - (when conditionp - (let ((*print-length* (or *debug-print-length* *print-length*)) - (*print-level* (or *debug-print-level* *print-level*)) - (kernel:*current-level* 0) - (*standard-output* *trace-output*) - (*in-trace* t)) - (fresh-line) - (print-trace-indentation) - (if (trace-info-encapsulated info) - (locally (declare (special basic-definition argument-list)) - (prin1 `(,(trace-info-what info) ,@argument-list))) - (print-frame-call frame)) - (terpri) - (trace-print frame (trace-info-print info))) - (trace-maybe-break info (trace-info-break info) "before" frame))) - - #'(lambda (frame cookie) - (declare (ignore frame)) - (push (cons cookie conditionp) *traced-entries*))))) - - -;;; TRACE-END-BREAKPOINT-FUN -- Internal -;;; -;;; This prints a representation of the return values delivered. First, -;;; this checks to see that cookie is at the top of *traced-entries*; if it is -;;; not, then we need to adjust this list to determine the correct indentation -;;; for output. We then check to see if the function is still traced and that -;;; the condition succeeded before printing anything. -;;; -(defun trace-end-breakpoint-fun (info) - #'(lambda (frame bpt *trace-values* cookie) - (declare (ignore bpt)) - (unless (eq cookie (caar *traced-entries*)) - (setf *traced-entries* - (member cookie *traced-entries* :key #'car))) - - (let ((entry (pop *traced-entries*))) - (when (and (not (trace-info-untraced info)) - (or (cdr entry) - (let ((cond (trace-info-condition-after info))) - (and cond (funcall (cdr cond) frame))))) - (let ((*print-length* (or *debug-print-length* *print-length*)) - (*print-level* (or *debug-print-level* *print-level*)) - (kernel:*current-level* 0) - (*standard-output* *trace-output*) - (*in-trace* t)) - (fresh-line) - (pprint-logical-block (*standard-output* nil) - (print-trace-indentation) - (pprint-indent :current 2) - (format t "~S returned" (trace-info-what info)) - (dolist (v *trace-values*) - (write-char #\space) - (pprint-newline :linear) - (prin1 v))) - (terpri) - (trace-print frame (trace-info-print-after info))) - (trace-maybe-break info (trace-info-break-after info) - "after" frame))))) - - -;;; TRACE-CALL -- Internal -;;; -;;; This function is called by the trace encapsulation. It calls the -;;; breakpoint hook functions with NIL for the breakpoint and cookie, which -;;; we have cleverly contrived to work for our hook functions. -;;; -(defun trace-call (info) - (multiple-value-bind - (start cookie) - (trace-start-breakpoint-fun info) - (let ((frame (di:frame-down (di:top-frame)))) - (funcall start frame nil) - (let ((*traced-entries* *traced-entries*)) - (declare (special basic-definition argument-list)) - (funcall cookie frame nil) - (let ((vals - (multiple-value-list - (apply basic-definition argument-list)))) - (funcall (trace-end-breakpoint-fun info) frame nil vals nil) - (values-list vals)))))) - - -;;; TRACE-1 -- Internal. -;;; -;;; Trace one function according to the specified options. We copy the -;;; trace info (it was a quoted constant), fill in the functions, and then -;;; install the breakpoints or encapsulation. -;;; -;;; If non-null, Definition is the new definition of a function that we are -;;; automatically retracing; this -;;; -(defun trace-1 (function-or-name info &optional definition) - (multiple-value-bind - (fun named kind) - (if definition - (values definition t - (nth-value 2 (trace-fdefinition definition))) - (trace-fdefinition function-or-name)) - (when (gethash fun *traced-functions*) - (warn "Function ~S already TRACE'd, retracing it." function-or-name) - (untrace-1 fun)) - - (let* ((debug-fun (di:function-debug-function fun)) - (encapsulated - (if (eq (trace-info-encapsulated info) :default) - (ecase kind - (:compiled nil) - (:compiled-closure - (unless (functionp function-or-name) - (warn "Tracing shared code for ~S:~% ~S" - function-or-name fun)) - nil) - ((:interpreted :interpreted-closure :funcallable-instance) - t)) - (trace-info-encapsulated info))) - (loc (if encapsulated - :encapsulated - (di:debug-function-start-location debug-fun))) - (info (make-trace-info - :what function-or-name - :named named - :encapsulated encapsulated - :wherein (trace-info-wherein info) - :condition (coerce-form (trace-info-condition info) loc) - :break (coerce-form (trace-info-break info) loc) - :print (coerce-form-list (trace-info-print info) loc) - :break-after (coerce-form (trace-info-break-after info) nil) - :condition-after - (coerce-form (trace-info-condition-after info) nil) - :print-after - (coerce-form-list (trace-info-print-after info) nil)))) - - (dolist (wherein (trace-info-wherein info)) - (unless (or (stringp wherein) - (fboundp wherein)) - (warn ":WHEREIN name is not a defined global function: ~S" - wherein))) - - (cond - (encapsulated - (unless named - (error "Can't use encapsulation to trace anonymous function ~S." - fun)) - (ext:encapsulate function-or-name 'trace `(trace-call ',info))) - (t - (multiple-value-bind - (start-fun cookie-fun) - (trace-start-breakpoint-fun info) - (let ((start (di:make-breakpoint start-fun debug-fun - :kind :function-start)) - (end (di:make-breakpoint - (trace-end-breakpoint-fun info) - debug-fun :kind :function-end - :function-end-cookie cookie-fun))) - (setf (trace-info-start-breakpoint info) start) - (setf (trace-info-end-breakpoint info) end) - ;; - ;; The next two forms must be in the order in which they appear, - ;; since the start breakpoint must run before the function-end - ;; breakpoint's start helper (which calls the cookie function.) - ;; One reason is that cookie function requires that the CONDITIONP - ;; shared closure variable be initialized. - (di:activate-breakpoint start) - (di:activate-breakpoint end))))) - - (setf (gethash fun *traced-functions*) info))) - - function-or-name) - - -;;;; The TRACE macro: - -;;; PARSE-TRACE-OPTIONS -- Internal -;;; -;;; Parse leading trace options off of Specs, modifying Info accordingly. -;;; The remaining portion of the list is returned when we encounter a plausible -;;; function name. -;;; -(defun parse-trace-options (specs info) - (let ((current specs)) - (loop - (when (endp current) (return)) - (let ((option (first current)) - (value (cons (second current) nil))) - (case option - (:condition (setf (trace-info-condition info) value)) - (:condition-after - (setf (trace-info-condition info) (cons nil nil)) - (setf (trace-info-condition-after info) value)) - (:condition-all - (setf (trace-info-condition info) value) - (setf (trace-info-condition-after info) value)) - (:wherein - (setf (trace-info-wherein info) - (if (listp (car value)) (car value) value))) - (:encapsulate - (setf (trace-info-encapsulated info) (car value))) - (:break (setf (trace-info-break info) value)) - (:break-after (setf (trace-info-break-after info) value)) - (:break-all - (setf (trace-info-break info) value) - (setf (trace-info-break-after info) value)) - (:print - (setf (trace-info-print info) - (append (trace-info-print info) (list value)))) - (:print-after - (setf (trace-info-print-after info) - (append (trace-info-print-after info) (list value)))) - (:print-all - (setf (trace-info-print info) - (append (trace-info-print info) (list value))) - (setf (trace-info-print-after info) - (append (trace-info-print-after info) (list value)))) - (t (return))) - (pop current) - (unless current - (error "Missing argument to ~S TRACE option." option)) - (pop current))) - current)) - - -;;; EXPAND-TRACE -- Internal -;;; -;;; Compute the expansion of TRACE in the non-trivial case (arguments -;;; specified.) If there are no :FUNCTION specs, then don't use a LET. This -;;; allows TRACE to be used without the full interpreter. -;;; -(defun expand-trace (specs) - (collect ((binds) - (forms)) - (let* ((global-options (make-trace-info)) - (current (parse-trace-options specs global-options))) - (loop - (when (endp current) (return)) - (let ((name (pop current)) - (options (copy-trace-info global-options))) - (cond - ((eq name :function) - (let ((temp (gensym))) - (binds `(,temp ,(pop current))) - (forms `(trace-1 ,temp ',options)))) - ((and (keywordp name) - (not (or (fboundp name) (macro-function name)))) - (error "Unknown TRACE option: ~S" name)) - (t - (forms `(trace-1 ',name ',options)))) - (setq current (parse-trace-options current options))))) - - (if (binds) - `(let ,(binds) (list ,@(forms))) - `(list ,@(forms))))) - - -;;; %LIST-TRACED-FUNCTIONS -- Internal -;;; -(defun %list-traced-functions () - (loop for x being each hash-value in *traced-functions* - collect (trace-info-what x))) - - -;;; TRACE -- Public. -;;; -(defmacro trace (&rest specs) - "TRACE {Option Global-Value}* {Name {Option Value}*}* - TRACE is a debugging tool that prints information when specified functions - are called. In its simplest form: - (trace Name-1 Name-2 ...) - - TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named - functions is entered or returns (the Names are not evaluated.) The output - is indented according to the number of pending traced calls, and this trace - depth is printed at the beginning of each line of output. - - Options allow modification of the default behavior. Each option is a pair - of an option keyword and a value form. Options may be interspersed with - function names. Options only affect tracing of the function whose name they - appear immediately after. Global options are specified before the first - name, and affect all functions traced by a given use of TRACE. - - The following options are defined: - - :CONDITION Form - :CONDITION-AFTER Form - :CONDITION-ALL Form - If :CONDITION is specified, then TRACE does nothing unless Form - evaluates to true at the time of the call. :CONDITION-AFTER is - similar, but suppresses the initial printout, and is tested when the - function returns. :CONDITION-ALL tries both before and after. - - :WHEREIN Names - If specified, Names is a function name or list of names. TRACE does - nothing unless a call to one of those functions encloses the call to - this function (i.e. it would appear in a backtrace.) Anonymous - functions have string names like \"DEFUN FOO\". - - :BREAK Form - :BREAK-AFTER Form - :BREAK-ALL Form - If specified, and Form evaluates to true, then the debugger is invoked - at the start of the function, at the end of the function, or both, - according to the respective option. - - :PRINT Form - :PRINT-AFTER Form - :PRINT-ALL Form - In addition to the usual prinout, he result of evaluating Form is - printed at the start of the function, at the end of the function, or - both, according to the respective option. Multiple print options cause - multiple values to be printed. - - :FUNCTION Function-Form - This is a not really an option, but rather another way of specifying - what function to trace. The Function-Form is evaluated immediately, - and the resulting function is traced. - - :ENCAPSULATE {:DEFAULT | T | NIL} - If T, the tracing is done via encapsulation (redefining the function - name) rather than by modifying the function. :DEFAULT is the default, - and means to use encapsulation for interpreted functions and funcallable - instances, breakpoints otherwise. When encapsulation is used, forms are - *not* evaluated in the function's lexical environment, but DEBUG:ARG can - still be used. - - :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment - of the called function; DEBUG:VAR and DEBUG:ARG can be used. The -AFTER and - -ALL forms are evaluated in the null environment." - (if specs - (expand-trace specs) - '(%list-traced-functions))) - - -;;;; Untracing: - -;;; UNTRACE-1 -- Internal -;;; -;;; Untrace one function. -;;; -(defun untrace-1 (function-or-name) - (let* ((fun (trace-fdefinition function-or-name)) - (info (gethash fun *traced-functions*))) - (cond - ((not info) (warn "Function is not TRACE'd -- ~S." function-or-name)) - (t - (cond - ((trace-info-encapsulated info) - (ext:unencapsulate (trace-info-what info) 'trace)) - (t - (di:delete-breakpoint (trace-info-start-breakpoint info)) - (di:delete-breakpoint (trace-info-end-breakpoint info)))) - (setf (trace-info-untraced info) t) - (remhash fun *traced-functions*))))) - -;;; UNTRACE-ALL -- Internal -;;; -;;; Untrace all traced functions. -;;; -(defun untrace-all () - (dolist (fun (%list-traced-functions)) - (untrace-1 fun)) - t) - -(defmacro untrace (&rest specs) - "Removes tracing from the specified functions. With no args, untraces all - functions." - (if specs - (collect ((res)) - (let ((current specs)) - (loop - (unless current (return)) - (let ((name (pop current))) - (res (if (eq name :function) - `(untrace-1 ,(pop current)) - `(untrace-1 ',name))))) - `(progn ,@(res) t))) - '(untrace-all))) diff --git a/code/numbers.lisp b/code/numbers.lisp deleted file mode 100644 index d075e3e7456a6862961bc5235a97780f82d514a8..0000000000000000000000000000000000000000 --- a/code/numbers.lisp +++ /dev/null @@ -1,1226 +0,0 @@ -;;; -*- Mode: Lisp; Package: KERNEL; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/numbers.lisp,v 1.20 1992/02/07 11:33:23 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.20 1992/02/07 11:33:23 ram Exp $ -;;; -;;; This file contains the definitions of most number functions. -;;; -;;; Author: Rob MacLachlan -;;; -;;; Much code in this file was derived from code written by William Lott, Dave -;;; Mcdonald, Jim Large, Scott Fahlman, etc. -;;; -(in-package "LISP") - -(export '(zerop plusp minusp oddp evenp = /= < > <= >= max min + - * / 1+ 1- - conjugate abs phase signum float floor ceiling truncate cis round mod - rem ffloor fceiling fround ftruncate complex realpart imagpart - logior logxor logand logeqv lognand lognor logandc1 logandc2 logorc1 - logorc2 boole boole-clr boole-set boole-1 boole-2 boole-c1 boole-c2 - boole-and boole-ior boole-xor boole-eqv boole-nand boole-nor - boole-andc1 boole-andc2 boole-orc1 boole-orc2 lognot logtest - logbitp ash integer-length byte byte-size byte-position - ldb ldb-test mask-field dpb deposit-field - upgraded-complex-part-type)) - -(in-package "KERNEL") - - -;;;; Number dispatch macro: - -(eval-when (compile load eval) - -;;; PARSE-NUMBER-DISPATCH -- Internal -;;; -;;; Grovel an individual case to NUMBER-DISPATCH, augmenting Result with the -;;; type dispatches and bodies. Result is a tree built of alists representing -;;; the dispatching off each arg (in order). The leaf is the body to be -;;; executed in that case. -;;; -(defun parse-number-dispatch (vars result types var-types body) - (cond ((null vars) - (unless (null types) (error "More types than vars.")) - (when (cdr result) - (error "Duplicate case: ~S." body)) - (setf (cdr result) - (sublis var-types body :test #'equal))) - ((null types) - (error "More vars than types.")) - (t - (flet ((frob (var type) - (parse-number-dispatch - (rest vars) - (or (assoc type (cdr result) :test #'equal) - (car (setf (cdr result) - (acons type nil (cdr result))))) - (rest types) - (acons `(dispatch-type ,var) type var-types) - body))) - (let ((type (first types)) - (var (first vars))) - (if (and (consp type) (eq (first type) 'foreach)) - (dolist (type (rest type)) - (frob var type)) - (frob var type))))))) - - -;;; Our guess for the preferred order to do type tests in (cheaper and/or more -;;; probable first.) -;;; -(defconstant type-test-ordering - '(fixnum single-float double-float integer bignum complex ratio)) - -;;; Type-Test-Order -- Internal -;;; -;;; Return true if Type1 should be tested before Type2. -;;; -(defun type-test-order (type1 type2) - (let ((o1 (position type1 type-test-ordering)) - (o2 (position type2 type-test-ordering))) - (cond ((not o1) nil) - ((not o2) t) - (t - (< o1 o2))))) - - -;;; GENERATE-NUMBER-DISPATCH -- Internal -;;; -;;; Return an ETYPECASE form that does the type dispatch, ordering the cases -;;; for efficiency. -;;; -(defun generate-number-dispatch (vars error-tags cases) - (if vars - (let ((var (first vars)) - (cases (sort cases #'type-test-order :key #'car))) - `((typecase ,var - ,@(mapcar #'(lambda (case) - `(,(first case) - ,@(generate-number-dispatch (rest vars) - (rest error-tags) - (cdr case)))) - cases) - (t (go ,(first error-tags)))))) - cases)) - -); Eval-When (Compile Load Eval) - - -;;; NUMBER-DISPATCH -- Interface -;;; -(defmacro number-dispatch (var-specs &body cases) - "NUMBER-DISPATCH ({(Var Type)}*) {((Type*) Form*) | (Symbol Arg*)}* - A vaguely case-like macro that does number cross-product dispatches. The - Vars are the variables we are dispatching off of. The Type paired with each - Var is used in the error message when no case matches. Each case specifies a - Type for each var, and is executed when that signature holds. A type may be - a list (FOREACH Each-Type*), causing that case to be repeatedly instantiated - for every Each-Type. In the body of each case, any list of the form - (DISPATCH-TYPE Var-Name) is substituted with the type of that var in that - instance of the case. - - As an alternate to a case spec, there may be a form whose CAR is a symbol. - In this case, we apply the CAR of the form to the CDR and treat the result of - the call as a list of cases. This process is not applied recursively." - (let ((res (list nil)) - (vars (mapcar #'car var-specs)) - (block (gensym))) - (dolist (case cases) - (if (symbolp (first case)) - (let ((cases (apply (symbol-function (first case)) (rest case)))) - (dolist (case cases) - (parse-number-dispatch vars res (first case) nil (rest case)))) - (parse-number-dispatch vars res (first case) nil (rest case)))) - - (collect ((errors) - (error-tags)) - (dolist (spec var-specs) - (let ((var (first spec)) - (type (second spec)) - (tag (gensym))) - (error-tags tag) - (errors tag) - (errors `(return-from - ,block - (error 'simple-type-error :datum ,var - :expected-type ',type - :format-string - "Argument ~A is not a ~S: ~S." - :format-arguments - (list ',var ',type ,var)))))) - - `(block ,block - (tagbody - (return-from ,block - ,@(generate-number-dispatch vars (error-tags) - (cdr res))) - ,@(errors)))))) - - -;;;; Binary operation dispatching utilities: - -(eval-when (compile eval) - -;;; FLOAT-CONTAGION -- Internal -;;; -;;; Return NUMBER-DISPATCH forms for rational X float. -;;; -(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio))) - `(((single-float single-float) (,op ,x ,y)) - (((foreach ,@rat-types) (foreach single-float double-float)) - (,op (coerce ,x '(dispatch-type ,y)) ,y)) - (((foreach single-float double-float) (foreach ,@rat-types)) - (,op ,x (coerce ,y '(dispatch-type ,x)))) - (((foreach single-float double-float) double-float) - (,op (coerce ,x 'double-float) ,y)) - ((double-float single-float) - (,op ,x (coerce ,y 'double-float))))) - - -;;; BIGNUM-CROSS-FIXNUM -- Internal -;;; -;;; Return NUMBER-DISPATCH forms for bignum X fixnum. -;;; -(defun bignum-cross-fixnum (fix-op big-op) - `(((fixnum fixnum) (,fix-op x y)) - ((fixnum bignum) - (,big-op (make-small-bignum x) y)) - ((bignum fixnum) - (,big-op x (make-small-bignum y))) - ((bignum bignum) - (,big-op x y)))) - -); Eval-When (Compile Eval) - - -;;;; Canonicalization utilities: - -;;; CANONICAL-COMPLEX -- Internal -;;; -;;; If imagpart is 0, return realpart, otherwise make a complex. This is -;;; used when we know that realpart and imagpart are the same type, but -;;; rational canonicalization might still need to be done. -;;; -(proclaim '(inline canonical-complex)) -(defun canonical-complex (realpart imagpart) - (if (eql imagpart 0) - realpart - (%make-complex realpart imagpart))) - - -;;; BUILD-RATIO -- Internal -;;; -;;; Given a numerator and denominator with the GCD already divided out, make -;;; a canonical rational. We make the denominator positive, and check whether -;;; it is 1. -;;; -(proclaim '(inline build-ratio)) -(defun build-ratio (num den) - (multiple-value-bind (num den) - (if (minusp den) - (values (- num) (- den)) - (values num den)) - (if (eql den 1) - num - (%make-ratio num den)))) - - -;;; MAYBE-TRUNCATE -- Internal -;;; -;;; Truncate X and Y, but bum the case where Y is 1. -;;; -(proclaim '(inline maybe-truncate)) -(defun maybe-truncate (x y) - (if (eql y 1) - x - (truncate x y))) - - -;;;; Complexes: - -(defun upgraded-complex-part-type (spec) - "Returns the element type of the most specialized COMPLEX number type that - can hold parts of type Spec. This is currently always T." - (declare (ignore spec)) - t) - -(defun complex (realpart &optional (imagpart 0)) - "Builds a complex number from the specified components." - (number-dispatch ((realpart real) (imagpart real)) - ((rational rational) - (canonical-complex realpart imagpart)) - (float-contagion %make-complex realpart imagpart (rational)))) - -(defun realpart (number) - "Extracts the real part of a number." - (realpart number)) - -(defun imagpart (number) - "Extracts the imaginary part of a number." - (imagpart number)) - -(defun conjugate (number) - "Returns the complex conjugate of NUMBER. For non-complex numbers, this is - an identity." - (if (complexp number) - (complex (realpart number) (- (imagpart number))) - number)) - -(defun signum (number) - "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))." - (if (zerop number) - number - (if (rationalp number) - (if (plusp number) 1 -1) - (/ number (abs number))))) - - -;;;; Ratios. - -(defun numerator (number) - "Return the numerator of NUMBER, which must be rational." - (numerator number)) - -(defun denominator (number) - "Return the denominator of NUMBER, which must be rational." - (denominator number)) - - - -;;;; Arithmetic Operations - - -(defmacro define-arith (op init doc) - `(defun ,op (&rest args) - ,doc - (if (null args) ,init - (do ((args (cdr args) (cdr args)) - (res (car args) (,op res (car args)))) - ((null args) res))))) - -(define-arith + 0 - "Returns the sum of its arguments. With no args, returns 0.") -(define-arith * 1 - "Returns the product of its arguments. With no args, returns 1.") - -(defun - (number &rest more-numbers) - "Subtracts the second and all subsequent arguments from the first. - With one arg, negates it." - (if more-numbers - (do ((nlist more-numbers (cdr nlist)) - (result number)) - ((atom nlist) result) - (declare (list nlist)) - (setq result (- result (car nlist)))) - (- number))) - -(defun / (number &rest more-numbers) - "Divides the first arg by each of the following arguments, in turn. - With one arg, returns reciprocal." - (if more-numbers - (do ((nlist more-numbers (cdr nlist)) - (result number)) - ((atom nlist) result) - (declare (list nlist)) - (setq result (/ result (car nlist)))) - (/ number))) - -(defun 1+ (number) - "Returns NUMBER + 1." - (1+ number)) - -(defun 1- (number) - "Returns NUMBER - 1." - (1- number)) - - -(eval-when (compile) - -(defmacro two-arg-+/- (name op big-op) - `(defun ,name (x y) - (number-dispatch ((x number) (y number)) - (bignum-cross-fixnum ,op ,big-op) - (float-contagion ,op x y) - - ((complex complex) - (canonical-complex (,op (realpart x) (realpart y)) - (,op (imagpart x) (imagpart y)))) - (((foreach bignum fixnum ratio single-float double-float) complex) - (complex (,op x (realpart y)) (imagpart y))) - ((complex (or rational float)) - (complex (,op (realpart x) y) (imagpart x))) - - (((foreach fixnum bignum) ratio) - (let* ((dy (denominator y)) - (n (,op (* x dy) (numerator y)))) - (%make-ratio n dy))) - ((ratio integer) - (let* ((dx (denominator x)) - (n (,op (numerator x) (* y dx)))) - (%make-ratio n dx))) - ((ratio ratio) - (let* ((nx (numerator x)) - (dx (denominator x)) - (ny (numerator y)) - (dy (denominator y)) - (g1 (gcd dx dy))) - (if (eql g1 1) - (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy)) - (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny))) - (g2 (gcd t1 g1)) - (t2 (truncate dx g1))) - (cond ((eql t1 0) 0) - ((eql g2 1) - (%make-ratio t1 (* t2 dy))) - (T (let* ((nn (truncate t1 g2)) - (t3 (truncate dy g2)) - (nd (if (eql t2 1) t3 (* t2 t3)))) - (if (eql nd 1) nn (%make-ratio nn nd)))))))))))) - -); Eval-When (Compile) - - -(two-arg-+/- two-arg-+ + add-bignums) -(two-arg-+/- two-arg-- - subtract-bignum) - - - -(defun two-arg-* (x y) - (flet ((integer*ratio (x y) - (if (eql x 0) 0 - (let* ((ny (numerator y)) - (dy (denominator y)) - (gcd (gcd x dy))) - (if (eql gcd 1) - (%make-ratio (* x ny) dy) - (let ((nn (* (truncate x gcd) ny)) - (nd (truncate dy gcd))) - (if (eql nd 1) - nn - (%make-ratio nn nd))))))) - (complex*real (x y) - (canonical-complex (* (realpart x) y) (* (imagpart x) y)))) - (number-dispatch ((x number) (y number)) - (float-contagion * x y) - - ((fixnum fixnum) (multiply-fixnums x y)) - ((bignum fixnum) (multiply-bignum-and-fixnum x y)) - ((fixnum bignum) (multiply-bignum-and-fixnum y x)) - ((bignum bignum) (multiply-bignums x y)) - - ((complex complex) - (let* ((rx (realpart x)) - (ix (imagpart x)) - (ry (realpart y)) - (iy (imagpart y))) - (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry))))) - (((foreach bignum fixnum ratio single-float double-float) complex) - (complex*real y x)) - ((complex (or rational float)) - (complex*real x y)) - - (((foreach bignum fixnum) ratio) (integer*ratio x y)) - ((ratio integer) (integer*ratio y x)) - ((ratio ratio) - (let* ((nx (numerator x)) - (dx (denominator x)) - (ny (numerator y)) - (dy (denominator y)) - (g1 (gcd nx dy)) - (g2 (gcd dx ny))) - (build-ratio (* (maybe-truncate nx g1) - (maybe-truncate ny g2)) - (* (maybe-truncate dx g2) - (maybe-truncate dy g1)))))))) - - - -;;; INTEGER-/-INTEGER -- Internal -;;; -;;; Divide two integers, producing a canonical rational. If a fixnum, we -;;; see if they divide evenly before trying the GCD. In the bignum case, we -;;; don't bother, since bignum division is expensive, and the test is not very -;;; likely to suceed. -;;; -(defun integer-/-integer (x y) - (if (and (typep x 'fixnum) (typep y 'fixnum)) - (multiple-value-bind - (quo rem) - (truncate x y) - (if (zerop rem) - quo - (let ((gcd (gcd x y))) - (declare (fixnum gcd)) - (if (eql gcd 1) - (build-ratio x y) - (build-ratio (truncate x gcd) (truncate y gcd)))))) - (let ((gcd (gcd x y))) - (if (eql gcd 1) - (build-ratio x y) - (build-ratio (truncate x gcd) (truncate y gcd)))))) - - -(defun two-arg-/ (x y) - (number-dispatch ((x number) (y number)) - (float-contagion / x y (ratio integer)) - - ((complex complex) - (let* ((rx (realpart x)) - (ix (imagpart x)) - (ry (realpart y)) - (iy (imagpart y)) - (dn (+ (* ry ry) (* iy iy)))) - (canonical-complex (/ (+ (* rx ry) (* ix iy)) dn) - (/ (- (* ix ry) (* rx iy)) dn)))) - (((foreach integer ratio single-float double-float) complex) - (let* ((ry (realpart y)) - (iy (imagpart y)) - (dn (+ (* ry ry) (* iy iy)))) - (canonical-complex (/ (* x ry) dn) - (/ (- (* x iy)) dn)))) - ((complex (or rational float)) - (canonical-complex (/ (realpart x) y) - (/ (imagpart x) y))) - - ((ratio ratio) - (let* ((nx (numerator x)) - (dx (denominator x)) - (ny (numerator y)) - (dy (denominator y)) - (g1 (gcd nx ny)) - (g2 (gcd dx dy))) - (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2)) - (* (maybe-truncate dx g2) (maybe-truncate ny g1))))) - - ((integer integer) - (integer-/-integer x y)) - - ((integer ratio) - (if (zerop x) - 0 - (let* ((ny (numerator y)) - (dy (denominator y)) - (gcd (gcd x ny))) - (build-ratio (* (maybe-truncate x gcd) dy) - (maybe-truncate ny gcd))))) - - ((ratio integer) - (let* ((nx (numerator x)) - (gcd (gcd nx y))) - (build-ratio (maybe-truncate nx gcd) - (* (maybe-truncate y gcd) (denominator x))))))) - - -(defun %negate (n) - (number-dispatch ((n number)) - (((foreach fixnum single-float double-float)) - (%negate n)) - ((bignum) - (negate-bignum n)) - ((ratio) - (%make-ratio (- (numerator n)) (denominator n))) - ((complex) - (%make-complex (- (realpart n)) (- (imagpart n)))))) - - -;;;; Truncate & friends. - -(defun truncate (number &optional (divisor 1)) - "Returns number (or number/divisor) as an integer, rounded toward 0. - The second returned value is the remainder." - (macrolet ((truncate-float (rtype) - `(let* ((float-div (coerce divisor ',rtype)) - (res (%unary-truncate (/ number float-div)))) - (values res - (- number - (* (coerce res ',rtype) float-div)))))) - (number-dispatch ((number real) (divisor real)) - ((fixnum fixnum) (truncate number divisor)) - (((foreach fixnum bignum) ratio) - (truncate (* number (denominator divisor)) - (numerator divisor))) - ((fixnum bignum) - (values 0 number)) - ((ratio (or float rational)) - (let ((q (truncate (numerator number) - (* (denominator number) divisor)))) - (values q (- number (* q divisor))))) - ((bignum fixnum) - (bignum-truncate number (make-small-bignum divisor))) - ((bignum bignum) - (bignum-truncate number divisor)) - - (((foreach single-float double-float) (or rational single-float)) - (if (eql divisor 1) - (let ((res (%unary-truncate number))) - (values res (- number (coerce res '(dispatch-type number))))) - (truncate-float (dispatch-type number)))) - ((double-float (or single-float double-float)) - (truncate-float double-float)) - ((single-float double-float) - (truncate-float double-float)) - (((foreach fixnum bignum ratio) (foreach single-float double-float)) - (truncate-float (dispatch-type divisor)))))) - - -;;; Declare these guys inline to let them get optimized a little. Round and -;;; Fround are not declared inline since they seem too obscure and too -;;; big to inline-expand by default. Also, this gives the compiler a chance to -;;; pick off the unary float case. Simlarly, ceiling and floor are only -;;; maybe-inline for now, so that the power-of-2 ceiling and floor transforms -;;; get a chance. -;;; -(declaim (inline rem mod fceiling ffloor ftruncate)) -(declaim (maybe-inline ceiling floor)) - -;;; If the numbers do not divide exactly and the result of (/ number divisor) -;;; would be negative then decrement the quotient and augment the remainder by -;;; the divisor. -;;; -(defun floor (number &optional (divisor 1)) - "Returns the greatest integer not greater than number, or number/divisor. - The second returned value is (mod number divisor)." - (multiple-value-bind (tru rem) (truncate number divisor) - (if (and (not (zerop rem)) - (if (minusp divisor) - (plusp number) - (minusp number))) - (values (1- tru) (+ rem divisor)) - (values tru rem)))) - - -;;; If the numbers do not divide exactly and the result of (/ number divisor) -;;; would be positive then increment the quotient and decrement the remainder by -;;; the divisor. -;;; -(defun ceiling (number &optional (divisor 1)) - "Returns the smallest integer not less than number, or number/divisor. - The second returned value is the remainder." - (multiple-value-bind (tru rem) (truncate number divisor) - (if (and (not (zerop rem)) - (if (minusp divisor) - (minusp number) - (plusp number))) - (values (+ tru 1) (- rem divisor)) - (values tru rem)))) - - -(defun round (number &optional (divisor 1)) - "Rounds number (or number/divisor) to nearest integer. - The second returned value is the remainder." - (if (eql divisor 1) - (round number) - (multiple-value-bind (tru rem) (truncate number divisor) - (let ((thresh (/ (abs divisor) 2))) - (cond ((or (> rem thresh) - (and (= rem thresh) (oddp tru))) - (if (minusp divisor) - (values (- tru 1) (+ rem divisor)) - (values (+ tru 1) (- rem divisor)))) - ((let ((-thresh (- thresh))) - (or (< rem -thresh) - (and (= rem -thresh) (oddp tru)))) - (if (minusp divisor) - (values (+ tru 1) (- rem divisor)) - (values (- tru 1) (+ rem divisor)))) - (t (values tru rem))))))) - - -(defun rem (number divisor) - "Returns second result of TRUNCATE." - (multiple-value-bind (tru rem) (truncate number divisor) - (declare (ignore tru)) - rem)) - -(defun mod (number divisor) - "Returns second result of FLOOR." - (let ((rem (rem number divisor))) - (if (and (not (zerop rem)) - (if (minusp divisor) - (plusp number) - (minusp number))) - (+ rem divisor) - rem))) - - -(macrolet ((frob (name op doc) - `(defun ,name (number &optional (divisor 1)) - ,doc - (multiple-value-bind (res rem) (,op number divisor) - (values (float res (if (floatp rem) rem 1.0)) rem))))) - (frob ffloor floor - "Same as FLOOR, but returns first value as a float.") - (frob fceiling ceiling - "Same as CEILING, but returns first value as a float." ) - (frob ftruncate truncate - "Same as TRUNCATE, but returns first value as a float.") - (frob fround round - "Same as ROUND, but returns first value as a float.")) - - -;;;; Comparisons: - -(defun = (number &rest more-numbers) - "Returns T if all of its arguments are numerically equal, NIL otherwise." - (do ((nlist more-numbers (cdr nlist))) - ((atom nlist) T) - (declare (list nlist)) - (if (not (= (car nlist) number)) (return nil)))) - -(defun /= (number &rest more-numbers) - "Returns T if no two of its arguments are numerically equal, NIL otherwise." - (do* ((head number (car nlist)) - (nlist more-numbers (cdr nlist))) - ((atom nlist) t) - (declare (list nlist)) - (unless (do* ((nl nlist (cdr nl))) - ((atom nl) T) - (declare (list nl)) - (if (= head (car nl)) (return nil))) - (return nil)))) - -(defun < (number &rest more-numbers) - "Returns T if its arguments are in strictly increasing order, NIL otherwise." - (do* ((n number (car nlist)) - (nlist more-numbers (cdr nlist))) - ((atom nlist) t) - (declare (list nlist)) - (if (not (< n (car nlist))) (return nil)))) - -(defun > (number &rest more-numbers) - "Returns T if its arguments are in strictly decreasing order, NIL otherwise." - (do* ((n number (car nlist)) - (nlist more-numbers (cdr nlist))) - ((atom nlist) t) - (declare (list nlist)) - (if (not (> n (car nlist))) (return nil)))) - -(defun <= (number &rest more-numbers) - "Returns T if arguments are in strictly non-decreasing order, NIL otherwise." - (do* ((n number (car nlist)) - (nlist more-numbers (cdr nlist))) - ((atom nlist) t) - (declare (list nlist)) - (if (not (<= n (car nlist))) (return nil)))) - -(defun >= (number &rest more-numbers) - "Returns T if arguments are in strictly non-increasing order, NIL otherwise." - (do* ((n number (car nlist)) - (nlist more-numbers (cdr nlist))) - ((atom nlist) t) - (declare (list nlist)) - (if (not (>= n (car nlist))) (return nil)))) - -(defun max (number &rest more-numbers) - "Returns the greatest of its arguments." - (do ((nlist more-numbers (cdr nlist)) - (result number)) - ((null nlist) (return result)) - (declare (list nlist)) - (if (> (car nlist) result) (setq result (car nlist))))) - -(defun min (number &rest more-numbers) - "Returns the least of its arguments." - (do ((nlist more-numbers (cdr nlist)) - (result number)) - ((null nlist) (return result)) - (declare (list nlist)) - (if (< (car nlist) result) (setq result (car nlist))))) - -(eval-when (compile eval) - -(defun basic-compare (op) - `(((fixnum fixnum) (,op x y)) - - ((single-float single-float) (,op x y)) - (((foreach single-float double-float) double-float) - (,op (coerce x 'double-float) y)) - ((double-float single-float) - (,op x (coerce y 'double-float))) - (((foreach single-float double-float) rational) - (if (eql y 0) - (,op x (coerce 0 '(dispatch-type x))) - (,op (rational x) y))) - (((foreach bignum fixnum ratio) float) - (,op x (rational y))))) - - -(defmacro two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases) - `(defun ,name (x y) - (number-dispatch ((x real) (y real)) - (basic-compare ,op) - - (((foreach fixnum bignum) ratio) - (,op x (,ratio-arg2 (numerator y) (denominator y)))) - ((ratio integer) - (,op (,ratio-arg1 (numerator x) (denominator x)) y)) - ((ratio ratio) - (,op (* (numerator (truly-the ratio x)) - (denominator (truly-the ratio y))) - (* (numerator (truly-the ratio y)) - (denominator (truly-the ratio x))))) - ,@cases))) - -); Eval-When (Compile Eval) - -(two-arg-</> two-arg-< < floor ceiling - ((fixnum bignum) - (bignum-plus-p y)) - ((bignum fixnum) - (not (bignum-plus-p x))) - ((bignum bignum) - (minusp (bignum-compare x y)))) - -(two-arg-</> two-arg-> > ceiling floor - ((fixnum bignum) - (not (bignum-plus-p y))) - ((bignum fixnum) - (bignum-plus-p x)) - ((bignum bignum) - (plusp (bignum-compare x y)))) - - -(defun two-arg-= (x y) - (number-dispatch ((x number) (y number)) - (basic-compare eql) - - ((fixnum (or bignum ratio)) nil) - - ((bignum (or fixnum ratio)) nil) - ((bignum bignum) - (zerop (bignum-compare x y))) - - ((ratio integer) nil) - ((ratio ratio) - (and (eql (numerator x) (numerator y)) - (eql (denominator x) (denominator y)))) - - ((complex complex) - (and (= (realpart x) (realpart y)) - (= (imagpart x) (imagpart y)))) - (((foreach fixnum bignum ratio single-float double-float) complex) - (and (= x (realpart y)) - (zerop (imagpart y)))) - ((complex (or float rational)) - (and (= (realpart x) y) - (zerop (imagpart x)))))) - - -;;; EQL -- Public -;;; -(defun eql (obj1 obj2) - "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL." - (or (eq obj1 obj2) - (if (or (typep obj2 'fixnum) - (not (typep obj2 'number))) - nil - (macrolet ((foo (&rest stuff) - `(typecase obj2 - ,@(mapcar #'(lambda (foo) - (let ((type (car foo)) - (fn (cadr foo))) - `(,type - (and (typep obj1 ',type) - (,fn obj1 obj2))))) - stuff)))) - (foo - (single-float eql) - (double-float eql) - (bignum - (lambda (x y) - (zerop (bignum-compare x y)))) - (ratio - (lambda (x y) - (and (eql (numerator x) (numerator y)) - (eql (denominator x) (denominator y))))) - (complex - (lambda (x y) - (and (eql (realpart x) (realpart y)) - (eql (imagpart x) (imagpart y)))))))))) - - -;;;; Logicals: - -(defun logior (&rest integers) - "Returns the bit-wise or of its arguments. Args must be integers." - (declare (list integers)) - (if integers - (do ((result (pop integers) (logior result (pop integers)))) - ((null integers) result)) - 0)) - -(defun logxor (&rest integers) - "Returns the bit-wise exclusive or of its arguments. Args must be integers." - (declare (list integers)) - (if integers - (do ((result (pop integers) (logxor result (pop integers)))) - ((null integers) result)) - 0)) - -(defun logand (&rest integers) - "Returns the bit-wise and of its arguments. Args must be integers." - (declare (list integers)) - (if integers - (do ((result (pop integers) (logand result (pop integers)))) - ((null integers) result)) - -1)) - -(defun logeqv (&rest integers) - "Returns the bit-wise equivalence of its arguments. Args must be integers." - (declare (list integers)) - (if integers - (do ((result (pop integers) (logeqv result (pop integers)))) - ((null integers) result)) - -1)) - -(defun lognand (integer1 integer2) - "Returns the complement of the logical AND of integer1 and integer2." - (lognand integer1 integer2)) - -(defun lognor (integer1 integer2) - "Returns the complement of the logical OR of integer1 and integer2." - (lognor integer1 integer2)) - -(defun logandc1 (integer1 integer2) - "Returns the logical AND of (LOGNOT integer1) and integer2." - (logandc1 integer1 integer2)) - -(defun logandc2 (integer1 integer2) - "Returns the logical AND of integer1 and (LOGNOT integer2)." - (logandc2 integer1 integer2)) - -(defun logorc1 (integer1 integer2) - "Returns the logical OR of (LOGNOT integer1) and integer2." - (logorc1 integer1 integer2)) - -(defun logorc2 (integer1 integer2) - "Returns the logical OR of integer1 and (LOGNOT integer2)." - (logorc2 integer1 integer2)) - -(defun lognot (number) - "Returns the bit-wise logical not of integer." - (etypecase number - (fixnum (lognot (truly-the fixnum number))) - (bignum (bignum-logical-not number)))) - - -(macrolet ((frob (name op big-op) - `(defun ,name (x y) - (number-dispatch ((x integer) (y integer)) - (bignum-cross-fixnum ,op ,big-op))))) - (frob two-arg-and logand bignum-logical-and) - (frob two-arg-ior logior bignum-logical-ior) - (frob two-arg-xor logxor bignum-logical-xor)) - - -(defun logcount (integer) - "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits - if INTEGER is negative." - (etypecase integer - (fixnum - (logcount (truly-the (integer 0 #.(max most-positive-fixnum - (lognot most-negative-fixnum))) - (if (minusp (truly-the fixnum integer)) - (lognot (truly-the fixnum integer)) - integer)))) - (bignum - (bignum-logcount integer)))) - -(defun logtest (integer1 integer2) - "Predicate which returns T if logand of integer1 and integer2 is not zero." - (logtest integer1 integer2)) - -(defun logbitp (index integer) - "Predicate returns T if bit index of integer is a 1." - (logbitp index integer)) - -(defun ash (integer count) - "Shifts integer left by count places preserving sign. - count shifts right." - (declare (integer integer count)) - (etypecase integer - (fixnum - (cond ((zerop integer) - 0) - ((fixnump count) - (let ((length (integer-length (truly-the fixnum integer))) - (count (truly-the fixnum count))) - (declare (fixnum length count)) - (cond ((and (plusp count) - (> (+ length count) - (integer-length most-positive-fixnum))) - (bignum-ashift-left (make-small-bignum integer) count)) - (t - (truly-the fixnum - (ash (truly-the fixnum integer) count)))))) - ((minusp count) - (if (minusp integer) -1 0)) - (t - (bignum-ashift-left (make-small-bignum integer) count)))) - (bignum - (if (plusp count) - (bignum-ashift-left integer count) - (bignum-ashift-right integer (- count)))))) - -(defun integer-length (integer) - "Returns the number of significant bits in the absolute value of integer." - (etypecase integer - (fixnum - (integer-length (truly-the fixnum integer))) - (bignum - (bignum-integer-length integer)))) - - -;;;; Byte operations: - -(defun byte (size position) - "Returns a byte specifier which may be used by other byte functions." - (byte size position)) - -(defun byte-size (bytespec) - "Returns the size part of the byte specifier bytespec." - (byte-size bytespec)) - -(defun byte-position (bytespec) - "Returns the position part of the byte specifier bytespec." - (byte-position bytespec)) - -(defun ldb (bytespec integer) - "Extract the specified byte from integer, and right justify result." - (ldb bytespec integer)) - -(defun ldb-test (bytespec integer) - "Returns T if any of the specified bits in integer are 1's." - (ldb-test bytespec integer)) - -(defun mask-field (bytespec integer) - "Extract the specified byte from integer, but do not right justify result." - (mask-field bytespec integer)) - -(defun dpb (newbyte bytespec integer) - "Returns new integer with newbyte in specified position, newbyte is right justified." - (dpb newbyte bytespec integer)) - -(defun deposit-field (newbyte bytespec integer) - "Returns new integer with newbyte in specified position, newbyte is not right justified." - (deposit-field newbyte bytespec integer)) - - -(defun %ldb (size posn integer) - (logand (ash integer (- posn)) - (1- (ash 1 size)))) - -(defun %mask-field (size posn integer) - (logand integer (ash (1- (ash 1 size)) posn))) - -(defun %dpb (newbyte size posn integer) - (let ((mask (1- (ash 1 size)))) - (logior (logand integer (lognot (ash mask posn))) - (ash (logand newbyte mask) posn)))) - -(defun %deposit-field (newbyte size posn integer) - (let ((mask (ash (ldb (byte size 0) -1) posn))) - (logior (logand newbyte mask) - (logand integer (lognot mask))))) - - -;;;; Boole: - -;;; The boole function dispaches to any logic operation depending on -;;; the value of a variable. Presently, legal selector values are [0..15]. -;;; boole is open coded for calls with a constant selector. or with calls -;;; using any of the constants declared below. - -(defconstant boole-clr 0 - "Boole function op, makes BOOLE return 0.") - -(defconstant boole-set 1 - "Boole function op, makes BOOLE return -1.") - -(defconstant boole-1 2 - "Boole function op, makes BOOLE return integer1.") - -(defconstant boole-2 3 - "Boole function op, makes BOOLE return integer2.") - -(defconstant boole-c1 4 - "Boole function op, makes BOOLE return complement of integer1.") - -(defconstant boole-c2 5 - "Boole function op, makes BOOLE return complement of integer2.") - -(defconstant boole-and 6 - "Boole function op, makes BOOLE return logand of integer1 and integer2.") - -(defconstant boole-ior 7 - "Boole function op, makes BOOLE return logior of integer1 and integer2.") - -(defconstant boole-xor 8 - "Boole function op, makes BOOLE return logxor of integer1 and integer2.") - -(defconstant boole-eqv 9 - "Boole function op, makes BOOLE return logeqv of integer1 and integer2.") - -(defconstant boole-nand 10 - "Boole function op, makes BOOLE return log nand of integer1 and integer2.") - -(defconstant boole-nor 11 - "Boole function op, makes BOOLE return lognor of integer1 and integer2.") - -(defconstant boole-andc1 12 - "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.") - -(defconstant boole-andc2 13 - "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.") - -(defconstant boole-orc1 14 - "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.") - -(defconstant boole-orc2 15 - "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.") - - -(defun boole (op integer1 integer2) - "Bit-wise boolean function on two integers. Function chosen by OP: - 0 BOOLE-CLR - 1 BOOLE-SET - 2 BOOLE-1 - 3 BOOLE-2 - 4 BOOLE-C1 - 5 BOOLE-C2 - 6 BOOLE-AND - 7 BOOLE-IOR - 8 BOOLE-XOR - 9 BOOLE-EQV - 10 BOOLE-NAND - 11 BOOLE-NOR - 12 BOOLE-ANDC1 - 13 BOOLE-ANDC2 - 14 BOOLE-ORC1 - 15 BOOLE-ORC2" - (case op - (0 (boole 0 integer1 integer2)) - (1 (boole 1 integer1 integer2)) - (2 (boole 2 integer1 integer2)) - (3 (boole 3 integer1 integer2)) - (4 (boole 4 integer1 integer2)) - (5 (boole 5 integer1 integer2)) - (6 (boole 6 integer1 integer2)) - (7 (boole 7 integer1 integer2)) - (8 (boole 8 integer1 integer2)) - (9 (boole 9 integer1 integer2)) - (10 (boole 10 integer1 integer2)) - (11 (boole 11 integer1 integer2)) - (12 (boole 12 integer1 integer2)) - (13 (boole 13 integer1 integer2)) - (14 (boole 14 integer1 integer2)) - (15 (boole 15 integer1 integer2)) - (t (error "~S is not of type (mod 16)." op)))) - - -;;;; GCD, LCM: - -(defun gcd (&rest numbers) - "Returns the greatest common divisor of the arguments, which must be - integers. Gcd with no arguments is defined to be 0." - (cond ((null numbers) 0) - ((null (cdr numbers)) (abs (the integer (car numbers)))) - (t - (do ((gcd (the integer (car numbers)) - (gcd gcd (the integer (car rest)))) - (rest (cdr numbers) (cdr rest))) - ((null rest) gcd) - (declare (integer gcd) - (list rest)))))) - -(defun lcm (&rest numbers) - "Returns the least common multiple of one or more integers. LCM of no - arguments is defined to be 1." - (cond ((null numbers) 1) - ((null (cdr numbers)) (abs (the integer (car numbers)))) - (t - (do ((lcm (the integer (car numbers)) - (lcm lcm (the integer (car rest)))) - (rest (cdr numbers) (cdr rest))) - ((null rest) lcm) - (declare (integer lcm) (list rest)))))) - - -(defun two-arg-lcm (n m) - (declare (integer n m)) - (* (truncate (max n m) (gcd n m)) (min n m))) - - -;;; TWO-ARG-GCD -- Internal -;;; -;;; Do the GCD of two integer arguments. With fixnum arguments, we use the -;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly -;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case -;;; of 0 before the dispatch so that the bignum code doesn't have to worry -;;; about "small bignum" zeros. -;;; -(defun two-arg-gcd (u v) - (cond ((eql u 0) v) - ((eql v 0) u) - (t - (number-dispatch ((u integer) (v integer)) - ((fixnum fixnum) - (do ((k 0 (1+ k)) - (u (abs u) (ash u -1)) - (v (abs v) (ash v -1))) - ((oddp (logior u v)) - (do ((temp (if (oddp u) (- v) (ash u -1)) - (ash temp -1))) - (nil) - (declare (fixnum temp)) - (when (oddp temp) - (if (plusp temp) - (setq u temp) - (setq v (- temp))) - (setq temp (- u v)) - (when (zerop temp) - (return (the fixnum (ash u k))))))) - (declare (fixnum k u v)))) - ((bignum bignum) - (bignum-gcd u v)) - ((bignum fixnum) - (bignum-gcd u (make-small-bignum v))) - ((fixnum bignum) - (bignum-gcd (make-small-bignum u) v)))))) - - -;;; Primep -- Public -;;; -(defun primep (x) - "Returns T iff X is a positive prime integer." - (declare (integer x)) - (if (<= x 5) - (and (>= x 2) (/= x 4)) - (and (not (evenp x)) - (not (zerop (rem x 3))) - (do ((q 6) - (r 1) - (inc 2 (logxor inc 6)) ;; 2,4,2,4... - (d 5 (+ d inc))) - ((or (= r 0) (> d q)) (/= r 0)) - (declare (fixnum inc)) - (multiple-value-setq (q r) (truncate x d)))))) - - -;;;; Random number predicates: - -(macrolet ((frob (name doc) - `(defun ,name (number) ,doc (,name number)))) - (frob zerop "Returns T if number = 0, NIL otherwise.") - (frob plusp "Returns T if number > 0, NIL otherwise.") - (frob minusp "Returns T if number < 0, NIL otherwise.") - (frob oddp "Returns T if number is odd, NIL otherwise.") - (frob evenp "Returns T if number is even, NIL otherwise.")) diff --git a/code/old-loop.lisp b/code/old-loop.lisp deleted file mode 100644 index 620ed46f6b5e07ce26bc8eb2285eaa9655be87cf..0000000000000000000000000000000000000000 --- a/code/old-loop.lisp +++ /dev/null @@ -1,825 +0,0 @@ -;;; -*- Package: LOOP -*- -;;; -;;; ********************************************************************** -;;; 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/code/old-loop.lisp,v 1.8 1991/05/24 19:37:33 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/old-loop.lisp,v 1.8 1991/05/24 19:37:33 wlott Exp $ -;;; -;;; Loop facility, written by William Lott. -;;; -(in-package "LOOP") - -(in-package "LISP") -(export '(loop loop-finish)) - -(in-package "LOOP") - - -;;;; Specials used during the parse. - -;;; These specials hold the different parts of the result as we are generating -;;; them. -;;; -(defvar *loop-name*) -(defvar *outside-bindings*) -(defvar *prologue*) -(defvar *inside-bindings*) -(defvar *body-forms*) -(defvar *iteration-forms*) -(defvar *epilogue*) -(defvar *result-var*) -(defvar *return-value*) -(defvar *default-return-value*) -(defvar *accumulation-variables*) - -;;; This special holds the remaining stuff we need to parse. -;;; -(defvar *remaining-stuff*) - -;;; This special holds a value that is EQ only to itself. -;;; -(defvar *magic-cookie* (list '<magic-cookie>)) - - -;;;; Utility functions/macros used by the parser. - -(proclaim '(inline maybe-car maybe-cdr)) - -(defun maybe-car (thing) - (if (consp thing) (car thing) thing)) - -(defun maybe-cdr (thing) - (if (consp thing) (cdr thing) thing)) - - -(defmacro loop-keyword-p (thing keyword &rest more-keywords) - `(let ((thing ,thing)) - (and (symbolp thing) - (let ((name (symbol-name thing))) - (or ,@(mapcar #'(lambda (keyword) - `(string= name ,keyword)) - (cons keyword more-keywords))))))) - -(defun preposition-p (prep) - (when (loop-keyword-p (car *remaining-stuff*) prep) - (pop *remaining-stuff*) - t)) - - -(defun splice-in-subform (form subform) - (if (eq form *magic-cookie*) - subform - (labels ((sub-splice-in-subform (form path) - (cond ((atom form) - nil) - ((member form path) - nil) - ((eq (car form) *magic-cookie*) - (setf (car form) subform) - t) - (t - (let ((new-path (cons form path))) - (or (sub-splice-in-subform (car form) new-path) - (sub-splice-in-subform (cdr form) new-path))))))) - (if (sub-splice-in-subform form nil) - form - (error "Couldn't find the magic cookie in:~% ~S~%Loop is broken." - form))))) - -(defmacro queue-var (where name type &key - (initer nil initer-p) (stepper nil stepper-p)) - `(push (list ,name ,type ,initer-p ,initer ,stepper-p ,stepper) - ,where)) - -(defvar *default-values* '(nil 0 0.0) - "The different possible default values. When we need a default value, we - use the first value in this list that is typep the desired type.") - -(defun pick-default-value (var type) - (if (consp var) - (cons (pick-default-value (car var) (maybe-car type)) - (pick-default-value (cdr var) (maybe-cdr type))) - (dolist (default *default-values* - (error "Cannot default variables of type ~S ~ - (for variable ~S)." - type var)) - (when (typep default type) - (return default))))) - -(defun only-simple-types (type-spec) - (if (atom type-spec) - (member type-spec '(fixnum float t nil)) - (and (only-simple-types (car type-spec)) - (only-simple-types (cdr type-spec))))) - - -(defun build-let-expression (vars) - (if (null vars) - (values *magic-cookie* *magic-cookie*) - (let ((inside nil) - (outside nil) - (steppers nil) - (sub-lets nil)) - (dolist (var vars) - (labels - ((process (name type initial-p initial stepper-p stepper) - (cond ((atom name) - (cond ((not stepper-p) - (push (list type name initial) outside)) - ((not initial-p) - (push (list type name stepper) inside)) - (t - (push (list type name initial) outside) - (setf steppers - (nconc steppers (list name stepper)))))) - ((and (car name) (cdr name)) - (let ((temp (gensym (format nil "TEMP-FOR-~A-" name)))) - (process temp 'list initial-p initial - stepper-p stepper) - (push (if stepper-p - (list (car name) - (maybe-car type) - nil nil - t `(car ,temp)) - (list (car name) - (maybe-car type) - t `(car ,temp) - nil nil)) - sub-lets) - (push (if stepper-p - (list (cdr name) - (maybe-cdr type) - nil nil - t `(cdr ,temp)) - (list (car name) - (maybe-cdr type) - t `(cdr ,temp) - nil nil)) - sub-lets))) - ((car name) - (process (car name) - (maybe-car type) - initial-p `(car ,initial) - stepper-p `(car ,stepper))) - ((cdr name) - (process (cdr name) - (maybe-cdr type) - initial-p `(cdr ,initial) - stepper-p `(cdr ,stepper)))))) - (process (first var) (second var) (third var) - (fourth var) (fifth var) (sixth var)))) - (when steppers - (push (cons 'psetq steppers) - *iteration-forms*)) - (multiple-value-bind - (sub-outside sub-inside) - (build-let-expression sub-lets) - (values (build-bindings outside sub-outside) - (build-bindings inside sub-inside)))))) - -(defun build-bindings (vars guts) - (if (null vars) - guts - `(let ,(mapcar #'cdr vars) - (declare ,@(mapcar #'build-declare vars)) - ,guts))) - -(defun build-declare (var) - `(type ,(car var) ,(cadr var))) - - - -;;;; LOOP itself. - -(defmacro loop (&rest stuff) - "General iteration facility. See the manual for details, 'cause it's - very confusing." - (if (some #'atom stuff) - (parse-loop stuff) - (let ((repeat (gensym "REPEAT-")) - (out-of-here (gensym "OUT-OF-HERE-"))) - `(block nil - (tagbody - ,repeat - (macrolet ((loop-finish () `(go ,out-of-here))) - ,@stuff) - (go ,repeat) - ,out-of-here))))) - - - -;;;; The parser. - -;;; Top level parser. Bind the specials, and call the other parsers. -;;; -(defun parse-loop (stuff) - (let* ((*prologue* nil) - (*outside-bindings* *magic-cookie*) - (*inside-bindings* *magic-cookie*) - (*body-forms* nil) - (*iteration-forms* nil) - (*epilogue* nil) - (*result-var* nil) - (*return-value* nil) - (*default-return-value* nil) - (*accumulation-variables* nil) - (*remaining-stuff* stuff) - (name (parse-named))) - (loop - (when (null *remaining-stuff*) - (return)) - (let ((clause (pop *remaining-stuff*))) - (cond ((not (symbolp clause)) - (error "Invalid clause, ~S, must be a symbol." clause)) - ((loop-keyword-p clause "INITIALLY") - (setf *prologue* (nconc *prologue* (parse-expr-list)))) - ((loop-keyword-p clause "FINALLY") - (parse-finally)) - ((loop-keyword-p clause "WITH") - (parse-with)) - ((loop-keyword-p clause "FOR" "AS") - (parse-for-as)) - ((loop-keyword-p clause "REPEAT") - (parse-repeat)) - (t - (push clause *remaining-stuff*) - (return))))) - (loop - (when (null *remaining-stuff*) - (return)) - (let ((clause (pop *remaining-stuff*))) - (cond ((not (symbolp clause)) - (error "Invalid clause, ~S, must be a symbol." clause)) - ((loop-keyword-p clause "INITIALLY") - (setf *prologue* (nconc *prologue* (parse-expr-list)))) - ((loop-keyword-p clause "FINALLY") - (parse-finally)) - ((loop-keyword-p clause "WHILE") - (setf *body-forms* - (nconc *body-forms* - `((unless ,(pop *remaining-stuff*) - (loop-finish)))))) - ((loop-keyword-p clause "UNTIL") - (setf *body-forms* - (nconc *body-forms* - `((when ,(pop *remaining-stuff*) (loop-finish)))))) - ((loop-keyword-p clause "ALWAYS") - (setf *body-forms* - (nconc *body-forms* - `((unless ,(pop *remaining-stuff*) - (return-from ,name nil))))) - (setf *default-return-value* t)) - ((loop-keyword-p clause "NEVER") - (setf *body-forms* - (nconc *body-forms* - `((when ,(pop *remaining-stuff*) - (return-from ,name nil))))) - (setf *default-return-value* t)) - ((loop-keyword-p clause "THEREIS") - (setf *body-forms* - (nconc *body-forms* - (let ((temp (gensym "THEREIS-"))) - `((let ((,temp ,(pop *remaining-stuff*))) - (when ,temp - (return-from ,name ,temp)))))))) - (t - (push clause *remaining-stuff*) - (or (maybe-parse-unconditional) - (maybe-parse-conditional) - (maybe-parse-accumulation) - (error "Unknown clause, ~S" clause)))))) - (let ((again-tag (gensym "AGAIN-")) - (end-tag (gensym "THIS-IS-THE-END-"))) - `(block ,name - ,(splice-in-subform - *outside-bindings* - `(macrolet ((loop-finish () '(go ,end-tag))) - (tagbody - ,@*prologue* - ,again-tag - ,(splice-in-subform - *inside-bindings* - `(progn - ,@*body-forms* - ,@(nreverse *iteration-forms*))) - (go ,again-tag) - ,end-tag - ,@*epilogue* - (return-from ,name - ,(or *return-value* - *default-return-value* - *result-var*))))))))) - -(defun parse-named () - (when (loop-keyword-p (car *remaining-stuff*) "NAMED") - (pop *remaining-stuff*) - (if (symbolp (car *remaining-stuff*)) - (pop *remaining-stuff*) - (error "Loop name ~S is not a symbol." (car *remaining-stuff*))))) - - -(defun parse-expr-list () - (let ((results nil)) - (loop - (when (atom (car *remaining-stuff*)) - (return (nreverse results))) - (push (pop *remaining-stuff*) results)))) - -(defun parse-finally () - (let ((sub-clause (pop *remaining-stuff*))) - (if (loop-keyword-p sub-clause "RETURN") - (cond ((not (null *return-value*)) - (error "Cannot specify two FINALLY RETURN clauses.")) - ((null *remaining-stuff*) - (error "FINALLY RETURN must be followed with an expression.")) - (t - (setf *return-value* (pop *remaining-stuff*)))) - (progn - (unless (loop-keyword-p sub-clause "DO" "DOING") - (push sub-clause *remaining-stuff*)) - (setf *epilogue* (nconc *epilogue* (parse-expr-list))))))) - -(defun parse-with () - (let ((vars nil)) - (loop - (multiple-value-bind (var type) (parse-var-and-type-spec) - (let ((initial - (if (loop-keyword-p (car *remaining-stuff*) "=") - (progn - (pop *remaining-stuff*) - (pop *remaining-stuff*)) - (list 'quote - (pick-default-value var type))))) - (queue-var vars var type :initer initial))) - (if (loop-keyword-p (car *remaining-stuff*) "AND") - (pop *remaining-stuff*) - (return))) - (multiple-value-bind - (outside inside) - (build-let-expression vars) - (setf *outside-bindings* - (splice-in-subform *outside-bindings* outside)) - (setf *inside-bindings* - (splice-in-subform *inside-bindings* inside))))) - -(defun parse-var-and-type-spec () - (values (pop *remaining-stuff*) - (parse-type-spec t))) - -(defun parse-type-spec (default) - (cond ((preposition-p "OF-TYPE") - (pop *remaining-stuff*)) - ((and *remaining-stuff* - (only-simple-types (car *remaining-stuff*))) - (pop *remaining-stuff*)) - (t - default))) - - - -;;;; FOR/AS stuff. - -;;; These specials hold the vars that need to be bound for this FOR/AS clause -;;; and all of the FOR/AS clauses connected with AND. All the *for-as-vars* -;;; are bound in parallel followed by the *for-as-sub-vars*. -;;; -(defvar *for-as-vars*) -(defvar *for-as-sub-vars*) - -;;; These specials hold any extra termination tests. *for-as-term-tests* are -;;; processed after the *for-as-vars* are bound, but before the -;;; *for-as-sub-vars*. *for-as-sub-term-tests* are processed after the -;;; *for-as-sub-vars*. - -(defvar *for-as-term-tests*) -(defvar *for-as-sub-term-tests*) - - -(defun parse-for-as () - (let ((*for-as-vars* nil) - (*for-as-term-tests* nil) - (*for-as-sub-vars* nil) - (*for-as-sub-term-tests* nil)) - (loop - (multiple-value-bind (name type) (parse-var-and-type-spec) - (let ((sub-clause (pop *remaining-stuff*))) - (cond ((loop-keyword-p sub-clause "FROM" "DOWNFROM" "UPFROM" - "TO" "DOWNTO" "UPTO" "BELOW" "ABOVE") - (parse-arithmetic-for-as sub-clause name type)) - ((loop-keyword-p sub-clause "IN") - (parse-in-for-as name type)) - ((loop-keyword-p sub-clause "ON") - (parse-on-for-as name type)) - ((loop-keyword-p sub-clause "=") - (parse-equals-for-as name type)) - ((loop-keyword-p sub-clause "ACROSS") - (parse-across-for-as name type)) - ((loop-keyword-p sub-clause "BEING") - (parse-being-for-as name type)) - (t - (error "Invalid FOR/AS subclause: ~S" sub-clause))))) - (if (loop-keyword-p (car *remaining-stuff*) "AND") - (pop *remaining-stuff*) - (return))) - (multiple-value-bind - (outside inside) - (build-let-expression *for-as-vars*) - (multiple-value-bind - (sub-outside sub-inside) - (build-let-expression *for-as-sub-vars*) - (setf *outside-bindings* - (splice-in-subform *outside-bindings* - (splice-in-subform outside sub-outside))) - (let ((inside-body - (if *for-as-term-tests* - `(if (or ,@(nreverse *for-as-term-tests*)) - (loop-finish) - ,*magic-cookie*) - *magic-cookie*)) - (sub-inside-body - (if *for-as-sub-term-tests* - `(if (or ,@(nreverse *for-as-sub-term-tests*)) - (loop-finish) - ,*magic-cookie*) - *magic-cookie*))) - (setf *inside-bindings* - (splice-in-subform - *inside-bindings* - (splice-in-subform - inside - (splice-in-subform - inside-body - (splice-in-subform - sub-inside - sub-inside-body)))))))))) - -(defun parse-arithmetic-for-as (sub-clause name type) - (unless (atom name) - (error "Cannot destructure arithmetic FOR/AS variables: ~S" name)) - (let (start stop (inc 1) dir exclusive-p) - (cond ((loop-keyword-p sub-clause "FROM") - (setf start (pop *remaining-stuff*))) - ((loop-keyword-p sub-clause "DOWNFROM") - (setf start (pop *remaining-stuff*)) - (setf dir :down)) - ((loop-keyword-p sub-clause "UPFROM") - (setf start (pop *remaining-stuff*)) - (setf dir :up)) - (t - (push sub-clause *remaining-stuff*))) - (cond ((preposition-p "TO") - (setf stop (pop *remaining-stuff*))) - ((preposition-p "DOWNTO") - (setf stop (pop *remaining-stuff*)) - (if (eq dir :up) - (error "Can't mix UPFROM and DOWNTO in ~S." name) - (setf dir :down))) - ((preposition-p "UPTO") - (setf stop (pop *remaining-stuff*)) - (if (eq dir :down) - (error "Can't mix DOWNFROM and UPTO in ~S." name) - (setf dir :up))) - ((preposition-p "ABOVE") - (setf stop (pop *remaining-stuff*)) - (setf exclusive-p t) - (if (eq dir :up) - (error "Can't mix UPFROM and ABOVE in ~S." name) - (setf dir :down))) - ((preposition-p "BELOW") - (setf stop (pop *remaining-stuff*)) - (setf exclusive-p t) - (if (eq dir :down) - (error "Can't mix DOWNFROM and BELOW in ~S." name) - (setf dir :up)))) - (when (preposition-p "BY") - (setf inc (pop *remaining-stuff*))) - (when (and (eq dir :down) (null start)) - (error "No default starting value for decremental stepping.")) - (let ((temp (gensym "TEMP-AMOUNT-"))) - (queue-var *for-as-sub-vars* temp type :initer inc) - (queue-var *for-as-sub-vars* name type - :initer (or start 0) - :stepper `(,(if (eq dir :down) '- '+) ,name ,temp)) - (when stop - (let ((stop-var (gensym "STOP-VAR-"))) - (queue-var *for-as-sub-vars* stop-var type :initer stop) - (push (list (if (eq dir :down) - (if exclusive-p '<= '<) - (if exclusive-p '>= '>)) - name stop-var) - *for-as-sub-term-tests*)))))) - -(defun parse-in-for-as (name type) - (let* ((temp (gensym "LIST-")) - (initer (pop *remaining-stuff*)) - (stepper (if (preposition-p "BY") - `(funcall ,(pop *remaining-stuff*) ,temp) - `(cdr ,temp)))) - (queue-var *for-as-vars* temp 'list :initer initer :stepper stepper) - (queue-var *for-as-sub-vars* name type :stepper `(car ,temp)) - (push `(null ,temp) *for-as-sub-term-tests*))) - -(defun parse-on-for-as (name type) - (let* ((temp (if (atom name) name (gensym "LIST-"))) - (initer (pop *remaining-stuff*)) - (stepper (if (preposition-p "BY") - `(funcall ,(pop *remaining-stuff*) ,temp) - `(cdr ,temp)))) - (cond ((atom name) - (queue-var *for-as-sub-vars* name type - :initer initer :stepper stepper) - (push `(endp ,name) *for-as-sub-term-tests*)) - (t - (queue-var *for-as-vars* temp type - :initer initer :stepper stepper) - (queue-var *for-as-sub-vars* name type :stepper temp) - (push `(endp ,temp) *for-as-term-tests*))))) - -(defun parse-equals-for-as (name type) - (let ((initer (pop *remaining-stuff*))) - (if (preposition-p "THEN") - (queue-var *for-as-sub-vars* name type - :initer initer :stepper (pop *remaining-stuff*)) - (queue-var *for-as-vars* name type :stepper initer)))) - -(defun parse-across-for-as (name type) - (let* ((temp (gensym "VECTOR-")) - (length (gensym "LENGTH-")) - (index (gensym "INDEX-"))) - (queue-var *for-as-vars* temp `(vector ,type) - :initer (pop *remaining-stuff*)) - (queue-var *for-as-sub-vars* length 'fixnum - :initer `(length ,temp)) - (queue-var *for-as-vars* index 'fixnum :initer 0 :stepper `(1+ ,index)) - (queue-var *for-as-sub-vars* name type :stepper `(aref ,temp ,index)) - (push `(>= ,index ,length) *for-as-term-tests*))) - -(defun parse-being-for-as (name type) - (let ((clause (pop *remaining-stuff*))) - (unless (loop-keyword-p clause "EACH" "THE") - (error "BEING must be followed by either EACH or THE, not ~S" - clause))) - (let ((clause (pop *remaining-stuff*))) - (cond ((loop-keyword-p clause "HASH-KEY" "HASH-KEYS" - "HASH-VALUE" "HASH-VALUES") - (let ((prep (pop *remaining-stuff*))) - (unless (loop-keyword-p prep "IN" "OF") - (error "~A must be followed by either IN or OF, not ~S" - (symbol-name clause) prep))) - (let ((table (pop *remaining-stuff*)) - (iterator (gensym (format nil "~A-ITERATOR-" name))) - (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name))) - (key-temp (gensym (format nil "~A-KEY-TEMP-" name))) - (value-temp (gensym (format nil "~A-VALUE-TEMP-" name)))) - (setf *outside-bindings* - (splice-in-subform - *outside-bindings* - `(with-hash-table-iterator (,iterator ,table) - ,*magic-cookie*))) - (multiple-value-bind - (using using-type) - (when (preposition-p "USING") - ;; ### This is wrong. - (parse-var-and-type-spec)) - (multiple-value-bind - (key-var key-type value-var value-type) - (if (loop-keyword-p clause "HASH-KEY" "HASH-KEYS") - (values name type using using-type) - (values using using-type name type)) - (setf *inside-bindings* - (splice-in-subform - *inside-bindings* - `(multiple-value-bind - (,exists-temp ,key-temp ,value-temp) - (,iterator) - ,@(unless (and key-var value-var) - `((declare (ignore ,@(if (null key-var) - (list key-temp)) - ,@(if (null value-var) - (list value-temp)))))) - ,*magic-cookie*))) - (push `(not ,exists-temp) *for-as-term-tests*) - (when key-var - (queue-var *for-as-sub-vars* key-var key-type - :stepper key-temp)) - (when value-var - (queue-var *for-as-sub-vars* value-var value-type - :stepper value-temp)))))) - ((loop-keyword-p clause "SYMBOL" "PRESENT-SYMBOL" "EXTERNAL-SYMBOL" - "SYMBOLS" "PRESENT-SYMBOLS" "EXTERNAL-SYMBOLS") - (let ((package - (if (or (preposition-p "IN") - (preposition-p "OF")) - (pop *remaining-stuff*) - '*package*)) - (iterator (gensym (format nil "~A-ITERATOR-" name))) - (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name))) - (symbol-temp (gensym (format nil "~A-SYMBOL-TEMP-" name)))) - (setf *outside-bindings* - (splice-in-subform - *outside-bindings* - `(with-package-iterator - (,iterator - ,package - ,@(cond ((loop-keyword-p clause "SYMBOL" "SYMBOLS") - '(:internal :external :inherited)) - ((loop-keyword-p clause "PRESENT-SYMBOL" - "PRESENT-SYMBOLS") - '(:internal)) - ((loop-keyword-p clause "EXTERNAL-SYMBOL" - "EXTERNAL-SYMBOLS") - '(:external)) - (t - (error "Don't know how to deal with ~A? ~ - Bug in LOOP?" clause)))) - ,*magic-cookie*))) - (setf *inside-bindings* - (splice-in-subform - *inside-bindings* - `(multiple-value-bind - (,exists-temp ,symbol-temp) - (,iterator) - ,*magic-cookie*))) - (push `(not ,exists-temp) *for-as-term-tests*) - (queue-var *for-as-sub-vars* name type :stepper symbol-temp))) - (t - (error - "Unknown sub-clause, ~A, for BEING. Must be one of:~% ~ - HASH-KEY HASH-KEYS HASH-VALUE HASH-VALUES SYMBOL SYMBOLS~% ~ - PRESENT-SYMBOL PRESENT-SYMBOLS EXTERNAL-SYMBOL EXTERNAL-SYMBOLS" - (symbol-name clause)))))) - - - -;;;; - -(defun parse-repeat () - (let ((temp (gensym "REPEAT-"))) - (setf *outside-bindings* - (splice-in-subform *outside-bindings* - `(let ((,temp ,(pop *remaining-stuff*))) - ,*magic-cookie*))) - (setf *inside-bindings* - (splice-in-subform *inside-bindings* - `(if (minusp (decf ,temp)) - (loop-finish) - ,*magic-cookie*))))) - - -(defun maybe-parse-unconditional () - (when (loop-keyword-p (car *remaining-stuff*) "DO" "DOING") - (pop *remaining-stuff*) - (setf *body-forms* (nconc *body-forms* (parse-expr-list))) - t)) - -(defun maybe-parse-conditional () - (let ((clause (pop *remaining-stuff*))) - (cond ((loop-keyword-p clause "IF" "WHEN") - (parse-conditional (pop *remaining-stuff*)) - t) - ((loop-keyword-p clause "UNLESS") - (parse-conditional `(not ,(pop *remaining-stuff*))) - t) - (t - (push clause *remaining-stuff*) - nil)))) - -(defun parse-conditional (condition) - (let ((clauses (parse-and-clauses)) - (else-clauses (when (preposition-p "ELSE") - (parse-and-clauses)))) - (setf *body-forms* - (nconc *body-forms* - `((if ,condition - (progn - ,@clauses) - (progn - ,@else-clauses))))) - (preposition-p "END"))) - -(defun parse-and-clauses () - (let ((*body-forms* nil)) - (loop - (or (maybe-parse-unconditional) - (maybe-parse-conditional) - (maybe-parse-accumulation) - (error "Invalid clause for inside a conditional: ~S" - (car *remaining-stuff*))) - (unless (preposition-p "AND") - (return *body-forms*))))) - - -;;;; Assumulation stuff - -(defun maybe-parse-accumulation () - (when (loop-keyword-p (car *remaining-stuff*) - "COLLECT" "COLLECTING" - "APPEND" "APPENDING" "NCONC" "NCONCING" - "COUNT" "COUNTING" "SUM" "SUMMING" - "MAXIMIZE" "MAXIMIZING" "MINIMIZE" "MINIMIZING") - (parse-accumulation) - t)) - -(defun parse-accumulation () - (let* ((clause (pop *remaining-stuff*)) - (expr (pop *remaining-stuff*)) - (var (if (preposition-p "INTO") - (pop *remaining-stuff*) - (or *result-var* - (setf *result-var* - (gensym (concatenate 'simple-string - (string clause) - "-")))))) - (info (assoc var *accumulation-variables*)) - (type nil) - (initial nil)) - (cond ((loop-keyword-p clause "COLLECT" "COLLECTING" "APPEND" "APPENDING" - "NCONC" "NCONCING") - (setf initial nil) - (setf type 'list) - (let ((aux-var - (or (caddr info) - (let ((aux-var (gensym "LAST-"))) - (setf *outside-bindings* - (splice-in-subform *outside-bindings* - `(let ((,var nil) - (,aux-var nil)) - (declare (type list - ,var - ,aux-var)) - ,*magic-cookie*))) - (if (null info) - (push (setf info (list var 'list aux-var)) - *accumulation-variables*) - (setf (cddr info) (list aux-var))) - aux-var))) - (value - (cond ((loop-keyword-p clause "COLLECT" "COLLECTING") - `(list ,expr)) - ((loop-keyword-p clause "APPEND" "APPENDING") - `(copy-list ,expr)) - ((loop-keyword-p clause "NCONC" "NCONCING") - expr) - (t - (error "Bug in loop?"))))) - (setf *body-forms* - (nconc *body-forms* - `((cond ((null ,var) - (setf ,var ,value) - (setf ,aux-var (last ,var))) - (t - (nconc ,aux-var ,value) - (setf ,aux-var (last ,aux-var))))))))) - ((loop-keyword-p clause "COUNT" "COUNTING") - (setf type (parse-type-spec 'unsigned-byte)) - (setf initial 0) - (setf *body-forms* - (nconc *body-forms* - `((when ,expr (incf ,var)))))) - ((loop-keyword-p clause "SUM" "SUMMING") - (setf type (parse-type-spec 'number)) - (setf initial 0) - (setf *body-forms* - (nconc *body-forms* - `((incf ,var ,expr))))) - ((loop-keyword-p clause "MAXIMIZE" "MAXIMIZING") - (setf type `(or null ,(parse-type-spec 'number))) - (setf initial nil) - (setf *body-forms* - (nconc *body-forms* - (let ((temp (gensym "MAX-TEMP-"))) - `((let ((,temp ,expr)) - (when (or (null ,var) - (> ,temp ,var)) - (setf ,var ,temp)))))))) - ((loop-keyword-p clause "MINIMIZE" "MINIMIZING") - (setf type `(or null ,(parse-type-spec 'number))) - (setf initial nil) - (setf *body-forms* - (nconc *body-forms* - (let ((temp (gensym "MIN-TEMP-"))) - `((let ((,temp ,expr)) - (when (or (null ,var) - (< ,temp ,var)) - (setf ,var ,temp)))))))) - (t - (error "Invalid accumulation clause: ~S" clause))) - (cond (info - (unless (equal type (cadr info)) - (error "Attempt to use ~S for both types ~S and ~S." - var type (cadr info)))) - (t - (push (list var type) *accumulation-variables*) - (setf *outside-bindings* - (splice-in-subform *outside-bindings* - `(let ((,var ,initial)) - (declare (type ,type ,var)) - ,*magic-cookie*))))))) diff --git a/code/package.lisp b/code/package.lisp deleted file mode 100644 index 116fdb15166c13591bfb8fa56e105ac1084e6e83..0000000000000000000000000000000000000000 --- a/code/package.lisp +++ /dev/null @@ -1,1455 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/package.lisp,v 1.27 1992/11/30 16:41:45 phg Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Package stuff and stuff like that. -;;; -;;; Re-Written by Rob MacLachlan. Earlier version written by -;;; Lee Schumacher. Apropos & iteration macros courtesy of Skef Wholey. -;;; Defpackage by Dan Zigmond. With-Package-Iterator by Blaine Burks. -;;; Defpackage and do-mumble-symbols macros re-written by William Lott. -;;; -(in-package 'lisp) -(export '(package packagep *package* make-package in-package find-package - package-name package-nicknames rename-package delete-package - package-use-list package-used-by-list package-shadowing-symbols - list-all-packages intern find-symbol unintern export - unexport import shadowing-import shadow use-package - unuse-package find-all-symbols do-symbols with-package-iterator - do-external-symbols do-all-symbols apropos apropos-list defpackage)) - -(in-package "EXTENSIONS") -(export '(*keyword-package* *lisp-package* *default-package-use-list*)) - -(in-package "KERNEL") -(export '(%in-package old-in-package)) - -(in-package 'lisp) - -(defvar *default-package-use-list* '("COMMON-LISP") - "The list of packages to use by default of no :USE argument is supplied - to MAKE-PACKAGE or other package creation forms.") - - -(defstruct (package - (:constructor internal-make-package) - (:predicate packagep) - (:print-function - (lambda (s stream d) - (declare (ignore d) (stream stream)) - (multiple-value-bind (iu it) (internal-symbol-count s) - (multiple-value-bind (eu et) (external-symbol-count s) - (format stream - "#<The ~A package, ~D/~D internal, ~D/~D external>" - (package-%name s) iu it eu et))))) - (:make-load-form-fun - (lambda (package) - (values `(package-or-lose ',(package-name package)) - nil)))) - "Standard structure for the description of a package. Consists of - a list of all hash tables, the name of the package, the nicknames of - the package, the use-list for the package, the used-by- list, hash- - tables for the internal and external symbols, and a list of the - shadowing symbols." - (tables (list nil)) ; A list of all the hashtables for inherited symbols. - %name ; The string name of the package. - %nicknames ; List of nickname strings. - (%use-list ()) ; List of packages we use. - (%used-by-list ()) ; List of packages that use this package. - internal-symbols ; Hashtable of internal symbols. - external-symbols ; Hashtable of external symbols. - (%shadowing-symbols ())) ; List of shadowing symbols. - -(macrolet ((frob (ext real) - `(defun ,ext (x) (,real (package-or-lose x))))) - (frob package-name package-%name) - (frob package-nicknames package-%nicknames) - (frob package-use-list package-%use-list) - (frob package-used-by-list package-%used-by-list) - (frob package-shadowing-symbols package-%shadowing-symbols)) - -(defvar *package* () "The current package.") - -;;; An equal hashtable from package names to packages. -;;; -(defvar *package-names* (make-hash-table :test #'equal)) - - -;;; Lots of people want the keyword package and Lisp package without a lot -;;; of fuss, so we give them their own variables. -;;; -(defvar *lisp-package*) -(defvar *keyword-package*) - - -;;; This magical variable is T during initialization so Use-Package's of packages -;;; that don't yet exist quietly win. Such packages are thrown onto the list -;;; *Deferred-Use-Packages* so that this can be fixed up later. - -(defvar *in-package-init* nil) -(defvar *deferred-use-packages* nil) - -;;; Find-Package -- Public -;;; -;;; -(defun find-package (name) - "Find the package having the specified name." - (values (gethash (string name) *package-names*))) - -;;; Package-Listify -- Internal -;;; -;;; Return a list of packages given a package-or-string-or-symbol or -;;; list thereof, or die trying. -;;; -(defun package-listify (thing) - (let ((res ())) - (dolist (thing (if (listp thing) thing (list thing)) res) - (push (package-or-lose thing) res)))) - -;;; Package-Or-Lose -- Internal -;;; -;;; Take a package-or-string-or-symbol and return a package. -;;; -(defun package-or-lose (thing) - (if (packagep thing) - thing - (let ((thing (string thing))) - (cond ((gethash thing *package-names*)) - (t - (cerror "Make this package." - "~S is not the name of a package." thing) - (make-package thing)))))) - - -;;;; Package-Hashtables -;;; -;;; Packages are implemented using a special kind of hashtable. It is -;;; an open hashtable with a parallel 8-bit I-vector of hash-codes. The -;;; primary purpose of the hash for each entry is to reduce paging by -;;; allowing collisions and misses to be detected without paging in the -;;; symbol and pname for an entry. If the hash for an entry doesn't -;;; match that for the symbol that we are looking for, then we can -;;; go on without touching the symbol, pname, or even hastable vector. -;;; It turns out that, contrary to my expectations, paging is a very -;;; important consideration the design of the package representation. -;;; Using a similar scheme without the entry hash, the fasloader was -;;; spending more than half its time paging in INTERN. -;;; The hash code also indicates the status of an entry. If it zero, -;;; the the entry is unused. If it is one, then it is deleted. -;;; Double-hashing is used for collision resolution. - -(defstruct (package-hashtable - (:constructor internal-make-package-hashtable ()) - (:copier nil) - (:print-function - (lambda (table stream d) - (declare (ignore d)) - (format stream - "#<Package-Hashtable: Size = ~D, Free = ~D, Deleted = ~D>" - (package-hashtable-size table) - (package-hashtable-free table) - (package-hashtable-deleted table))))) - table ; The g-vector of symbols. - hash ; The i-vector of pname hash values. - size ; The maximum number of entries allowed. - free ; The entries that can be made before we have to rehash. - deleted) ; The number of deleted entries. - - -;;; The maximum density we allow in a package hashtable. -;;; -(defparameter package-rehash-threshold 3/4) - -;;; Entry-Hash -- Internal -;;; -;;; Compute a number from the sxhash of the pname and the length which -;;; must be between 2 and 255. -;;; -(defmacro entry-hash (length sxhash) - `(the fixnum - (+ (the fixnum - (rem (the fixnum - (logxor ,length - ,sxhash - (the fixnum (ash ,sxhash -8)) - (the fixnum (ash ,sxhash -16)) - (the fixnum (ash ,sxhash -19)))) - 254)) - 2))) - -;;; Make-Package-Hashtable -- Internal -;;; -;;; Make a package hashtable having a prime number of entries at least -;;; as great as (/ size package-rehash-threshold). If Res is supplied, -;;; then it is destructively modified to produce the result. This is -;;; useful when changing the size, since there are many pointers to -;;; the hashtable. -;;; -(defun make-package-hashtable (size &optional - (res (internal-make-package-hashtable))) - (do ((n (logior (truncate size package-rehash-threshold) 1) - (+ n 2))) - ((primep n) - (setf (package-hashtable-table res) - (make-array n)) - (setf (package-hashtable-hash res) - (make-array n :element-type '(unsigned-byte 8) - :initial-element 0)) - (let ((size (truncate (* n package-rehash-threshold)))) - (setf (package-hashtable-size res) size) - (setf (package-hashtable-free res) size)) - (setf (package-hashtable-deleted res) 0) - res) - (declare (fixnum n)))) - - -;;; Internal-Symbol-Count, External-Symbols-Count -- Internal -;;; -;;; Return internal and external symbols. Used by Genesis and stuff. -;;; -(flet ((stuff (table) - (let ((size (the fixnum - (- (the fixnum (package-hashtable-size table)) - (the fixnum - (package-hashtable-deleted table)))))) - (declare (fixnum size)) - (values (the fixnum - (- size - (the fixnum - (package-hashtable-free table)))) - size)))) - - (defun internal-symbol-count (package) - (stuff (package-internal-symbols package))) - - (defun external-symbol-count (package) - (stuff (package-external-symbols package)))) - - -;;; Add-Symbol -- Internal -;;; -;;; Add a symbol to a package hashtable. The symbol is assumed -;;; not to be present. -;;; -(defun add-symbol (table symbol) - (let* ((vec (package-hashtable-table table)) - (hash (package-hashtable-hash table)) - (len (length vec)) - (sxhash (%sxhash-simple-string (symbol-name symbol))) - (h2 (the fixnum (1+ (the fixnum (rem sxhash - (the fixnum (- len 2)))))))) - (declare (simple-vector vec) - (type (simple-array (unsigned-byte 8)) hash) - (fixnum len sxhash h2)) - (cond ((zerop (the fixnum (package-hashtable-free table))) - (make-package-hashtable (the fixnum - (* (the fixnum - (package-hashtable-size table)) - 2)) - table) - (add-symbol table symbol) - (dotimes (i len) - (declare (fixnum i)) - (when (> (the fixnum (aref hash i)) 1) - (add-symbol table (svref vec i))))) - (t - (do ((i (rem sxhash len) (rem (+ i h2) len))) - ((< (the fixnum (aref hash i)) 2) - (if (zerop (the fixnum (aref hash i))) - (decf (the fixnum (package-hashtable-free table))) - (decf (the fixnum (package-hashtable-deleted table)))) - (setf (svref vec i) symbol) - (setf (aref hash i) - (entry-hash (length (the simple-string - (symbol-name symbol))) - sxhash))) - (declare (fixnum i))))))) - -;;; With-Symbol -- Internal -;;; -;;; Find where the symbol named String is stored in Table. Index-Var -;;; is bound to the index, or NIL if it is not present. Symbol-Var -;;; is bound to the symbol. Length and Hash are the length and sxhash -;;; of String. Entry-Hash is the entry-hash of the string and length. -;;; -(defmacro with-symbol ((index-var symbol-var table string length sxhash - entry-hash) - &body forms) - (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym)) - (name (gensym)) (name-len (gensym)) (ehash (gensym))) - `(let* ((,vec (package-hashtable-table ,table)) - (,hash (package-hashtable-hash ,table)) - (,len (length ,vec)) - (,h2 (1+ (the fixnum (rem (the fixnum ,sxhash) - (the fixnum (- ,len 2))))))) - (declare (type (simple-array (unsigned-byte 8) (*)) ,hash) - (simple-vector ,vec) - (fixnum ,len ,h2)) - (prog ((,index-var (rem (the fixnum ,sxhash) ,len)) - ,symbol-var ,ehash) - (declare (type (or fixnum null) ,index-var)) - LOOP - (setq ,ehash (aref ,hash ,index-var)) - (cond ((eql ,ehash ,entry-hash) - (setq ,symbol-var (svref ,vec ,index-var)) - (let* ((,name (symbol-name ,symbol-var)) - (,name-len (length ,name))) - (declare (simple-string ,name) - (fixnum ,name-len)) - (when (and (= ,name-len ,length) - (string= ,string ,name :end1 ,length - :end2 ,name-len)) - (go DOIT)))) - ((zerop ,ehash) - (setq ,index-var nil) - (go DOIT))) - (setq ,index-var (+ ,index-var ,h2)) - (when (>= ,index-var ,len) - (setq ,index-var (- ,index-var ,len))) - (go LOOP) - DOIT - (return (progn ,@forms)))))) - -;;; Nuke-Symbol -- Internal -;;; -;;; Delete the entry for String in Table. The entry must exist. -;;; -(defun nuke-symbol (table string) - (declare (simple-string string)) - (let* ((length (length string)) - (hash (%sxhash-simple-string string)) - (ehash (entry-hash length hash))) - (declare (fixnum length hash)) - (with-symbol (index symbol table string length hash ehash) - (setf (aref (package-hashtable-hash table) index) 1) - (setf (aref (package-hashtable-table table) index) nil) - (incf (package-hashtable-deleted table))))) - -;;;; Iteration macros. - -(defmacro do-symbols ((var &optional (package '*package*) result-form) - &body body) - "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}* - Executes the FORMs at least once for each symbol accessible in the given - PACKAGE with VAR bound to the current symbol." - (let ((flet-name (gensym "DO-SYMBOLS-"))) - `(block nil - (flet ((,flet-name (,var) ,@body)) - (let* ((package (package-or-lose ,package)) - (shadows (package-%shadowing-symbols package))) - (flet ((iterate-over-hash-table (table ignore) - (let ((hash-vec (package-hashtable-hash table)) - (sym-vec (package-hashtable-table table))) - (declare (type (simple-array (unsigned-byte 8) (*)) - hash-vec) - (type simple-vector sym-vec)) - (dotimes (i (length sym-vec)) - (when (>= (aref hash-vec i) 2) - (let ((sym (aref sym-vec i))) - (unless (member sym ignore) - (,flet-name sym)))))))) - (iterate-over-hash-table (package-internal-symbols package) nil) - (iterate-over-hash-table (package-external-symbols package) nil) - (dolist (table (cdr (package-tables package))) - (iterate-over-hash-table table shadows))))) - (let ((,var nil)) - (declare (ignorable ,var)) - ,result-form)))) - -(defmacro do-external-symbols ((var &optional (package '*package*) result-form) - &body body) - "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}* - Executes the FORMs once for each external symbol in the given PACKAGE with - VAR bound to the current symbol." - (let ((flet-name (gensym "DO-SYMBOLS-"))) - `(block nil - (flet ((,flet-name (,var) - ,@body)) - (let* ((package (package-or-lose ,package)) - (table (package-external-symbols package)) - (hash-vec (package-hashtable-hash table)) - (sym-vec (package-hashtable-table table))) - (declare (type (simple-array (unsigned-byte 8) (*)) - hash-vec) - (type simple-vector sym-vec)) - (dotimes (i (length sym-vec)) - (when (>= (aref hash-vec i) 2) - (,flet-name (aref sym-vec i)))))) - (let ((,var nil)) - (declare (ignorable ,var)) - ,result-form)))) - -(defmacro do-all-symbols ((var &optional result-form) &body body) - "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}* - Executes the FORMs once for each symbol in every package with VAR bound - to the current symbol." - (let ((flet-name (gensym "DO-SYMBOLS-"))) - `(block nil - (flet ((,flet-name (,var) - ,@body)) - (dolist (package (list-all-packages)) - (flet ((iterate-over-hash-table (table) - (let ((hash-vec (package-hashtable-hash table)) - (sym-vec (package-hashtable-table table))) - (declare (type (simple-array (unsigned-byte 8) (*)) - hash-vec) - (type simple-vector sym-vec)) - (dotimes (i (length sym-vec)) - (when (>= (aref hash-vec i) 2) - (,flet-name (aref sym-vec i))))))) - (iterate-over-hash-table (package-internal-symbols package)) - (iterate-over-hash-table (package-external-symbols package))))) - (let ((,var nil)) - (declare (ignorable ,var)) - ,result-form)))) - - -;;;; WITH-PACKAGE-ITERATOR - -(defmacro with-package-iterator ((mname package-list &rest symbol-types) - &body body) - (let* ((packages (gensym)) - (these-packages (gensym)) - (ordered-types (let ((res nil)) - (dolist (kind '(:inherited :external :internal) - res) - (when (member kind symbol-types) - (push kind res))))) ; Order symbol-types. - (counter (gensym)) - (kind (gensym)) - (hash-vector (gensym)) - (vector (gensym)) - (package-use-list (gensym)) - (init-macro (gensym)) - (end-test-macro (gensym)) - (real-symbol-p (gensym)) - (BLOCK (gensym))) - `(let* ((,these-packages ,package-list) - (,packages `,(mapcar #'(lambda (package) - (if (packagep package) - package - (find-package package))) - (if (consp ,these-packages) - ,these-packages - (list ,these-packages)))) - (,counter nil) - (,kind (car ,packages)) - (,hash-vector nil) - (,vector nil) - (,package-use-list nil)) - ,(if (member :inherited ordered-types) - `(setf ,package-use-list (package-%use-list (car ,packages))) - `(declare (ignore ,package-use-list))) - (macrolet ((,init-macro (next-kind) - (let ((symbols (gensym))) - `(progn - (setf ,',kind ,next-kind) - (setf ,',counter nil) - ,(case next-kind - (:internal - `(let ((,symbols (package-internal-symbols - (car ,',packages)))) - (setf ,',vector (package-hashtable-table ,symbols)) - (setf ,',hash-vector (package-hashtable-hash ,symbols)))) - (:external - `(let ((,symbols (package-external-symbols - (car ,',packages)))) - (setf ,',vector (package-hashtable-table ,symbols)) - (setf ,',hash-vector (package-hashtable-hash ,symbols)))) - (:inherited - `(let ((,symbols (package-external-symbols - (car ,',package-use-list)))) - (setf ,',vector (package-hashtable-table ,symbols)) - (setf ,',hash-vector (package-hashtable-hash ,symbols)))))))) - (,end-test-macro (this-kind) - `,(let ((next-kind (cadr (member this-kind - ',ordered-types)))) - (if next-kind - `(,',init-macro ,next-kind) - `(if (endp (setf ,',packages (cdr ,',packages))) - (return-from ,',BLOCK) - (,',init-macro ,(car ',ordered-types))))))) - (when ,packages - ,(when (null symbol-types) - (error "Must supply at least one of :internal, :external, or ~ - :inherited.")) - ,(dolist (symbol symbol-types) - (unless (member symbol '(:internal :external :inherited)) - (error "~S is not one of :internal, :external, or :inherited." - symbol))) - (,init-macro ,(car ordered-types)) - (flet ((,real-symbol-p (number) - (> number 1))) - (macrolet ((,mname () - `(block ,',BLOCK - (loop - (case ,',kind - ,@(when (member :internal ',ordered-types) - `((:internal - (setf ,',counter - (position-if #',',real-symbol-p ,',hash-vector - :start (if ,',counter - (1+ ,',counter) - 0))) - (if ,',counter - (return-from ,',BLOCK - (values t (svref ,',vector ,',counter) - ,',kind (car ,',packages))) - (,',end-test-macro :internal))))) - ,@(when (member :external ',ordered-types) - `((:external - (setf ,',counter - (position-if #',',real-symbol-p ,',hash-vector - :start (if ,',counter - (1+ ,',counter) - 0))) - (if ,',counter - (return-from ,',BLOCK - (values t (svref ,',vector ,',counter) - ,',kind (car ,',packages))) - (,',end-test-macro :external))))) - ,@(when (member :inherited ',ordered-types) - `((:inherited - (setf ,',counter - (position-if #',',real-symbol-p ,',hash-vector - :start (if ,',counter - (1+ ,',counter) - 0))) - (cond (,',counter - (return-from - ,',BLOCK - (values t (svref ,',vector ,',counter) - ,',kind (car ,',packages)))) - (t - (setf ,',package-use-list - (cdr ,',package-use-list)) - (cond ((endp ,',package-use-list) - (setf ,',packages (cdr ,',packages)) - (when (endp ,',packages) - (return-from ,',BLOCK)) - (setf ,',package-use-list - (package-%use-list - (car ,',packages))) - (,',init-macro ,(car ',ordered-types))) - (t (,',init-macro :inherited) - (setf ,',counter nil))))))))))))) - ,@body))))))) - - -;;;; DEFPACKAGE: - -(defmacro defpackage (package &rest options) - "Defines a new package called PACKAGE. Each of OPTIONS should be one of the - following: - (:NICKNAMES {package-name}*) - (:SIZE <integer>) - (:SHADOW {symbol-name}*) - (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*) - (:USE {package-name}*) - (:IMPORT-FROM <package-name> {symbol-name}*) - (:INTERN {symbol-name}*) - (:EXPORT {symbol-name}*) - All options except :SIZE can be used multiple times." - (let ((nicknames nil) - (size nil) - (shadows nil) - (shadowing-imports nil) - (use nil) - (use-p nil) - (imports nil) - (interns nil) - (exports nil) - (incomming nil) - (outgoing nil)) - (dolist (option options) - (unless (consp option) - (error "Bogus DEFPACKAGE option: ~S" option)) - (case (car option) - (:nicknames - (let ((new (stringify-names (cdr option) "package"))) - (setf nicknames (append-unique new nicknames :nicknames)))) - (:size - (cond (size - (error "Can't specify :SIZE twice.")) - ((and (consp (cdr option)) - (typep (second option) 'unsigned-byte)) - (setf size (second option))) - (t - (error "Bogus :SIZE, must be a positive integer: ~S" - (second option))))) - (:shadow - (let ((new (stringify-names (cdr option) "symbol"))) - (setf incomming (append-unique new incomming :shadow)) - (setf shadows (append shadows new)))) - (:shadowing-import-from - (let ((package-name (stringify-name (second option) "package")) - (names (stringify-names (cddr option) "symbol"))) - (setf incomming (append-unique names incomming :shadowing-import)) - (let ((assoc (assoc package-name shadowing-imports - :test #'string=))) - (if assoc - (setf (cdr assoc) (append (cdr assoc) names)) - (setf shadowing-imports - (acons package-name names shadowing-imports)))))) - (:use - (let ((new (stringify-names (cdr option) "package"))) - (setf use (append-unique new nicknames :use)) - (setf use-p t))) - (:import-from - (let ((package-name (stringify-name (second option) "package")) - (names (stringify-names (cddr option) "symbol"))) - (setf incomming (append-unique names incomming :import-from)) - (let ((assoc (assoc package-name imports - :test #'string=))) - (if assoc - (setf (cdr assoc) (append (cdr assoc) names)) - (setf imports (acons package-name names imports)))))) - (:intern - (let ((new (stringify-names (cdr option) "symbol"))) - (setf incomming (append-unique new incomming :intern)) - (setf outgoing (append-unique new incomming :intern)) - (setf interns (append interns new)))) - (:export - (let ((new (stringify-names (cdr option) "symbol"))) - (setf outgoing (append-unique new incomming :export)) - (setf exports (append exports new)))) - (t - (error "Bogus DEFPACKAGE option: ~S" option)))) - `(eval-when (compile load eval) - (%defpackage ,(stringify-name package "package") ',nicknames ',size - ',shadows ',shadowing-imports ',(if use-p use :default) - ',imports ',interns ',exports)))) - -(defun stringify-name (name kind) - (typecase name - (simple-string name) - (string (coerce name 'simple-string)) - (symbol (symbol-name name)) - (t - (error "Bogus ~A name: ~S" kind name)))) - -(defun stringify-names (names kind) - (mapcar #'(lambda (name) - (stringify-name name kind)) - names)) - -(defun append-unique (new old list) - (dolist (name new) - (if (member name old) - (cerror "Ignore it." - "Duplicate name in the ~S list: ~A" list name) - (push name old))) - old) - -(defun %defpackage (name nicknames size shadows shadowing-imports - use imports interns exports) - (declare (type simple-base-string name) - (type list nicknames shadows shadowing-imports - imports interns exports) - (type (or list (member :default)) use)) - (let ((package (or (find-package name) - (progn - (when (eq use :default) - (setf use *default-package-use-list*)) - (make-package name - :use nil - :internal-symbols (or size 10) - :external-symbols (length exports)))))) - (unless (string= (package-name name) name) - (error "~A is a nick-name for the package ~A" - name (package-name name))) - (enter-new-nicknames package nicknames) - ;; Shadows and Shadowing-imports. - (let ((old-shadows (package-%shadowing-symbols package))) - (shadow shadows package) - (dolist (sym-name shadows) - (setf old-shadows (remove (find-symbol sym-name package) old-shadows))) - (dolist (simports-from shadowing-imports) - (let ((other-package (package-or-lose (car simports-from)))) - (dolist (sym-name (cdr simports-from)) - (let ((sym (find-or-make-symbol sym-name other-package))) - (shadowing-import sym package) - (setf old-shadows (remove sym old-shadows)))))) - (when old-shadows - (warn "~A also shadows the following symbols:~% ~S" - name old-shadows))) - ;; Use - (unless (eq use :default) - (let ((old-use-list (package-use-list package)) - (new-use-list (mapcar #'package-or-lose use))) - (use-package (set-difference new-use-list old-use-list) package) - (let ((laterize (set-difference old-use-list new-use-list))) - (when laterize - (unuse-package laterize package) - (warn "~A used to use the following packages:~% ~S" laterize))))) - ;; Import and Intern. - (dolist (sym-name interns) - (intern sym-name package)) - (dolist (imports-from imports) - (let ((other-package (package-or-lose (car imports-from)))) - (dolist (sym-name (cdr imports-from)) - (import (find-or-make-symbol sym-name other-package) package)))) - ;; Exports. - (let ((old-exports nil)) - (do-external-symbols (sym package) - (push sym old-exports)) - (dolist (sym-name exports) - (let ((sym (intern sym-name package))) - (export sym package) - (setf old-exports (delete sym old-exports :test #'eq)))) - (when old-exports - (warn "~A also exports the following symbols:~% ~S" - name old-exports))) - package)) - -(defun find-or-make-symbol (name package) - (multiple-value-bind - (symbol how) - (find-symbol name package) - (cond (how - symbol) - (t - (cerror "INTERN it." - "~A does not contain a symbol ~A" - (package-name package) - name) - (intern name package))))) - - -;;; Enter-New-Nicknames -- Internal -;;; -;;; Enter any new Nicknames for Package into *package-names*. -;;; If there is a conflict then give the user a chance to do -;;; something about it. -;;; -(defun enter-new-nicknames (package nicknames) - (check-type nicknames list) - (dolist (n nicknames) - (let* ((n (string n)) - (found (gethash n *package-names*))) - (cond ((not found) - (setf (gethash n *package-names*) package) - (push n (package-%nicknames package))) - ((eq found package)) - ((string= (package-%name found) n) - (cerror "Ignore this nickname." - "~S is a package name, so it cannot be a nickname for ~S." - n (package-%name package))) - (t - (cerror "Redefine this nickname." - "~S is already a nickname for ~S." - n (package-%name found)) - (setf (gethash n *package-names*) package) - (push n (package-%nicknames package))))))) - - -;;; Make-Package -- Public -;;; -;;; Check for package name conflicts in name and nicknames, then -;;; make the package. Do a use-package for each thing in the use list -;;; so that checking for conflicting exports among used packages is done. -;;; -(defun make-package (name &key (use *default-package-use-list*) nicknames - (internal-symbols 10) (external-symbols 10)) - "Makes a new package having the specified Name and Nicknames. The - package will inherit all external symbols from each package in - the use list. :Internal-Symbols and :External-Symbols are - estimates for the number of internal and external symbols which - will ultimately be present in the package." - (when (find-package name) - (error "A package named ~S already exists" name)) - (let* ((name (string name)) - (package (internal-make-package - :%name name - :internal-symbols (make-package-hashtable internal-symbols) - :external-symbols (make-package-hashtable external-symbols)))) - (if *in-package-init* - (push (list use package) *deferred-use-packages*) - (use-package use package)) - (enter-new-nicknames package nicknames) - (setf (gethash name *package-names*) package))) - -;;; Old-In-Package -- Sorta Public. -;;; -;;; Like Make-Package, only different. Should go away someday. -;;; -(defun old-in-package (name &rest keys &key nicknames use) - "Sets *package* to package with given name, creating the package if - it does not exist. If the package already exists then it is modified - to agree with the :Use and :Nicknames arguments. Any new nicknames - are added without removing any old ones not specified. If any package - in the :Use list is not currently used, then it is added to the use - list." - (let ((package (find-package name))) - (cond - (package - (if *in-package-init* - (push (list use package) *deferred-use-packages*) - (use-package use package)) - (enter-new-nicknames package nicknames) - (setq *package* package)) - (t - (setq *package* (apply #'make-package name keys)))))) - -;;; IN-PACKAGE -- public. -;;; -(defmacro in-package (package &rest noise) - (cond ((or noise - (not (or (stringp package) (symbolp package)))) - (warn "Old-style IN-PACKAGE.") - `(old-in-package ,package ,@noise)) - (t - `(%in-package ',(stringify-name package "package"))))) -;;; -(defun %in-package (name) - (setf *package* (package-or-lose name))) - -;;; Rename-Package -- Public -;;; -;;; Change the name if we can, blast any old nicknames and then -;;; add in any new ones. -;;; -(defun rename-package (package name &optional (nicknames ())) - "Changes the name and nicknames for a package." - (let* ((package (package-or-lose package)) - (name (string name)) - (found (find-package name))) - (unless (or (not found) (eq found package)) - (error "A package named ~S already exists." name)) - (remhash (package-%name package) *package-names*) - (dolist (n (package-%nicknames package)) - (remhash n *package-names*)) - (setf (package-%name package) name) - (setf (gethash name *package-names*) package) - (setf (package-%nicknames package) ()) - (enter-new-nicknames package nicknames) - package)) - -;;; Delete-Package -- Public -;;; -;;; Delete the package (string or package) from the package system data -;;; structures. -;;; -(defun delete-package (package) - (let ((pack-struc nil) - (pack-name nil) - (use-list nil)) - (cond ((packagep package) ; Package argument is a package-object. - (setf pack-name (package-name package) - pack-struc package - use-list (package-used-by-list package))) - ((stringp package) ; Package argument is a name. - (setf pack-struc (find-package package)) - (if pack-struc - (setf pack-name (package-name pack-struc))) - (unless pack-struc - ;; Package argument is a name, but there is no package-object - ;; of that name. - (cerror "Return NIL" "No package of name ~S." package) - (return-from delete-package nil)) - (setf use-list (package-used-by-list pack-struc)))) - (when (and pack-struc (not pack-name)) ; Package already deleted. - (return-from delete-package nil)) - (when use-list ; The package is used by other packages. - ;; Correctable error, if continued, then unuse-package on all. - (cerror "Remove dependency in other packages." - "~S is used by package(s) ~S" package use-list) - (dolist (p use-list) - (unuse-package pack-name p))) - ;; Delete package slot for all symbols in the package by uninterning them. - (loop for s being each present-symbol of pack-struc - do (unintern s pack-struc)) - (setf (package-%name pack-struc) nil - (package-%nicknames pack-struc) nil) - (return-from delete-package t))) - -;;; List-All-Packages -- Public -;;; -;;; -(defun list-all-packages () - "Returns a list of all existing packages." - (let ((res ())) - (maphash #'(lambda (k v) - (declare (ignore k)) - (pushnew v res)) - *package-names*) - res)) - -;;; Intern -- Public -;;; -;;; Simple-stringify the name and call intern*. -;;; -(defun intern (name &optional package) - "Returns a symbol having the specified name, creating it if necessary." - (let ((name (if (simple-string-p name) name (coerce name 'simple-string)))) - (declare (simple-string name)) - (intern* name (length name) - (if package (package-or-lose package) *package*)))) - -;;; Find-Symbol -- Public -;;; -;;; Ditto. -;;; -(defun find-symbol (name &optional package) - "Returns the symbol named String in Package. If such a symbol is found - then the second value is :internal, :external or :inherited to indicate - how the symbol is accessible. If no symbol is found then both values - are NIL." - (let ((name (if (simple-string-p name) name (coerce name 'simple-string)))) - (declare (simple-string name)) - (find-symbol* name (length name) - (if package (package-or-lose package) *package*)))) - -;;; Intern* -- Internal -;;; -;;; If the symbol doesn't exist then create it, special-casing -;;; the keyword package. -;;; -(defun intern* (name length package) - (declare (simple-string name)) - (multiple-value-bind (symbol where) (find-symbol* name length package) - (if where - (values symbol where) - (let ((symbol (make-symbol (subseq name 0 length)))) - (%set-symbol-package symbol package) - (cond ((eq package *keyword-package*) - (add-symbol (package-external-symbols package) symbol) - (%set-symbol-value symbol symbol)) - (t - (add-symbol (package-internal-symbols package) symbol))) - (values symbol nil))))) - -;;; Find-Symbol* -- Internal -;;; -;;; Check internal and external symbols, then scan down the list -;;; of hashtables for inherited symbols. When an inherited symbol -;;; is found pull that table to the beginning of the list. -;;; -(defun find-symbol* (string length package) - (declare (simple-string string) - (fixnum length)) - (let* ((hash (%sxhash-simple-substring string length)) - (ehash (entry-hash length hash))) - (declare (fixnum hash ehash)) - (with-symbol (found symbol (package-internal-symbols package) - string length hash ehash) - (when found - (return-from find-symbol* (values symbol :internal)))) - (with-symbol (found symbol (package-external-symbols package) - string length hash ehash) - (when found - (return-from find-symbol* (values symbol :external)))) - (let ((head (package-tables package))) - (do ((prev head table) - (table (cdr head) (cdr table))) - ((null table) (values nil nil)) - (with-symbol (found symbol (car table) string length hash ehash) - (when found - (unless (eq prev head) - (shiftf (cdr prev) (cdr table) (cdr head) table)) - (return-from find-symbol* (values symbol :inherited)))))))) - -;;; Find-External-Symbol -- Internal -;;; -;;; Similar to Find-Symbol, but only looks for an external symbol. -;;; This is used for fast name-conflict checking in this file and symbol -;;; printing in the printer. -;;; -(defun find-external-symbol (string package) - (declare (simple-string string)) - (let* ((length (length string)) - (hash (%sxhash-simple-string string)) - (ehash (entry-hash length hash))) - (declare (fixnum length hash)) - (with-symbol (found symbol (package-external-symbols package) - string length hash ehash) - (values symbol found)))) - -;;; Unintern -- Public -;;; -;;; If we are uninterning a shadowing symbol, then a name conflict can -;;; result, otherwise just nuke the symbol. -;;; -(defun unintern (symbol &optional (package *package*)) - "Makes Symbol no longer present in Package. If Symbol was present - then T is returned, otherwise NIL. If Package is Symbol's home - package, then it is made uninterned." - (let* ((package (package-or-lose package)) - (name (symbol-name symbol)) - (shadowing-symbols (package-%shadowing-symbols package))) - (declare (list shadowing-symbols) (simple-string name)) - ;; - ;; If a name conflict is revealed, give use a chance to shadowing-import - ;; one of the accessible symbols. - (when (member symbol shadowing-symbols) - (let ((cset ())) - (dolist (p (package-%use-list package)) - (multiple-value-bind (s w) (find-external-symbol name p) - (when w (pushnew s cset)))) - (when (cdr cset) - (loop - (cerror - "prompt for a symbol to shadowing-import." - "Uninterning symbol ~S causes name conflict among these symbols:~%~S" - symbol cset) - (write-string "Symbol to shadowing-import: " *query-io*) - (let ((sym (read *query-io*))) - (cond - ((not (symbolp sym)) - (format *query-io* "~S is not a symbol.")) - ((not (member sym cset)) - (format *query-io* "~S is not one of the conflicting symbols.")) - (t - (shadowing-import sym package) - (return-from unintern t))))))) - (setf (package-%shadowing-symbols package) - (remove symbol shadowing-symbols))) - - (multiple-value-bind (s w) (find-symbol name package) - (declare (ignore s)) - (cond ((or (eq w :internal) (eq w :external)) - (nuke-symbol (if (eq w :internal) - (package-internal-symbols package) - (package-external-symbols package)) - name) - (if (eq (symbol-package symbol) package) - (%set-symbol-package symbol nil)) - t) - (t nil))))) - -;;; Symbol-Listify -- Internal -;;; -;;; Take a symbol-or-list-of-symbols and return a list, checking types. -;;; -(defun symbol-listify (thing) - (cond ((listp thing) - (dolist (s thing) - (unless (symbolp s) (error "~S is not a symbol." s))) - thing) - ((symbolp thing) (list thing)) - (t - (error "~S is neither a symbol nor a list of symbols." thing)))) - -;;; Moby-Unintern -- Internal -;;; -;;; Like Unintern, but if symbol is inherited chases down the -;;; package it is inherited from and uninterns it there. Used -;;; for name-conflict resolution. Shadowing symbols are not -;;; uninterned since they do not cause conflicts. -;;; -(defun moby-unintern (symbol package) - (unless (member symbol (package-%shadowing-symbols package)) - (or (unintern symbol package) - (let ((name (symbol-name symbol))) - (multiple-value-bind (s w) (find-symbol name package) - (declare (ignore s)) - (when (eq w :inherited) - (dolist (q (package-%use-list package)) - (multiple-value-bind (u x) (find-external-symbol name q) - (declare (ignore u)) - (when x - (unintern symbol q) - (return t)))))))))) - -;;; Export -- Public -;;; -;;; Do more stuff. -;;; -(defun export (symbols &optional (package *package*)) - "Exports Symbols from Package, checking that no name conflicts result." - (let ((package (package-or-lose package)) - (syms ())) - ;; - ;; Punt any symbols that are already external. - (dolist (sym (symbol-listify symbols)) - (multiple-value-bind (s w) - (find-external-symbol (symbol-name sym) package) - (declare (ignore s)) - (unless (or w (member sym syms)) (push sym syms)))) - ;; - ;; Find symbols and packages with conflicts. - (let ((used-by (package-%used-by-list package)) - (cpackages ()) - (cset ())) - (dolist (sym syms) - (let ((name (symbol-name sym))) - (dolist (p used-by) - (multiple-value-bind (s w) (find-symbol name p) - (when (and w (not (eq s sym)) - (not (member s (package-%shadowing-symbols p)))) - (pushnew sym cset) - (pushnew p cpackages)))))) - (when cset - (restart-case - (error "Exporting these symbols from the ~A package:~%~S~%~ - results in name conflicts with these packages:~%~{~A ~}" - (package-%name package) cset (mapcar #'package-%name cpackages)) - (unintern-conflicting-symbols () - :report "Unintern conflicting symbols." - (dolist (p cpackages) - (dolist (sym cset) - (moby-unintern sym p)))) - (skip-exporting-these-symbols () - :report "Skip exporting conflicting symbols." - (setq syms (nset-difference syms cset)))))) - ;; - ;; Check that all symbols are accessible. If not, ask to import them. - (let ((missing ()) - (imports ())) - (dolist (sym syms) - (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) - (cond ((not (and w (eq s sym))) (push sym missing)) - ((eq w :inherited) (push sym imports))))) - (when missing - (cerror "Import these symbols into the ~A package." - "These symbols are not accessible in the ~A package:~%~S" - (package-%name package) missing) - (import missing package)) - (import imports package)) - ;; - ;; And now, three pages later, we export the suckers. - (let ((internal (package-internal-symbols package)) - (external (package-external-symbols package))) - (dolist (sym syms) - (nuke-symbol internal (symbol-name sym)) - (add-symbol external sym))) - t)) - -;;; Unexport -- Public -;;; -;;; Check that all symbols are accessible, then move from external to -;;; internal. -;;; -(defun unexport (symbols &optional (package *package*)) - "Makes Symbols no longer exported from Package." - (let ((package (package-or-lose package)) - (syms ())) - (dolist (sym (symbol-listify symbols)) - (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) - (cond ((or (not w) (not (eq s sym))) - (error "~S is not accessible in the ~A package." - sym (package-%name package))) - ((eq w :external) (pushnew sym syms))))) - - (let ((internal (package-internal-symbols package)) - (external (package-external-symbols package))) - (dolist (sym syms) - (add-symbol internal sym) - (nuke-symbol external (symbol-name sym)))) - t)) - -;;; Import -- Public -;;; -;;; Check for name conflic caused by the import and let the user -;;; shadowing-import if there is. -;;; -(defun import (symbols &optional (package *package*)) - "Make Symbols accessible as internal symbols in Package. If a symbol - is already accessible then it has no effect. If a name conflict - would result from the importation, then a correctable error is signalled." - (let ((package (package-or-lose package)) - (symbols (symbol-listify symbols)) - (syms ()) - (cset ())) - (dolist (sym symbols) - (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) - (cond ((not w) - (let ((found (member sym syms :test #'string=))) - (if found - (when (not (eq (car found) sym)) - (push sym cset)) - (push sym syms)))) - ((not (eq s sym)) (push sym cset)) - ((eq w :inherited) (push sym syms))))) - (when cset - (cerror - "Import these symbols with Shadowing-Import." - "Importing these symbols into the ~A package causes a name conflict:~%~S" - (package-%name package) cset)) - ;; - ;; Add the new symbols to the internal hashtable. - (let ((internal (package-internal-symbols package))) - (dolist (sym syms) - (add-symbol internal sym))) - ;; - ;; If any of the symbols are uninterned, make them be owned by Package. - (dolist (sym symbols) - (unless (symbol-package sym) (%set-symbol-package sym package))) - (shadowing-import cset package))) - -;;; Shadowing-Import -- Public -;;; -;;; If a conflicting symbol is present, unintern it, otherwise just -;;; stick the symbol in. -;;; -(defun shadowing-import (symbols &optional (package *package*)) - "Import Symbols into package, disregarding any name conflict. If - a symbol of the same name is present, then it is uninterned. - The symbols are added to the Package-Shadowing-Symbols." - (let* ((package (package-or-lose package)) - (internal (package-internal-symbols package))) - (dolist (sym (symbol-listify symbols)) - (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) - (unless (and w (not (eq w :inherited)) (eq s sym)) - (when (or (eq w :internal) (eq w :external)) - ;; - ;; If it was shadowed, we don't want Unintern to flame out... - (setf (package-%shadowing-symbols package) - (remove s (the list (package-%shadowing-symbols package)))) - (unintern s package)) - (add-symbol internal sym)) - (pushnew sym (package-%shadowing-symbols package))))) - t) - - -;;; Shadow -- Public -;;; -;;; -(defun shadow (symbols &optional (package *package*)) - "Make an internal symbol in Package with the same name as each of the - specified symbols, adding the new symbols to the Package-Shadowing-Symbols. - If a symbol with the given name is already present in Package, then - the existing symbol is placed in the shadowing symbols list if it is - not already present." - (let* ((package (package-or-lose package)) - (internal (package-internal-symbols package))) - (dolist (name (mapcar #'string - (if (listp symbols) symbols (list symbols)))) - (multiple-value-bind (s w) (find-symbol name package) - (when (or (not w) (eq w :inherited)) - (setq s (make-symbol name)) - (%set-symbol-package s package) - (add-symbol internal s)) - (pushnew s (package-%shadowing-symbols package))))) - t) - - - -;;; Use-Package -- Public -;;; -;;; Do stuff to use a package, with all kinds of fun name-conflict -;;; checking. -;;; -(defun use-package (packages-to-use &optional (package *package*)) - "Add all the Package-To-Use to the use list for Package so that - the external symbols of the used packages are accessible as internal - symbols in Package." - (let ((packages (package-listify packages-to-use)) - (package (package-or-lose package))) - ;; - ;; Loop over each package, use'ing one at a time... - (dolist (pkg packages) - (unless (member pkg (package-%use-list package)) - (let ((cset ()) - (shadowing-symbols (package-%shadowing-symbols package)) - (use-list (package-%use-list package))) - ;; - ;; If the number of symbols already accessible is less than the - ;; number to be inherited then it is faster to run the test the - ;; other way. This is particularly valuable in the case of - ;; a new package use'ing Lisp. - (cond - ((< (+ (internal-symbol-count package) - (external-symbol-count package) - (let ((res 0)) - (dolist (p use-list res) - (incf res (external-symbol-count p))))) - (external-symbol-count pkg)) - (do-symbols (sym package) - (multiple-value-bind (s w) - (find-external-symbol (symbol-name sym) pkg) - (when (and w (not (eq s sym)) - (not (member sym shadowing-symbols))) - (push sym cset)))) - (dolist (p use-list) - (do-external-symbols (sym p) - (multiple-value-bind (s w) - (find-external-symbol (symbol-name sym) - pkg) - (when (and w (not (eq s sym)) - (not (member (find-symbol (symbol-name sym) - package) - shadowing-symbols))) - (push sym cset)))))) - (t - (do-external-symbols (sym pkg) - (multiple-value-bind (s w) - (find-symbol (symbol-name sym) package) - (when (and w (not (eq s sym)) - (not (member s shadowing-symbols))) - (push s cset)))))) - - (when cset - (cerror - "unintern the conflicting symbols in the ~2*~A package." - "Use'ing package ~A results in name conflicts for these symbols:~%~S" - (package-%name pkg) cset (package-%name package)) - (dolist (s cset) (moby-unintern s package)))) - - (push pkg (package-%use-list package)) - (push (package-external-symbols pkg) (cdr (package-tables package))) - (push package (package-%used-by-list pkg))))) - t) - -;;; Unuse-Package -- Public -;;; -;;; -(defun unuse-package (packages-to-unuse &optional (package *package*)) - "Remove Packages-To-Unuse from the use list for Package." - (let ((package (package-or-lose package))) - (dolist (p (package-listify packages-to-unuse)) - (setf (package-%use-list package) - (remove p (the list (package-%use-list package)))) - (setf (package-tables package) - (delete (package-external-symbols p) - (the list (package-tables package)))) - (setf (package-%used-by-list p) - (remove package (the list (package-%used-by-list p))))) - t)) - -;;; Find-All-Symbols -- Public -;;; -;;; -(defun find-all-symbols (string-or-symbol) - "Return a list of all symbols in the system having the specified name." - (let ((string (string string-or-symbol)) - (res ())) - (maphash #'(lambda (k v) - (declare (ignore k)) - (multiple-value-bind (s w) (find-symbol string v) - (when w (pushnew s res)))) - *package-names*) - res)) - - -;;; Apropos and Apropos-List. - -(defun briefly-describe-symbol (symbol) - (fresh-line) - (prin1 symbol) - (when (boundp symbol) - (write-string ", value: ") - (prin1 (symbol-value symbol))) - (if (fboundp symbol) - (write-string " (defined)"))) - -(defun apropos-search (symbol string) - (declare (simple-string string)) - (do* ((index 0 (1+ index)) - (name (symbol-name symbol)) - (length (length string)) - (terminus (- (length name) length))) - ((> index terminus) - nil) - (declare (simple-string name) - (fixnum index terminus length)) - (if (do ((jndex 0 (1+ jndex)) - (kndex index (1+ kndex))) - ((= jndex length) - t) - (declare (fixnum jndex kndex)) - (let ((char (schar name kndex))) - (unless (char= (schar string jndex) (char-upcase char)) - (return nil)))) - (return t)))) - -(defun apropos (string &optional package external-only) - "Briefly describe all symbols which contain the specified String. - If Package is supplied then only describe symbols present in - that package. If External-Only is true then only describe - external symbols in the specified package." - (let ((string (string-upcase string))) - (declare (simple-string string)) - (if (null package) - (do-all-symbols (symbol) - (if (apropos-search symbol string) - (briefly-describe-symbol symbol))) - (let ((package (package-or-lose package))) - (if external-only - (do-external-symbols (symbol package) - (if (apropos-search symbol string) - (briefly-describe-symbol symbol))) - (do-symbols (symbol package) - (if (apropos-search symbol string) - (briefly-describe-symbol symbol)))))) - (values))) - -(defun apropos-list (string &optional package external-only) - "Identical to Apropos, except that it returns a list of the symbols - found instead of describing them." - (let ((string (string-upcase string)) - (list '())) - (declare (simple-string string)) - (if (null package) - (do-all-symbols (symbol) - (if (apropos-search symbol string) - (push symbol list))) - (let ((package (package-or-lose package))) - (if external-only - (do-external-symbols (symbol package) - (if (apropos-search symbol string) - (push symbol list))) - (do-symbols (symbol package) - (if (apropos-search symbol string) - (push symbol list)))))) - list)) - -;;; Initialization. - -;;; The cold loader (Genesis) makes the data structure in *initial-symbols*. -;;; We grovel over it, making the specified packages and interning the -;;; symbols. For a description of the format of *initial-symbols* see -;;; the Genesis source. - -(defvar *initial-symbols*) - -(defun package-init () - (let ((*in-package-init* t)) - (dolist (spec *initial-symbols*) - (let* ((pkg (apply #'make-package (first spec))) - (internal (package-internal-symbols pkg)) - (external (package-external-symbols pkg))) - ;; - ;; Put internal symbols in the internal hashtable and set package. - (dolist (symbol (second spec)) - (add-symbol internal symbol) - (%set-symbol-package symbol pkg)) - ;; - ;; External symbols same, only go in external table. - (dolist (symbol (third spec)) - (add-symbol external symbol) - (%set-symbol-package symbol pkg)) - ;; - ;; Don't set package for Imported symbols. - (dolist (symbol (fourth spec)) - (add-symbol internal symbol)) - (dolist (symbol (fifth spec)) - (add-symbol external symbol)) - ;; - ;; Put shadowing symbols in the shadowing symbols list. - (setf (package-%shadowing-symbols pkg) (sixth spec)))) - - (makunbound '*initial-symbols*) ; So it gets GC'ed. - - ;; Make some other packages that should be around in the cold load: - (make-package "COMMON-LISP-USER" :nicknames '("CL-USER" "USER")) - - ;; Now do the *deferred-use-packages*: - (dolist (args *deferred-use-packages*) - (apply #'use-package args)) - (makunbound '*deferred-use-packages*) - - (setq *lisp-package* (find-package "LISP")) - (setq *keyword-package* (find-package "KEYWORD")) - - ;; For the kernel core image wizards, set the package to *Lisp-Package*. - (setq *package* *lisp-package*))) diff --git a/code/parse-time.lisp b/code/parse-time.lisp deleted file mode 100644 index 37b1b8f60866c2fff5911bda8a7a777b1818a7b8..0000000000000000000000000000000000000000 --- a/code/parse-time.lisp +++ /dev/null @@ -1,607 +0,0 @@ -;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*- - -;;; ********************************************************************** -;;; 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/code/parse-time.lisp,v 1.3 1991/07/26 11:35:16 chiles Exp $") -;;; -;;; ********************************************************************** - -;;; Parsing routines for time and date strings. Parse-time returns the -;;; universal time integer for the time and/or date given in the string. - -;;; Written by Jim Healy, June 1987. - -;;; ********************************************************************** - -(in-package "EXTENSIONS" :use "LISP") - -(export 'parse-time) - -(defconstant whitespace-chars '(#\space #\tab #\newline #\, #\' #\`)) -(defconstant time-dividers '(#\: #\.)) -(defconstant date-dividers '(#\\ #\/ #\-)) - -(defvar *error-on-mismatch* nil - "If t, an error will be signalled if parse-time is unable - to determine the time/date format of the string.") - -;;; Set up hash tables for month, weekday, zone, and special strings. -;;; Provides quick, easy access to associated information for these items. - -;;; Hashlist takes an association list and hashes each pair into the -;;; specified tables using the car of the pair as the key and the cdr as -;;; the data object. - -(defmacro hashlist (list table) - `(dolist (item ,list) - (setf (gethash (car item) ,table) (cdr item)))) - -(defparameter weekday-table-size 23) -(defparameter month-table-size 31) -(defparameter zone-table-size 11) -(defparameter special-table-size 11) - -(defvar *weekday-strings* (make-hash-table :test #'equal - :size weekday-table-size)) - -(defvar *month-strings* (make-hash-table :test #'equal - :size month-table-size)) - -(defvar *zone-strings* (make-hash-table :test #'equal - :size zone-table-size)) - -(defvar *special-strings* (make-hash-table :test #'equal - :size special-table-size)) - -;;; Load-time creation of the hash tables. - -(hashlist '(("monday" . 0) ("mon" . 0) - ("tuesday" . 1) ("tues" . 1) ("tue" . 1) - ("wednesday" . 2) ("wednes" . 2) ("wed" . 2) - ("thursday" . 3) ("thurs" . 3) ("thu" . 3) - ("friday" . 4) ("fri" . 4) - ("saturday" . 5) ("sat" . 5) - ("sunday" . 6) ("sun" . 6)) - *weekday-strings*) - -(hashlist '(("january" . 1) ("jan" . 1) - ("february" . 2) ("feb" . 2) - ("march" . 3) ("mar" . 3) - ("april" . 4) ("apr" . 4) - ("may" . 5) ("june" . 6) - ("jun" . 6) ("july" . 7) - ("jul" . 7) ("august" . 8) - ("aug" . 8) ("september" . 9) - ("sept" . 9) ("sep" . 9) - ("october" . 10) ("oct" . 10) - ("november" . 11) ("nov" . 11) - ("december" . 12) ("dec" . 12)) - *month-strings*) - -(hashlist '(("gmt" . 0) ("est" . 5) - ("edt" . 4) ("cst" . 6) - ("cdt" . 5) ("mst" . 7) - ("mdt" . 6) ("pst" . 8) - ("pdt" . 7)) - *zone-strings*) - -(hashlist '(("yesterday" . yesterday) ("today" . today) - ("tomorrow" . tomorrow) ("now" . now)) - *special-strings*) - -;;; Time/date format patterns are specified as lists of symbols repre- -;;; senting the elements. Optional elements can be specified by -;;; enclosing them in parentheses. Note that the order in which the -;;; patterns are specified below determines the order of search. - -;;; Choices of pattern symbols are: second, minute, hour, day, month, -;;; year, time-divider, date-divider, am-pm, zone, weekday, noon-midn, -;;; and any special symbol. - -(defparameter patterns - '( - ;; Date formats. - ((weekday) month (date-divider) day (date-divider) year (noon-midn)) - ((weekday) day (date-divider) month (date-divider) year (noon-midn)) - ((weekday) month (date-divider) day (noon-midn)) - (year (date-divider) month (date-divider) day (noon-midn)) - (month (date-divider) year (noon-midn)) - (year (date-divider) month (noon-midn)) - - ((noon-midn) (weekday) month (date-divider) day (date-divider) year) - ((noon-midn) (weekday) day (date-divider) month (date-divider) year) - ((noon-midn) (weekday) month (date-divider) day) - ((noon-midn) year (date-divider) month (date-divider) day) - ((noon-midn) month (date-divider) year) - ((noon-midn) year (date-divider) month) - - ;; Time formats. - (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) - (date-divider) (zone)) - (noon-midn) - (hour (noon-midn)) - - ;; Time/date combined formats. - ((weekday) month (date-divider) day (date-divider) year - hour (time-divider) (minute) (time-divider) (secondp) - (am-pm) (date-divider) (zone)) - ((weekday) day (date-divider) month (date-divider) year - hour (time-divider) (minute) (time-divider) (secondp) - (am-pm) (date-divider) (zone)) - ((weekday) month (date-divider) day - hour (time-divider) (minute) (time-divider) (secondp) - (am-pm) (date-divider) (zone)) - (year (date-divider) month (date-divider) day - hour (time-divider) (minute) (time-divider) (secondp) - (am-pm) (date-divider) (zone)) - (month (date-divider) year - hour (time-divider) (minute) (time-divider) (secondp) - (am-pm) (date-divider) (zone)) - (year (date-divider) month - hour (time-divider) (minute) (time-divider) (secondp) - (am-pm) (date-divider) (zone)) - - (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) - (date-divider) (zone) (weekday) month (date-divider) - day (date-divider) year) - (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) - (date-divider) (zone) (weekday) day (date-divider) - month (date-divider) year) - (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) - (date-divider) (zone) (weekday) month (date-divider) - day) - (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) - (date-divider) (zone) year (date-divider) month - (date-divider) day) - (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) - (date-divider) (zone) month (date-divider) year) - (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) - (date-divider) (zone) year (date-divider) month) - - ;; Weird, non-standard formats. - (weekday month day hour (time-divider) minute (time-divider) - secondp (am-pm) - (zone) year) - ((weekday) day (date-divider) month (date-divider) year hour - (time-divider) minute (time-divider) (secondp) (am-pm) - (date-divider) (zone)) - ((weekday) month (date-divider) day (date-divider) year hour - (time-divider) minute (time-divider) (secondp) (am-pm) - (date-divider) (zone)) - - ;; Special-string formats. - (now (yesterday)) - ((yesterday) now) - (now (today)) - ((today) now) - (now (tomorrow)) - ((tomorrow) now) - (yesterday (noon-midn)) - ((noon-midn) yesterday) - (today (noon-midn)) - ((noon-midn) today) - (tomorrow (noon-midn)) - ((noon-midn) tomorrow) -)) - -;;; The decoded-time structure holds the time/date values which are -;;; eventually passed to 'encode-universal-time' after parsing. - -;;; Note: Currently nothing is done with the day of the week. It might -;;; be appropriate to add a function to see if it matches the date. - -(defstruct decoded-time - (second 0 :type integer) ; Value between 0 and 59. - (minute 0 :type integer) ; Value between 0 and 59. - (hour 0 :type integer) ; Value between 0 and 23. - (day 1 :type integer) ; Value between 1 and 31. - (month 1 :type integer) ; Value between 1 and 12. - (year 1900 :type integer) ; Value above 1899 or between 0 and 99. - (zone 0 :type integer) ; Value between 0 and 23. - (dotw 0 :type integer)) ; Value between 0 and 6. - -;;; Make-default-time returns a decoded-time structure with the default -;;; time values already set. The default time is currently 00:00 on -;;; the current day, current month, current year, and current time-zone. - -(defun make-default-time (def-sec def-min def-hour def-day - def-mon def-year def-zone def-dotw) - (let ((default-time (make-decoded-time))) - (multiple-value-bind (sec min hour day mon year dotw dst zone) - (get-decoded-time) - (declare (ignore dst)) - (if def-sec - (if (eq def-sec :current) - (setf (decoded-time-second default-time) sec) - (setf (decoded-time-second default-time) def-sec)) - (setf (decoded-time-second default-time) 0)) - (if def-min - (if (eq def-min :current) - (setf (decoded-time-minute default-time) min) - (setf (decoded-time-minute default-time) def-min)) - (setf (decoded-time-minute default-time) 0)) - (if def-hour - (if (eq def-hour :current) - (setf (decoded-time-hour default-time) hour) - (setf (decoded-time-hour default-time) def-hour)) - (setf (decoded-time-hour default-time) 0)) - (if def-day - (if (eq def-day :current) - (setf (decoded-time-day default-time) day) - (setf (decoded-time-day default-time) def-day)) - (setf (decoded-time-day default-time) day)) - (if def-mon - (if (eq def-mon :current) - (setf (decoded-time-month default-time) mon) - (setf (decoded-time-month default-time) def-mon)) - (setf (decoded-time-month default-time) mon)) - (if def-year - (if (eq def-year :current) - (setf (decoded-time-year default-time) year) - (setf (decoded-time-year default-time) def-year)) - (setf (decoded-time-year default-time) year)) - (if def-zone - (if (eq def-zone :current) - (setf (decoded-time-zone default-time) zone) - (setf (decoded-time-zone default-time) def-zone)) - (setf (decoded-time-zone default-time) zone)) - (if def-dotw - (if (eq def-dotw :current) - (setf (decoded-time-dotw default-time) dotw) - (setf (decoded-time-dotw default-time) def-dotw)) - (setf (decoded-time-dotw default-time) dotw)) - default-time))) - -;;; Converts the values in the decoded-time structure to universal time -;;; by calling extensions:encode-universal-time. -;;; If zone is in numerical form, tweeks it appropriately. - -(defun convert-to-unitime (parsed-values) - (let ((zone (decoded-time-zone parsed-values))) - (encode-universal-time (decoded-time-second parsed-values) - (decoded-time-minute parsed-values) - (decoded-time-hour parsed-values) - (decoded-time-day parsed-values) - (decoded-time-month parsed-values) - (decoded-time-year parsed-values) - (if (or (> zone 23) (< zone -23)) - (let ((new-zone (/ zone 100))) - (cond ((minusp new-zone) (- new-zone)) - ((plusp new-zone) (- 24 new-zone)) - ;; must be zero (GMT) - (t new-zone))) - zone)))) - -;;; Sets the current values for the time and/or date parts of the -;;; decoded time structure. - -(defun set-current-value (values-structure &key (time nil) (date nil) (zone nil)) - (multiple-value-bind (sec min hour day mon year dotw dst tz) - (get-decoded-time) - (declare (ignore dst)) - (when time - (setf (decoded-time-second values-structure) sec) - (setf (decoded-time-minute values-structure) min) - (setf (decoded-time-hour values-structure) hour)) - (when date - (setf (decoded-time-day values-structure) day) - (setf (decoded-time-month values-structure) mon) - (setf (decoded-time-year values-structure) year) - (setf (decoded-time-dotw values-structure) dotw)) - (when zone - (setf (decoded-time-zone values-structure) tz)))) - -;;; Special function definitions. To define a special substring, add -;;; a dotted pair consisting of the substring and a symbol in the -;;; *special-strings* hashlist statement above. Then define a function -;;; here which takes one argument- the decoded time structure- and -;;; sets the values of the structure to whatever is necessary. Also, -;;; add a some patterns to the patterns list using whatever combinations -;;; of special and pre-existing symbols desired. - -(defun yesterday (parsed-values) - (set-current-value parsed-values :date t :zone t) - (setf (decoded-time-day parsed-values) - (1- (decoded-time-day parsed-values)))) - -(defun today (parsed-values) - (set-current-value parsed-values :date t :zone t)) - -(defun tomorrow (parsed-values) - (set-current-value parsed-values :date t :zone t) - (setf (decoded-time-day parsed-values) - (1+ (decoded-time-day parsed-values)))) - -(defun now (parsed-values) - (set-current-value parsed-values :time t)) - -;;; Predicates for symbols. Each symbol has a corresponding function -;;; defined here which is applied to a part of the datum to see if -;;; it matches the qualifications. - -(defun am-pm (string) - (and (simple-string-p string) - (cond ((string= string "am") 'am) - ((string= string "pm") 'pm) - (t nil)))) - -(defun noon-midn (string) - (and (simple-string-p string) - (cond ((string= string "noon") 'noon) - ((string= string "midnight") 'midn) - (t nil)))) - -(defun weekday (string) - (and (simple-string-p string) (gethash string *weekday-strings*))) - -(defun month (thing) - (or (and (simple-string-p thing) (gethash thing *month-strings*)) - (and (integerp thing) (<= 1 thing 12)))) - -(defun zone (thing) - (or (and (simple-string-p thing) (gethash thing *zone-strings*)) - (if (integerp thing) - (let ((zone (/ thing 100))) - (and (integerp zone) (<= -23 zone 23)))))) - -(defun special (string) - (and (simple-string-p string) (gethash string *special-strings*))) - -(defun secondp (number) - (and (integerp number) (<= 0 number 59))) - -(defun minute (number) - (and (integerp number) (<= 0 number 59))) - -(defun hour (number) - (and (integerp number) (<= 0 number 23))) - -(defun day (number) - (and (integerp number) (<= 1 number 31))) - -(defun year (number) - (and (integerp number) - (or (<= 0 number 99) - (<= 1900 number)))) - -(defun time-divider (character) - (and (characterp character) - (member character time-dividers :test #'char=))) - -(defun date-divider (character) - (and (characterp character) - (member character date-dividers :test #'char=))) - -;;; Match-substring takes a string argument and tries to match it with -;;; the strings in one of the four hash tables: *weekday-strings*, *month- -;;; strings*, *zone-strings*, *special-strings*. It returns a specific -;;; keyword and/or the object it finds in the hash table. If no match -;;; is made then it immediately signals an error. - -(defun match-substring (substring) - (let ((substring (nstring-downcase substring))) - (or (let ((test-value (month substring))) - (if test-value (cons 'month test-value))) - (let ((test-value (weekday substring))) - (if test-value (cons 'weekday test-value))) - (let ((test-value (am-pm substring))) - (if test-value (cons 'am-pm test-value))) - (let ((test-value (noon-midn substring))) - (if test-value (cons 'noon-midn test-value))) - (let ((test-value (zone substring))) - (if test-value (cons 'zone test-value))) - (let ((test-value (special substring))) - (if test-value (cons 'special test-value))) - (if *error-on-mismatch* - (error "\"~A\" is not a recognized word or abbreviation." - substring) - (return-from match-substring nil))))) - -;;; Decompose-string takes the time/date string and decomposes it into a -;;; list of alphabetic substrings, numbers, and special divider characters. -;;; It matches whatever strings it can and replaces them with a dotted pair -;;; containing a symbol and value. - -(defun decompose-string (string &key (start 0) (end (length string)) (radix 10)) - (do ((string-index start) - (next-negative nil) - (parts-list nil)) - ((eq string-index end) (nreverse parts-list)) - (let ((next-char (char string string-index)) - (prev-char (if (= string-index start) - nil - (char string (1- string-index))))) - (cond ((alpha-char-p next-char) - ;; Alphabetic character - scan to the end of the substring. - (do ((scan-index (1+ string-index) (1+ scan-index))) - ((or (eq scan-index end) - (not (alpha-char-p (char string scan-index)))) - (let ((match-symbol (match-substring - (subseq string string-index scan-index)))) - (if match-symbol - (push match-symbol parts-list) - (return-from decompose-string nil))) - (setf string-index scan-index)))) - ((digit-char-p next-char radix) - ;; Numeric digit - convert digit-string to a decimal value. - (do ((scan-index string-index (1+ scan-index)) - (numeric-value 0 (+ (* numeric-value radix) - (digit-char-p (char string scan-index) radix)))) - ((or (eq scan-index end) - (not (digit-char-p (char string scan-index) radix))) - ;; If next-negative is t, set the numeric value to it's - ;; opposite and reset next-negative to nil. - (when next-negative - (setf next-negative nil) - (setf numeric-value (- numeric-value))) - (push numeric-value parts-list) - (setf string-index scan-index)))) - ((and (char= next-char #\-) - (or (not prev-char) - (member prev-char whitespace-chars :test #'char=))) - ;; If we see a minus sign before a number, but not after one, - ;; it is not a date divider, but a negative offset from GMT, so - ;; set next-negative to t and continue. - (setf next-negative t) - (incf string-index)) - ((member next-char time-dividers :test #'char=) - ;; Time-divider - add it to the parts-list with symbol. - (push (cons 'time-divider next-char) parts-list) - (incf string-index)) - ((member next-char date-dividers :test #'char=) - ;; Date-divider - add it to the parts-list with symbol. - (push (cons 'date-divider next-char) parts-list) - (incf string-index)) - ((member next-char whitespace-chars :test #'char=) - ;; Whitespace character - ignore it completely. - (incf string-index)) - ((char= next-char #\() - ;; Parenthesized string - scan to the end and ignore it. - (do ((scan-index string-index (1+ scan-index))) - ((or (eq scan-index end) - (char= (char string scan-index) #\))) - (setf string-index (1+ scan-index))))) - (t - ;; Unrecognized character - barf voraciously. - (if *error-on-mismatch* - (error (concatenate 'simple-string ">>> " string - "~%~VT^-- Bogus character encountered here.") - (+ string-index 4)) - (return-from decompose-string nil))))))) - -;;; Match-pattern-element tries to match a pattern element with a datum -;;; element and returns the symbol associated with the datum element if -;;; successful. Otherwise nil is returned. - -(defun match-pattern-element (pattern-element datum-element) - (cond ((listp datum-element) - (let ((datum-type (if (eq (car datum-element) 'special) - (cdr datum-element) - (car datum-element)))) - (if (eq datum-type pattern-element) datum-element))) - ((funcall pattern-element datum-element) - (cons pattern-element datum-element)) - (t nil))) - -;;; Match-pattern matches a pattern against a datum, returning the -;;; pattern if successful and nil otherwise. - -(defun match-pattern (pattern datum datum-length) - (if (>= (length pattern) datum-length) - (let ((form-list nil)) - (do ((pattern pattern (cdr pattern)) - (datum datum (cdr datum))) - ((or (null pattern) (null datum)) - (cond ((and (null pattern) (null datum)) - (nreverse form-list)) - ((null pattern) nil) - ((null datum) (dolist (element pattern - (nreverse form-list)) - (if (not (listp element)) - (return nil)))))) - (let* ((pattern-element (car pattern)) - (datum-element (car datum)) - (optional (listp pattern-element)) - (matching (match-pattern-element (if optional - (car pattern-element) - pattern-element) - datum-element))) - (cond (matching (let ((form-type (car matching))) - (unless (or (eq form-type 'time-divider) - (eq form-type 'date-divider)) - (push matching form-list)))) - (optional (push datum-element datum)) - (t (return-from match-pattern nil)))))))) - -;;; Deal-with-noon-midn sets the decoded-time values to either noon -;;; or midnight depending on the argument form-value. Form-value -;;; can be either 'noon or 'midn. - -(defun deal-with-noon-midn (form-value parsed-values) - (cond ((eq form-value 'noon) - (setf (decoded-time-hour parsed-values) 12)) - ((eq form-value 'midn) - (setf (decoded-time-hour parsed-values) 0)) - (t (error "Unrecognized symbol: ~A" form-value))) - (setf (decoded-time-minute parsed-values) 0) - (setf (decoded-time-second parsed-values) 0)) - -;;; Deal-with-am-pm sets the decoded-time values to be in the am -;;; or pm depending on the argument form-value. Form-value can -;;; be either 'am or 'pm. - -(defun deal-with-am-pm (form-value parsed-values) - (let ((hour (decoded-time-hour parsed-values))) - (cond ((eq form-value 'am) - (cond ((eq hour 12) - (setf (decoded-time-hour parsed-values) 0)) - ((not (<= 0 hour 12)) - (if *error-on-mismatch* - (error "~D is not an AM hour, dummy." hour))))) - ((eq form-value 'pm) - (if (<= 0 hour 11) - (setf (decoded-time-hour parsed-values) - (mod (+ hour 12) 24)))) - (t (error "~A isn't AM/PM - this shouldn't happen."))))) - -;;; Set-time-values uses the association list of symbols and values -;;; to set the time in the decoded-time structure. - -(defun set-time-values (string-form parsed-values) - (dolist (form-part string-form t) - (let ((form-type (car form-part)) - (form-value (cdr form-part))) - (case form-type - (secondp (setf (decoded-time-second parsed-values) form-value)) - (minute (setf (decoded-time-minute parsed-values) form-value)) - (hour (setf (decoded-time-hour parsed-values) form-value)) - (day (setf (decoded-time-day parsed-values) form-value)) - (month (setf (decoded-time-month parsed-values) form-value)) - (year (setf (decoded-time-year parsed-values) form-value)) - (zone (setf (decoded-time-zone parsed-values) form-value)) - (weekday (setf (decoded-time-dotw parsed-values) form-value)) - (am-pm (deal-with-am-pm form-value parsed-values)) - (noon-midn (deal-with-noon-midn form-value parsed-values)) - (special (funcall form-value parsed-values)) - (t (error "Unrecognized symbol in form list: ~A." form-type)))))) - -(defun parse-time (time-string &key (start 0) (end (length time-string)) - (error-on-mismatch nil) - (default-seconds nil) (default-minutes nil) - (default-hours nil) (default-day nil) - (default-month nil) (default-year nil) - (default-zone nil) (default-weekday nil)) - "Tries very hard to make sense out of the argument time-string and - returns a single integer representing the universal time if - successful. If not, it returns nil. If the :error-on-mismatch - keyword is true, parse-time will signal an error instead of - returning nil. Default values for each part of the time/date - can be specified by the appropriate :default- keyword. These - keywords can be given a numeric value or the keyword :current - to set them to the current value. The default-default values - are 00:00:00 on the current date, current time-zone." - (setq *error-on-mismatch* error-on-mismatch) - (let* ((string-parts (decompose-string time-string :start start :end end)) - (parts-length (length string-parts)) - (string-form (dolist (pattern patterns) - (let ((match-result (match-pattern pattern - string-parts - parts-length))) - (if match-result (return match-result)))))) - (if string-form - (let ((parsed-values (make-default-time default-seconds default-minutes - default-hours default-day - default-month default-year - default-zone default-weekday))) - (set-time-values string-form parsed-values) - (convert-to-unitime parsed-values)) - (if *error-on-mismatch* - (error "\"~A\" is not a recognized time/date format." time-string) - nil)))) - - diff --git a/code/pathname.lisp b/code/pathname.lisp deleted file mode 100644 index 6a24dbbc8cec2d740c1c3eff73507ce7f69e3b53..0000000000000000000000000000000000000000 --- a/code/pathname.lisp +++ /dev/null @@ -1,2006 +0,0 @@ -;;; -*- Package: LISP -*- -;;; ********************************************************************** -;;; 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/code/pathname.lisp,v 1.15 1992/09/04 15:17:24 phg Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Machine/filesystem independent pathname functions for CMU Common Lisp. -;;; -;;; Written by William Lott, enhancements for logical-pathnames -;;; written by Paul Gleichauf. -;;; Earlier version written by Jim Large and Rob MacLachlan -;;; -;;; ********************************************************************** - -(in-package "LISP") - -(export '(pathname pathnamep logical-pathname logical-pathname-p - parse-namestring merge-pathnames make-pathname - pathname-host pathname-device pathname-directory pathname-name - pathname-type pathname-version namestring file-namestring - directory-namestring host-namestring enough-namestring - wild-pathname-p pathname-match-p translate-pathname - translate-logical-pathname logical-pathname-translations - load-logical-pathname-translations *default-pathname-defaults*)) - -(in-package "EXTENSIONS") -(export '(search-list search-list-defined-p clear-search-list - enumerate-search-list)) - -(in-package "LISP") - - -;;;; Structures and types. - -;;; Pathname structure holds the essential properties of the parsed path. - -(defstruct (pathname - (:conc-name %pathname-) - (:print-function %print-pathname) - (:constructor - %make-pathname (host device directory name type version)) - (:predicate pathnamep) - (:make-load-form-fun :just-dump-it-normally)) - ;; Slot holds the host, at present either a UNIX or logical host. - (host nil :type (or host null)) - ;; Device is the name of a logical or physical device holding files. - (device nil :type (member nil :unspecific)) - ;; A list of strings that are the component subdirectory components. - (directory nil :type list) - ;; The filename. - (name nil :type (or simple-string pattern null)) - ;; The type extension of the file. - (type nil :type (or simple-string pattern null (member :unspecific))) - ;; The version number of the file, a positive integer, but not supported - ;; on standard UNIX filesystems. - (version nil :type (or integer null (member :newest :wild)))) - -;;; %PRINT-PATHNAME -- Internal -;;; -;;; The printed representation of the pathname structure. -;;; -(defun %print-pathname (pathname stream depth) - (declare (ignore depth)) - (let ((namestring (handler-case (namestring pathname) - (error nil)))) - (cond (namestring - (format stream "#p~S" namestring)) - (*print-readably* - (error "~S Cannot be printed readably." pathname)) - (*print-pretty* - (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (funcall (formatter - "~2IUnprintable pathname: ~_Host=~S, ~_Device=~S, ~_~ - Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~ - Type=~S, ~_Version=~S") - stream - (%pathname-host pathname) - (%pathname-device pathname) - (%pathname-directory pathname) - (%pathname-name pathname) - (%pathname-type pathname) - (%pathname-version pathname)))) - (t - (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~ - Directory=~S, File=~S, Name=~S, Version=~S>") - stream - (%pathname-host pathname) - (%pathname-device pathname) - (%pathname-directory pathname) - (%pathname-name pathname) - (%pathname-type pathname) - (%pathname-version pathname)))))) - -;;;; HOST structure - -;;; The host structure holds the functions that both parse the pathname -;;; information into sturcture slot entries, and after translation the inverse -;;; (unparse) functions. -;;; -(defstruct (host - (:print-function %print-host)) - (parse (required-argument) :type function) - (unparse (required-argument) :type function) - (unparse-host (required-argument) :type function) - (unparse-directory (required-argument) :type function) - (unparse-file (required-argument) :type function) - (unparse-enough (required-argument) :type function) - (customary-case (required-argument) :type (member :upper :lower))) - -;;; %PRINT-HOST -- Internal -;;; -(defun %print-host (host stream depth) - (declare (ignore depth)) - (print-unreadable-object (host stream :type t :identity t))) - - -;;;; Patterns - -;;; Patterns are a list of entries and wildcards used for pattern matches -;;; of translations. - -(defstruct (pattern - (:print-function %print-pattern) - (:make-load-form-fun :just-dump-it-normally) - (:constructor make-pattern (pieces))) - (pieces nil :type list)) - -;;; %PRINT-PATTERN -- Internal -;;; -(defun %print-pattern (pattern stream depth) - (declare (ignore depth)) - (print-unreadable-object (pattern stream :type t) - (if *print-pretty* - (let ((*print-escape* t)) - (pprint-fill stream (pattern-pieces pattern) nil)) - (prin1 (pattern-pieces pattern) stream)))) - -;;; PATTERN= -- Internal -;;; -(defun pattern= (pattern1 pattern2) - (declare (type pattern pattern1 pattern2)) - (let ((pieces1 (pattern-pieces pattern1)) - (pieces2 (pattern-pieces pattern2))) - (and (= (length pieces1) (length pieces2)) - (every #'(lambda (piece1 piece2) - (typecase piece1 - (simple-string - (and (simple-string-p piece2) - (string= piece1 piece2))) - (cons - (and (consp piece2) - (eq (car piece1) (car piece2)) - (string= (cdr piece1) (cdr piece2)))) - (t - (eq piece1 piece2)))) - pieces1 - pieces2)))) - -;;; PATTERN-MATCHES -- Internal -;;; -(defun pattern-matches (pattern string) - (declare (type pattern pattern) - (type simple-string string)) - (let ((len (length string))) - (labels ((maybe-prepend (subs cur-sub chars) - (if cur-sub - (let* ((len (length chars)) - (new (make-string len)) - (index len)) - (dolist (char chars) - (setf (schar new (decf index)) char)) - (cons new subs)) - subs)) - (matches (pieces start subs cur-sub chars) - (if (null pieces) - (if (= start len) - (values t (maybe-prepend subs cur-sub chars)) - (values nil nil)) - (let ((piece (car pieces))) - (etypecase piece - (simple-string - (let ((end (+ start (length piece)))) - (and (<= end len) - (string= piece string - :start2 start :end2 end) - (matches (cdr pieces) end - (maybe-prepend subs cur-sub chars) - nil nil)))) - (list - (ecase (car piece) - (:character-set - (and (< start len) - (let ((char (schar string start))) - (if (find char (cdr piece) :test #'char=) - (matches (cdr pieces) (1+ start) subs t - (cons char chars)))))))) - ((member :single-char-wild) - (and (< start len) - (matches (cdr pieces) (1+ start) subs t - (cons (schar string start) chars)))) - ((member :multi-char-wild) - (multiple-value-bind - (won new-subs) - (matches (cdr pieces) start subs t chars) - (if won - (values t new-subs) - (and (< start len) - (matches pieces (1+ start) subs t - (cons (schar string start) - chars))))))))))) - (multiple-value-bind - (won subs) - (matches (pattern-pieces pattern) 0 nil nil nil) - (values won (reverse subs)))))) - -;;; COMPONENTS-MATCH -- Internal -;;; -;;; Wilds in to are matched against from where both are either lists -;;; containing :wild and :wild-inferiors, patterns or strings. -;;; FROM = :WILD-INFERIORS or :WILD handled separately for directory -;;; component. Not communative. -;;; -(defun components-match (from to) - (or (eq from to) - (typecase from - (simple-base-string - (typecase to - (pattern - (values (pattern-matches to from))) - (simple-base-string - (string-equal from to)))) - (pattern - (and (pattern-p to) (pattern= from to))) - ((member :wild) ; :WILD component matches any string, or pattern or NIL. - (or (stringp to) - (logical-host-p to) - (pattern-p to) - (member to '(nil :unspecific :newest :wild :wild-inferiors)))) - ((member :newest) - (member to '(:wild))) - (cons ; Watch for wildcards. - (and (consp from) - (let ((from1 (first from)) - (from2 nil) - (to1 (first to))) - (typecase from1 - ((member :wild) - (or (stringp to1) - (pattern-p to1) - (not to1) - (eq to1 :unspecific))) - ((member :wild-inferiors) - (setf from2 (second from)) - (cond ((not from2) - ;; Nothing left of from, hence anything else in to - ;; matches :wild-inferiors. - t) - ((components-match - (rest (rest from)) - (rest (member from2 to :test #'equal)))))) - (keyword ; :unspecific, :up, :back - (and (keywordp to1) - (eq from1 to1) - (components-match (rest from) (rest to)))) - (string - (and (stringp to1) - (string-equal from1 to1) - (components-match (rest from) (rest to)))))))) - ((member :back :up :unspecific nil) - (and (pattern-p from) - (equal (pattern-pieces from) '(:multi-char-wild))))))) - - -;;;; Utilities. - -;;; COMPARE-COMPONENT -- Internal -;;; -;;; A predicate for comparing two pathname slot component sub-entries. -;;; -(defun compare-component (this that) - (or (eql this that) - (typecase this - (simple-string - (and (simple-string-p that) - (string= this that))) - (pattern - (and (pattern-p that) - (pattern= this that))) - (cons - (and (consp that) - (compare-component (car this) (car that)) - (compare-component (cdr this) (cdr that))))))) - - -;;;; Pathname functions. - -;;; Implementation determined defaults to pathname slots. - -(defvar *default-pathname-defaults*) - -;;; PATHNAME= -- Internal -;;; -(defun pathname= (pathname1 pathname2) - (and (eq (%pathname-host pathname1) - (%pathname-host pathname2)) - (compare-component (%pathname-device pathname1) - (%pathname-device pathname2)) - (compare-component (%pathname-directory pathname1) - (%pathname-directory pathname2)) - (compare-component (%pathname-name pathname1) - (%pathname-name pathname2)) - (compare-component (%pathname-type pathname1) - (%pathname-type pathname2)) - (compare-component (%pathname-version pathname1) - (%pathname-version pathname2)))) - -;;; WITH-PATHNAME -- Internal -;;; Converts the var, a pathname designator (a pathname, or string, or -;;; stream), into a pathname. -;;; -(defmacro with-pathname ((var expr) &body body) - `(let ((,var (let ((,var ,expr)) - (etypecase ,var - (pathname ,var) - (string (parse-namestring ,var)) - (stream (parse-namestring (file-name ,var))))))) - ,@body)) - - -;;; PATHNAME -- Interface -;;; -(defun pathname (thing) - "Convert thing (a pathname, string or stream) into a pathname." - (declare (type pathnamelike thing)) - (with-pathname (pathname thing) - pathname)) - -;;; MAYBE-DIDDLE-CASE -- Internal -;;; -;;; Change the case of thing if diddle-p T. -;;; -(defun maybe-diddle-case (thing diddle-p) - (declare (type (or list pattern simple-base-string (member :unspecific)) - thing) - (values (or list pattern simple-base-string (member :unspecific)))) - (if diddle-p - (labels ((check-for (pred in) - (etypecase in - (pattern - (dolist (piece (pattern-pieces in)) - (when (typecase piece - (simple-string - (check-for pred piece)) - (cons - (case (car in) - (:character-set - (check-for pred (cdr in)))))) - (return t)))) - (list - (dolist (x in) - (when (check-for pred x) - (return t)))) - (simple-base-string - (dotimes (i (length in)) - (when (funcall pred (schar in i)) - (return t)))) - ((member :unspecific :up :absolute :relative) - nil))) - (diddle-with (fun thing) - (etypecase thing - (pattern - (make-pattern - (mapcar #'(lambda (piece) - (typecase piece - (simple-base-string - (funcall fun thing)) - (cons - (case (car piece) - (:character-set - (cons :character-set - (funcall fun (cdr piece)))) - (t - piece))) - (t - piece))) - (pattern-pieces thing)))) - (list - (mapcar fun thing)) - (simple-base-string - (funcall fun thing)) - ((member :unspecific :up :absolute :relative) - thing)))) - (let ((any-uppers (check-for #'upper-case-p thing)) - (any-lowers (check-for #'lower-case-p thing))) - (cond ((and any-uppers any-lowers) - ;; Mixed case, stays the same. - thing) - (any-uppers - ;; All uppercase, becomes all lower case. - (diddle-with #'(lambda (x) (if (stringp x) - (string-downcase x) - x)) thing)) - (any-lowers - ;; All lowercase, becomes all upper case. - (diddle-with #'(lambda (x) (if (stringp x) - (string-upcase x) - x)) thing)) - (t - ;; No letters? I guess just leave it. - thing)))) - thing)) - -;;; MERGE-DIRECTORIES -- Internal -;;; -(defun merge-directories (dir1 dir2 diddle-case) - (if (or (eq (car dir1) :absolute) - (null dir2)) - dir1 - (let ((results nil)) - (flet ((add (dir) - (if (and (eq dir :back) - results - (not (eq (car results) :back))) - (pop results) - (push dir results)))) - (dolist (dir (maybe-diddle-case dir2 diddle-case)) - (add dir)) - (dolist (dir (cdr dir1)) - (add dir))) - (reverse results)))) - -;;; MERGE-PATHNAMES -- Interface -;;; -(defun merge-pathnames (pathname - &optional - (defaults *default-pathname-defaults*) - (default-version :newest)) - "Construct a filled in pathname by completing the unspecified components - from the defaults." - (with-pathname (defaults defaults) - (let ((pathname (let ((*default-pathname-defaults* defaults)) - (pathname pathname)))) - (let* ((default-host (%pathname-host defaults)) - (pathname-host (%pathname-host pathname)) - (diddle-case - (and default-host pathname-host - (not (eq (host-customary-case default-host) - (host-customary-case pathname-host)))))) - (%make-pathname (or pathname-host default-host) - (or (%pathname-device pathname) - (maybe-diddle-case (%pathname-device defaults) - diddle-case)) - (merge-directories (%pathname-directory pathname) - (%pathname-directory defaults) - diddle-case) - (or (%pathname-name pathname) - (maybe-diddle-case (%pathname-name defaults) - diddle-case)) - (or (%pathname-type pathname) - (maybe-diddle-case (%pathname-type defaults) - diddle-case)) - (or (%pathname-version pathname) - default-version)))))) - -;;; IMPORT-DIRECTORY -- Internal -;;; -(defun import-directory (directory diddle-case) - (etypecase directory - (null nil) - (list - (collect ((results)) - (ecase (pop directory) - (:absolute - (results :absolute) - (when (search-list-p (car directory)) - (results (pop directory)))) - (:relative - (results :relative))) - (dolist (piece directory) - (cond ((eq piece :wild) - (results (make-pattern (list :multi-char-wild)))) - ((eq piece :wild-inferiors) - (results piece)) - ((member piece '(:up :back)) - (results piece)) - ((or (simple-string-p piece) (pattern-p piece)) - (results (maybe-diddle-case piece diddle-case))) - ((stringp piece) - (results (maybe-diddle-case (coerce piece 'simple-string) - diddle-case))) - (t - (error "~S is not allowed as a directory component." piece)))) - (results))) - (simple-string - `(:absolute - ,(maybe-diddle-case directory diddle-case))) - (string - `(:absolute - ,(maybe-diddle-case (coerce directory 'simple-string) - diddle-case))))) - -;;; MAKE-PATHNAME -- Interface -;;; -(defun make-pathname (&key (host nil hostp) - (device nil devp) - (directory nil dirp) - (name nil namep) - (type nil typep) - (version nil versionp) - defaults (case :local)) - "Makes a new pathname from the component arguments. Note that host is a host- - structure." - (declare (type (or host null) host) - (type (member nil :unspecific) device) - (type (or list string pattern (member :wild)) directory) - (type (or null string pattern (member :wild)) name) - (type (or null string pattern (member :unspecific :wild)) type) - (type (or null integer (member :unspecific :wild :newest)) version) - (type (or pathnamelike null) defaults) - (type (member :common :local) case)) - (let* ((defaults (if defaults - (with-pathname (defaults defaults) defaults))) - (default-host (if defaults - (%pathname-host defaults) - (pathname-host *default-pathname-defaults*))) - (host (if hostp host default-host)) - (diddle-args (and (eq case :common) - (eq (host-customary-case host) :lower))) - (diddle-defaults - (not (eq (host-customary-case host) - (host-customary-case default-host))))) - (macrolet ((pick (var varp field) - `(cond ((eq ,var :wild) - (make-pattern (list :multi-char-wild))) - ((or (simple-string-p ,var) - (pattern-p ,var)) - (maybe-diddle-case ,var diddle-args)) - ((stringp ,var) - (maybe-diddle-case (coerce ,var 'simple-string) - diddle-args)) - (,varp - (maybe-diddle-case ,var diddle-args)) - (defaults - (maybe-diddle-case (,field defaults) - diddle-defaults)) - (t - nil)))) - (%make-pathname - host - (if devp device (if defaults (%pathname-device defaults))) - (let ((dir (import-directory directory diddle-args))) - (if (and defaults (not dirp)) - (merge-directories dir - (%pathname-directory defaults) - diddle-defaults) - dir)) - (pick name namep %pathname-name) - (pick type typep %pathname-type) - (cond - (versionp version) - (defaults (%pathname-version defaults)) - (t nil)))))) - -;;; PATHNAME-HOST -- Interface -;;; -(defun pathname-host (pathname &key (case :local)) - "Accessor for the pathname's host." - (declare (type pathnamelike pathname) - (type (member :local :common) case) - (ignore case)) - (with-pathname (pathname pathname) - (%pathname-host pathname))) - -;;; PATHNAME-DEVICE -- Interface -;;; -(defun pathname-device (pathname &key (case :local)) - "Accessor for pathname's device." - (declare (type pathnamelike pathname) - (type (member :local :common) case)) - (with-pathname (pathname pathname) - (maybe-diddle-case (%pathname-device pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) - -;;; PATHNAME-DIRECTORY -- Interface -;;; -(defun pathname-directory (pathname &key (case :local)) - "Accessor for the pathname's directory list." - (declare (type pathnamelike pathname) - (type (member :local :common) case)) - (with-pathname (pathname pathname) - (maybe-diddle-case (%pathname-directory pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) -;;; PATHNAME-NAME -- Interface -;;; -(defun pathname-name (pathname &key (case :local)) - "Accessor for the pathname's name." - (declare (type pathnamelike pathname) - (type (member :local :common) case)) - (with-pathname (pathname pathname) - (maybe-diddle-case (%pathname-name pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) - -;;; PATHNAME-TYPE -;;; -(defun pathname-type (pathname &key (case :local)) - "Accessor for the pathname's name." - (declare (type pathnamelike pathname) - (type (member :local :common) case)) - (with-pathname (pathname pathname) - (maybe-diddle-case (%pathname-type pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) -;;; PATHNAME-VERSION -;;; -(defun pathname-version (pathname) - "Accessor for the pathname's version." - (declare (type pathnamelike pathname)) - (with-pathname (pathname pathname) - (%pathname-version pathname))) - - -;;;; Namestrings - -;;; %PRINT-NAMESTRING-PARSE-ERROR -- Internal -;;; -(defun %print-namestring-parse-error (condition stream) - (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^" - (namestring-parse-error-complaint condition) - (namestring-parse-error-arguments condition) - (namestring-parse-error-namestring condition) - (namestring-parse-error-offset condition))) - -(define-condition namestring-parse-error (error) - ((complaint :init-form (required-argument)) - (arguments :init-form nil) - (namestring :init-form (required-argument)) - (offset :init-form (required-argument))) - (:report %print-namestring-parse-error)) - -;;; %PARSE-NAMESTRING -- Internal -;;; -(defun %parse-namestring (namestr start end host junk-allowed) - (declare (type string namestr) - (type index start end) - (type host host) - (values (or null pathname) index)) - (cond (junk-allowed - (handler-case (%parse-namestring namestr start end host nil) - (namestring-parse-error (condition) - (values nil (namestring-parse-error-offset condition))))) - ((simple-string-p namestr) - (multiple-value-bind - (new-host device directory file type version) - (funcall (host-parse host) namestr start end) - (values (%make-pathname (or new-host host) - device - directory - file - type - version) - end))) - (t - (%parse-namestring (coerce namestr 'simple-string) - start end host nil)))) - -;;; PARSE-NAMESTRING -- Interface -;;; -(defun parse-namestring (thing - &optional host (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed) - "Converts thing, a pathname designator, into a pathname structure, returns - the printed representation." - (declare (type (or simple-base-string stream pathname) thing) - (type (or null host) host) - (type pathnamelike defaults) - (type index start) - (type (or index null) end) - (type (or null (not null)) junk-allowed) - (values (or null pathname) index)) - (cond ((stringp thing) - (let* ((end1 (or end (length thing))) - (things-host nil) - (hosts-name (when host - (funcall (host-parse host) thing start end1)))) - (setf things-host - (maybe-extract-logical-host thing start end1)) - (when (and host things-host) ; A logical host and host are defined. - (unless (string= things-host hosts-name) - (error "Hosts do not match: ~S in ~S and ~S." - things-host thing host))) - (if things-host - (unless (gethash (string-downcase things-host) *search-lists*) - ;; Not a search-list name, make it a logical-host name. - (setf host (intern-logical-host things-host)))) - (%parse-namestring thing start end1 - (or host - (with-pathname (defaults defaults) - (%pathname-host defaults))) - junk-allowed))) - ((pathnamep thing) - (when host - (unless (eq host (%pathname-host thing)) - (error "Hosts do not match: ~S and ~S." - host - (%pathname-host thing)))) - (values thing start)) - ((streamp thing) - (let ((host-name (funcall (host-unparse-host host) host)) - (stream-type (type-of thing)) - (stream-host-name (host-namestring thing))) - (unless (or (eq stream-type 'fd-stream) - ;;********Change fd-stream to file-stream in sources too. - (eq stream-type 'synonym-stream)) - (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~ - or MAKE-SYNONYM-FILE." thing)) - (unless (string-equal stream-host-name host-name) - (error "Hosts do not match: ~S and ~S." - host - host-name))) - (values thing start)))) - -;;; NAMESTRING -- Interface -;;; -(defun namestring (pathname) - "Construct the full (name)string form of the pathname." - (declare (type pathnamelike pathname)) - (with-pathname (pathname pathname) - (let ((host (%pathname-host pathname))) - (cond ((logical-host-p host) - (funcall (logical-host-unparse host) pathname)) - ((host-p host) - (funcall (host-unparse host) pathname)) - (t - (error - "Cannot determine the namestring for pathnames with no ~ - host:~% ~S" pathname)))))) - -;;; HOST-NAMESTRING -- Interface -;;; -(defun host-namestring (pathname) - "Returns a string representation of the name of the host in the pathname." - (declare (type pathnamelike pathname)) - (with-pathname (pathname pathname) - (let ((host (%pathname-host pathname))) - (if host - (funcall (host-unparse-host host) pathname) - (error - "Cannot determine the namestring for pathnames with no host:~% ~S" - pathname))))) - -;;; DIRECTORY-NAMESTRING -- Interface -;;; -(defun directory-namestring (pathname) - "Returns a string representation of the directories used in the pathname." - (declare (type pathnamelike pathname)) - (with-pathname (pathname pathname) - (let ((host (%pathname-host pathname))) - (if host - (funcall (host-unparse-directory host) pathname) - (error - "Cannot determine the namestring for pathnames with no host:~% ~S" - pathname))))) - -;;; FILE-NAMESTRING -- Interface -;;; -(defun file-namestring (pathname) - "Returns a string representation of the name used in the pathname." - (declare (type pathnamelike pathname)) - (with-pathname (pathname pathname) - (let ((host (%pathname-host pathname))) - (if host - (funcall (host-unparse-file host) pathname) - (error - "Cannot determine the namestring for pathnames with no host:~% ~S" - pathname))))) - -;;; ENOUGH-NAMESTRING -- Interface -;;; -(defun enough-namestring (pathname - &optional (defaults *default-pathname-defaults*)) - "Returns an abbreviated pathname sufficent to identify the pathname relative - to the defaults." - (declare (type pathnamelike pathname)) - (with-pathname (pathname pathname) - (let ((host (%pathname-host pathname))) - (if host - (with-pathname (defaults defaults) - (funcall (host-unparse-enough host) pathname defaults)) - (error - "Cannot determine the namestring for pathnames with no host:~% ~S" - pathname))))) - - -;;;; Wild pathnames. - -;;; WILD-PATHNAME-P -- Interface -;;; -(defun wild-pathname-p (pathname &optional field-key) - "Predicate for determining whether pathname contains any wildcards." - (declare (type pathnamelike pathname) - (type (member nil :host :device :directory :name :type :version) - field-key)) - (with-pathname (pathname pathname) - (ecase field-key - ((nil) - (or (wild-pathname-p pathname :host) - (wild-pathname-p pathname :device) - (wild-pathname-p pathname :directory) - (wild-pathname-p pathname :name) - (wild-pathname-p pathname :type) - (wild-pathname-p pathname :version))) - (:host - (pattern-p (%pathname-host pathname))) - (:device - (pattern-p (%pathname-host pathname))) - (:directory - (some #'pattern-p (%pathname-directory pathname))) - (:name - (pattern-p (%pathname-name pathname))) - (:type - (pattern-p (%pathname-type pathname))) - (:version - (eq (%pathname-version pathname) :wild))))) - -;;; PATHNAME-MATCH -- Interface -;;; -(defun pathname-match-p (pathname wildname) - "Pathname matches the wildname template?" - (with-pathname (pathname pathname) - (with-pathname (wildname wildname) - (macrolet ((frob (field) - `(or (null (,field wildname)) - (components-match (,field wildname) - (,field pathname))))) - (and (frob %pathname-host) - (frob %pathname-device) - (frob %pathname-directory) - (frob %pathname-name) - (frob %pathname-type) - (or (null (%pathname-version wildname)) - (eq (%pathname-version wildname) :wild) - (eql (%pathname-version pathname) - (%pathname-version wildname)))))))) - -;;; SUBSTITUTE-INTO -- Internal -;;; -(defun substitute-into (pattern subs) - (declare (type pattern pattern) - (type list subs)) - (let ((in-wildcard nil) - (pieces nil) - (strings nil)) - (dolist (piece (pattern-pieces pattern)) - (cond ((simple-string-p piece) - (push piece strings) - (setf in-wildcard nil)) - (in-wildcard) - ((null subs)) - (t - (let ((sub (pop subs))) - (etypecase sub - (pattern - (when strings - (push (apply #'concatenate 'simple-string - (nreverse strings)) - pieces)) - (dolist (piece (pattern-pieces sub)) - (push piece pieces))) - (simple-string - (push sub strings)))) - (setf in-wildcard t)))) - (when strings - (push (apply #'concatenate 'simple-string - (nreverse strings)) - pieces)) - (if (and pieces - (simple-string-p (car pieces)) - (null (cdr pieces))) - (car pieces) - (make-pattern (nreverse pieces))))) - -;;; TRANSLATE-COMPONENT -- Internal -;;; -;;; Use the source as a pattern to fill the from path and form the to path. -;;; -(defun translate-component (source from to) - (typecase to - (pattern - (if (pattern-p from) - (typecase source - (pattern - (if (pattern= from source) - source - :error)) - (simple-string - (multiple-value-bind - (won subs) - (pattern-matches from source) - (if won - (values (substitute-into to subs)) - :error))) - (t - :error)) - source)) - ((member nil :wild) - source) - (t - (if (components-match source from) - to - :error)))) - -;;; TRANSLATE-DIRECTORIES -- Internal -;;; -(defun translate-directories (source from to) - (if (null to) - source - (let ((subs nil)) - (loop - for from-part in from - for source-part in source - do (when (pattern-p from-part) - (typecase source-part - (pattern - (if (pattern= from-part source-part) - (setf subs (append subs (list source-part))) - (return-from translate-directories :error))) - (simple-string - (multiple-value-bind - (won new-subs) - (pattern-matches from-part source-part) - (if won - (setf subs (append subs new-subs)) - (return-from translate-directories :error)))) - ((member :back :up) - (if (equal (pattern-pieces from-part) - '(:multi-char-wild)) - (setf subs (append subs (list source-part))) - (return-from translate-directories :error))) - (t - (return-from translate-directories :error))))) - (mapcar #'(lambda (to-part) - (if (pattern-p to-part) - (if (or (eq (car subs) :up) (eq (car subs) :back)) - (if (equal (pattern-pieces to-part) - '(:multi-char-wild)) - (pop subs) - (error "Can't splice ~S into the middle of a ~ - wildcard pattern." - (car subs))) - (multiple-value-bind - (new new-subs) - (substitute-into to-part subs) - (setf subs new-subs) - new)) - to-part)) - to)))) - -;;; TRANSLATE-PATHNAME -- Interface -;;; -(defun translate-pathname (source from-wildname to-wildname &key) - "Use the source pathname to translate the from-wildname's wild and - unspecified elements into a completed to-pathname based on the to-wildname." - (declare (type pathnamelike source from-wildname to-wildname)) - (with-pathname (source source) - (with-pathname (from from-wildname) - (with-pathname (to to-wildname) - (macrolet ((frob (field) - `(let ((result (translate-component (,field source) - (,field from) - (,field to)))) - (if (eq result :error) - (error "~S doesn't match ~S" source from) - result)))) - (%make-pathname (frob %pathname-host) - (frob %pathname-device) - (let ((result (translate-directories - (%pathname-directory source) - (%pathname-directory from) - (%pathname-directory to)))) - (if (eq result :error) - (error "~S doesn't match ~S" source from) - result)) - (frob %pathname-name) - (frob %pathname-type) - (frob %pathname-version))))))) - - -;;;; Search lists. - -;;; The SEARCH-LIST structure. -;;; -(defstruct (search-list - (:print-function %print-search-list) - (:make-load-form-fun - (lambda (search-list) - (values `(intern-search-list ',(search-list-name search-list)) - nil)))) - ;; - ;; The name of this search-list. Always stored in lowercase. - (name (required-argument) :type simple-string) - ;; - ;; T if this search-list has been defined. Otherwise NIL. - (defined nil :type (member t nil)) - ;; - ;; The list of expansions for this search-list. Each expansion is the list - ;; of directory components to use in place of this search-list. - (%expansions (%primitive c:make-value-cell nil))); :type list)) - -(defun search-list-expansions (x) - (%primitive c:value-cell-ref (search-list-%expansions x))) - -(defun (setf search-list-expansions) (val x) - (%primitive c:value-cell-set (search-list-%expansions x) val)) - -(defun %print-search-list (sl stream depth) - (declare (ignore depth)) - (print-unreadable-object (sl stream :type t) - (write-string (search-list-name sl) stream))) - -;;; *SEARCH-LISTS* -- internal. -;;; -;;; Hash table mapping search-list names to search-list structures. -;;; -(defvar *search-lists* (make-hash-table :test #'equal)) - -;;; INTERN-SEARCH-LIST -- internal interface. -;;; -;;; When search-lists are encountered in namestrings, they are converted to -;;; search-list structures right then, instead of waiting until the search -;;; list used. This allows us to verify ahead of time that there are no -;;; circularities and makes expansion much quicker. -;;; -(defun intern-search-list (name) - (let ((name (string-downcase name))) - (or (gethash name *search-lists*) - (let ((new (make-search-list :name name))) - (setf (gethash name *search-lists*) new) - new)))) - -;;; CLEAR-SEARCH-LIST -- public. -;;; -;;; Clear the definition. Note: we can't remove it from the hash-table -;;; because there may be pathnames still refering to it. So we just clear -;;; out the expansions and ste defined to NIL. -;;; -(defun clear-search-list (name) - "Clear the current definition for the search-list NAME. Returns T if such - a definition existed, and NIL if not." - (let* ((name (string-downcase name)) - (search-list (gethash name *search-lists*))) - (when (and search-list (search-list-defined search-list)) - (setf (search-list-defined search-list) nil) - (setf (search-list-expansions search-list) nil) - t))) - -;;; CLEAR-ALL-SEARCH-LISTS -- sorta public. -;;; -;;; Again, we can't actually remove the entries from the hash-table, so we -;;; just mark them as being undefined. -;;; -(defun clear-all-search-lists () - "Clear the definition for all search-lists. Only use this if you know - what you are doing." - (maphash #'(lambda (name search-list) - (declare (ignore name)) - (setf (search-list-defined search-list) nil) - (setf (search-list-expansions search-list) nil)) - *search-lists*) - nil) - -;;; EXTRACT-SEARCH-LIST -- internal. -;;; -;;; Extract the search-list from PATHNAME and return it. If PATHNAME -;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE -;;; is true) or return NIL (if FLAME-IF-NONE is false). -;;; -(defun extract-search-list (pathname flame-if-none) - (with-pathname (pathname pathname) - (let* ((directory (%pathname-directory pathname)) - (search-list (cadr directory))) - (cond ((search-list-p search-list) - search-list) - (flame-if-none - (error "~S doesn't start with a search-list." pathname)) - (t - nil))))) - -;;; SEARCH-LIST -- public. -;;; -;;; We have to convert the internal form of the search-list back into a -;;; bunch of pathnames. -;;; -(defun search-list (pathname) - "Return the expansions for the search-list starting PATHNAME. If PATHNAME - does not start with a search-list, then an error is signaled. If - the search-list has not been defined yet, then an error is signaled. - The expansion for a search-list can be set with SETF." - (with-pathname (pathname pathname) - (let ((search-list (extract-search-list pathname t)) - (host (pathname-host pathname))) - (if (search-list-defined search-list) - (mapcar #'(lambda (directory) - (make-pathname :host host - :directory (cons :absolute directory))) - (search-list-expansions search-list)) - (error "Search list ~S has not been defined yet." pathname))))) - -;;; SEARCH-LIST-DEFINED-P -- public. -;;; -(defun search-list-defined-p (pathname) - "Returns T if the search-list starting PATHNAME is currently defined, and - NIL otherwise. An error is signaled if PATHNAME does not start with a - search-list." - (with-pathname (pathname pathname) - (search-list-defined (extract-search-list pathname t)))) - -;;; %SET-SEARCH-LIST -- public setf method -;;; -;;; Set the expansion for the search-list in PATHNAME. If this would result -;;; in any circularities, we flame out. If anything goes wrong, we leave the -;;; old defintion intact. -;;; -(defun %set-search-list (pathname values) - (let ((search-list (extract-search-list pathname t))) - (labels - ((check (target-list path) - (when (eq search-list target-list) - (error "That would result in a circularity:~% ~ - ~A~{ -> ~A~} -> ~A" - (search-list-name search-list) - (reverse path) - (search-list-name target-list))) - (when (search-list-p target-list) - (push (search-list-name target-list) path) - (dolist (expansion (search-list-expansions target-list)) - (check (car expansion) path)))) - (convert (pathname) - (with-pathname (pathname pathname) - (when (or (pathname-name pathname) - (pathname-type pathname) - (pathname-version pathname)) - (error "Search-lists cannot expand into pathnames that have ~ - a name, type, or ~%version specified:~% ~S" - pathname)) - (let ((directory (pathname-directory pathname))) - (let ((expansion - (if directory - (ecase (car directory) - (:absolute (cdr directory)) - (:relative (cons (intern-search-list "default") - (cdr directory)))) - (list (intern-search-list "default"))))) - (check (car expansion) nil) - expansion))))) - (setf (search-list-expansions search-list) - (if (listp values) - (mapcar #'convert values) - (list (convert values))))) - (setf (search-list-defined search-list) t)) - values) - -;;; ENUMERATE-SEARCH-LIST -- public. -;;; -(defmacro enumerate-search-list ((var pathname &optional result) &body body) - "Execute BODY with VAR bound to each successive possible expansion for - PATHNAME and then return RESULT. Note: if PATHNAME does not contain a - search-list, then BODY is executed exactly once. Everything is wrapped - in a block named NIL, so RETURN can be used to terminate early. Note: - VAR is *not* bound inside of RESULT." - (let ((body-name (gensym))) - `(block nil - (flet ((,body-name (,var) - ,@body)) - (%enumerate-search-list ,pathname #',body-name) - ,result)))) - -(defun %enumerate-search-list (pathname function) - (let ((search-list (extract-search-list pathname nil))) - (cond - ((not search-list) - (funcall function pathname)) - ((not (search-list-defined search-list)) - (error "Undefined search list: ~A" - (search-list-name search-list))) - (t - (let ((tail (cddr (pathname-directory pathname)))) - (dolist (expansion - (search-list-expansions search-list)) - (%enumerate-search-list (make-pathname :defaults pathname - :directory - (cons :absolute - (append expansion - tail))) - function))))))) - - -;;;; Logical pathname support. ANSI 92-102 specification. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Logical pathnames have the following format: -;;; -;;; logical-namestring ::= -;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]] -;;; -;;; host ::= word -;;; directory ::= word | wildcard-word | ** -;;; name ::= word | wildcard-word -;;; type ::= word | wildcard-word -;;; version ::= pos-int | newest | NEWEST | * -;;; word ::= {uppercase-letter | digit | -}+ -;;; wildcard-word ::= [word] '* {word '*}* [word] -;;; pos-int ::= integer > 0 -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Logical pathnames are a subclass of pathnames and can use the same -;; data structures with the device slot necessarily nil. The current lack of -;; an integrated efficient CLOS means that the classes are mimiced using -;; structures. They follow the pattern set by search-lists, a CMUCL specific -;; extension. - -(defstruct (logical-host - (:include host - (:parse #'parse-logical-namestring) - (:unparse #'unparse-logical-namestring) - (:unparse-host #'unparse-logical-host) - (:unparse-directory #'unparse-logical-directory) - (:unparse-file #'unparse-logical-file) - (:unparse-enough #'identity) - (:customary-case :upper))) - (name "" :type simple-string) - (translations nil :type list) - (canon-transls nil :type list)) - -(deftype logical-pathname () - '(satisfies logical-pathname-p)) - -;;; LOGICAL-PATHNAME-P -- Public -;;; -(defun logical-pathname-p (thing) - "Return T if THING is a LOGICAL-PATHNAME object." - (and (pathnamep thing) - (logical-host-p (%pathname-host thing)))) - -;;; *LOGICAL-PATHNAMES* --internal. -;;; -;;; Hash table searching maps a logical-pathname's host to their physical -;;; pathname translation. - -(defvar *logical-pathnames* (make-hash-table :test #'equal)) - -(define-condition logical-namestring-parse-error (error) - ((complaint :init-form (required-argument)) - (arguments :init-form nil) - (namestring :init-form (required-argument)) - (offset :init-form (required-argument))) - (:report %print-namestring-parse-error)) - -;;; MAYBE-MAKE-LOGICAL-PATTERN -- Internal -;;; -(defun maybe-make-logical-pattern (namestr start end) - "Take the ; reduced strings and break them into words and wildcard-words." - (declare (type simple-base-string namestr) - (type index start end)) - (collect ((pattern)) - (let ((last-regular-char nil) - (look-ahead+1 nil) - (index start) - (char nil)) - (flet ((flush-pending-regulars () - (when last-regular-char - (pattern (subseq namestr last-regular-char index)) - (setf last-regular-char nil)))) - (loop - (when (>= index end) - (return)) - (setf char (schar namestr index)) - (cond ((or (char= #\. char) (char= #\; char)) ; End of pattern piece. - (flush-pending-regulars)) - ((or (char= #\- char) ; Hyphen is a legal word character. - (alphanumericp char)) ; Building a word. - (unless last-regular-char - (setf last-regular-char index))) - ((char= #\* char) ; Wildcard word, :wild or wildcard-inferior. - (if (<= end index) - (setf look-ahead+1 nil) - (setf look-ahead+1 (schar namestr (1+ index)))) - (cond ((or (char= #\. look-ahead+1) - (char= #\; look-ahead+1)) - (flush-pending-regulars) - (pattern :wild) - (incf index)) ; skip * and ; - ((and (char= #\* look-ahead+1) - (char= #\; (schar namestr (+ 2 index)))) - (pattern :wild-inferiors) - (setq last-regular-char nil) - (incf index 2)) ; skip ** and ; - (t ; wildcard-word, keep going - (flush-pending-regulars) - (pattern :wild) - (incf index) - (unless last-regular-char - (setf last-regular-char index)) - ))) - (t (error "Incorrect logical pathname syntax."))) - (incf index)) - (flush-pending-regulars)) - (cond ((null (pattern)) - "") - ((and (null (cdr (pattern))) - (simple-string-p (car (pattern)))) - (car (pattern))) - ((= 1 (length (pattern))) - (let ((elmt (first (pattern)))) - (if (or (eq elmt :wild) (eq elmt :wild-inferiors)) - elmt))) - (t - (make-pattern (pattern))))))) - -;;; INTERN-LOGICAL-HOST -;;; -(defun intern-logical-host (name) - (declare (simple-string name) - (values logical-host)) - (let ((name (string-upcase name))) - (or (gethash name *logical-pathnames*) - (let ((new (make-logical-host :name name))) - (setf (gethash name *logical-pathnames*) new) - new)))) - -;;; EXTRACT-LOGICAL-NAME-TYPE-AND-VERSION -;;; -(defun extract-logical-name-type-and-version (namestr start end) - (declare (type simple-base-string namestr) - (type index start end)) - (let* ((last-dot (position #\. namestr :start (1+ start) :end end - :from-end t)) - (second-to-last-dot (and last-dot - (position #\. namestr :start (1+ start) - :end last-dot :from-end t))) - (version :newest)) - ;; If there is a second-to-last dot, check to see if there is a valid - ;; version after the last dot. - (when second-to-last-dot - (cond ((and (= (+ last-dot 2) end) - (char= (schar namestr (1+ last-dot)) #\*)) - (setf version :wild)) - ((and (< (1+ last-dot) end) - (do ((index (1+ last-dot) (1+ index))) - ((= index end) t) - (unless (char<= #\0 (schar namestr index) #\9) - (return nil)))) - (setf version - (parse-integer namestr :start (1+ last-dot) :end end))) - (t - (setf second-to-last-dot nil)))) - (cond (second-to-last-dot - (values (maybe-make-logical-pattern - namestr start second-to-last-dot) - (maybe-make-logical-pattern - namestr (1+ second-to-last-dot) last-dot) - version)) - (last-dot - (values (maybe-make-logical-pattern namestr start last-dot) - (maybe-make-logical-pattern namestr (1+ last-dot) end) - version)) - (t - (values (maybe-make-logical-pattern namestr start end) - nil - version))))) - -;;; LOGICAL-WORD-P -- Internal -;;; -;;; Predicate for testing whether the syntax of the word is consistent -;;; with the form of a logical host. -;;; -(defun logical-word-p (word) - (declare (type simple-base-string word) - (values boolean)) - (let ((ch nil)) - (dotimes (i (length word)) - (setf ch (schar word i)) - (unless (or (alphanumericp ch) (eq ch #\-)) - (return-from logical-word-p nil)))) - t) - -;;; MAYBE-EXTRACT-LOGICAL-HOST -- Internal -;;; Verify whether there is a logical host prefix in the namestr. If one is -;;; found return its name and the index of the remainder of the namestring. -;;; If not return nil. -;;; -(defun maybe-extract-logical-host (namestr start end) - (declare (type simple-base-string namestr) - (type index start) - (type index start end) - (values (or (member :wild) simple-base-string null) (or null index))) - (let ((colon-pos (position #\: namestr :start start :end end))) - (if colon-pos - (let ((host (subseq namestr start colon-pos))) - (cond ((logical-word-p host) - (return-from maybe-extract-logical-host - (values (string-upcase host) (1+ colon-pos)))) - ((string= host "*") - (return-from maybe-extract-logical-host - (values :wild (1+ colon-pos)))))) - ;; Implied host - (values nil 0)))) - -;;; PARSE-LOGICAL-NAMESTRING -- Internal -;;; -;;; Break up a logical-namestring into its constituent parts. -;;; -(defun parse-logical-namestring (namestr start end) - - (declare (type simple-base-string namestr) - (type index start end) - (values (or logical-host null) - (or (member nil :unspecific) simple-base-string) - list - (or simple-base-string list pattern (member :wild)) - (or simple-string pattern null (member :unspecific :wild)) - (or integer null (member :newest :wild)))) - (multiple-value-bind ; Parse for : - (host place) - (maybe-extract-logical-host namestr start end) - (typecase host - (keyword t) ; :wild for example. - (simple-string ; Already a search-list element? - (unless (gethash (string-downcase host) *search-lists*) - (setf host (intern-logical-host host)))) - (null nil)) - (multiple-value-bind - (absolute pieces) - (split-at-slashes namestr place end #\;) - ;; Logical paths follow opposite convention of physical pathnames. - (setf absolute (not absolute)) - (multiple-value-bind (name type version) - (let* ((tail (car (last pieces))) - (tail-start (car tail)) - (tail-end (cdr tail))) - (unless (= tail-start tail-end) - (setf pieces (butlast pieces)) - (extract-logical-name-type-and-version - namestr tail-start tail-end))) - ;; Now we have everything we want. So return it. - (values host - :unspecific - (collect ((dirs)) - (dolist (piece pieces) - (let ((piece-start (car piece)) - (piece-end (cdr piece))) - (unless (= piece-start piece-end) - (let ((dir (maybe-make-logical-pattern namestr - piece-start - piece-end))) - (if (and (simple-string-p dir) - (string= dir "..")) - (dirs :up) - (dirs dir)))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - (cons :relative (dirs))) - (t - nil))) - name - type - version))))) - -;;; UNPARSE-LOGICAL-DIRECTORY-LIST -- Internal -;;; -(defun unparse-logical-directory-list (directory) - (declare (type list directory)) - (collect ((pieces)) - (when directory - (ecase (pop directory) - (:absolute - ;; Nothing special. - ) - (:relative - (pieces ";") - )) - (dolist (dir directory) - (cond ((or (stringp dir) (pattern-p dir)) - (pieces (unparse-logical-piece dir)) - (pieces ";")) - ((eq dir :wild) - (pieces "*;")) - ((eq dir :wild-inferiors) - (pieces "**;")) - (t - (error "Invalid directory component: ~S" dir))))) - (apply #'concatenate 'simple-string (pieces)))) - -;;; UNPARSE-LOGICAL-DIRECTORY -- Internal -;;; -(defun unparse-logical-directory (pathname) - (declare (type pathname pathname)) - (unparse-logical-directory-list (%pathname-directory pathname))) - -;;; UNPARSE-LOGICAL-PIECE -- Internal -;;; -(defun unparse-logical-piece (thing) - (etypecase thing - (simple-string - (let* ((srclen (length thing)) - (dstlen srclen)) - (dotimes (i srclen) - (case (schar thing i) - (#\* - (incf dstlen)))) - (let ((result (make-string dstlen)) - (dst 0)) - (dotimes (src srclen) - (let ((char (schar thing src))) - (case char - (#\* - (setf (schar result dst) #\\) - (incf dst))) - (setf (schar result dst) char) - (incf dst))) - result))) - (pattern - (collect ((strings)) - (dolist (piece (pattern-pieces thing)) - (typecase piece - (simple-string - (strings piece)) - (keyword - (cond ((eq piece :wild-inferiors) - (strings "**")) - ((eq piece :wild) - (strings "*")) - (t (error "Invalid keyword: ~S" piece)))) - (t - (error "Invalid pattern piece: ~S" piece)))) - (apply #'concatenate - 'simple-string - (strings)))))) - -;;; UNPARSE-LOGICAL-FILE -- Internal -;;; -(defun unparse-logical-file (pathname) - (declare (type pathname pathname)) - (declare (type pathname pathname)) - (unparse-unix-file pathname)) - -;;; UNPARSE-LOGICAL-HOST -- Internal -;;; -(defun unparse-logical-host (pathname) - (declare (type logical-pathname pathname)) - (logical-host-name (%pathname-host pathname))) - -;;; UNPARSE-LOGICAL-NAMESTRING -- Internal -;;; -(defun unparse-logical-namestring (pathname) - (declare (type logical-pathname pathname)) - (concatenate 'simple-string - (unparse-logical-host pathname) ":" - (unparse-logical-directory pathname) - (unparse-logical-file pathname))) - -;;; LOGICAL-PATHNAME -- Public -;;; -;;; Logical-pathname must signal a type error of type type-error. -;;; -(defun logical-pathname (pathspec) - "Converts the pathspec argument to a logical-pathname and returns it." - (declare (type (or logical-pathname string stream) pathspec) - (values logical-pathname)) - ;; Decide whether to typedef logical-pathname, logical-pathname-string, - ;; or streams for which the pathname function returns a logical-pathname. - (cond ((logical-pathname-p pathspec) pathspec) - ((stringp pathspec) - (if (maybe-extract-logical-host pathspec 0 (length pathspec)) - (pathname pathspec) - (error "Pathspec is not a logical pathname prefaced by <host>:."))) - ((streamp pathspec) - (if (logical-pathname-p pathspec) - (pathname pathspec) - (error "Stream ~S is not a logical-pathname." pathspec))) - (t - (error "~S is not either ~% - a logical-pathname object, or~% - a logical pathname namestring, or~% - a stream named by a logical pathname." pathspec)))) - -;;; TRANSLATIONS-TEST-P -;;; -;;; Verify that the list of translations consists of lists and prepare -;;; canonical translations from the pathnames. -;;; -(defun translations-test-p (transl-list host) - (declare (type logical-host host) - (type list transl-list) - (values boolean)) - (let ((can-transls nil)) - (setf can-transls (make-list (length transl-list)) - (logical-host-canon-transls host) can-transls) - (do* ((i 0 (1+ i)) - (tr (nth i transl-list) (nth i transl-list)) - (from-path (first tr) (first tr)) - (to-path (second tr) (second tr)) - (c-tr (nth i can-transls) (nth i can-transls))) - ((<= (length transl-list) i)) - (setf c-tr (make-list 2)) - (if (logical-pathname-p from-path) - (setf (first c-tr) from-path) - (setf (first c-tr) (parse-namestring from-path host))) - (if (pathnamep to-path) - (setf (second c-tr) to-path) - (setf (second c-tr) (parse-namestring to-path))) - ;; Verify form of translations. - (unless (and (or (logical-pathname-p from-path) - (first c-tr)) - (second c-tr)) - (return-from translations-test-p nil)) - (setf (nth i can-transls) c-tr))) - (setf (logical-host-translations host) transl-list) - t) - -;;; LOGICAL-PATHNAME-TRANSLATIONS -- Public -;;; -(defun logical-pathname-translations (host) - "Return the (logical) host object argument's list of translations." - (declare (type (or simple-base-string logical-host) host) - (values list)) - (etypecase host - (simple-string - (setf host (string-upcase host)) - (let ((host-struc (gethash host *logical-pathnames*))) - (if host-struc - (logical-host-translations host-struc) - (error "HOST ~S is not defined." host)))) - (logical-host - (logical-host-translations host)))) - -;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public -;;; -(defun (setf logical-pathname-translations) (translations host) - "Set the translations list for the logical host argument. - Return translations." - (declare (type (or simple-base-string logical-host) host) - (type list translations) - (values list)) - (typecase host - (simple-base-string - (setf host (string-upcase host)) - (multiple-value-bind - (hash-host xst?) - (gethash host *logical-pathnames*) - (unless xst? - (intern-logical-host host) - (setf hash-host (gethash host *logical-pathnames*))) - (unless (translations-test-p translations hash-host) - (error "Translations ~S is not a list of pairs of from-, ~ - to-pathnames." translations))) - translations) - (t - (unless (translations-test-p translations host) - (error "Translations ~S is not a list of pairs of from-, ~ - to-pathnames." translations)) - translations))) - -;;; The search mechanism for loading pathname translations uses the CMUCL -;;; extension of search-lists. The user can add to the library: search-list -;;; using setf. The file for translations should have the name defined by -;;; the hostname (a string) and with type component "translations". - -;;; SAVE-LOGICAL-PATHNAME-TRANSLATIONS -- Public -;;; -(defun save-logical-pathname-translations (host directory) - "Save the translations for host in the file named host in - the directory argument. This is an internal convenience function and - not part of the ANSI standard." - (declare (type simple-base-string host directory)) - (setf host (string-upcase host)) - (let* ((p-name (make-pathname :directory (%pathname-directory - (pathname directory)) - :name host - :type "translations" - :version :newest)) - (new-stuff (gethash host *logical-pathnames*)) - (new-transl (logical-host-translations new-stuff))) - (with-open-file (out-str p-name - :direction :output - :if-exists :new-version - :if-does-not-exist :create) - (write new-transl :stream out-str) - (format t "Created a new version of the file:~% ~ - ~S~% ~ - containing logical-pathname translations:~% ~ - ~S~% ~ - for the host:~% ~ - ~S.~%" p-name new-transl host)))) - -;;; Define a SYS area for system dependent logical translations, should we -;;; ever want to use them. ########### Decision still need to made whether -;;; to take advantage of this area. - -#| -(progn - (intern-logical-host "SYS") - (save-logical-pathname-translations "SYS" "library:")) -|# -;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public -;;; -(defun load-logical-pathname-translations (host) - "Search for a logical pathname named host, if not already defined. If already - defined no attempt to find or load a definition is attempted and NIL is - returned. If host is not already defined, but definition is found and loaded - successfully, T is returned, else error." - (declare (type simple-base-string host) - (values boolean)) - (setf host (string-upcase host)) - (let ((p-name nil) - (p-trans nil)) - (multiple-value-bind - (log-host xst?) - (gethash host *logical-pathnames*) - (if xst? - ;; host already has a set of defined translations. - (return-from load-logical-pathname-translations nil) - (enumerate-search-list (p "library:") - (setf p-name (make-pathname :host (%pathname-host p) - :directory (%pathname-directory p) - :device (%pathname-device p) - :name host - :type "translations" - :version :newest)) - (if (member p-name (directory p) :test #'pathname=) - (with-open-file (in-str p-name - :direction :input - :if-does-not-exist :error) - (setf p-trans (read in-str)) - (setf log-host (intern-logical-host host)) - (format t ";; Loading ~S~%" p-name) - (unless (translations-test-p p-trans log-host) - (error "Translations ~S is not a list of pairs of from-, ~ - to-pathnames." p-trans)) - (format t ";; Loading done.~%") - (return-from load-logical-pathname-translations t)))))))) - -;;; COMPILE-FILE-PATHNAME -- Public -;;; -(defun compile-file-pathname (file-path &key output-file) - (declare (type (or string stream pathname logical-pathname) file-path) - (type (or string stream pathname logical-pathname) output-file) - (values pathname)) - (with-pathname (path file-path) - (cond ((and (logical-pathname-p path) (not output-file)) - (make-pathname :host (%pathname-host path) - :directory (%pathname-directory path) - :device (%pathname-device path) - :name (%pathname-name path) - :type (c:backend-fasl-file-type c:*backend*))) - ((logical-pathname-p path) - (translate-logical-pathname path)) - (t file-path)))) - -;;; TRANSLATE-WILD-P -- Internal -;;; -(defmacro translate-wild-p (to-obj) - "Translate :wild?" - (declare (type keyword to-obj)) - `(etypecase ,to-obj - ((or (member :wild :unspecific nil :up :back) - string - pattern) - t))) - -;;; INTERMEDIATE-REP -- Internal -;;; -(defun intermediate-rep (from to) - "A logical component transition function that translates from one argument - to the other. This function is specific to the CMUCL implementation." - (declare (type (or logical-host host simple-base-string pattern symbol list) - from) - (type (or logical-host host simple-base-string pattern symbol list) - to) - (values - (or logical-host host simple-base-string pattern list symbol))) - (etypecase from - (logical-host - (if (or (host-p to) (logical-host-p to)) - to)) - (host - (if (host-p to) - to)) - (simple-base-string - (etypecase to - (pattern - (multiple-value-bind - (won subs) - (pattern-matches to from) - (if won - (values (substitute-into to subs)) - (error "String ~S failed to match pattern ~S" from to)))) - (simple-base-string to) - ((member nil :wild :wild-inferiors) from))) - (pattern - (etypecase to - (pattern - (if (pattern= to from) - to - (error "Patterns ~S and ~S do not match."))))) - ((member :absolute :relative) - (if (eq to from) - to - (error "The directory bases (FROM = ~S, TO = ~S) for the logical ~%~ - pathname translation are not consistently relative or absolute." from to))) - ((member :wild) - (etypecase to - ((or string - pattern - (member nil :unspecific :newest :wild :wild-inferiors)) - to))) - ((member :wild-inferiors) ; Only when single directory component. - (etypecase to - ((or string pattern cons (member nil :unspecific :wild :wild-inferiors)) - to))) - ((member :unspecific nil) - from) - ((member :newest) - (case to - (:wild from) - (:unspecific :unspecific) - (:newest to) - ((member nil) from))))) - -(proclaim '(inline translate-logical-component)) - -;;; TRANSLATE-LOGICAL-COMPONENT -- Internal -;;; -(defun translate-logical-component (source from to) - (intermediate-rep (intermediate-rep source from) to)) - -;;; TRANSLATE-LOGICAL-DIRECTORY -- Internal -;;; -;;; Translate logical directories within the UNIX heirarchical file system. -;;; -(defun translate-logical-directory (source from to) - ;; Handle unfilled components. - (if (or (eql source :UNSPECIFIC) - (eql from :UNSPECIFIC) - (eql to :UNSPECIFIC)) - (return-from translate-logical-directory :UNSPECIFIC)) - (if (or (not source) (not from) (not to)) - (return-from translate-logical-directory nil)) - ;; Handle directory component abbreviated as a wildcard. - (if (member source '(:WILD :WILD-INFERIORS)) - (setf source '(:ABSOLUTE :WILD-INFERIORS))) - (if (member source '(:WILD :WILD-INFERIORS)) - (setf source '(:ABSOLUTE :WILD-INFERIORS))) - (if (member source '(:WILD :WILD-INFERIORS)) - (setf to '(:ABSOLUTE :WILD-INFERIORS))) - ;; Make two stage translation, storing the intermediate results in ires - ;; and finally returned in the list rres. - (let ((ires nil) - (rres nil) - (dummy nil) - (slen (length source)) - (flen (length from)) - (tlen (length to))) - (do* ((i 0 (1+ i)) - (j 0 (1+ j)) - (k 0) - (s-el (nth i source) (nth i source)) - (s-next-el nil) - (f-el (nth j from) (nth j from))) - ((<= slen i)) - (cond ((eq s-el :wild-inferiors) - (setf s-next-el (nth (+ 1 i) source)) ; NIL if beyond end. - (cond ((setf k (position s-next-el from :start (1+ j))) - ;; Found it, splice this portion into ires. - (setf ires - (append ires - (subseq from j (1- k))) - j (1- k))) - (t - ;; Either did not find next source element in from, - ;; or was nil. - (setf ires - (append ires - (subseq from j flen))) - (unless (= i (1- slen)) - (error "Source ~S inconsistent with from translation ~ - ~S~%." source from))))) - (t - (setf ires (append ires (list (intermediate-rep s-el f-el))))))) - ;; Remember to add leftover elements of from. - (if (< slen flen) - (setf ires (append ires (last from (- flen slen))))) - (do* ((i 0 (1+ i)) - (j 0 (1+ j)) - (k 0) - (irlen (length ires)) - (ir-el (nth i ires) (nth i ires)) - (ir-next-el nil) - (t-el (nth j to) (nth j to))) - ((<= tlen i)) - ;; Remember to add leftover elements of to. - (cond ((eq ir-el :wild-inferiors) - (setf ir-next-el (nth (+ 1 i) ires)) ; NIL if beyond end. - (cond ((setf k (position ir-next-el from :start (1+ j))) - ;; Found it, splice this portion into rres. - (setf rres - (append rres - (subseq from j (1- k))) - j (1- k))) - (t - ;; Either did not find next source element in from, - ;; or was nil. - (setf rres - (append rres - (subseq from j tlen))) - (unless (= i (1- irlen)) - (error "Intermediate path ~S inconsistent with to~ - translation ~S~%." ires to))))) - (t (if (setf dummy (intermediate-rep ir-el t-el)) - (setf rres (append rres (list dummy))))))) - (if (< flen tlen) - (setf rres (append rres (last to (- tlen flen))))) - rres)) - -;;; A physical-pathname is a pathname that does not contain any wildcards, -;;; but is not a logical-pathname. - -(deftype physical-pathname () - '(and (satisfies pathnamep) - (not (or (satisfies wild-pathname-p) - (satisfies logical-pathname-p))))) - -;;; TRANSLATE-LOGICAL-PATHNAME -- Public -;;; -(defun translate-logical-pathname (pathname &key) - "Translates pathname to a physical pathname, which is returned." - (declare (type logical-pathname pathname)) - (with-pathname (source pathname) - (etypecase source - (physical-pathname source) - (logical-pathname - (let ((source-host (%pathname-host source)) - (result-path nil)) - (unless (gethash - (funcall (logical-host-unparse-host source-host) source) - *logical-pathnames*) - (error "The logical host ~S is not defined.~%" - (logical-host-name source-host))) - (dolist (src-transl (logical-host-canon-transls source-host) - (error "~S has no matching translation for ~ - logical host ~S.~%" - pathname (logical-host-name source-host))) - (when (pathname-match-p source (first src-transl)) - (macrolet ((frob (field) - `(let* ((from (first src-transl)) - (to (second src-transl)) - (result (translate-logical-component - (,field source) - (,field from) - (,field to)))) - result))) - (setf result-path - (%make-pathname (frob %pathname-host) - :unspecific - (let* ((from (first src-transl)) - (to (second src-transl)) - (result - (translate-logical-directory - (%pathname-directory source) - (%pathname-directory from) - (%pathname-directory to)))) - (if (eq result :error) - (error "~S doesn't match ~S" - source from) - result)) - (frob %pathname-name) - (frob %pathname-type) - (frob %pathname-version)))) - (etypecase result-path - (logical-pathname - (translate-logical-pathname result-path)) - (physical-pathname - (return-from translate-logical-pathname result-path)))))))))) - - - - diff --git a/code/pmax-disassem.lisp b/code/pmax-disassem.lisp deleted file mode 100644 index 02c5701c07ebbd64efc5dca4f958a351c0c2d2f0..0000000000000000000000000000000000000000 --- a/code/pmax-disassem.lisp +++ /dev/null @@ -1,517 +0,0 @@ -;;; -*- Mode: Lisp; Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/code/pmax-disassem.lisp,v 1.17 1991/02/08 13:34:36 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; A simple dissambler for the MIPS R2000. -;;; -;;; Written by Christopher Hoover. -;;; - -(in-package "MIPS" :use '("LISP")) - -(export '(register-name disassemble-code-vector)) - - -;;;; Instruction Layout - -;;; -;;; Each instrunction on the MIPS R2000 consists of a single word (32 -;;; bits) aligned on a single word boundaray. There are three -;;; instrunction formats: -;;; -;;; I-Type (Immediate) -;;; -;;; 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 -;;; 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 -;;; --------------------------------------------------------------- -;;; [ op ] [ rs ] [ rt ] [ immediate ] -;;; --------------------------------------------------------------- -;;; -;;; -;;; J-Type (Jump) -;;; -;;; 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 -;;; 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 -;;; --------------------------------------------------------------- -;;; [ op ] [ target ] -;;; --------------------------------------------------------------- -;;; -;;; -;;; R-Type (Register) -;;; -;;; 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 -;;; 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 -;;; --------------------------------------------------------------- -;;; [ op ] [ rs ] [ rt ] [ rd ] [ shmat ] [ funct ] -;;; --------------------------------------------------------------- -;;; -;;; These instructions fall into 5 categories: Load/Store, -;;; Computational, Jump/Branch, Coprocessor, and Special. -;;; - - -;;;; Register Names - -(defun register-name (register-number) - (unless (<= 0 register-number 31) - (error "Illegal register number!")) - (svref *register-names* register-number)) - - - -;;;; Instruction Type Definition - -;;; -;;; These instruction types correspond to the various ways the decoded -;;; instructions are printed which in turn corresponds somewhat to the -;;; way the instructions are decoded. -;;; - -(defvar *mips-instruction-types* (make-hash-table :test #'eq)) - -(defmacro def-mips-instruction-type (types &body body) - `(let ((closure #'(lambda (name word stream) ,@body))) - (dolist (type ',types) - (when (gethash type *mips-instruction-types*) - (warn "Instruction type ~S being redefined" type)) - (setf (gethash type *mips-instruction-types*) closure)))) - -(defun mips-instruction-type-p (type) - (not (not (gethash type *mips-instruction-types*)))) - - -;;;; Instruction Types - -;;; -;;; Used later for relative branches. -(defvar *current-instruction-number* 0) - -(def-mips-instruction-type (:ls-type) - (let ((rs (ldb (byte 5 21) word)) - (rt (ldb (byte 5 16) word)) - (immed (signed-ldb (byte 16 0) word))) - (format stream "~16,8T~A~8,8T~A, #x~X(~A)~%" - name (register-name rt) immed (register-name rs)))) - -(def-mips-instruction-type (:si-type) - (let ((rs (ldb (byte 5 21) word)) - (rt (ldb (byte 5 16) word)) - (immed (signed-ldb (byte 16 0) word))) - (cond ((and (zerop rs) (or (string= name "ADDI") (string= name "ADDIU"))) - (format stream "~16,8TLOADI~8,8T~A, #x~X~%" - (register-name rt) immed)) - ((and (= rs null-offset) (string= name "ADDI")) - ;; Major hack ... - (format stream "~16,8T~A~8,8T~A, ~A, #x~X~48,8T; ~S~%" - name (register-name rt) (register-name rs) immed - (vm:offset-static-symbol immed))) - (t - (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%" - name (register-name rt) (register-name rs) immed))))) - -(def-mips-instruction-type (:ui-type) - (let ((rs (ldb (byte 5 21) word)) - (rt (ldb (byte 5 16) word)) - (immed (ldb (byte 16 0) word))) - (cond ((and (zerop rs) (or (string= name "ORI") (string= name "XORI"))) - (format stream "~16,8TLOADI~8,8T~A, #x~X~%" - (register-name rt) immed)) - (t - (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%" - name (register-name rt) (register-name rs) immed))))) - -(def-mips-instruction-type (:lui-type) - (let ((rt (ldb (byte 5 16) word)) - (immed (ldb (byte 16 0) word))) - (format stream "~16,8T~A~8,8T~A, #x~X~%" name (register-name rt) immed))) - -(def-mips-instruction-type (:j-type) - (let ((target (ldb (byte 26 0) word))) - (format stream "~16,8T~A~8,8Ttarget = ~D~%" name target))) - -(def-mips-instruction-type (:jr-type) - (let ((rs (ldb (byte 5 21) word))) - (format stream "~16,8T~A~8,8T~A~%" name (register-name rs)))) - -(def-mips-instruction-type (:jalr-type) - (let ((rs (ldb (byte 5 21) word)) - (rd (ldb (byte 5 11) word))) - (format stream "~16,8T~A~8,8T~A, ~A~%" name - (register-name rd) (register-name rs)))) - -(defun branch-target (offset) - (+ *current-instruction-number* offset 1)) - -(def-mips-instruction-type (:branch-type) - (let ((rs (ldb (byte 5 21) word)) - (offset (signed-ldb (byte 16 0) word))) - (format stream "~16,8T~A~8,8T~A, ~D~%" name - (register-name rs) (branch-target offset)))) - -(def-mips-instruction-type (:branch2-type) - (let* ((rs (ldb (byte 5 21) word)) - (rt (ldb (byte 5 16) word)) - (offset (signed-ldb (byte 16 0) word)) - (target (branch-target offset))) - (cond ((and (zerop rs) (zerop rt) (string= name "BEQ")) - (format stream "~16,8TB~8,8T~D~%" target)) - (t - (format stream "~16,8T~A~8,8T~A, ~A, ~D~%" name - (register-name rs) (register-name rt) target))))) - -(def-mips-instruction-type (:r3-type) - (let ((rs (ldb (byte 5 21) word)) - (rt (ldb (byte 5 16) word)) - (rd (ldb (byte 5 11) word))) - (cond ((zerop rd) - ;; Hack for NOP - (format stream "~16,8TNOP~%")) - ((and (zerop rt) (or (string= name "OR") (string= name "ADDU"))) - ;; Hack for MOVE - (format stream "~16,8TMOVE~8,8T~A, ~A~%" - (register-name rd) (register-name rs))) - (t - (format stream "~16,8T~A~8,8T~A, ~A, ~A~%" - name (register-name rd) (register-name rs) - (register-name rt)))))) - -(def-mips-instruction-type (:mf-type) - (let ((rd (ldb (byte 5 11) word))) - (format stream "~16,8T~A~8,8T~A~%" name (register-name rd)))) - -(def-mips-instruction-type (:mt-type) - (let ((rs (ldb (byte 5 21) word))) - (format stream "~16,8T~A~8,8T~A~%" name (register-name rs)))) - -(def-mips-instruction-type (:mult-type) - (let ((rs (ldb (byte 5 21) word)) - (rt (ldb (byte 5 16) word))) - (format stream "~16,8T~A~8,8T~A, ~A~%" name - (register-name rs) (register-name rt)))) - -(def-mips-instruction-type (:shift-type) - (let ((rt (ldb (byte 5 16) word)) - (rd (ldb (byte 5 11) word)) - (shamt (ldb (byte 5 6) word))) - ;; Hack for NOP - (cond ((= word 0) - (format stream "~16,8TNOP~%")) - (t - (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%" - name (register-name rd) (register-name rt) shamt))))) - -(def-mips-instruction-type (:shiftv-type) - (let ((rs (ldb (byte 5 21) word)) - (rt (ldb (byte 5 16) word)) - (rd (ldb (byte 5 11) word))) - (format stream "~16,8T~A~8,8T~A, ~A, ~A~%" - name (register-name rd) (register-name rt) (register-name rs)))) - -(def-mips-instruction-type (:break-type) - (let ((code (ldb (byte 10 16) word))) ; The entire field is (byte 20 6) - (format stream "~16,8T~A~8,8T#x~X~%" name code))) - -(def-mips-instruction-type (:syscall-type) - (declare (ignore word)) - (format stream "~16,8T~A~%" name)) - -(def-mips-instruction-type (:cop0-type :cop1-type :cop2-type :cop3-type) - (format stream "~16,8T~A~8,8T(#x~X)~%" name word)) - - -;;;; Instruction Definition - -(defstruct (mips-instruction - (:constructor make-mips-instruction (name type)) - (:print-function %print-mips-instruction)) - (name "" :type simple-string) - type) - -(defun %print-mips-instruction (instr stream depth) - (declare (ignore depth)) - (format stream "#<MIPS instruction ~A>" (mips-instruction-name instr))) - - -(defconstant mips-instruction-bits 6) - -(defvar *mips-instructions* - (make-array (ash 1 mips-instruction-bits) :initial-element nil)) -(proclaim '(type simple-vector *mips-instructions*)) - -(defmacro def-mips-instr (name op-code type) - `(let ((name ,name) - (type ,type)) - (unless (mips-instruction-type-p type) - (warn "~S is an unknown instruction type" type)) - (setf (svref *mips-instructions* ,op-code) - (make-mips-instruction name ,type)) - name)) - - -(defconstant mips-special-instruction-bits 6) - -(defvar *mips-special-instructions* - (make-array (ash 1 mips-special-instruction-bits) :initial-element nil)) -(proclaim '(type simple-vector *mips-special-instructions*)) - -(defmacro def-mips-special-instr (name op-code type) - `(let ((name ,name) - (type ,type)) - (unless (mips-instruction-type-p type) - (warn "~S is an unknown instruction type" type)) - (setf (svref *mips-special-instructions* ,op-code) - (make-mips-instruction name ,type)) - name)) - - -(defconstant mips-bcond-instruction-bits 6) - -(defvar *mips-bcond-instructions* - (make-array (ash 1 mips-bcond-instruction-bits) :initial-element nil)) -(proclaim '(type simple-vector *mips-bcond-instructions*)) - -(defmacro def-mips-bcond-instr (name op-code type) - `(let ((name ,name) - (type ,type)) - (unless (mips-instruction-type-p type) - (warn "~S is an unknown instruction type" type)) - (setf (svref *mips-bcond-instructions* ,op-code) - (make-mips-instruction name ,type)) - name)) - - -;;;; Normal Opcodes - -(def-mips-instr "J" #b000010 :j-type) -(def-mips-instr "JAL" #b000011 :j-type) -(def-mips-instr "BEQ" #b000100 :branch2-type) -(def-mips-instr "BNE" #b000101 :branch2-type) -(def-mips-instr "BLEZ" #b000110 :branch-type) -(def-mips-instr "BGTZ" #b000111 :branch-type) - -(def-mips-instr "ADDI" #b001000 :si-type) -(def-mips-instr "ADDIU" #b001001 :si-type) -(def-mips-instr "SLTI" #b001010 :si-type) -(def-mips-instr "SLTIU" #b001011 :si-type) -(def-mips-instr "ANDI" #b001100 :ui-type) -(def-mips-instr "ORI" #b001101 :ui-type) -(def-mips-instr "XORI" #b001110 :ui-type) -(def-mips-instr "LUI" #b001111 :lui-type) - -(def-mips-instr "COP0" #b010000 :cop0-type) -(def-mips-instr "COP1" #b010001 :cop1-type) -(def-mips-instr "COP2" #b010010 :cop2-type) -(def-mips-instr "COP3" #b010011 :cop3-type) - -(def-mips-instr "LB" #b100000 :ls-type) -(def-mips-instr "LH" #b100001 :ls-type) -(def-mips-instr "LWL" #b100010 :ls-type) -(def-mips-instr "LW" #b100011 :ls-type) -(def-mips-instr "LBU" #b100100 :ls-type) -(def-mips-instr "LHU" #b100101 :ls-type) -(def-mips-instr "LWR" #b100110 :ls-type) - -(def-mips-instr "SB" #b101000 :ls-type) -(def-mips-instr "SH" #b101001 :ls-type) -(def-mips-instr "SWL" #b101010 :ls-type) -(def-mips-instr "SW" #b101011 :ls-type) -(def-mips-instr "SWR" #b101110 :ls-type) - -(def-mips-instr "LWC0" #b110000 :cop0-type) -(def-mips-instr "LWC1" #b110001 :cop1-type) -(def-mips-instr "LWC2" #b110010 :cop2-type) -(def-mips-instr "LWC3" #b110011 :cop3-type) - -(def-mips-instr "SWC0" #b111000 :cop0-type) -(def-mips-instr "SWC1" #b111001 :cop1-type) -(def-mips-instr "SWC2" #b111010 :cop2-type) -(def-mips-instr "SWC3" #b111011 :cop3-type) - - -;;;; SPECIAL Opcodes - -(defconstant special-op #b000000) - -(def-mips-special-instr "SLL" #b000000 :shift-type) -(def-mips-special-instr "SRL" #b000010 :shift-type) -(def-mips-special-instr "SRA" #b000011 :shift-type) -(def-mips-special-instr "SLLV" #b000100 :shiftv-type) -(def-mips-special-instr "SRLV" #b000110 :shiftv-type) -(def-mips-special-instr "SRAV" #b000111 :shiftv-type) - -(def-mips-special-instr "JR" #b001000 :jr-type) -(def-mips-special-instr "JALR" #b001001 :jalr-type) -(def-mips-special-instr "SYSCALL" #b001100 :syscall-type) -(def-mips-special-instr "BREAK" #b001101 :break-type) - -(def-mips-special-instr "MFHI" #b010000 :mf-type) -(def-mips-special-instr "MTHI" #b010001 :mt-type) -(def-mips-special-instr "MFLO" #b010010 :mf-type) -(def-mips-special-instr "MTLO" #b010011 :mt-type) - -(def-mips-special-instr "MULT" #b011000 :mult-type) -(def-mips-special-instr "MULTU" #b011001 :mult-type) -(def-mips-special-instr "DIV" #b011010 :mult-type) -(def-mips-special-instr "DIVU" #b011011 :mult-type) - -(def-mips-special-instr "ADD" #b100000 :r3-type) -(def-mips-special-instr "ADDU" #b100001 :r3-type) -(def-mips-special-instr "SUB" #b100010 :r3-type) -(def-mips-special-instr "SUBU" #b100011 :r3-type) -(def-mips-special-instr "AND" #b100100 :r3-type) -(def-mips-special-instr "OR" #b100101 :r3-type) -(def-mips-special-instr "XOR" #b100110 :r3-type) -(def-mips-special-instr "NOR" #b100111 :r3-type) - -(def-mips-special-instr "SLT" #b101010 :r3-type) -(def-mips-special-instr "SLTU" #b101011 :r3-type) - - -;;;; BCOND Opcodes - -(defconstant bcond-op #b000001) - -(def-mips-bcond-instr "BLTZ" #b00000 :branch-type) -(def-mips-bcond-instr "BLTZAL" #b00001 :branch-type) - -(def-mips-bcond-instr "BLTZAL" #b10000 :branch-type) -(def-mips-bcond-instr "BGEZAL" #b10001 :branch-type) - - -;;;; Signed-Ldb - -(defun signed-ldb (byte-spec integer) - (let ((unsigned (ldb byte-spec integer)) - (length (byte-size byte-spec))) - (if (logbitp (1- length) unsigned) - (- unsigned (ash 1 length)) - unsigned))) - - -;;;; Instruction Decoding - -(defun mips-instruction (word) - (let* ((opcode (ldb (byte 6 26) word))) - (cond ((= opcode special-op) - (let ((function (ldb (byte 6 0) word))) - (svref *mips-special-instructions* function))) - ((= opcode bcond-op) - (let ((cond (ldb (byte 5 16) word))) - (svref *mips-bcond-instructions* cond))) - (t - (svref *mips-instructions* opcode))))) - - -;;;; Disassemble-Instruction - -(defun disassemble-instruction (word &optional (stream t)) - (let* ((instr (mips-instruction word))) - (cond (instr - (let* ((instr-name (mips-instruction-name instr)) - (instr-type (mips-instruction-type instr)) - (closure (gethash instr-type *mips-instruction-types*))) - (cond (closure - (funcall closure instr-name word stream)) - (t - (format stream "UNKNOWN TYPE (~A/~S/#x~X)~%" - instr-name instr-type word))) - (values instr-name instr-type))) - (t - (format stream "~16,8TDATA~8,8T#x~X~%" word) - (return-from disassemble-instruction (values nil nil)))))) - - - -;;; Dissassemble-Code-Vector - -(defconstant delay-slot-instruction-types - '(:j-type :jr-type :jalr-type :branch-type :branch2-type)) - -(defun disassemble-code-vector (code-vector length &optional (stream t)) - (do ((i 0 (+ i 4)) - (*current-instruction-number* 0 (1+ *current-instruction-number*)) - (instruction-in-delay-slot-p nil)) - ((>= i length)) - (unless instruction-in-delay-slot-p - (format stream "~6D:" *current-instruction-number*)) - (multiple-value-bind - (name type) - (disassemble-instruction (logior (aref code-vector i) - (ash (aref code-vector (+ i 1)) 8) - (ash (aref code-vector (+ i 2)) 16) - (ash (aref code-vector (+ i 3)) 24)) - stream) - (declare (ignore name)) - (cond ((member type delay-slot-instruction-types :test #'eq) - (setf instruction-in-delay-slot-p t)) - (t - (setf instruction-in-delay-slot-p nil)))))) - - - -;;;; Disassemble-code-sap - -(defun disassemble-code-sap (sap length &optional (stream t)) - (do ((*current-instruction-number* 0 (1+ *current-instruction-number*)) - (instruction-in-delay-slot-p nil)) - ((>= *current-instruction-number* length)) - (unless instruction-in-delay-slot-p - (format stream "~6D:" *current-instruction-number*)) - (multiple-value-bind - (name type) - (disassemble-instruction (system:sap-ref-32 - sap - *current-instruction-number*) - stream) - (declare (ignore name)) - (cond ((member type delay-slot-instruction-types :test #'eq) - (setf instruction-in-delay-slot-p t)) - (t - (setf instruction-in-delay-slot-p nil)))))) - - -;;;; Disassemble - -(defun compile-function-lambda-expr (function) - (multiple-value-bind - (lambda closurep name) - (function-lambda-expression function) - (declare (ignore name)) - (when closurep - (error "Cannot compile lexical closure.")) - (compile nil lambda))) - -(defun disassemble (object &optional (stream *standard-output*)) - (let* ((function (cond ((or (symbolp object) - (and (listp object) - (eq (car object) 'lisp:setf))) - (let ((temp (fdefinition object))) - (if (eval:interpreted-function-p temp) - (compile-function-lambda-expr temp) - temp))) - ((eval:interpreted-function-p object) - (compile-function-lambda-expr object)) - ((functionp object) - object) - ((and (listp object) - (eq (car object) 'lisp::lambda)) - (compile nil object)) - (t - (error "Invalid argument to disassemble - ~S" - object)))) - (self (system:%primitive function-self function)) - (code (di::function-code-header self))) - (disassemble-code-sap (truly-the system:system-area-pointer - (system:%primitive code-instructions - code)) - (system:%primitive code-code-size code) - stream))) diff --git a/code/pmax-machdef.lisp b/code/pmax-machdef.lisp deleted file mode 100644 index 1e9536445049c425c5851dc478466c70703aa404..0000000000000000000000000000000000000000 --- a/code/pmax-machdef.lisp +++ /dev/null @@ -1,39 +0,0 @@ -;;; -*- Log: code.log; Package: Mach -*- -;;; -;;; ********************************************************************** -;;; 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/code/pmax-machdef.lisp,v 1.2 1991/02/08 13:34:41 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Record definitions needed for the interface to Mach. -;;; -(in-package "MACH") - - -(export '(sigcontext-onstack sigcontext-mask sigcontext-pc sigcontext-regs - sigcontext-mdlo sigcontext-mdhi sigcontext-ownedfp sigcontext-fpregs - sigcontext-fpc_csr sigcontext-fpc_eir sigcontext-cause - sigcontext-badvaddr sigcontext-badpaddr sigcontext *sigcontext - indirect-*sigcontext)) - - -(def-c-record sigcontext - (onstack unsigned-long) - (mask unsigned-long) - (pc system-area-pointer) - (regs int-array) - (mdlo unsigned-long) - (mdhi unsigned-long) - (ownedfp unsigned-long) - (fpregs int-array) - (fpc_csr unsigned-long) - (fpc_eir unsigned-long) - (cause unsigned-long) - (badvaddr system-area-pointer) - (badpaddr system-area-pointer)) diff --git a/code/pmax-vm.lisp b/code/pmax-vm.lisp deleted file mode 100644 index aec8bc20226bb58a7272f7248cbda6dd17d1629d..0000000000000000000000000000000000000000 --- a/code/pmax-vm.lisp +++ /dev/null @@ -1,209 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/code/pmax-vm.lisp,v 1.12 1992/10/08 22:10:34 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.12 1992/10/08 22:10:34 wlott Exp $ -;;; -;;; This file contains the PMAX specific runtime stuff. -;;; -(in-package "MIPS") -(use-package "SYSTEM") -(use-package "ALIEN") -(use-package "C-CALL") -(use-package "UNIX") - -(export '(fixup-code-object internal-error-arguments - sigcontext-program-counter sigcontext-register - sigcontext-float-register sigcontext-floating-point-modes - extern-alien-name sanctify-for-execution)) - - -;;;; The sigcontext structure. - -(def-alien-type sigcontext - (struct nil - (sc-onstack unsigned-long) - (sc-mask unsigned-long) - (sc-pc system-area-pointer) - (sc-regs (array unsigned-long 32)) - (sc-mdlo unsigned-long) - (sc-mdhi unsigned-long) - (sc-ownedfp unsigned-long) - (sc-fpregs (array unsigned-long 32)) - (sc-fpc-csr unsigned-long) - (sc-fpc-eir unsigned-long) - (sc-cause unsigned-long) - (sc-badvaddr system-area-pointer) - (sc-badpaddr system-area-pointer))) - - - -;;;; Add machine specific features to *features* - -(pushnew :decstation-3100 *features*) -(pushnew :pmax *features*) - - - -;;;; MACHINE-TYPE and MACHINE-VERSION - -(defun machine-type () - "Returns a string describing the type of the local machine." - "DECstation") - -(defun machine-version () - "Returns a string describing the version of the local machine." - "DECstation") - - - -;;; FIXUP-CODE-OBJECT -- Interface -;;; -(defun fixup-code-object (code offset fixup kind) - (unless (zerop (rem offset word-bytes)) - (error "Unaligned instruction? offset=#x~X." offset)) - (system:without-gcing - (let ((sap (truly-the system-area-pointer - (%primitive c::code-instructions code)))) - (ecase kind - (:jump - (assert (zerop (ash fixup -26))) - (setf (ldb (byte 26 0) (system:sap-ref-32 sap offset)) - (ash fixup -2))) - (:lui - (setf (sap-ref-16 sap offset) - (+ (ash fixup -16) - (if (logbitp 15 fixup) 1 0)))) - (:addi - (setf (sap-ref-16 sap offset) - (ldb (byte 16 0) fixup))))))) - - -;;;; Internal-error-arguments. - -;;; INTERNAL-ERROR-ARGUMENTS -- interface. -;;; -;;; Given the sigcontext, extract the internal error arguments from the -;;; instruction stream. -;;; -(defun internal-error-arguments (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (let ((pc (slot scp 'sc-pc))) - (declare (type system-area-pointer pc)) - (when (logbitp 31 (slot scp 'sc-cause)) - (setf pc (sap+ pc 4))) - (when (= (sap-ref-8 pc 4) 255) - (setf pc (sap+ pc 1))) - (let* ((length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) - (declare (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) - (copy-from-system-area pc (* vm:byte-bits 5) - vector (* vm:word-bits - vm:vector-data-offset) - (* length vm:byte-bits)) - (let* ((index 0) - (error-number (c::read-var-integer vector index))) - (collect ((sc-offsets)) - (loop - (when (>= index length) - (return)) - (sc-offsets (c::read-var-integer vector index))) - (values error-number (sc-offsets)))))))) - - -;;;; Sigcontext access functions. - -;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. -;;; -(defun sigcontext-program-counter (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (slot scp 'sc-pc))) - -;;; SIGCONTEXT-REGISTER -- Interface. -;;; -;;; An escape register saves the value of a register for a frame that someone -;;; interrupts. -;;; -(defun sigcontext-register (scp index) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (deref (slot scp 'sc-regs) index))) - -(defun %set-sigcontext-register (scp index new) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (setf (deref (slot scp 'sc-regs) index) new) - new)) - -(defsetf sigcontext-register %set-sigcontext-register) - - -;;; SIGCONTEXT-FLOAT-REGISTER -- Interface. -;;; -;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. -;;; Format is the type of float to return. -;;; -(defun sigcontext-float-register (scp index format) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (let ((sap (alien-sap (slot scp 'sc-fpregs)))) - (ecase format - (single-float (system:sap-ref-single sap (* index vm:word-bytes))) - (double-float (system:sap-ref-double sap (* index vm:word-bytes))))))) -;;; -(defun %set-sigcontext-float-register (scp index format new-value) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (let ((sap (alien-sap (slot scp 'sc-fpregs)))) - (ecase format - (single-float - (setf (sap-ref-single sap (* index vm:word-bytes)) new-value)) - (double-float - (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) -;;; -(defsetf sigcontext-float-register %set-sigcontext-float-register) - - -;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface -;;; -;;; Given a sigcontext pointer, return the floating point modes word in the -;;; same format as returned by FLOATING-POINT-MODES. -;;; -(defun sigcontext-floating-point-modes (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (slot scp 'sc-fpc-csr))) - - - -;;; EXTERN-ALIEN-NAME -- interface. -;;; -;;; The loader uses this to convert alien names to the form they occure in -;;; the symbol table (for example, prepending an underscore). On the MIPS, -;;; we don't do anything. -;;; -(defun extern-alien-name (name) - (declare (type simple-base-string name)) - name) - - - -;;; SANCTIFY-FOR-EXECUTION -- Interface. -;;; -;;; Do whatever is necessary to make the given code component executable. -;;; -(defun sanctify-for-execution (component) - (declare (ignore component)) - nil) diff --git a/code/pprint.lisp b/code/pprint.lisp deleted file mode 100644 index 798cd73136befb730482d1f267f80ecae6963c4d..0000000000000000000000000000000000000000 --- a/code/pprint.lisp +++ /dev/null @@ -1,1474 +0,0 @@ -;;; -*- Package: PRETTY-PRINT -*- -;;; -;;; ********************************************************************** -;;; 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/code/pprint.lisp,v 1.13 1992/12/08 20:01:11 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; CMU Common Lisp pretty printer. -;;; Written by William Lott. Algorithm stolen from Richard Waters' XP. -;;; -(in-package "PRETTY-PRINT" :nicknames '("PP")) -(use-package "EXT") -(use-package "KERNEL") - -(export '(pretty-stream pretty-stream-p)) - -(in-package "LISP") -(export '(pprint-logical-block pprint-pop pprint-exit-if-list-exhausted - pprint-newline pprint-indent pprint-tab - pprint-fill pprint-linear pprint-tabular - copy-pprint-dispatch pprint-dispatch set-pprint-dispatch)) -(in-package "PP") - - -;;;; Pretty streams - -;;; There are three different units for measuring character positions: -;;; COLUMN - offset (if characters) from the start of the current line. -;;; INDEX - index into the output buffer. -;;; POSITION - some position in the stream of characters cycling through -;;; the output buffer. -;;; -(deftype column () - '(and fixnum unsigned-byte)) -;;; The INDEX type is picked up from the kernel package. -(deftype position () - 'fixnum) - -(defconstant initial-buffer-size 128) - -(defconstant default-line-length 80) - -(defstruct (pretty-stream - (:include stream - (:out #'pretty-out) - (:sout #'pretty-sout) - (:misc #'pretty-misc)) - (:constructor make-pretty-stream (target)) - (:print-function %print-pretty-stream)) - ;; - ;; Where the output is going to finally go. - ;; - (target (required-argument) :type stream) - ;; - ;; Line length we should format to. Cached here so we don't have to keep - ;; extracting it from the target stream. - (line-length (or *print-right-margin* - (lisp::line-length target) - default-line-length) - :type column) - ;; - ;; A simple string holding all the text that has been output but not yet - ;; printed. - (buffer (make-string initial-buffer-size) :type simple-string) - ;; - ;; The index into BUFFER where more text should be put. - (buffer-fill-pointer 0 :type index) - ;; - ;; Whenever we output stuff from the buffer, we shift the remaining noise - ;; over. This makes it difficult to keep references to locations in - ;; the buffer. Therefore, we have to keep track of the total amount of - ;; stuff that has been shifted out of the buffer. - (buffer-offset 0 :type position) - ;; - ;; The column the first character in the buffer will appear in. Normally - ;; zero, but if we end up with a very long line with no breaks in it we - ;; might have to output part of it. Then this will no longer be zero. - (buffer-start-column (or (lisp::charpos target) 0) :type column) - ;; - ;; The line number we are currently on. Used for *print-lines* abrevs and - ;; to tell when sections have been split across multiple lines. - (line-number 0 :type index) - ;; - ;; Stack of logical blocks in effect at the buffer start. - (blocks (list (make-logical-block)) :type list) - ;; - ;; Buffer holding the per-line prefix active at the buffer start. - ;; Indentation is included in this. The length of this is stored - ;; in the logical block stack. - (prefix (make-string initial-buffer-size) :type simple-string) - ;; - ;; Buffer holding the total remaining suffix active at the buffer start. - ;; The characters are right-justified in the buffer to make it easier - ;; to output the buffer. The length is stored in the logical block - ;; stack. - (suffix (make-string initial-buffer-size) :type simple-string) - ;; - ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, - ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) - ;; cons. Adding things to the queue is basically (setf (cdr head) (list - ;; new)) and removing them is basically (pop tail) [except that care must - ;; be taken to handle the empty queue case correctly.] - (queue-tail nil :type list) - (queue-head nil :type list) - ;; - ;; Block-start queue entries in effect at the queue head. - (pending-blocks nil :type list) - ) - -(defun %print-pretty-stream (pstream stream depth) - (declare (ignore depth)) - #+nil - (print-unreadable-object (pstream stream :type t :identity t)) - (format stream "#<pretty stream {~8,'0X}>" - (kernel:get-lisp-obj-address pstream))) - - -(declaim (inline index-position position-index position-column)) -(defun index-position (index stream) - (declare (type index index) (type pretty-stream stream) - (values position)) - (+ index (pretty-stream-buffer-offset stream))) -(defun position-index (position stream) - (declare (type position position) (type pretty-stream stream) - (values index)) - (- position (pretty-stream-buffer-offset stream))) -(defun position-column (position stream) - (declare (type position position) (type pretty-stream stream) - (values position)) - (index-column (position-index position stream) stream)) - - -;;;; Stream interface routines. - -(defun pretty-out (stream char) - (declare (type pretty-stream stream) - (type base-character char)) - (cond ((char= char #\newline) - (enqueue-newline stream :literal)) - (t - (assure-space-in-buffer stream 1) - (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream))) - (setf (schar (pretty-stream-buffer stream) fill-pointer) char) - (setf (pretty-stream-buffer-fill-pointer stream) - (1+ fill-pointer)))))) - -(defun pretty-sout (stream string start end) - (declare (type pretty-stream stream) - (type simple-string string) - (type index start) - (type (or index null) end)) - (let ((end (or end (length string)))) - (unless (= start end) - (let ((newline (position #\newline string :start start :end end))) - (cond - (newline - (pretty-sout stream string start newline) - (enqueue-newline stream :literal) - (pretty-sout stream string (1+ newline) end)) - (t - (let ((chars (- end start))) - (loop - (let* ((available (assure-space-in-buffer stream chars)) - (count (min available chars)) - (fill-pointer (pretty-stream-buffer-fill-pointer stream)) - (new-fill-ptr (+ fill-pointer count))) - (replace (pretty-stream-buffer stream) - string - :start1 fill-pointer :end1 new-fill-ptr - :start2 start) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (decf chars count) - (when (zerop count) - (return)) - (incf start count)))))))))) - -(defun pretty-misc (stream op &optional arg1 arg2) - (declare (ignore stream op arg1 arg2))) - - - -;;;; Logical blocks. - -(defstruct logical-block - ;; - ;; The column this logical block started in. - (start-column 0 :type column) - ;; - ;; The column the current section started in. - (section-column 0 :type column) - ;; - ;; The length of the per-line prefix. We can't move the indentation - ;; left of this. - (per-line-prefix-end 0 :type index) - ;; - ;; The overall length of the prefix, including any indentation. - (prefix-length 0 :type index) - ;; - ;; The overall length of the suffix. - (suffix-length 0 :type index) - ;; - ;; The line number - (section-start-line 0 :type index)) - -(defun really-start-logical-block (stream column prefix suffix) - (let* ((blocks (pretty-stream-blocks stream)) - (prev-block (car blocks)) - (per-line-end (logical-block-per-line-prefix-end prev-block)) - (prefix-length (logical-block-prefix-length prev-block)) - (suffix-length (logical-block-suffix-length prev-block)) - (block (make-logical-block - :start-column column - :section-column column - :per-line-prefix-end per-line-end - :prefix-length prefix-length - :suffix-length suffix-length - :section-start-line (pretty-stream-line-number stream)))) - (setf (pretty-stream-blocks stream) (cons block blocks)) - (set-indentation stream column) - (when prefix - (setf (logical-block-per-line-prefix-end block) column) - (replace (pretty-stream-prefix stream) prefix - :start1 (- column (length prefix)) :end1 column)) - (when suffix - (let* ((total-suffix (pretty-stream-suffix stream)) - (total-suffix-len (length total-suffix)) - (additional (length suffix)) - (new-suffix-len (+ suffix-length additional))) - (when (> new-suffix-len total-suffix-len) - (let ((new-total-suffix-len - (max (* total-suffix-len 2) - (+ suffix-length - (floor (* additional 5) 4))))) - (setf total-suffix - (replace (make-string new-total-suffix-len) total-suffix - :start1 (- new-total-suffix-len suffix-length) - :start2 (- total-suffix-len suffix-length))) - (setf total-suffix-len new-total-suffix-len) - (setf (pretty-stream-suffix stream) total-suffix))) - (replace total-suffix suffix - :start1 (- total-suffix-len new-suffix-len) - :end1 (- total-suffix-len suffix-length)) - (setf (logical-block-suffix-length block) new-suffix-len)))) - nil) - -(defun set-indentation (stream column) - (let* ((prefix (pretty-stream-prefix stream)) - (prefix-len (length prefix)) - (block (car (pretty-stream-blocks stream))) - (current (logical-block-prefix-length block)) - (minimum (logical-block-per-line-prefix-end block)) - (column (max minimum column))) - (when (> column prefix-len) - (setf prefix - (replace (make-string (max (* prefix-len 2) - (+ prefix-len - (floor (* (- column prefix-len) 5) - 4)))) - prefix - :end1 current)) - (setf (pretty-stream-prefix stream) prefix)) - (when (> column current) - (fill prefix #\space :start current :end column)) - (setf (logical-block-prefix-length block) column))) - -(defun really-end-logical-block (stream) - (let* ((old (pop (pretty-stream-blocks stream))) - (old-indent (logical-block-prefix-length old)) - (new (car (pretty-stream-blocks stream))) - (new-indent (logical-block-prefix-length new))) - (when (> new-indent old-indent) - (fill (pretty-stream-prefix stream) #\space - :start old-indent :end new-indent))) - nil) - - - -;;;; The pending operation queue. - -(defstruct queued-op - (position 0 :type position)) - -(defmacro enqueue (stream type &rest args) - (let ((constructor (intern (concatenate 'string - "MAKE-" - (symbol-name type))))) - (once-only ((stream stream) - (entry `(,constructor :position - (index-position - (pretty-stream-buffer-fill-pointer - ,stream) - ,stream) - ,@args)) - (op `(list ,entry)) - (head `(pretty-stream-queue-head ,stream))) - `(progn - (if ,head - (setf (cdr ,head) ,op) - (setf (pretty-stream-queue-tail ,stream) ,op)) - (setf (pretty-stream-queue-head ,stream) ,op) - ,entry)))) - -(defstruct (section-start - (:include queued-op)) - (depth 0 :type index) - (section-end nil :type (or null newline block-end))) - -(defstruct (newline - (:include section-start)) - (kind (required-argument) - :type (member :linear :fill :miser :literal :mandatory))) - -(defun enqueue-newline (stream kind) - (let* ((depth (length (pretty-stream-pending-blocks stream))) - (newline (enqueue stream newline :kind kind :depth depth))) - (dolist (entry (pretty-stream-queue-tail stream)) - (when (and (not (eq newline entry)) - (section-start-p entry) - (null (section-start-section-end entry)) - (<= depth (section-start-depth entry))) - (setf (section-start-section-end entry) newline)))) - (maybe-output stream (or (eq kind :literal) (eq kind :mandatory)))) - -(defstruct (indentation - (:include queued-op)) - (kind (required-argument) :type (member :block :current)) - (amount 0 :type fixnum)) - -(defun enqueue-indent (stream kind amount) - (enqueue stream indentation :kind kind :amount amount)) - -(defstruct (block-start - (:include section-start)) - (block-end nil :type (or null block-end)) - (prefix nil :type (or null simple-string)) - (suffix nil :type (or null simple-string))) - -(defun start-logical-block (stream prefix per-line-p suffix) - (when prefix - (pretty-sout stream prefix 0 (length prefix))) - (let* ((pending-blocks (pretty-stream-pending-blocks stream)) - (start (enqueue stream block-start - :prefix (and per-line-p prefix) - :suffix suffix - :depth (length pending-blocks)))) - (setf (pretty-stream-pending-blocks stream) - (cons start pending-blocks)))) - -(defstruct (block-end - (:include queued-op)) - (suffix nil :type (or null simple-string))) - -(defun end-logical-block (stream) - (let* ((start (pop (pretty-stream-pending-blocks stream))) - (suffix (block-start-suffix start)) - (end (enqueue stream block-end :suffix suffix))) - (when suffix - (pretty-sout stream suffix 0 (length suffix))) - (setf (block-start-block-end start) end))) - -(defstruct (tab - (:include queued-op)) - (sectionp nil :type (member t nil)) - (relativep nil :type (member t nil)) - (colnum 0 :type column) - (colinc 0 :type column)) - -(defun enqueue-tab (stream kind colnum colinc) - (multiple-value-bind - (sectionp relativep) - (ecase kind - (:line (values nil nil)) - (:line-relative (values nil t)) - (:section (values t nil)) - (:section-relative (values t t))) - (enqueue stream tab :sectionp sectionp :relativep relativep - :colnum colnum :colinc colinc))) - - -;;;; Tab support. - -(defun compute-tab-size (tab section-start column) - (let ((origin (if (tab-sectionp tab) section-start 0)) - (colnum (tab-colnum tab)) - (colinc (tab-colinc tab))) - (cond ((tab-relativep tab) - (unless (<= colinc 1) - (let ((newposn (+ column colnum))) - (let ((rem (rem newposn colinc))) - (unless (zerop rem) - (incf colnum (- colinc rem)))))) - colnum) - ((<= column (+ colnum origin)) - (- (+ colnum origin) column)) - (t - (- colinc - (rem (- column origin) colinc)))))) - -(defun index-column (index stream) - (let ((column (pretty-stream-buffer-start-column stream)) - (section-start (logical-block-section-column - (first (pretty-stream-blocks stream)))) - (end-position (index-position index stream))) - (dolist (op (pretty-stream-queue-tail stream)) - (when (>= (queued-op-position op) end-position) - (return)) - (typecase op - (tab - (incf column - (compute-tab-size op - section-start - (+ column - (position-index (tab-position op) - stream))))) - ((or newline block-start) - (setf section-start - (+ column (position-index (queued-op-position op) - stream)))))) - (+ column index))) - -(defun expand-tabs (stream through) - (let ((insertions nil) - (additional 0) - (column (pretty-stream-buffer-start-column stream)) - (section-start (logical-block-section-column - (first (pretty-stream-blocks stream))))) - (dolist (op (pretty-stream-queue-tail stream)) - (typecase op - (tab - (let* ((index (position-index (tab-position op) stream)) - (tabsize (compute-tab-size op - section-start - (+ column index)))) - (unless (zerop tabsize) - (push (cons index tabsize) insertions) - (incf additional tabsize) - (incf column tabsize)))) - ((or newline block-start) - (setf section-start - (+ column (position-index (queued-op-position op) stream))))) - (when (eq op through) - (return))) - (when insertions - (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (new-fill-ptr (+ fill-ptr additional)) - (buffer (pretty-stream-buffer stream)) - (new-buffer buffer) - (length (length buffer)) - (end fill-ptr)) - (when (> new-fill-ptr length) - (let ((new-length (max (* length 2) - (+ fill-ptr - (floor (* additional 5) 4))))) - (setf new-buffer (make-string new-length)) - (setf (pretty-stream-buffer stream) new-buffer))) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (decf (pretty-stream-buffer-offset stream) additional) - (dolist (insertion insertions) - (let* ((srcpos (car insertion)) - (amount (cdr insertion)) - (dstpos (+ srcpos additional))) - (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end) - (fill new-buffer #\space :start srcpos :end dstpos) - (decf additional amount) - (setf end srcpos))) - (unless (eq new-buffer buffer) - (replace new-buffer buffer :end1 end :end2 end)))))) - - -;;;; Stuff to do the actual outputting. - -(defun assure-space-in-buffer (stream want) - (declare (type pretty-stream stream) - (type index want)) - (let* ((buffer (pretty-stream-buffer stream)) - (length (length buffer)) - (fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (available (- length fill-ptr))) - (cond ((plusp available) - available) - ((> fill-ptr (pretty-stream-line-length stream)) - (unless (maybe-output stream nil) - (output-partial-line stream)) - (assure-space-in-buffer stream want)) - (t - (let* ((new-length (max (* length 2) - (+ length - (floor (* want 5) 4)))) - (new-buffer (make-string new-length))) - (setf (pretty-stream-buffer stream) new-buffer) - (replace new-buffer buffer :end1 fill-ptr) - (- new-length fill-ptr)))))) - -(defun maybe-output (stream force-newlines-p) - (declare (type pretty-stream stream)) - (let ((tail (pretty-stream-queue-tail stream)) - (output-anything nil)) - (loop - (unless tail - (setf (pretty-stream-queue-head stream) nil) - (return)) - (let ((next (pop tail))) - (etypecase next - (newline - (when (ecase (newline-kind next) - ((:literal :mandatory :linear) t) - (:miser (misering-p stream)) - (:fill - (or (misering-p stream) - (> (pretty-stream-line-number stream) - (logical-block-section-start-line - (first (pretty-stream-blocks stream)))) - (ecase (fits-on-line-p stream - (newline-section-end next) - force-newlines-p) - ((t) nil) - ((nil) t) - (:dont-know - (return)))))) - (setf output-anything t) - (output-line stream next))) - (indentation - (unless (misering-p stream) - (set-indentation stream - (+ (ecase (indentation-kind next) - (:block - (logical-block-start-column - (car (pretty-stream-blocks stream)))) - (:current - (position-column - (indentation-position next) - stream))) - (indentation-amount next))))) - (block-start - (ecase (fits-on-line-p stream (block-start-section-end next) - force-newlines-p) - ((t) - ;; Just nuke the whole logical block and make it look like one - ;; nice long literal. - (let ((end (block-start-block-end next))) - (expand-tabs stream end) - (setf tail (cdr (member end tail))))) - ((nil) - (really-start-logical-block - stream - (position-column (block-start-position next) stream) - (block-start-prefix next) - (block-start-suffix next))) - (:dont-know - (return)))) - (block-end - (really-end-logical-block stream)) - (tab - (expand-tabs stream next)))) - (setf (pretty-stream-queue-tail stream) tail)) - output-anything)) - -(defun misering-p (stream) - (declare (type pretty-stream stream)) - (and *print-miser-width* - (<= (- (pretty-stream-line-length stream) - (logical-block-start-column (car (pretty-stream-blocks stream)))) - *print-miser-width*))) - -(defun fits-on-line-p (stream until force-newlines-p) - (let ((available (pretty-stream-line-length stream))) - (when (and *print-lines* - (= *print-lines* (pretty-stream-line-number stream))) - (decf available 3) ; for the `` ..'' - (decf available (logical-block-suffix-length - (car (pretty-stream-blocks stream))))) - (cond (until - (<= (position-column (queued-op-position until) stream) available)) - (force-newlines-p nil) - ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream) - available) - nil) - (t - :dont-know)))) - -(defun output-line (stream until) - (declare (type pretty-stream stream) - (type newline until)) - (let* ((target (pretty-stream-target stream)) - (buffer (pretty-stream-buffer stream)) - (kind (newline-kind until)) - (literal-p (eq kind :literal)) - (amount-to-consume (position-index (newline-position until) stream)) - (amount-to-print - (if literal-p - amount-to-consume - (let ((last-non-blank - (position #\space buffer :end amount-to-consume - :from-end t :test #'char/=))) - (if last-non-blank - (1+ last-non-blank) - 0))))) - (write-string buffer target :end amount-to-print) - (let ((line-number (pretty-stream-line-number stream))) - (incf line-number) - (when (and *print-lines* (>= line-number *print-lines*)) - (write-string " .." target) - (let ((suffix-length (logical-block-suffix-length - (car (pretty-stream-blocks stream))))) - (unless (zerop suffix-length) - (let* ((suffix (pretty-stream-suffix stream)) - (len (length suffix))) - (write-string suffix target - :start (- len suffix-length) - :end len)))) - (throw 'line-limit-abbreviation-happened t)) - (setf (pretty-stream-line-number stream) line-number) - (write-char #\newline target) - (setf (pretty-stream-buffer-start-column stream) 0) - (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (block (first (pretty-stream-blocks stream))) - (prefix-len - (if literal-p - (logical-block-per-line-prefix-end block) - (logical-block-prefix-length block))) - (shift (- amount-to-consume prefix-len)) - (new-fill-ptr (- fill-ptr shift)) - (new-buffer buffer) - (buffer-length (length buffer))) - (when (> new-fill-ptr buffer-length) - (setf new-buffer - (make-string (max (* buffer-length 2) - (+ buffer-length - (floor (* (- new-fill-ptr buffer-length) - 5) - 4))))) - (setf (pretty-stream-buffer stream) new-buffer)) - (replace new-buffer buffer - :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr) - (replace new-buffer (pretty-stream-prefix stream) - :end1 prefix-len) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (incf (pretty-stream-buffer-offset stream) shift) - (unless literal-p - (setf (logical-block-section-column block) prefix-len) - (setf (logical-block-section-start-line block) line-number)))))) - -(defun output-partial-line (stream) - (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (tail (pretty-stream-queue-tail stream)) - (count - (if tail - (position-index (queued-op-position (car tail)) stream) - fill-ptr)) - (new-fill-ptr (- fill-ptr count)) - (buffer (pretty-stream-buffer stream))) - (when (zerop count) - (error "Output-partial-line called when nothing can be output.")) - (write-string buffer (pretty-stream-target stream) - :start 0 :end count) - (incf (pretty-stream-buffer-start-column stream) count) - (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (incf (pretty-stream-buffer-offset stream) count))) - -(defun force-pretty-output (stream) - (maybe-output stream nil) - (expand-tabs stream nil) - (write-string (pretty-stream-buffer stream) - (pretty-stream-target stream) - :end (pretty-stream-buffer-fill-pointer stream))) - - -;;;; Utilities. - -;;; WITH-PRETTY-STREAM -- internal. -;;; -(defmacro with-pretty-stream - ((stream-var &optional (stream-expression stream-var)) &body body) - (let ((flet-name (gensym "WITH-PRETTY-STREAM-"))) - `(flet ((,flet-name (,stream-var) - ,@body)) - (let ((stream ,stream-expression)) - (if (pretty-stream-p stream) - (,flet-name stream) - (catch 'line-limit-abbreviation-happened - (let ((stream (make-pretty-stream stream))) - (,flet-name stream) - (force-pretty-output stream))))) - nil))) - - -;;;; User interface to the pretty printer. - -(defmacro pprint-logical-block - ((stream-symbol object &key prefix per-line-prefix suffix) - &body body) - "Group some output into a logical block. STREAM-SYMBOL should be either a - stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer - control variable *PRINT-LEVEL* is automatically handled." - (when (and prefix per-line-prefix) - (error "Cannot specify both a prefix and a per-line-perfix.")) - (multiple-value-bind - (stream-var stream-expression) - (case stream-symbol - ((nil) - (values '*standard-output* '*standard-output*)) - ((t) - (values '*terminal-io* '*terminal-io*)) - (t - (values stream-symbol - (once-only ((stream stream-symbol)) - `(case ,stream - ((nil) *standard-output*) - ((t) *terminal-io*) - (t ,stream)))))) - (let* ((object-var (if object (gensym) nil)) - (block-name (gensym "PPRINT-LOGICAL-BLOCK-")) - (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-")) - (pp-pop-name (gensym "PPRINT-POP-")) - (body - `(descend-into (,stream-var) - (let ((,count-name 0)) - (declare (type index ,count-name) (ignorable ,count-name)) - (start-logical-block ,stream-var ,(or prefix per-line-prefix) - ,(if per-line-prefix t nil) ,suffix) - (block ,block-name - (flet ((,pp-pop-name () - ,@(when object - `((unless (listp ,object-var) - (write-string ". " ,stream-var) - (output-object ,object-var ,stream-var) - (return-from ,block-name nil)))) - (when (eql ,count-name *print-length*) - (write-string "..." ,stream-var) - (return-from ,block-name nil)) - ,@(when object - `((when (and ,object-var - (plusp ,count-name) - (check-for-circularity - ,object-var)) - (write-string ". " ,stream-var) - (output-object ,object-var ,stream-var) - (return-from ,block-name nil)))) - (incf ,count-name) - ,@(when object - `((pop ,object-var))))) - (declare (ignorable #',pp-pop-name)) - (macrolet ((pprint-pop () - '(,pp-pop-name)) - (pprint-exit-if-list-exhausted () - ,(if object - `'(when (null ,object-var) - (return-from ,block-name nil)) - `'(return-from ,block-name nil)))) - ,@body))) - (end-logical-block ,stream-var))))) - (when object - (setf body - `(let ((,object-var ,object)) - (if (listp ,object-var) - ,body - (output-object ,object-var ,stream-var))))) - `(with-pretty-stream (,stream-var ,stream-expression) - ,body)))) - -(defmacro pprint-exit-if-list-exhausted () - "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return - if it's list argument is exhausted. Can only be used inside - PPRINT-LOGICAL-BLOCK, and only when the LIST argument to - PPRINT-LOGICAL-BLOCK is supplied." - (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~ - PPRINT-LOGICAL-BLOCK.")) - -(defmacro pprint-pop () - "Return the next element from LIST argument to the closest enclosing - use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH* - and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK. - If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing - is poped, but the *PRINT-LENGTH* testing still happens." - (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK.")) - -(defun pprint-newline (kind &optional stream) - "Output a conditional newline to STREAM (which defaults to - *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do - nothing if not. KIND can be one of: - :LINEAR - A line break is inserted if and only if the immediatly - containing section cannot be printed on one line. - :MISER - Same as LINEAR, but only if ``miser-style'' is in effect. - (See *PRINT-MISER-WIDTH*.) - :FILL - A line break is inserted if and only if either: - (a) the following section cannot be printed on the end of the - current line, - (b) the preceding section was not printed on a single line, or - (c) the immediately containing section cannot be printed on one - line and miser-style is in effect. - :MANDATORY - A line break is always inserted. - When a line break is inserted by any type of conditional newline, any - blanks that immediately precede the conditional newline are ommitted - from the output and indentation is introduced at the beginning of the - next line. (See PPRINT-INDENT.)" - (declare (type (member :linear :miser :fill :mandatory) kind) - (type (or stream (member t nil)) stream) - (values null)) - (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) - (when (pretty-stream-p stream) - (enqueue-newline stream kind))) - nil) - -(defun pprint-indent (relative-to n &optional stream) - "Specify the indentation to use in the current logical block if STREAM - (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream - and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indention - to use (in ems, the width of an ``m'') and RELATIVE-TO can be either: - :BLOCK - Indent relative to the column the current logical block - started on. - :CURRENT - Indent relative to the current column. - The new indention value does not take effect until the following line - break." - (declare (type (member :block :current) relative-to) - (type integer n) - (type (or stream (member t nil)) stream) - (values null)) - (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) - (when (pretty-stream-p stream) - (enqueue-indent stream relative-to n))) - nil) - -(defun pprint-tab (kind colnum colinc &optional stream) - "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing - stream, perform tabbing based on KIND, otherwise do nothing. KIND can - be one of: - :LINE - Tab to column COLNUM. If already past COLNUM tab to the next - multiple of COLINC. - :SECTION - Same as :LINE, but count from the start of the current - section, not the start of the line. - :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of - COLINC. - :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start - of the current section, not the start of the line." - (declare (type (member :line :section :line-relative :section-relative) kind) - (type unsigned-byte colnum colinc) - (type (or stream (member t nil)) stream) - (values null)) - (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) - (when (pretty-stream-p stream) - (enqueue-tab stream kind colnum colinc))) - nil) - -(defun pprint-fill (stream list &optional (colon? t) atsign?) - "Output LIST to STREAM putting :FILL conditional newlines between each - element. If COLON? is NIL (defaults to T), then no parens are printed - around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL - can be used with the ~/.../ format directive." - (declare (ignore atsign?)) - (pprint-logical-block (stream list - :prefix (if colon? "(") - :suffix (if colon? ")")) - (pprint-exit-if-list-exhausted) - (loop - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :fill stream)))) - -(defun pprint-linear (stream list &optional (colon? t) atsign?) - "Output LIST to STREAM putting :LINEAR conditional newlines between each - element. If COLON? is NIL (defaults to T), then no parens are printed - around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR - can be used with the ~/.../ format directive." - (declare (ignore atsign?)) - (pprint-logical-block (stream list - :prefix (if colon? "(") - :suffix (if colon? ")")) - (pprint-exit-if-list-exhausted) - (loop - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream)))) - -(defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize) - "Output LIST to STREAM tabbing to the next column that is an even multiple - of TABSIZE (which defaults to 16) between each element. :FILL style - conditional newlines are also output between each element. If COLON? is - NIL (defaults to T), then no parens are printed around the output. - ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with - the ~/.../ format directive." - (declare (ignore atsign?)) - (pprint-logical-block (stream list - :prefix (if colon? "(") - :suffix (if colon? ")")) - (pprint-exit-if-list-exhausted) - (loop - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-tab :section-relative 0 (or tabsize 16) stream) - (pprint-newline :fill stream)))) - - -;;;; Pprint-dispatch tables. - -(defvar *initial-pprint-dispatch*) -(defvar *building-initial-table* nil) - -(defstruct (pprint-dispatch-entry - (:print-function %print-pprint-dispatch-entry)) - ;; - ;; The type specifier for this entry. - (type (required-argument) :type t) - ;; - ;; A function to test to see if an object is of this time. Pretty must - ;; just (lambda (obj) (typep object type)) except that we handle the - ;; CONS type specially so that (cons (member foo)) works. We don't - ;; bother computing this for entries in the CONS hash table, because - ;; we don't need it. - (test-fn nil :type (or function null)) - ;; - ;; The priority for this guy. - (priority 0 :type real) - ;; - ;; T iff one of the original entries. - (initial-p *building-initial-table* :type (member t nil)) - ;; - ;; And the associated function. - (function (required-argument) :type function)) - -(defun %print-pprint-dispatch-entry (entry stream depth) - (declare (ignore depth)) - (print-unreadable-object (entry stream :type t) - (format stream "Type=~S, priority=~S~@[ [Initial]~]" - (pprint-dispatch-entry-type entry) - (pprint-dispatch-entry-priority entry) - (pprint-dispatch-entry-initial-p entry)))) - -(defstruct (pprint-dispatch-table - (:print-function %print-pprint-dispatch-table)) - ;; - ;; A list of all the entries (except for CONS entries below) in highest - ;; to lowest priority. - (entries nil :type list) - ;; - ;; A hash table mapping things to entries for type specifiers of the - ;; form (CONS (MEMBER <thing>)). If the type specifier is of this form, - ;; we put it in this hash table instead of the regular entries table. - (cons-entries (make-hash-table :test #'eql))) - -(defun %print-pprint-dispatch-table (table stream depth) - (declare (ignore depth)) - (print-unreadable-object (table stream :type t :identity t))) - -(defun cons-type-specifier-p (spec) - (and (consp spec) - (eq (car spec) 'cons) - (cdr spec) - (null (cddr spec)) - (let ((car (cadr spec))) - (and (consp car) - (let ((carcar (car car))) - (or (eq carcar 'member) - (eq carcar 'eql))) - (cdr car) - (null (cddr car)))))) - -(defun entry< (e1 e2) - (declare (type pprint-dispatch-entry e1 e2)) - (if (pprint-dispatch-entry-initial-p e1) - (if (pprint-dispatch-entry-initial-p e2) - (< (pprint-dispatch-entry-priority e1) - (pprint-dispatch-entry-priority e2)) - t) - (if (pprint-dispatch-entry-initial-p e2) - nil - (< (pprint-dispatch-entry-priority e1) - (pprint-dispatch-entry-priority e2))))) - -(defun compute-test-fn (type) - (labels ((compute-test-expr (type object) - (if (listp type) - (case (car type) - (cons - (destructuring-bind - (&optional (car nil car-p) (cdr nil cdr-p)) - (cdr type) - `(and (consp ,object) - ,@(when car-p - `(,(compute-test-expr car `(car ,object)))) - ,@(when cdr-p - `(,(compute-test-expr cdr `(cdr ,object))))))) - (not - (destructuring-bind (type) (cdr type) - `(not ,(compute-test-expr type object)))) - (and - `(and ,@(mapcar #'(lambda (type) - (compute-test-expr type object)) - (cdr type)))) - (or - `(or ,@(mapcar #'(lambda (type) - (compute-test-expr type object)) - (cdr type)))) - (t - `(typep ,object ',type))) - `(typep ,object ',type)))) - (compile nil `(lambda (object) ,(compute-test-expr type 'object))))) - -(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) - (declare (type (or pprint-dispatch-table null) table)) - (let* ((orig (or table *initial-pprint-dispatch*)) - (new (make-pprint-dispatch-table - :entries (copy-list (pprint-dispatch-table-entries orig)))) - (new-cons-entries (pprint-dispatch-table-cons-entries new))) - (maphash #'(lambda (key value) - (setf (gethash key new-cons-entries) value)) - (pprint-dispatch-table-cons-entries orig)) - new)) - -(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*)) - (declare (type (or pprint-dispatch-table null) table)) - (let* ((table (or table *initial-pprint-dispatch*)) - (cons-entry - (and (consp object) - (gethash (car object) - (pprint-dispatch-table-cons-entries table)))) - (entry - (dolist (entry (pprint-dispatch-table-entries table) cons-entry) - (when (and cons-entry - (entry< entry cons-entry)) - (return cons-entry)) - (when (funcall (pprint-dispatch-entry-test-fn entry) object) - (return entry))))) - (if entry - (values (pprint-dispatch-entry-function entry) t) - (values #'(lambda (stream object) - (output-ugly-object object stream)) - nil)))) - -(defun set-pprint-dispatch (type function &optional - (priority 0) (table *print-pprint-dispatch*)) - (declare (type (or null function) function) - (type real priority) - (type pprint-dispatch-table table)) - (if function - (if (cons-type-specifier-p type) - (setf (gethash (second (second type)) - (pprint-dispatch-table-cons-entries table)) - (make-pprint-dispatch-entry :type type :priority priority - :function function)) - (let ((list (delete type (pprint-dispatch-table-entries table) - :key #'pprint-dispatch-entry-type - :test #'equal)) - (entry (make-pprint-dispatch-entry - :type type :test-fn (compute-test-fn type) - :priority priority :function function))) - (do ((prev nil next) - (next list (cdr next))) - ((null next) - (if prev - (setf (cdr prev) (list entry)) - (setf list (list entry)))) - (when (entry< (car next) entry) - (if prev - (setf (cdr prev) (cons entry next)) - (setf list (cons entry next))) - (return))) - (setf (pprint-dispatch-table-entries table) list))) - (if (cons-type-specifier-p type) - (remhash (second (second type)) - (pprint-dispatch-table-cons-entries table)) - (setf (pprint-dispatch-table-entries table) - (delete type (pprint-dispatch-table-entries table) - :key #'pprint-dispatch-entry-type - :test #'equal)))) - nil) - - -;;;; Standard pretty-printing routines. - -(defun pprint-array (stream array) - (cond ((or (and (null *print-array*) (null *print-readably*)) - (stringp array) - (bit-vector-p array)) - (output-ugly-object array stream)) - ((and *print-readably* (not (eq (array-element-type array) 't))) - (let ((*print-readably* nil)) - (error "~S cannot be printed readably."))) - ((vectorp array) - (pprint-vector stream array)) - (t - (pprint-multi-dim-array stream array)))) - -(defun pprint-vector (stream vector) - (pprint-logical-block (stream nil :prefix "#(" :suffix ")") - (dotimes (i (length vector)) - (pprint-pop) - (unless (zerop i) - (write-char #\space stream) - (pprint-newline :fill stream)) - (output-object (aref vector i) stream)))) - -(defun pprint-multi-dim-array (stream array) - (funcall (formatter "#~DA") stream (array-rank array)) - (lisp::with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (labels ((output-guts (stream index dimensions) - (if (null dimensions) - (output-object (aref data index) stream) - (pprint-logical-block - (stream nil :prefix "(" :suffix ")") - (let ((dim (car dimensions))) - (unless (zerop dim) - (let* ((dims (cdr dimensions)) - (index index) - (step (reduce #'* dims)) - (count 0)) - (loop - (pprint-pop) - (output-guts stream index dims) - (when (= (incf count) dim) - (return)) - (write-char #\space stream) - (pprint-newline (if dims :linear :fill) - stream) - (incf index step))))))))) - (output-guts stream start (array-dimensions array))))) - -(defun pprint-lambda-list (stream lambda-list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")") - (let ((state :required) - (first t)) - (loop - (pprint-exit-if-list-exhausted) - (unless first - (write-char #\space stream)) - (let ((arg (pprint-pop))) - (unless first - (case arg - (&optional - (setf state :optional) - (pprint-newline :linear stream)) - ((&rest &body) - (setf state :required) - (pprint-newline :linear stream)) - (&key - (setf state :key) - (pprint-newline :linear stream)) - (&aux - (setf state :optional) - (pprint-newline :linear stream)) - (t - (pprint-newline :fill stream)))) - (ecase state - (:required - (pprint-lambda-list stream arg)) - ((:optional :key) - (pprint-logical-block - (stream arg :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (if (eq state :key) - (pprint-logical-block - (stream (pprint-pop) :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :fill stream) - (pprint-lambda-list stream (pprint-pop)) - (loop - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :fill stream) - (output-object (pprint-pop) stream))) - (pprint-lambda-list stream (pprint-pop))) - (loop - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (output-object (pprint-pop) stream)))))) - (setf first nil))))) - -(defun pprint-lambda (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") - stream list)) - -(defun pprint-block (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list)) - -(defun pprint-flet (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>") - stream - list)) - -(defun pprint-let (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>") - stream - list)) - -(defun pprint-progn (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list)) - -(defun pprint-progv (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>") - stream list)) - -(defun pprint-quote (stream list &rest noise) - (declare (ignore noise)) - (if (and (consp list) - (consp (cdr list)) - (null (cddr list))) - (case (car list) - (function - (write-string "#'" stream) - (output-object (cadr list) stream)) - (quote - (write-char #\' stream) - (output-object (cadr list) stream)) - (t - (pprint-fill stream list))) - (pprint-fill stream list))) - -(defun pprint-setq (stream list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :miser stream) - (if (> (length list) 3) - (loop - (pprint-indent :current 2 stream) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (pprint-indent :current -2 stream) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream)) - (progn - (pprint-indent :current 0 stream) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (output-object (pprint-pop) stream))))) - -(defmacro pprint-tagbody-guts (stream) - `(loop - (pprint-exit-if-list-exhausted) - (write-char #\space ,stream) - (let ((form-or-tag (pprint-pop))) - (pprint-indent :block - (if (atom form-or-tag) 0 1) - ,stream) - (pprint-newline :linear ,stream) - (output-object form-or-tag ,stream)))) - -(defun pprint-tagbody (stream list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (output-object (pprint-pop) stream) - (pprint-tagbody-guts stream))) - -(defun pprint-case (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/PP:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>") - stream - list)) - -(defun pprint-defun (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^ ~@_~:I~W~^ ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") - stream - list)) - -(defun pprint-destructuring-bind (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^~3I ~_~:/PP:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>") - stream list)) - -(defun pprint-do (stream list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-indent :current 0 stream) - (funcall (formatter "~:<~@{~:<~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>") - stream - (pprint-pop)) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (pprint-linear stream (pprint-pop)) - (pprint-tagbody-guts stream))) - -(defun pprint-dolist (stream list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (pprint-indent :block 3 stream) - (write-char #\space stream) - (pprint-newline :fill stream) - (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>") - stream - (pprint-pop)) - (pprint-tagbody-guts stream))) - -(defun pprint-typecase (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter - "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>") - stream - list)) - -(defun pprint-prog (stream list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :miser stream) - (pprint-fill stream (pprint-pop)) - (pprint-tagbody-guts stream))) - -(defun pprint-function-call (stream list &rest noise) - (declare (ignore noise)) - (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>") - stream - list)) - - -;;;; Interface seen by regular (ugly) printer and initialization routines. - -;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when *PRINT-PRETTY* is -;;; bound to T. -;;; -(defun output-pretty-object (object stream) - (with-pretty-stream (stream) - (funcall (pprint-dispatch object) stream object))) - -(defparameter magic-forms - '((lambda pprint-lambda) - ;; Special forms. - (block pprint-block) - (catch pprint-block) - (compiler-let pprint-let) - (eval-when pprint-block) - (flet pprint-flet) - (function pprint-quote) - (generic-flet pprint-flet) - (generic-labels pprint-flet) - (labels pprint-flet) - (let pprint-let) - (let* pprint-let) - (locally pprint-progn) - (macrolet pprint-flet) - (multiple-value-call pprint-block) - (multiple-value-prog1 pprint-block) - (progn pprint-progn) - (progv pprint-progv) - (quote pprint-quote) - (return-from pprint-block) - (setq pprint-setq) - (symbol-macrolet pprint-let) - (tagbody pprint-tagbody) - (throw pprint-block) - (unwind-protect pprint-block) - (with-added-methods pprint-flet) - - ;; Macros. - (case pprint-case) - (ccase pprint-case) - (ctypecase pprint-typecase) - (defconstant pprint-block) - (define-modify-macro pprint-defun) - (define-setf-method pprint-defun) - (defmacro pprint-defun) - (defparameter pprint-block) - (defsetf pprint-defun) - (defstruct pprint-block) - (deftype pprint-defun) - (defun pprint-defun) - (defvar pprint-block) - (destructuring-bind pprint-destructuring-bind) - (do pprint-do) - (do* pprint-do) - (do-all-symbols pprint-dolist) - (do-external-symbols pprint-dolist) - (do-symbols pprint-dolist) - (dolist pprint-dolist) - (dotimes pprint-dolist) - (ecase pprint-case) - (etypecase pprint-typecase) - #+nil (handler-bind ...) - #+nil (handler-case ...) - #+nil (loop ...) - (multiple-value-bind pprint-progv) - (multiple-value-setq pprint-block) - (pprint-logical-block pprint-block) - (print-unreadable-object pprint-block) - (prog pprint-prog) - (prog* pprint-prog) - (prog1 pprint-block) - (prog2 pprint-progv) - (psetf pprint-setq) - (psetq pprint-setq) - #+nil (restart-bind ...) - #+nil (restart-case ...) - (setf pprint-setq) - (step pprint-progn) - (time pprint-progn) - (typecase pprint-typecase) - (unless pprint-block) - (when pprint-block) - (with-compilation-unit pprint-block) - #+nil (with-condition-restarts ...) - (with-hash-table-iterator pprint-block) - (with-input-from-string pprint-block) - (with-open-file pprint-block) - (with-open-stream pprint-block) - (with-output-to-string pprint-block) - (with-package-iterator pprint-block) - (with-simple-restart pprint-block) - (with-standard-io-syntax pprint-progn))) - -(defun pprint-init () - (setf *initial-pprint-dispatch* (make-pprint-dispatch-table)) - (let ((*print-pprint-dispatch* *initial-pprint-dispatch*) - (*building-initial-table* t)) - ;; Printers for regular types. - (set-pprint-dispatch 'array #'pprint-array) - (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) - #'pprint-function-call -1) - (set-pprint-dispatch 'cons #'pprint-fill -2) - ;; Cons cells with interesting things for the car. - (dolist (magic-form magic-forms) - (set-pprint-dispatch `(cons (eql ,(first magic-form))) - (symbol-function (second magic-form)))) - ;; Other pretty-print init forms. - (lisp::backq-pp-init)) - - (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) - (setf *pretty-printer* #'output-pretty-object) - (setf *print-pretty* t)) diff --git a/code/profile.lisp b/code/profile.lisp deleted file mode 100644 index 9dac381816ad5d12b757f672c7123d386b0e50e4..0000000000000000000000000000000000000000 --- a/code/profile.lisp +++ /dev/null @@ -1,502 +0,0 @@ -;;; -*- Package: Profile -*- -;;; -;;; ********************************************************************** -;;; 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/code/profile.lisp,v 1.7 1992/09/07 16:11:12 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Description: Simple profiling facility. -;;; -;;; Author: Skef Wholey, Rob MacLachlan -;;; -;;; Compatibility: Runs in any valid Common Lisp. Three small implementation- -;;; dependent changes can be made to improve performance and prettiness. -;;; -;;; Dependencies: The macro Quickly-Get-Time and the function -;;; Required-Arguments should probably be tailored to the implementation for -;;; the best results. They will default to working, albeit inefficent, forms -;;; in non-CMU implementations. The Total-Consing macro is used to profile -;;; consing: in unknown implementations 0 will be used. -;;; See the "Implementation Parameters" section. -;;; -;;; Note: a timing overhead factor is computed when REPORT-TIME is first -;;; called. This will be incorrect if profiling code is run in a different -;;; environment than the first call to REPORT-TIME. For example, saving a core -;;; image on a high performance machine and running it on a low performance one -;;; will result in use of an erroneously small timing overhead factor. In CMU -;;; CL, this cache is invalidated when a core is saved. -;;; -(in-package "PROFILE") - -(export '(*timed-functions* profile unprofile report-time reset-time)) - - -;;;; Implementation dependent interfaces: - - -(progn - #-cmu - (eval-when (compile eval) - (warn - "You may want to supply an implementation-specific ~ - Quickly-Get-Time function.")) - - (defconstant quick-time-units-per-second internal-time-units-per-second) - - (defmacro quickly-get-time () - `(the time-type (get-internal-run-time)))) - - -;;; The type of the result from quickly-get-time. -#+cmu -(deftype time-type () '(unsigned-byte 29)) -#-cmu -(deftype time-type () 'unsigned-byte) - - -;;; To avoid unnecessary consing in the "encapsulation" code, we find out the -;;; number of required arguments, and use &rest to capture only non-required -;;; arguments. The function Required-Arguments returns two values: the first -;;; is the number of required arguments, and the second is T iff there are any -;;; non-required arguments (e.g. &optional, &rest, &key). - -#+cmu -(defun required-arguments (name) - (let ((type (ext:info function type name))) - (cond ((not (kernel:function-type-p type)) - (warn "No argument count information available for:~% ~S~@ - Allow for &rest arg consing." - name) - (values 0 t)) - (t - (values (length (kernel:function-type-required type)) - (if (or (kernel:function-type-optional type) - (kernel:function-type-keyp type) - (kernel:function-type-rest type)) - t nil)))))) - -#-cmu -(progn - (eval-when (compile eval) - (warn - "You may want to add an implementation-specific Required-Arguments function.")) - (eval-when (load eval) - (defun required-arguments (name) - (declare (ignore name)) - (values 0 t)))) - - - -;;; The Total-Consing macro is called to find the total number of bytes consed -;;; since the beginning of time. - -#+cmu -(defmacro total-consing () '(the consing-type (ext:get-bytes-consed))) - -#-cmu -(progn - (eval-when (compile eval) - (warn "No consing will be reported unless a Total-Consing function is ~ - defined.")) - - (defmacro total-consing () '0)) - - -;;; The type of the result of TOTAL-CONSING. -#+cmu -(deftype consing-type () '(unsigned-byte 29)) -#-cmu -(deftype consing-type () 'unsigned-byte) - - -;;;; Global data structures: - -(defvar *timed-functions* () - "List of functions that are currently being timed.") - -;;; We associate a PROFILE-INFO structure with each profiled function name. -;;; This holds the functions that we call to manipulate the closure which -;;; implements the encapsulation. -;;; -(defvar *profile-info* (make-hash-table :test #'equal)) -(defstruct profile-info - (name nil) - (old-definition (error "Required keyword arg not supplied.") :type function) - (new-definition (error "Required keyword arg not supplied.") :type function) - (read-time (error "Required keyword arg not supplied.") :type function) - (reset-time (error "Required keyword arg not supplied.") :type function)) - -;;; PROFILE-INFO-OR-LOSE -- Internal -;;; -(defun profile-info-or-lose (name) - (or (gethash name *profile-info*) - (error "~S is not a profiled function." name))) - - -;;; We keep around a bunch of functions that make encapsulations, one of each -;;; (min-args . optional-p) signature we have encountered so far. We also -;;; precompute a bunch of encapsulation functions. -;;; -(defvar *existing-encapsulations* (make-hash-table :test #'equal)) - - -;;; These variables are used to subtract out the time and consing for recursive -;;; and other dynamically nested profiled calls. The total resource consumed -;;; for each nested call is added into the appropriate variable. When the -;;; outer function returns, these amounts are subtracted from the total. -;;; -(defvar *enclosed-time* 0) -(defvar *enclosed-consing* 0) -(defvar *enclosed-profilings* 0) -(proclaim '(type time-type *enclosed-time*)) -(proclaim '(type consing-type *enclosed-consing*)) -(proclaim '(fixnum *enclosed-profilings*)) - - -;;; The number of seconds a bare function call takes. Factored into the other -;;; overheads, but not used for itself. -;;; -(defvar *call-overhead*) - -;;; The number of seconds that will be charged to a profiled function due to -;;; the profiling code. -(defvar *internal-profile-overhead*) - -;;; The number of seconds of overhead for profiling that a single profiled call -;;; adds to the total runtime for the program. -;;; -(defvar *total-profile-overhead*) - -(proclaim '(single-float *call-overhead* *internal-profile-overhead* - *total-profile-overhead*)) - - -;;;; Profile encapsulations: - -(eval-when (compile load eval) - -;;; MAKE-PROFILE-ENCAPSULATION -- Internal -;;; -;;; Return a lambda expression for a function that (when called with the -;;; function name) will set up that function for profiling. -;;; -;;; A function is profiled by replacing its definition with a closure created -;;; by the following function. The closure records the starting time, calls -;;; the original function, and records finishing time. Other closures are used -;;; to perform various operations on the encapsulated function. -;;; -(defun make-profile-encapsulation (min-args optionals-p) - (let ((required-args ())) - (dotimes (i min-args) - (push (gensym) required-args)) - `(lambda (name) - (let* ((time 0) - (count 0) - (consed 0) - (profile 0) - (old-definition (fdefinition name))) - (declare (type time-type time) (type consing-type consed) - (fixnum count)) - (pushnew name *timed-functions*) - - (setf (fdefinition name) - #'(lambda (,@required-args - ,@(if optionals-p - `(&rest optional-args))) - (incf count) - (let ((time-inc 0) (cons-inc 0) (profile-inc 0)) - (declare (type time-type time-inc) - (type consing-type cons-inc) - (fixnum profile-inc)) - (multiple-value-prog1 - (let ((start-time (quickly-get-time)) - (start-consed (total-consing)) - (*enclosed-time* 0) - (*enclosed-consing* 0) - (*enclosed-profilings* 0)) - (multiple-value-prog1 - ,(if optionals-p - `(apply old-definition - ,@required-args optional-args) - `(funcall old-definition ,@required-args)) - (setq time-inc (- (quickly-get-time) start-time)) - (setq cons-inc (- (total-consing) start-consed)) - (setq profile-inc *enclosed-profilings*) - (incf time - (the time-type - (- time-inc *enclosed-time*))) - (incf consed - (the consing-type - (- cons-inc *enclosed-consing*))) - (incf profile profile-inc))) - (incf *enclosed-time* time-inc) - (incf *enclosed-consing* cons-inc) - (incf *enclosed-profilings* - (the fixnum (1+ profile-inc))))))) - - (setf (gethash name *profile-info*) - (make-profile-info - :name name - :old-definition old-definition - :new-definition (fdefinition name) - :read-time - #'(lambda () - (values count time consed profile)) - :reset-time - #'(lambda () - (setq count 0) - (setq time 0) - (setq consed 0) - (setq profile 0) - t))))))) - -); EVAL-WHEN (COMPILE LOAD EVAL) - - -;;; Precompute some encapsulation functions: -;;; -(eval-when (compile eval) - (defconstant precomputed-encapsulations 8)) -;;; -(macrolet ((frob () - (let ((res ())) - (dotimes (i precomputed-encapsulations) - (push `(setf (gethash '(,i . nil) *existing-encapsulations*) - #',(make-profile-encapsulation i nil)) - res) - (push `(setf (gethash '(,i . t) *existing-encapsulations*) - #',(make-profile-encapsulation i t)) - res)) - `(progn ,@res)))) - (frob)) - - - -;;; Interfaces: - -;;; PROFILE-1-FUNCTION -- Internal -;;; -;;; Profile the function Name. If already profiled, unprofile first. -;;; -(defun profile-1-function (name) - (cond ((fboundp name) - (when (gethash name *profile-info*) - (warn "~S already profiled, so unprofiling it first." name) - (unprofile-1-function name)) - (multiple-value-bind (min-args optionals-p) - (required-arguments name) - (funcall (or (gethash (cons min-args optionals-p) - *existing-encapsulations*) - (setf (gethash (cons min-args optionals-p) - *existing-encapsulations*) - (compile nil (make-profile-encapsulation - min-args optionals-p)))) - name))) - (t - (warn "Ignoring undefined function ~S." name)))) - - -;;; PROFILE -- Public -;;; -(defmacro profile (&rest names) - "PROFILE Name* - Wraps profiling code around the named functions. As in TRACE, the names are - not evaluated. If a function is already profiled, then unprofile and - reprofile (useful to notice function redefinition.) If a name is undefined, - then we give a warning and ignore it. See also UNPROFILE, REPORT-TIME and - RESET-TIME." - `(progn - ,@(mapcar #'(lambda (name) - `(profile-1-function ',name)) - names) - (values))) - - -;;; UNPROFILE -- Public -;;; -(defmacro unprofile (&rest names) - "Unwraps the profiling code around the named functions. Names defaults to - the list of all currently profiled functions." - `(dolist (name ,(if names `',names '*timed-functions*) (values)) - (unprofile-1-function name))) - - -;;; UNPROFILE-1-FUNCTION -- Internal -;;; -(defun unprofile-1-function (name) - (let ((info (profile-info-or-lose name))) - (remhash name *profile-info*) - (setq *timed-functions* - (delete name *timed-functions* - :test #'equal)) - (if (eq (fdefinition name) (profile-info-new-definition info)) - (setf (fdefinition name) (profile-info-old-definition info)) - (warn "Preserving current definition of redefined function ~S." - name)))) - - -(defmacro report-time (&rest names) - "Reports the time spent in the named functions. Names defaults to the list of - all currently profiled functions." - `(%report-times ,(if names `',names '*timed-functions*))) - - -(defstruct (time-info - (:constructor make-time-info (name calls time consing))) - name - calls - time - consing) - - -;;; COMPENSATE-TIME -- Internal -;;; -;;; Return our best guess for the run time in a function, subtracting out -;;; factors for profiling overhead. We subtract out the internal overhead for -;;; each call to this function, since the internal overhead is the part of the -;;; profiling overhead for a function that is charged to that function. -;;; -;;; We also subtract out a factor for each call to a profiled function -;;; within this profiled function. This factor is the total profiling overhead -;;; *minus the internal overhead*. We don't subtract out the internal -;;; overhead, since it was already subtracted when the nested profiled -;;; functions subtracted their running time from the time for the enclosing -;;; function. -;;; -(defun compensate-time (calls time profile) - (let ((compensated - (- (/ (float time) (float quick-time-units-per-second)) - (* *internal-profile-overhead* (float calls)) - (* (- *total-profile-overhead* *internal-profile-overhead*) - (float profile))))) - (if (minusp compensated) 0.0 compensated))) - - -(defun %report-times (names) - (unless (boundp '*call-overhead*) - (compute-time-overhead)) - (let ((info ()) - (no-call ())) - (dolist (name names) - (let ((pinfo (profile-info-or-lose name))) - (unless (eq (fdefinition name) - (profile-info-new-definition pinfo)) - (warn "Function ~S has been redefined, so times may be inaccurate.~@ - PROFILE it again to record calls to the new definition." - name)) - (multiple-value-bind - (calls time consing profile) - (funcall (profile-info-read-time pinfo)) - (if (zerop calls) - (push name no-call) - (push (make-time-info name calls - (compensate-time calls time profile) - consing) - info))))) - - (setq info (sort info #'>= :key #'time-info-time)) - - (format *trace-output* - "~& Seconds | Consed | Calls | Sec/Call | Name:~@ - ------------------------------------------------------~%") - - (let ((total-time 0.0) - (total-consed 0) - (total-calls 0)) - (dolist (time info) - (incf total-time (time-info-time time)) - (incf total-calls (time-info-calls time)) - (incf total-consed (time-info-consing time)) - (format *trace-output* - "~10,3F | ~9:D | ~7:D | ~10,5F | ~S~%" - (time-info-time time) - (time-info-consing time) - (time-info-calls time) - (/ (time-info-time time) (float (time-info-calls time))) - (time-info-name time))) - (format *trace-output* - "------------------------------------------------------~@ - ~10,3F | ~9:D | ~7:D | | Total~%" - total-time total-consed total-calls) - - (format *trace-output* - "~%Estimated total profiling overhead: ~4,2F seconds~%" - (* *total-profile-overhead* (float total-calls)))) - - (when no-call - (format *trace-output* - "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" - (sort no-call #'string< :key #'symbol-name))) - (values))) - - -(defmacro reset-time (&rest names) - "Resets the time counter for the named functions. Names defaults to the list - of all currently profiled functions." - `(%reset-time ,(if names `',names '*timed-functions*))) - -(defun %reset-time (names) - (dolist (name names) - (funcall (profile-info-reset-time (profile-info-or-lose name)))) - (values)) - - -;;;; Overhead computation. - -;;; We average the timing overhead over this many iterations. -;;; -(defconstant timer-overhead-iterations 5000) - - -;;; COMPUTE-TIME-OVERHEAD-AUX -- Internal -;;; -;;; Dummy function we profile to find profiling overhead. Declare -;;; debug-info to make sure we have arglist info. -;;; -(proclaim '(notinline compute-time-overhead-aux)) -(defun compute-time-overhead-aux (x) - (declare (ext:optimize-interface (debug-info 2))) - (declare (ignore x))) - - -;;; COMPUTE-TIME-OVERHEAD -- Internal -;;; -;;; Initialize the profiling overhead variables. -;;; -(defun compute-time-overhead () - (macrolet ((frob (var) - `(let ((start (quickly-get-time)) - (fun (symbol-function 'compute-time-overhead-aux))) - (dotimes (i timer-overhead-iterations) - (funcall fun fun)) - (setq ,var - (/ (float (- (quickly-get-time) start)) - (float quick-time-units-per-second) - (float timer-overhead-iterations)))))) - (frob *call-overhead*) - - (unwind-protect - (progn - (profile compute-time-overhead-aux) - (frob *total-profile-overhead*) - (decf *total-profile-overhead* *call-overhead*) - (let ((pinfo (profile-info-or-lose 'compute-time-overhead-aux))) - (multiple-value-bind (calls time) - (funcall (profile-info-read-time pinfo)) - (declare (ignore calls)) - (setq *internal-profile-overhead* - (/ (float time) - (float quick-time-units-per-second) - (float timer-overhead-iterations)))))) - (unprofile compute-time-overhead-aux)))) - -#+cmu -(pushnew #'(lambda () - (makunbound '*call-overhead*)) - ext:*before-save-initializations*) diff --git a/code/purify.lisp b/code/purify.lisp deleted file mode 100644 index 1ced80ba23d4b198f98583784c5f5973caba05d1..0000000000000000000000000000000000000000 --- a/code/purify.lisp +++ /dev/null @@ -1,41 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/purify.lisp,v 1.13 1992/03/26 03:18:51 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Storage purifier for Spice Lisp. -;;; Written by Rob MacLachlan and Skef Wholey. -;;; -;;; Rewritten in C by William Lott. -;;; -(in-package 'lisp) - -(alien:def-alien-routine ("purify" %purify) c-call:void - (static-roots c-call:unsigned-long) - (read-only-roots c-call:unsigned-long)) - -(defun purify (&key root-structures constants) - (let ((*gc-notify-before* - #'(lambda (bytes-in-use) - (declare (ignore bytes-in-use)) - (write-string "[Doing purification: ") - (force-output))) - (*internal-gc* - #'(lambda () - (%purify (get-lisp-obj-address root-structures) - (get-lisp-obj-address constants)))) - (*gc-notify-after* - #'(lambda (&rest ignore) - (declare (ignore ignore)) - (write-line "Done.]")))) - (gc t)) - nil) - diff --git a/code/query.lisp b/code/query.lisp deleted file mode 100644 index 2a5efca2fd645d730488aae75972eecbd5bff46b..0000000000000000000000000000000000000000 --- a/code/query.lisp +++ /dev/null @@ -1,79 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/query.lisp,v 1.3 1991/02/14 19:03:24 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Querying the user. -;;; Written by Walter van Roggen, 27 December 1982. -;;; Brought up to date and fixed somewhat by Rob MacLachlan. -;;; Modified by Bill Chiles. -;;; -;;; These functions are part of the standard Spice Lisp environment. -;;; -;;; ********************************************************************** -;;; - -(in-package "LISP") - -(export '(y-or-n-p yes-or-no-p)) - -(eval-when (compile) - (defmacro query-readline () - `(string-trim " " (read-line *query-io*)))) - -;;; Y-OR-N-P -- Public. -;;; -(defun y-or-n-p (&optional format-string &rest arguments) - "Y-OR-N-P prints the message, if any, and reads characters from *QUERY-IO* - until the user enters y or Y as an affirmative, or either n or N as a - negative answer. It ignores preceding whitespace and asks again if you - enter any other characters." - (when format-string - (fresh-line *query-io*) - (apply #'format *query-io* format-string arguments) - (force-output *query-io*)) - (loop - (let* ((line (query-readline)) - (ans (if (string= line "") - #\? ;Force CASE below to issue instruction. - (schar line 0)))) - (unless (whitespacep ans) - (case ans - ((#\y #\Y) (return t)) - ((#\n #\N) (return nil)) - (t - (write-line "Type \"y\" for yes or \"n\" for no. " *query-io*) - (when format-string - (apply #'format *query-io* format-string arguments)) - (force-output *query-io*))))))) - -;;; YES-OR-NO-P -- Public. -;;; -;;; This is similar to Y-OR-N-P, but it clears the input buffer, beeps, and -;;; uses READ-LINE to get "YES" or "NO". -;;; -(defun yes-or-no-p (&optional format-string &rest arguments) - "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the - input buffer, beeps, and uses READ-LINE to get the strings - YES or NO." - (clear-input *query-io*) - (beep) - (when format-string - (fresh-line *query-io*) - (apply #'format *query-io* format-string arguments)) - (do ((ans (query-readline) (query-readline))) - (()) - (cond ((string-equal ans "YES") (return t)) - ((string-equal ans "NO") (return nil)) - (t - (write-line "Type \"yes\" for yes or \"no\" for no. " *query-io*) - (when format-string - (apply #'format *query-io* format-string arguments)))))) diff --git a/code/rand.lisp b/code/rand.lisp deleted file mode 100644 index 306279f2dfe91fa4eceb33ba07517d2922c80fce..0000000000000000000000000000000000000000 --- a/code/rand.lisp +++ /dev/null @@ -1,119 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/rand.lisp,v 1.4 1991/12/14 09:01:01 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Functions to random number functions for Spice Lisp -;;; Written by David Adam. -;;; -;;; The random number functions are part of the standard Spicelisp environment. -;;; -;;; ********************************************************************** -;;; -(in-package 'lisp) -(export '(random-state random-state-p random *random-state* - make-random-state)) - -(defconstant random-const-a 8373) -(defconstant random-const-c 101010101) -(defconstant random-upper-bound (1- most-positive-fixnum)) -(defconstant random-max 54) -(defconstant %fixnum-length (integer-length most-positive-fixnum)) -(defvar rand-seed 0) - -(defstruct (random-state - (:constructor make-random-object) - (:make-load-form-fun :just-dump-it-normally)) - (j 24 :type integer) - (k 0 :type integer) - (seed (make-array (1+ random-max) :initial-contents - (do ((list-rands () (cons (rand1) list-rands)) - (i 0 (1+ i))) - ((> i random-max) list-rands))) - :type simple-vector)) - - -;;; Generates a random number from rand-seed. -(defun rand1 () - (setq rand-seed (mod (+ (* rand-seed random-const-a) random-const-c) - (1+ random-upper-bound)))) - - -(defvar *random-state* (make-random-object)) - - -;;; rand3 -- Internal -;;; -;;; This function generates fixnums between 0 and random-upper-bound, -;;; inclusive For the algorithm to work random-upper-bound must be an -;;; even positive fixnum. State is the random state to use. -;;; -(defun rand3 (state) - (let ((seed (random-state-seed state)) - (j (random-state-j state)) - (k (random-state-k state))) - (declare (fixnum j k) (simple-vector seed)) - (setf (svref seed k) - (let ((a (- random-upper-bound - (svref seed - (setf (random-state-j state) - (if (= j 0) random-max (1- j)))) - (svref seed - (setf (random-state-k state) - (if (= k 0) random-max (1- k))))))) - (if (minusp a) (- a) (- random-upper-bound a)))))) - - -(defun copy-state (cur-state) - (let ((state (make-random-object - :seed (make-array 55) - :j (random-state-j cur-state) - :k (random-state-k cur-state)))) - (do ((i 0 (1+ i))) - ((= i 55) state) - (declare (fixnum i)) - (setf (aref (random-state-seed state) i) - (aref (random-state-seed cur-state) i))))) - -(defun make-random-state (&optional state) - "Make a random state object. If State is not supplied, return a copy - of the default random state. If State is a random state, then return a - copy of it. If state is T then return a random state generated from - the universal time." - (cond ((not state) (copy-state *random-state*)) - ((random-state-p state) (copy-state state)) - ((eq state t) (setq rand-seed (get-universal-time)) - (make-random-object)) - (t (error "Bad argument, ~A, for RANDOM-STATE." state)))) - -(proclaim '(ftype (function (t) fixnum) rand3)) -(defun random (arg &optional (state *random-state*)) - "Generate a uniformly distributed pseudo-random number between zero - and Arg. State, if supplied, is the random state to use." - (typecase arg - (fixnum - (unless (plusp (the fixnum arg)) - (error "Non-positive argument, ~A, to RANDOM." arg)) - (rem (the fixnum (rand3 state)) (the fixnum arg))) - (float - (unless (plusp arg) - (error "Non-positive argument, ~A, to RANDOM." arg)) - (let ((arg-length (float-digits arg))) - (* arg (/ (float (random (ash 2 arg-length) state)) - (float (ash 2 arg-length)))))) - (integer - (unless (plusp arg) - (error "Non-positive argument, ~A, to RANDOM." arg)) - (do ((tot (rand3 state) (+ (ash tot %fixnum-length) (rand3 state))) - (end (ash arg (- %fixnum-length)) - (ash end (- %fixnum-length)))) - ((zerop end) (mod tot arg)))) - (t (error "Wrong type argument, ~A, to RANDOM." arg)))) diff --git a/code/reader.lisp b/code/reader.lisp deleted file mode 100644 index 714ba23bdf3ae2fe1df49eacdaef5670037306a8..0000000000000000000000000000000000000000 --- a/code/reader.lisp +++ /dev/null @@ -1,1417 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/reader.lisp,v 1.16 1992/06/04 17:03:51 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Spice Lisp Reader -;;; Written by David Dill -;;; Package system interface by Lee Schumacher. -;;; Runs in the standard Spice Lisp environment. -;;; - -(in-package "EXTENSIONS") -(export '*ignore-extra-close-parentheses*) - -(in-package "LISP") -(export '(readtable readtable-case readtablep *read-base* *readtable* - copy-readtable set-syntax-from-char set-macro-character - get-macro-character make-dispatch-macro-character - set-dispatch-macro-character get-dispatch-macro-character read - *read-default-float-format* read-preserving-whitespace - read-delimited-list parse-integer read-from-string *read-suppress* - reader-error)) - - -;;;Random global variables - -(defvar *read-default-float-format* 'single-float "Float format for 1.0E1") - -(defvar *readtable* () "Variable bound to current readtable.") - - -;;;; Reader errors: - -(define-condition reader-error (stream-error) - (format-control - (format-arguments :init-form ())) - (:report - (lambda (condition stream) - (let ((error-stream (stream-error-stream condition))) - (format stream "Reader error ~@[at ~D ~]on ~S:~%~?" - (file-position error-stream) error-stream - (reader-error-format-control condition) - (reader-error-format-arguments condition)))))) - -(define-condition reader-package-error (reader-error)) - -;;; %READ-ERROR -- Interface -;;; -;;; Like, signal a READ-ERROR, man... -;;; -(defun %reader-error (stream control &rest args) - (error 'reader-error :stream stream :format-control control - :format-arguments args)) - -(define-condition reader-eof-error (end-of-file) - (context) - (:report - (lambda (condition stream) - (format stream "Unexpected EOF on ~S ~A." - (stream-error-stream condition) - (reader-eof-error-context condition))))) - -(defun reader-eof-error (stream context) - (error 'reader-eof-error :stream stream :context context)) - - -;;;; Readtable implementation. - - -(defvar std-lisp-readtable () - "Standard lisp readtable. This is for recovery from broken - read-tables, and should not normally be user-visible.") - -(defstruct (readtable - (:conc-name nil) - (:predicate readtablep) - (:copier nil) - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (print-unreadable-object (s stream :identity t) - (prin1 'readtable stream))))) - "Readtable is a data structure that maps characters into syntax - types for the Common Lisp expression reader." - ;; The CHARACTER-ATTRIBUTE-TABLE is a vector of CHAR-CODE-LIMIT integers for - ;; describing the character type. Conceptually, there are 4 distinct - ;; "primary" character attributes: WHITESPACE, TERMINATING-MACRO, ESCAPE, and - ;; CONSTITUENT. Non-terminating macros (such as the symbol reader) have the - ;; attribute CONSTITUENT. - ;; - ;; In order to make the READ-TOKEN fast, all this information is - ;; stored in the character attribute table by having different varieties of - ;; constituents. - (character-attribute-table (make-character-attribute-table) - :type simple-vector) - ;; - ;; The CHARACTER-MACRO-TABLE is a vector of CHAR-CODE-LIMIT functions. One - ;; of these functions called with appropriate arguments whenever any - ;; non-WHITESPACE character is encountered inside READ-PRESERVING-WHITESPACE. - ;; These functions are used to implement user-defined read-macros, system - ;; read-macros, and the number-symbol reader. - (character-macro-table (make-character-macro-table) :type simple-vector) - ;; - ;; DISPATCH-TABLES entry, which is an alist from dispatch characters to - ;; vectors of CHAR-CODE-LIMIT functions, for use in defining dispatching - ;; macros (like #-macro). - (dispatch-tables () :type list) - (readtable-case :upcase :type (member :upcase :downcase :preserve :invert))) - - -;;;; Constants for character attributes. These are all as in the manual. - -(eval-when (compile load eval) - (defconstant whitespace 0) - (defconstant terminating-macro 1) - (defconstant escape 2) - (defconstant constituent 3) - (defconstant constituent-dot 4) - (defconstant constituent-expt 5) - (defconstant constituent-slash 6) - (defconstant constituent-digit 7) - (defconstant constituent-sign 8) - ; 9 - (defconstant multiple-escape 10) - (defconstant package-delimiter 11) - ;;fake attribute for use in read-unqualified-token - (defconstant delimiter 12)) - - -;;;; Package specials. - -(defvar *old-package* () - "Value of *package* at the start of the last read or Nil.") - -;;; In case we get an error trying to parse a symbol, we want to rebind the -;;; above stuff so it's cool. - -(proclaim '(special *package* *keyword-package* *read-base*)) - - - -;;;; Macros and functions for character tables. - -(defmacro get-cat-entry (char rt) - ;;only give this side-effect-free args. - `(elt (the simple-vector (character-attribute-table ,rt)) - (char-code ,char))) - -(defun set-cat-entry (char newvalue &optional (rt *readtable*)) - (setf (elt (the simple-vector (character-attribute-table rt)) - (char-code char)) - newvalue)) - -(defmacro get-cmt-entry (char rt) - `(elt (the simple-vector (character-macro-table ,rt)) - (char-code ,char))) - -(defun set-cmt-entry (char newvalue &optional (rt *readtable*)) - (setf (elt (the simple-vector (character-macro-table rt)) - (char-code char)) - newvalue)) - -(defun make-character-attribute-table () - (make-array char-code-limit :element-type t :initial-element #.constituent)) - -(defun make-character-macro-table () - (make-array char-code-limit :element-type t - :initial-element #'undefined-macro-char)) - -(defun undefined-macro-char (stream char) - (unless *read-suppress* - (%reader-error stream "Undefined read-macro character ~S" char))) - -;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers. - -(defmacro test-attribute (char whichclass rt) - `(= (the fixnum (get-cat-entry ,char ,rt)) ,whichclass)) - -;;; Predicates for testing character attributes - -;;; Make this a function, since other people want to use it. -;;; -(proclaim '(inline whitespacep)) -(defun whitespacep (char &optional (rt *readtable*)) - (test-attribute char whitespace rt)) - -(defmacro constituentp (char &optional (rt '*readtable*)) - `(>= (get-cat-entry ,char ,rt) #.constituent)) - -(defmacro terminating-macrop (char &optional (rt '*readtable*)) - `(test-attribute ,char #.terminating-macro ,rt)) - -(defmacro escapep (char &optional (rt '*readtable*)) - `(test-attribute ,char #.escape ,rt)) - -(defmacro multiple-escape-p (char &optional (rt '*readtable*)) - `(test-attribute ,char #.multiple-escape ,rt)) - -(defmacro token-delimiterp (char &optional (rt '*readtable*)) - ;;depends on actual attribute numbering above. - `(<= (get-cat-entry ,char ,rt) #.terminating-macro)) - - - -;;;; Secondary attribute table. - -;;; There are a number of "secondary" attributes which are constant properties -;;; of characters characters (as long as they are constituents). - -(defvar secondary-attribute-table ()) - -(defun set-secondary-attribute (char attribute) - (setf (elt (the simple-vector secondary-attribute-table) (char-code char)) - attribute)) - - -(defun init-secondary-attribute-table () - (setq secondary-attribute-table - (make-array char-code-limit :element-type t - :initial-element #.constituent)) - (set-secondary-attribute #\: #.package-delimiter) - (set-secondary-attribute #\| #.multiple-escape) ; |) [For EMACS] - (set-secondary-attribute #\. #.constituent-dot) - (set-secondary-attribute #\+ #.constituent-sign) - (set-secondary-attribute #\- #.constituent-sign) - (set-secondary-attribute #\/ #.constituent-slash) - (do ((i (char-code #\0) (1+ i))) - ((> i (char-code #\9))) - (set-secondary-attribute (code-char i) #.constituent-digit)) - (set-secondary-attribute #\E #.constituent-expt) - (set-secondary-attribute #\F #.constituent-expt) - (set-secondary-attribute #\D #.constituent-expt) - (set-secondary-attribute #\S #.constituent-expt) - (set-secondary-attribute #\L #.constituent-expt) - (set-secondary-attribute #\e #.constituent-expt) - (set-secondary-attribute #\f #.constituent-expt) - (set-secondary-attribute #\d #.constituent-expt) - (set-secondary-attribute #\s #.constituent-expt) - (set-secondary-attribute #\l #.constituent-expt)) - -(defmacro get-secondary-attribute (char) - `(elt (the simple-vector secondary-attribute-table) - (char-code ,char))) - - - -;;;; Readtable operations. - -(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) - "A copy is made of from-readtable and place into to-readtable." - (let ((from-readtable (or from-readtable std-lisp-readtable)) - (to-readtable (or to-readtable (make-readtable)))) - ;;physically clobber contents of internal tables. - (replace (character-attribute-table to-readtable) - (character-attribute-table from-readtable)) - (replace (character-macro-table to-readtable) - (character-macro-table from-readtable)) - (setf (dispatch-tables to-readtable) - (mapcar #'(lambda (pair) (cons (car pair) - (copy-seq (cdr pair)))) - (dispatch-tables from-readtable))) - to-readtable)) - -(defun set-syntax-from-char (to-char from-char &optional - (to-readtable *readtable*) - (from-readtable ())) - "Causes the syntax of to-char to be the same as from-char in the - optional readtable (defaults to the current readtable). The - from-table defaults the standard lisp readtable by being nil." - (let ((from-readtable (or from-readtable std-lisp-readtable))) - ;;copy from-char entries to to-char entries, but make sure that if - ;;from char is a constituent you don't copy non-movable secondary - ;;attributes (constituent types), and that said attributes magically - ;;appear if you transform a non-constituent to a constituent. - (let ((att (get-cat-entry from-char from-readtable))) - (if (constituentp from-char from-readtable) - (setq att (get-secondary-attribute to-char))) - (set-cat-entry to-char att to-readtable) - (set-cmt-entry to-char - (get-cmt-entry from-char from-readtable) - to-readtable))) - t) - -(defun set-macro-character (char function &optional - (non-terminatingp nil) (rt *readtable*)) - "Causes char to be a macro character which invokes function when - seen by the reader. The non-terminatingp flag can be used to - make the macro character non-terminating. The optional readtable - argument defaults to the current readtable. Set-macro-character - returns T." - (if non-terminatingp - (set-cat-entry char (get-secondary-attribute char) rt) - (set-cat-entry char #.terminating-macro rt)) - (set-cmt-entry char function rt) - T) - -(defun get-macro-character (char &optional rt) - "Returns the function associated with the specified char which is a macro - character. The optional readtable argument defaults to the current - readtable." - (let ((rt (or rt *readtable*))) - ;; Check macro syntax, return associated function if it's there. - ;; Returns a value for all constituents. - (cond ((constituentp char) - (values (get-cmt-entry char rt) t)) - ((terminating-macrop char) - (values (get-cmt-entry char rt) nil)) - (t nil)))) - - -;;;; These definitions support internal programming conventions. - -(defconstant eof-object '(*eof*)) - -(defmacro eofp (char) `(eq ,char eof-object)) - -(defun flush-whitespace (stream) - ;;This flushes whitespace chars, returning the last char it read (a non-white - ;;one). It always gets an error on end-of-file. - (prepare-for-fast-read-char stream - (do ((attribute-table (character-attribute-table *readtable*)) - (char (fast-read-char t) (fast-read-char t))) - ((/= (the fixnum (svref attribute-table (char-code char))) #.whitespace) - (done-with-fast-read-char) - char)))) - - - -;;;; Temporary initialization hack. - -(defun init-std-lisp-readtable () - (setq std-lisp-readtable (make-readtable)) - ;;all characters default to "constituent" in make-readtable - ;;*** un-constituent-ize some of these *** - (let ((*readtable* std-lisp-readtable)) - (set-cat-entry #\tab #.whitespace) - (set-cat-entry #\linefeed #.whitespace) - (set-cat-entry #\space #.whitespace) - (set-cat-entry #\page #.whitespace) - (set-cat-entry #\return #.whitespace) - (set-cat-entry #\\ #.escape) - (set-cmt-entry #\\ #'read-token) - (set-cat-entry #\rubout #.whitespace) - (set-cmt-entry #\: #'read-token) - (set-cmt-entry #\| #'read-token) - ;;macro definitions - (set-macro-character #\" #'read-string) - ;;* # macro - (set-macro-character #\' #'read-quote) - (set-macro-character #\( #'read-list) - (set-macro-character #\) #'read-right-paren) - (set-macro-character #\; #'read-comment) - ;;* backquote - ;;all constituents - (do ((ichar 0 (1+ ichar)) - (char)) - ((= ichar #O200)) - (setq char (code-char ichar)) - (when (constituentp char std-lisp-readtable) - (set-cat-entry char (get-secondary-attribute char)) - (set-cmt-entry char #'read-token))))) - - - -;;;; read-buffer implementation. - -(defvar read-buffer) -(defvar read-buffer-length) - -(defvar inch-ptr) -(defvar ouch-ptr) - -(defmacro reset-read-buffer () - ;;turn read-buffer into an empty read-buffer. - ;;ouch-ptr always points to next char to write - `(progn - ;;next is in case interrupt processor has re-bound read-buffer to nil. - (unless (or (boundp 'read-buffer) read-buffer) (init-read-buffer)) - (setq ouch-ptr 0) - ;;inch-ptr always points to next char to read - (setq inch-ptr 0))) - -(defun init-read-buffer () - (setq read-buffer (make-string 512)) ;initial bufsize - (setq read-buffer-length 512) - (reset-read-buffer)) - -(defmacro ouch-read-buffer (char) - `(progn - (if (>= (the fixnum ouch-ptr) - (the fixnum read-buffer-length)) - ;;buffer overflow -- double the size - (grow-read-buffer)) - (setf (elt (the simple-string read-buffer) ouch-ptr) ,char) - (setq ouch-ptr (1+ ouch-ptr)))) -;; macro to move ouch-ptr back one. -(defmacro ouch-unread-buffer () - '(if (> (the fixnum ouch-ptr) (the fixnum inch-ptr)) - (setq ouch-ptr (1- (the fixnum ouch-ptr))))) - -(defun grow-read-buffer () - (let ((rbl (length (the simple-string read-buffer)))) - (declare (fixnum rbl)) - (setq read-buffer - (concatenate 'simple-string - (the simple-string read-buffer) - (the simple-string (make-string rbl)))) - (setq read-buffer-length (* 2 rbl)))) - -(defun inchpeek-read-buffer () - (if (>= (the fixnum inch-ptr) (the fixnum ouch-ptr)) - eof-object - (elt (the simple-string read-buffer) inch-ptr))) - -(defun inch-read-buffer () - (cond ((>= (the fixnum inch-ptr) (the fixnum ouch-ptr)) - eof-object) - (t (prog1 (elt (the simple-string read-buffer) inch-ptr) - (setq inch-ptr (1+ (the fixnum inch-ptr))))))) - -(defmacro unread-buffer () - `(decf (the fixnum inch-ptr))) - -(defun read-unwind-read-buffer () - ;;keep contents, but make next (inch..) return first char. - (setq inch-ptr 0)) - -(defun read-buffer-to-string () - (subseq (the simple-string read-buffer) 0 ouch-ptr)) - - - -;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ. - -(defvar *ignore-extra-close-parentheses* t - "If true, only warn when there is an extra close paren, otherwise error.") - -;; Alist for #=. Used to keep track of objects with labels assigned that have -;; been completly read. Entry is (integer-tag gensym-tag value). -;; -(defvar *sharp-equal-alist* ()) - -(proclaim '(special *standard-input*)) - -;;; READ-PRESERVING-WHITESPACE behaves just like read only it makes sure -;;; to leave terminating whitespace in the stream. -;;; -(defun read-preserving-whitespace (&optional (stream *standard-input*) - (eof-errorp t) (eof-value nil) - (recursivep nil)) - "Reads from stream and returns the object read, preserving the whitespace - that followed the object." - (cond - (recursivep - ;; Loop for repeating when a macro returns nothing. - (loop - (let ((char (read-char stream eof-errorp eof-object))) - (cond ((eofp char) (return eof-value)) - ((whitespacep char)) - (t - (let* ((macrofun (get-cmt-entry char *readtable*)) - (result (multiple-value-list - (funcall macrofun stream char)))) - ;; Repeat if macro returned nothing. - (if result (return (car result))))))))) - (t - (let ((*sharp-equal-alist* nil)) - (read-preserving-whitespace stream eof-errorp eof-value t))))) - - -(defun read-maybe-nothing (stream char) - ;;returns nil or a list with one thing, depending. - ;;for functions that want comments to return so they can look - ;;past them. Assumes char is not whitespace. - (let ((retval (multiple-value-list - (funcall (get-cmt-entry char *readtable*) stream char)))) - (if retval (rplacd retval nil)))) - -(defun read (&optional (stream *standard-input*) (eof-errorp t) - (eof-value ()) (recursivep ())) - "Reads in the next object in the stream, which defaults to - *standard-input*. For details see the I/O chapter of - the manual." - (prog1 - (read-preserving-whitespace stream eof-errorp eof-value recursivep) - (let ((whitechar (read-char stream nil eof-object))) - (if (and (not (eofp whitechar)) - (or (not (whitespacep whitechar)) - recursivep)) - (unread-char whitechar stream))))) - -(defun read-delimited-list (endchar &optional - (input-stream *standard-input*) - recursive-p) - "Reads objects from input-stream until the next character after an - object's representation is endchar. A list of those objects read - is returned." - (declare (ignore recursive-p)) - (do ((char (flush-whitespace input-stream) - (flush-whitespace input-stream)) - (retlist ())) - ((char= char endchar) (nreverse retlist)) - (setq retlist (nconc (read-maybe-nothing input-stream char) retlist)))) - - - -;;;; Standard ReadMacro definitions to implement the reader. - -(defun read-quote (stream ignore) - (declare (ignore ignore)) - (list 'quote (read stream t nil t))) - -(defun read-comment (stream ignore) - (declare (ignore ignore)) - (prepare-for-fast-read-char stream - (do ((char (fast-read-char nil nil) - (fast-read-char nil nil))) - ((or (not char) (char= char #\newline)) - (done-with-fast-read-char)))) - ;;don't return anything - (values)) - -(defun read-list (stream ignore) - (declare (ignore ignore)) - (let* ((thelist (list nil)) - (listtail thelist)) - (do ((firstchar (flush-whitespace stream) (flush-whitespace stream))) - ((char= firstchar #\) ) (cdr thelist)) - (when (char= firstchar #\.) - (let ((nextchar (read-char stream t))) - (cond ((token-delimiterp nextchar) - (cond ((eq listtail thelist) - (%reader-error stream "Nothing appears before . in list.")) - ((whitespacep nextchar) - (setq nextchar (flush-whitespace stream)))) - (rplacd listtail - ;;return list containing last thing. - (car (read-after-dot stream nextchar))) - (return (cdr thelist))) - ;;put back nextchar so we can read it normally. - (t (unread-char nextchar stream))))) - ;;next thing is not an isolated dot. - (let ((listobj (read-maybe-nothing stream firstchar))) - ;;allows the possibility that a comment was read. - (when listobj - (rplacd listtail listobj) - (setq listtail listobj)))))) - -(defun read-after-dot (stream firstchar) - ;;firstchar is non-whitespace! - (let ((lastobj ())) - (do ((char firstchar (flush-whitespace stream))) - ((char= char #\) ) - (%reader-error stream "Nothing appears after . in list.")) - ;;see if there's something there. - (setq lastobj (read-maybe-nothing stream char)) - (when lastobj (return t))) - ;;at least one thing appears after the dot. - ;;check for more than one thing following dot. - (do ((lastchar (flush-whitespace stream) - (flush-whitespace stream))) - ((char= lastchar #\) ) lastobj) ;success! - ;;try reading virtual whitespace - (if (read-maybe-nothing stream lastchar) - (%reader-error stream "More than one object follows . in list."))))) - -(defun read-string (stream closech) - ;;this accumulates chars until it sees same char that invoked it. - ;;for a very long string, this could end up bloating the read buffer. - (reset-read-buffer) - (prepare-for-fast-read-char stream - (do ((char (fast-read-char t) (fast-read-char t))) - ((char= char closech) - (done-with-fast-read-char)) - (if (escapep char) (setq char (fast-read-char t))) - (ouch-read-buffer char))) - (read-buffer-to-string)) - -(defun read-right-paren (stream ignore) - (declare (ignore ignore)) - (cond (*ignore-extra-close-parentheses* - (warn "Ignoring unmatched close parenthesis~ - ~@[ at file position ~D~]." - (file-position stream)) - (values)) - (t - (%reader-error stream "Unmatched close parenthesis.")))) - -;;; INTERNAL-READ-EXTENDED-TOKEN -- Internal -;;; -;;; Read from the stream up to the next delimiter. Leaves resulting token in -;;; read-buffer, returns two values: -;;; -- a list of the escaped character positions, and -;;; -- The position of the first package delimiter (or NIL). -;;; -(defun internal-read-extended-token (stream firstchar) - (reset-read-buffer) - (do ((char firstchar (read-char stream nil eof-object)) - (escapes ()) - (colon nil)) - ((cond ((eofp char) t) - ((token-delimiterp char) - (unread-char char stream) - t) - (t nil)) - (values escapes colon)) - (cond ((escapep char) - ;;it can't be a number, even if it's 1\23. - ;;read next char here, so it won't be casified. - (push ouch-ptr escapes) - (let ((nextchar (read-char stream nil eof-object))) - (if (eofp nextchar) - (reader-eof-error stream "after escape character") - (ouch-read-buffer nextchar)))) - ((multiple-escape-p char) - ;; read to next multiple-escape, escaping single chars along - ;; the way - (loop - (let ((ch (read-char stream nil eof-object))) - (cond - ((eofp ch) - (reader-eof-error stream "inside extended token")) - ((multiple-escape-p ch) (return)) - ((escapep ch) - (let ((nextchar (read-char stream nil eof-object))) - (if (eofp nextchar) - (reader-eof-error stream "after escape character") - (ouch-read-buffer nextchar)))) - (t - (push ouch-ptr escapes) - (ouch-read-buffer ch)))))) - (t - (when (and (constituentp char) - (eql (get-secondary-attribute char) #.package-delimiter) - (not colon)) - (setq colon ouch-ptr)) - (ouch-read-buffer char))))) - - -;;;; Character classes. - -;;; return the character class for a char -;;; -(defmacro char-class (char attable) - `(let ((att (svref ,attable (char-code ,char)))) - (declare (fixnum att)) - (if (<= att #.terminating-macro) - #.delimiter - att))) - -;;; return the character class for a char which might be part of a rational -;;; number -;;; -(defmacro char-class2 (char attable) - `(let ((att (svref ,attable (char-code ,char)))) - (declare (fixnum att)) - (if (<= att #.terminating-macro) - #.delimiter - (if (digit-char-p ,char *read-base*) - constituent-digit - (if (= att constituent-digit) - constituent - att))))) - -;;; return the character class for a char which might be part of a rational or -;;; floating number (assume that it is a digit if it could be) -;;; -(defmacro char-class3 (char attable) - `(let ((att (svref ,attable (char-code ,char)))) - (declare (fixnum att)) - (if possibly-rational - (setq possibly-rational - (or (digit-char-p ,char *read-base*) - (= att constituent-slash)))) - (if possibly-float - (setq possibly-float - (or (digit-char-p ,char 10) - (= att constituent-dot)))) - (if (<= att #.terminating-macro) - #.delimiter - (if (digit-char-p ,char (max *read-base* 10)) - (if (digit-char-p ,char *read-base*) - constituent-digit - constituent) - att)))) - - - -;;;; Token fetching. - -(defvar *read-suppress* nil - "Suppresses most interpreting of the reader when T") - -(defvar *read-base* 10 - "The radix that Lisp reads numbers in.") - - -;;; CASIFY-READ-BUFFER -- Internal -;;; -;;; Modify the read-buffer according to READTABLE-CASE, ignoring escapes. -;;; ESCAPES is a list of the escaped indices, in reverse order. -;;; -(defun casify-read-buffer (escapes) - (let ((case (readtable-case *readtable*))) - (cond - ((and (null escapes) (eq case :upcase)) - (dotimes (i ouch-ptr) - (setf (schar read-buffer i) (char-upcase (schar read-buffer i))))) - ((eq case :preserve)) - (t - (macrolet ((skip-esc (&body body) - `(do ((i (1- ouch-ptr) (1- i)) - (escapes escapes)) - ((minusp i)) - (declare (fixnum i)) - (when (or (null escapes) - (let ((esc (first escapes))) - (declare (fixnum esc)) - (cond ((< esc i) t) - (t - (assert (= esc i)) - (pop escapes) - nil)))) - (let ((ch (schar read-buffer i))) - ,@body))))) - (flet ((lower-em () - (skip-esc (setf (schar read-buffer i) (char-downcase ch)))) - (raise-em () - (skip-esc (setf (schar read-buffer i) (char-upcase ch))))) - (ecase case - (:upcase (raise-em)) - (:downcase (lower-em)) - (:invert - (let ((all-upper t) - (all-lower t)) - (skip-esc - (when (both-case-p ch) - (if (upper-case-p ch) - (setq all-lower nil) - (setq all-upper nil)))) - (cond (all-lower (raise-em)) - (all-upper (lower-em)))))))))))) - -(defun read-token (stream firstchar) - "This function is just an fsm that recognizes numbers and symbols." - ;;check explicitly whether firstchar has entry for non-terminating - ;;in character-attribute-table and read-dot-number-symbol in CMT. - ;;Report an error if these are violated (if we called this, we want - ;;something that is a legitimate token!). - ;;read in the longest possible string satisfying the bnf for - ;;"unqualified-token". Leave the result in the READ-BUFFER. - ;;Return next char after token (last char read). - (when *read-suppress* - (internal-read-extended-token stream firstchar) - (return-from read-token nil)) - (let ((attribute-table (character-attribute-table *readtable*)) - (package nil) - (colons 0) - (possibly-rational t) - (possibly-float t) - (escapes ())) - (reset-read-buffer) - (prog ((char firstchar)) - (case (char-class3 char attribute-table) - (#.constituent-sign (go SIGN)) - (#.constituent-digit (go LEFTDIGIT)) - (#.constituent-dot (go FRONTDOT)) - (#.escape (go ESCAPE)) - (#.package-delimiter (go COLON)) - (#.multiple-escape (go MULT-ESCAPE)) - ;;can't have eof, whitespace, or terminating macro as first char! - (t (go SYMBOL))) - SIGN - ;;saw "sign" - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (go RETURN-SYMBOL)) - (setq possibly-rational t - possibly-float t) - (case (char-class3 char attribute-table) - (#.constituent-digit (go LEFTDIGIT)) - (#.constituent-dot (go SIGNDOT)) - (#.escape (go ESCAPE)) - (#.package-delimiter (go COLON)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (t (go SYMBOL))) - LEFTDIGIT - ;;saw "[sign] {digit}+" - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (return (make-integer stream))) - (case (char-class3 char attribute-table) - (#.constituent-digit (go LEFTDIGIT)) - (#.constituent-dot (if possibly-float - (go MIDDLEDOT) - (go SYMBOL))) - (#.constituent-expt (go EXPONENT)) - (#.constituent-slash (if possibly-rational - (go RATIO) - (go SYMBOL))) - (#.delimiter (unread-char char stream) (return (make-integer stream))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - MIDDLEDOT - ;;saw "[sign] {digit}+ dot" - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (return (let ((*read-base* 10)) - (make-integer stream)))) - (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.constituent-expt (go EXPONENT)) - (#.delimiter - (unread-char char stream) - (return (let ((*read-base* 10)) - (make-integer stream)))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - RIGHTDIGIT - ;;saw "[sign] {digit}* dot {digit}+" - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (return (make-float))) - (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.constituent-expt (go EXPONENT)) - (#.delimiter (unread-char char stream) (return (make-float))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - SIGNDOT - ;;saw "[sign] dot" - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (t (go SYMBOL))) - FRONTDOT - ;;saw "dot" - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (%reader-error stream "Dot context error.")) - (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.constituent-dot (go DOTS)) - (#.delimiter (%reader-error stream "Dot context error.")) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - EXPONENT - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.constituent-sign (go EXPTSIGN)) - (#.constituent-digit (go EXPTDIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - EXPTSIGN - ;;we got to EXPONENT, and saw a sign character. - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.constituent-digit (go EXPTDIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - EXPTDIGIT - ;;got to EXPONENT, saw "[sign] {digit}+" - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (return (make-float))) - (case (char-class char attribute-table) - (#.constituent-digit (go EXPTDIGIT)) - (#.delimiter (unread-char char stream) (return (make-float))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - RATIO - ;;saw "[sign] {digit}+ slash" - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (go RETURN-SYMBOL)) - (case (char-class2 char attribute-table) - (#.constituent-digit (go RATIODIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - RATIODIGIT - ;;saw "[sign] {digit}+ slash {digit}+" - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (return (make-ratio))) - (case (char-class2 char attribute-table) - (#.constituent-digit (go RATIODIGIT)) - (#.delimiter (unread-char char stream) (return (make-ratio))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - DOTS - ;;saw "dot {dot}+" - (ouch-read-buffer char) - (setq char (read-char stream nil nil)) - (unless char (%reader-error stream "Too many dots.")) - (case (char-class char attribute-table) - (#.constituent-dot (go DOTS)) - (#.delimiter - (unread-char char stream) - (%reader-error stream "Too many dots.")) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - SYMBOL - ;;not a dot, dots, or number. - (prepare-for-fast-read-char stream - (prog () - SYMBOL-LOOP - (ouch-read-buffer char) - (setq char (fast-read-char nil nil)) - (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.escape (done-with-fast-read-char) - (go ESCAPE)) - (#.delimiter (done-with-fast-read-char) - (unread-char char stream) - (go RETURN-SYMBOL)) - (#.multiple-escape (done-with-fast-read-char) - (go MULT-ESCAPE)) - (#.package-delimiter (done-with-fast-read-char) - (go COLON)) - (t (go SYMBOL-LOOP))))) - ESCAPE - ;;saw an escape. - ;;don't put the escape in the read-buffer. - ;;read-next char, put in buffer (no case conversion). - (let ((nextchar (read-char stream nil nil))) - (unless nextchar - (reader-eof-error stream "after escape character")) - (push ouch-ptr escapes) - (ouch-read-buffer nextchar)) - (setq char (read-char stream nil nil)) - (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - MULT-ESCAPE - (do ((char (read-char stream t) (read-char stream t))) - ((multiple-escape-p char)) - (if (escapep char) (setq char (read-char stream t))) - (push ouch-ptr escapes) - (ouch-read-buffer char)) - (setq char (read-char stream nil nil)) - (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL))) - COLON - (casify-read-buffer escapes) - (unless (zerop colons) - (%reader-error stream "Too many colons in ~S" - (read-buffer-to-string))) - (setq colons 1) - (setq package (read-buffer-to-string)) - - (reset-read-buffer) - (setq escapes ()) - (setq char (read-char stream nil nil)) - (unless char (reader-eof-error stream "after reading a colon")) - (case (char-class char attribute-table) - (#.delimiter - (unread-char char stream) - (%reader-error stream "Illegal terminating character after a colon, ~S." - char)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go INTERN)) - (t (go SYMBOL))) - INTERN - (setq colons 2) - (setq char (read-char stream nil nil)) - (unless char - (reader-eof-error stream "after reading a colon")) - (case (char-class char attribute-table) - (#.delimiter - (unread-char char stream) - (%reader-error stream "Illegal terminating character after a colon, ~S" - char)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter - (%reader-error stream "To many colons after ~S:" package)) - (t (go SYMBOL))) - RETURN-SYMBOL - (casify-read-buffer escapes) - (let ((found (if package (find-package package) *package*))) - (unless found - (error 'reader-package-error :stream stream - :format-arguments (list package) - :format-control "Package ~S not found.")) - - (if (or (zerop colons) (= colons 2) (eq found *keyword-package*)) - (return (intern* read-buffer ouch-ptr found)) - (multiple-value-bind (symbol test) - (find-symbol* read-buffer ouch-ptr found) - (when (eq test :external) (return symbol)) - (let ((name (read-buffer-to-string))) - (with-simple-restart (continue "Use symbol anyway.") - (error 'reader-package-error :stream stream - :format-arguments (list name (package-name found)) - :format-control - (if test - "The symbol ~S is not external in the ~A package." - "Symbol ~S not found in the ~A package."))) - (return (intern name found))))))))) - - -(defun read-extended-token (stream &optional (*readtable* *readtable*)) - "For semi-external use: returns 3 values: the string for the token, - a flag for whether there was an escape char, and the position of any - package delimiter." - (let ((firstch (read-char stream nil nil t))) - (cond (firstch - (multiple-value-bind (escapes colon) - (internal-read-extended-token stream firstch) - (casify-read-buffer escapes) - (values (read-buffer-to-string) (not (null escapes)) colon))) - (t - (values "" nil nil))))) - - -;;;; Number reading functions. - -(defmacro digit* nil - `(do ((ch char (inch-read-buffer))) - ((or (eofp ch) (not (digit-char-p ch))) (setq char ch)) - ;;report if at least one digit is seen: - (setq one-digit t))) - -(defmacro exponent-letterp (letter) - `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d))) - - -(defvar *integer-reader-safe-digits* - '#(NIL NIL - 26 17 13 11 10 9 8 8 8 7 7 7 7 6 6 6 6 6 6 6 6 5 5 5 5 5 5 5 5 5 5 5 5 5 5) - "Holds the mapping of base to 'safe' number of digits to read for a fixnum.") - -(defvar *integer-reader-base-power* - '#(NIL NIL - 67108864 129140163 67108864 48828125 60466176 40353607 - 16777216 43046721 100000000 19487171 35831808 62748517 105413504 11390625 - 16777216 24137569 34012224 47045881 64000000 85766121 113379904 6436343 - 7962624 9765625 11881376 14348907 17210368 20511149 24300000 28629151 - 33554432 39135393 45435424 52521875 60466176) - "Holds the largest fixnum power of the base for make-integer.") - -#| -(defun init-integer-reader () - (do ((base 2 (1+ base))) - ((> base 36)) - (let ((digits - (do ((fix (truncate most-positive-fixnum base) - (truncate fix base)) - (digits 0 (1+ digits))) - ((zerop fix) digits)))) - (setf (aref *integer-reader-safe-digits* base) - digits - (aref *integer-reader-base-power* base) - (expt base digits))))) -|# - -(defun make-integer (stream) - "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits, - then multiplying by a power of the base and adding." - (let* ((base (if (boundp '*read-base*) - (if (and (fixnump *read-base*) - (<= 1 *read-base* 36)) - *read-base* - (%reader-error stream "~A not a valid number for *read-base*." - *read-base*)) - 10.)) - (digits-per (aref *integer-reader-safe-digits* base)) - (base-power (aref *integer-reader-base-power* base)) - (negativep nil) - (number 0)) - (read-unwind-read-buffer) - (let ((char (inch-read-buffer))) - (cond ((char= char #\-) - (setq negativep t)) - ((char= char #\+)) - (t (unread-buffer)))) - (loop - (let ((num 0)) - (dotimes (digit digits-per) - (let* ((ch (inch-read-buffer))) - (cond ((or (eofp ch) (char= ch #\.)) - (return-from make-integer - (let ((res - (if (zerop number) num - (+ num (* number - (expt base digit)))))) - (if negativep (- res) res)))) - (t (setq num (+ (digit-char-p ch base) (* num base))))))) - (setq number (+ num (* number base-power))))))) - - - -(defun make-float () - ;;assume that the contents of read-buffer are a legal float, with nothing - ;;else after it. - (read-unwind-read-buffer) - (let ((negative-fraction nil) - (number 0) - (divisor 1) - (negative-exponent nil) - (exponent 0) - (float-char ()) - (char (inch-read-buffer))) - (if (cond ((char= char #\+) t) - ((char= char #\-) (setq negative-fraction t))) - ;;flush it - (setq char (inch-read-buffer))) - ;;read digits before the dot - (do* ((ch char (inch-read-buffer)) - (dig (digit-char-p ch) (digit-char-p ch))) - ((not dig) (setq char ch)) - (setq number (+ (* number 10) dig))) - ;;deal with the dot, if it's there. - (when (char= char #\.) - (setq char (inch-read-buffer)) - ;;read digits after the dot. - (do* ((ch char (inch-read-buffer)) - (dig (and (not (eofp ch)) (digit-char-p ch)) - (and (not (eofp ch)) (digit-char-p ch)))) - ((not dig) (setq char ch)) - (setq divisor (* divisor 10)) - (setq number (+ (* number 10) dig)))) - ;;is there an exponent letter? - (cond ((eofp char) - ;;if not, we've read the whole number. - (let ((num (make-float-aux number divisor - *read-default-float-format*))) - (return-from make-float (if negative-fraction (- num) num)))) - ((exponent-letterp char) - (setq float-char char) - ;;build exponent - (setq char (inch-read-buffer)) - ;;check leading sign - (if (cond ((char= char #\+) t) - ((char= char #\-) (setq negative-exponent t))) - ;;flush sign - (setq char (inch-read-buffer))) - ;;read digits for exponent - (do* ((ch char (inch-read-buffer)) - (dig (and (not (eofp ch)) (digit-char-p ch)) - (and (not (eofp ch)) (digit-char-p ch)))) - ((not dig) - (setq exponent (if negative-exponent (- exponent) exponent))) - (setq exponent (+ (* exponent 10) dig))) - ;;generate and return the float, depending on float-char: - (let* ((float-format (case (char-upcase float-char) - (#\E *read-default-float-format*) - (#\S 'short-float) - (#\F 'single-float) - (#\D 'double-float) - (#\L 'long-float))) - (num (make-float-aux number divisor float-format))) - (setq num (* num (expt 10 exponent))) - (return-from make-float (if negative-fraction (- num) num)))) - ;;should never happen: - (t (error "Internal error in floating point reader."))))) - -(defun make-float-aux (number divisor float-format) - (coerce (/ number divisor) float-format)) - - -(defun make-ratio () - ;;assume read-buffer contains a legal ratio. Build the number from - ;;the string. - ;;look for optional "+" or "-". - (let ((numerator 0) (denominator 0) (char ()) (negative-number nil)) - (read-unwind-read-buffer) - (setq char (inch-read-buffer)) - (cond ((char= char #\+) - (setq char (inch-read-buffer))) - ((char= char #\-) - (setq char (inch-read-buffer)) - (setq negative-number t))) - ;;get numerator - (do* ((ch char (inch-read-buffer)) - (dig (digit-char-p ch *read-base*) - (digit-char-p ch *read-base*))) - ((not dig)) - (setq numerator (+ (* numerator *read-base*) dig))) - ;;get denominator - (do* ((ch (inch-read-buffer) (inch-read-buffer)) - (dig ())) - ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*))))) - (setq denominator (+ (* denominator *read-base*) dig))) - (let ((num (/ numerator denominator))) - (if negative-number (- num) num)))) - - - -;;;; dispatching macro cruft - -(defun make-char-dispatch-table () - (make-array char-code-limit :initial-element #'dispatch-char-error)) - -(defun dispatch-char-error (stream sub-char ignore) - (declare (ignore ignore)) - (if *read-suppress* - (values) - (%reader-error stream "No dispatch function defined for ~S." sub-char))) - -(defun make-dispatch-macro-character (char &optional - (non-terminating-p nil) - (rt *readtable*)) - "Causes char to become a dispatching macro character in readtable - (which defaults to the current readtable). If the non-terminating-p - flag is set to T, the char will be non-terminating. Make-dispatch- - macro-character returns T." - (set-macro-character char #'read-dispatch-char non-terminating-p rt) - (let* ((dalist (dispatch-tables rt)) - (dtable (cdr (find char dalist :test #'char= :key #'car)))) - (cond (dtable - (error "Dispatch character already exists")) - (t - (setf (dispatch-tables rt) - (push (cons char (make-char-dispatch-table)) dalist)))))) - -(defun set-dispatch-macro-character - (disp-char sub-char function &optional (rt *readtable*)) - "Causes function to be called whenever the reader reads - disp-char followed by sub-char. Set-dispatch-macro-character - returns T." - ;;get the dispatch char for macro (error if not there), diddle - ;;entry for sub-char. - (when (digit-char-p sub-char) - (error "Sub-Char must not be a decibal digit: ~S" sub-char)) - (let* ((sub-char (char-upcase sub-char)) - (dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) - (if dpair - (setf (elt (the simple-vector (cdr dpair)) - (char-code sub-char)) - function) - (error "~S is not a dispatch char." disp-char)))) - -(defun get-dispatch-macro-character (disp-char sub-char &optional rt) - "Returns the macro character function for sub-char under disp-char - or nil if there is no associated function." - (unless (digit-char-p sub-char) - (let* ((sub-char (char-upcase sub-char)) - (rt (or rt *readtable*)) - (dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) - (if dpair - (elt (the simple-vector (cdr dpair)) - (char-code sub-char)) - (error "~S is not a dispatch char." disp-char))))) - -(defun read-dispatch-char (stream char) - ;;read some digits - (let ((numargp nil) - (numarg 0) - (sub-char ())) - (do* ((ch (read-char stream nil eof-object) - (read-char stream nil eof-object)) - (dig ())) - ((or (eofp ch) - (not (setq dig (digit-char-p ch)))) - ;;take care of the extra char. - (if (eofp ch) - (reader-eof-error stream "inside dispatch character") - (setq sub-char (char-upcase ch)))) - (setq numargp t) - (setq numarg (+ (* numarg 10) dig))) - ;;look up the function and call it. - (let ((dpair (find char (dispatch-tables *readtable*) - :test #'char= :key #'car))) - (if dpair - (funcall (elt (the simple-vector (cdr dpair)) - (char-code sub-char)) - stream sub-char (if numargp numarg nil)) - (%reader-error stream "No dispatch table for dispatch char."))))) - - - -;;;; READ-FROM-STRING. - -(defvar read-from-string-spares () - "A resource of string streams for Read-From-String.") - -(defun read-from-string (string &optional eof-error-p eof-value - &key (start 0) end - preserve-whitespace) - "The characters of string are successively given to the lisp reader - and the lisp object built by the reader is returned. Macro chars - will take effect." - (declare (string string)) - (with-array-data ((string string) - (start start) - (end (or end (length string)))) - (unless read-from-string-spares - (push (internal-make-string-input-stream "" 0 0) - read-from-string-spares)) - (let ((stream (pop read-from-string-spares))) - (setf (string-input-stream-string stream) string) - (setf (string-input-stream-current stream) start) - (setf (string-input-stream-end stream) end) - (unwind-protect - (values (if preserve-whitespace - (read-preserving-whitespace stream eof-error-p eof-value) - (read stream eof-error-p eof-value)) - (string-input-stream-current stream)) - (push stream read-from-string-spares))))) - - -;;;; PARSE-INTEGER. - -(defun parse-integer (string &key (start 0) end (radix 10) junk-allowed) - "Examine the substring of string delimited by start and end - (default to the beginning and end of the string) It skips over - whitespace characters and then tries to parse an integer. The - radix parameter must be between 2 and 36." - (with-array-data ((string string) - (start start) - (end (or end (length string)))) - (let ((index (do ((i start (1+ i))) - ((= i end) - (if junk-allowed - (return-from parse-integer (values nil end)) - (error "No non-whitespace characters in number."))) - (declare (fixnum i)) - (unless (whitespacep (char string i)) (return i)))) - (minusp nil) - (found-digit nil) - (result 0)) - (declare (fixnum index)) - (let ((char (char string index))) - (cond ((char= char #\-) - (setq minusp t) - (incf index)) - ((char= char #\+) - (incf index)))) - (loop - (when (= index end) (return nil)) - (let* ((char (char string index)) - (weight (digit-char-p char radix))) - (cond (weight - (setq result (+ weight (* result radix)) - found-digit t)) - (junk-allowed (return nil)) - ((whitespacep char) - (do ((jndex (1+ index) (1+ jndex))) - ((= jndex end)) - (declare (fixnum jndex)) - (unless (whitespacep (char string jndex)) - (error "There's junk in this string: ~S." string))) - (return nil)) - (t - (error "There's junk in this string: ~S." string)))) - (incf index)) - (values - (if found-digit - (if minusp (- result) result) - (if junk-allowed - nil - (error "There's no digits in this string: ~S" string))) - index)))) - - -;;;; Reader initialization code. - -(defun reader-init () - (init-read-buffer) - (init-secondary-attribute-table) - (init-std-lisp-readtable) -; (init-integer-reader) - ) diff --git a/code/remote.lisp b/code/remote.lisp deleted file mode 100644 index 8cbcdb4390cd3ddca2eba6fb03a64ec0b95e0e47..0000000000000000000000000000000000000000 --- a/code/remote.lisp +++ /dev/null @@ -1,367 +0,0 @@ -;;; -*- Log: code.log; Package: wire -*- -;;; -;;; ********************************************************************** -;;; 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/code/remote.lisp,v 1.4 1992/12/08 20:05:17 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file implements a simple remote procedure call mechanism on top -;;; of wire.lisp. -;;; -;;; Written by William Lott. -;;; - -(in-package "WIRE") - -(export '(remote remote-value remote-value-bind create-request-server - destroy-request-server connect-to-remote-server)) - - -(defstruct remote-wait - value1 value2 value3 value4 value5 - abort - finished) - -(defvar *pending-returns* nil - "AList of wire . remote-wait structs") - - -;;; MAYBE-NUKE-REMOTE-WAIT -- internal -;;; -;;; If the remote wait has finished, remove the external translation. -;;; Otherwise, mark the remote wait as finished so the next call to -;;; MAYBE-NUKE-REMOTE-WAIT will really nuke it. -;;; -(defun maybe-nuke-remote-wait (remote) - (cond ((remote-wait-finished remote) - (forget-remote-translation remote) - t) - (t - (setf (remote-wait-finished remote) - t) - nil))) - -;;; REMOTE -- public -;;; -;;; Execute the body remotly. Subforms are executed locally in the lexical -;;; envionment of the macro call. No values are returned. -;;; -(defmacro remote (wire-form &body forms) - "Evaluates the given forms remotly. No values are returned, as the remote -evaluation is asyncronus." - (let ((wire (gensym))) - `(let ((,wire ,wire-form)) - ,@(mapcar #'(lambda (form) - `(wire-output-funcall ,wire - ',(car form) - ,@(cdr form))) - forms) - (values)))) - -;;; REMOTE-VALUE-BIND -- public -;;; -;;; Send to remote forms. First, a call to the correct dispatch routine based -;;; on the number of args, then the actual call. The dispatch routine will get -;;; the second funcall and fill in the correct number of arguments. -;;; Note: if there are no arguments, we don't even wait for the function to -;;; return, cause we can kind of guess at what the currect results would be. -;;; -(defmacro remote-value-bind (wire-form vars form &rest body) - "Bind vars to the multiple values of form (which is executed remotly). The -forms in body are only executed if the remote function returned as apposed -to aborting due to a throw." - (cond - ((null vars) - `(progn - (remote ,wire-form ,form) - ,@body)) - (t - (let ((remote (gensym)) - (wire (gensym))) - `(let* ((,remote (make-remote-wait)) - (,wire ,wire-form) - (*pending-returns* (cons (cons ,wire ,remote) - *pending-returns*))) - (unwind-protect - (let ,vars - (remote ,wire - (,(case (length vars) - (1 'do-1-value-call) - (2 'do-2-value-call) - (3 'do-3-value-call) - (4 'do-4-value-call) - (5 'do-5-value-call) - (t 'do-n-value-call)) - (make-remote-object ,remote)) - ,form) - (wire-force-output ,wire) - (loop - (system:serve-all-events) - (when (remote-wait-finished ,remote) - (return))) - (unless (remote-wait-abort ,remote) - ,(case (length vars) - (1 `(setf ,(first vars) (remote-wait-value1 ,remote))) - (2 `(setf ,(first vars) (remote-wait-value1 ,remote) - ,(second vars) (remote-wait-value2 ,remote))) - (3 `(setf ,(first vars) (remote-wait-value1 ,remote) - ,(second vars) (remote-wait-value2 ,remote) - ,(third vars) (remote-wait-value3 ,remote))) - (4 `(setf ,(first vars) (remote-wait-value1 ,remote) - ,(second vars) (remote-wait-value2 ,remote) - ,(third vars) (remote-wait-value3 ,remote) - ,(fourth vars) (remote-wait-value4 ,remote))) - (5 `(setf ,(first vars) (remote-wait-value1 ,remote) - ,(second vars) (remote-wait-value2 ,remote) - ,(third vars) (remote-wait-value3 ,remote) - ,(fourth vars) (remote-wait-value4 ,remote) - ,(fifth vars) (remote-wait-value5 ,remote))) - (t - (do ((remaining-vars vars (cdr remaining-vars)) - (form (list 'setf) - (nconc form - (list (car remaining-vars) - `(pop values))))) - ((null remaining-vars) - `(let ((values (remote-wait-value1 ,remote))) - ,form))))) - ,@body)) - (maybe-nuke-remote-wait ,remote))))))) - - -;;; REMOTE-VALUE -- public -;;; -;;; Alternate interface to getting the single return value of a remote -;;; function. Works pretty much just the same, except the single value is -;;; returned. -;;; -(defmacro remote-value (wire-form form &optional - (on-server-unwind - `(error "Remote server unwound"))) - "Execute the single form remotly. The value of the form is returned. - The optional form on-server-unwind is only evaluated if the server unwinds - instead of returning." - (let ((remote (gensym)) - (wire (gensym))) - `(let* ((,remote (make-remote-wait)) - (,wire ,wire-form) - (*pending-returns* (cons (cons ,wire ,remote) - *pending-returns*))) - (unwind-protect - (progn - (remote ,wire - (do-1-value-call (make-remote-object ,remote)) - ,form) - (wire-force-output ,wire) - (loop - (system:serve-all-events) - (when (remote-wait-finished ,remote) - (return)))) - (maybe-nuke-remote-wait ,remote)) - (if (remote-wait-abort ,remote) - ,on-server-unwind - (remote-wait-value1 ,remote))))) - -;;; DEFINE-FUNCTIONS -- internal -;;; -;;; Defines two functions, one that the client runs in the server, and one -;;; that the server runs in the client: -;;; -;;; DO-n-VALUE-CALL -- internal -;;; -;;; Executed by the remote process. Reads the next object off the wire and -;;; sends the value back. Unwind-protect is used to make sure we send something -;;; back so the requestor doesn't hang. -;;; -;;; RETURN-n-VALUE -- internal -;;; -;;; The remote procedure returned the given value, so fill it in the -;;; remote-wait structure. Note, if the requestor has aborted, just throw -;;; the value away. -;;; -(defmacro define-functions (values) - (let ((do-call (intern (format nil "~:@(do-~D-value-call~)" values))) - (return-values (intern (format nil "~:@(return-~D-value~:P~)" values))) - (vars nil)) - (dotimes (i values) - (push (gensym) vars)) - (setf vars (nreverse vars)) - `(progn - (defun ,do-call (result) - (let (worked ,@vars) - (unwind-protect - (progn - (multiple-value-setq ,vars - (wire-get-object *current-wire*)) - (setf worked t)) - (if worked - (remote *current-wire* - (,return-values result ,@vars)) - (remote *current-wire* - (remote-return-abort result))) - (wire-force-output *current-wire*)))) - (defun ,return-values (remote ,@vars) - (let ((result (remote-object-value remote))) - (unless (maybe-nuke-remote-wait result) - ,@(let ((setf-forms nil)) - (dotimes (i values) - (push `(setf (,(intern (format nil - "~:@(remote-wait-value~D~)" - (1+ i))) - result) - ,(nth i vars)) - setf-forms)) - (nreverse setf-forms)))) - nil)))) - -(define-functions 1) -(define-functions 2) -(define-functions 3) -(define-functions 4) -(define-functions 5) - - -;;; DO-N-VALUE-CALL -- internal -;;; -;;; For more values then 5, all the values are rolled into a list and passed -;;; back as the first value, so we use RETURN-1-VALUE to return it. -;;; -(defun do-n-value-call (result) - (let (worked values) - (unwind-protect - (progn - (setf values - (multiple-value-list (wire-get-object *current-wire*))) - (setf worked t)) - (if worked - (remote *current-wire* - (return-1-values result values)) - (remote *current-wire* - (remote-return-abort result))) - (wire-force-output *current-wire*)))) - -;;; REMOTE-RETURN-ABORT -- internal -;;; -;;; The remote call aborted instead of returned. -;;; -(defun remote-return-abort (result) - (setf result (remote-object-value result)) - (unless (maybe-nuke-remote-wait result) - (setf (remote-wait-abort result) t))) - -;;; SERVE-REQUESTS -- internal -;;; -;;; Serve all pending requests on the given wire. -;;; -(defun serve-requests (wire on-death) - (handler-bind - ((wire-eof #'(lambda (condition) - (declare (ignore condition)) - (system:invalidate-descriptor (wire-fd wire)) - (unix:unix-close (wire-fd wire)) - (dolist (pending *pending-returns*) - (when (eq (car pending) - wire) - (unless (maybe-nuke-remote-wait (cdr pending)) - (setf (remote-wait-abort (cdr pending)) - t)))) - (when on-death - (funcall on-death)) - (return-from serve-requests (values)))) - (wire-error #'(lambda (condition) - (declare (ignore condition)) - (system:invalidate-descriptor (wire-fd wire))))) - (loop - (unless (wire-listen wire) - (return)) - (wire-get-object wire))) - (values)) - -;;; NEW-CONNECTION -- internal -;;; -;;; Maybe build a new wire and add it to the servers list of fds. If the user -;;; Supplied a function, close the socket if it returns NIL. Otherwise, install -;;; the wire. -;;; -(defun new-connection (socket addr on-connect) - (let ((wire (make-wire socket)) - (on-death nil)) - (if (or (null on-connect) - (multiple-value-bind (okay death-fn) - (funcall on-connect wire addr) - (setf on-death death-fn) - okay)) - (system:add-fd-handler socket :input - #'(lambda (socket) - (declare (ignore socket)) - (serve-requests wire on-death))) - (ext:close-socket socket)))) - -;;; REQUEST-SERVER structure -;;; -;;; Just a simple handle on the socket and system:serve-event handler that make -;;; up a request server. -;;; -(defstruct (request-server - (:print-function %print-request-server)) - socket - handler) - -(defun %print-request-server (rs stream depth) - (declare (ignore depth)) - (print-unreadable-object (rs stream :type t) - (format stream "for ~D" (request-server-socket rs)))) - -;;; CREATE-REQUEST-SERVER -- Public. -;;; -;;; Create a TCP/IP listener on the given port. If anyone tries to connect to -;;; it, call NEW-CONNECTION to do the connecting. -;;; -(defun create-request-server (port &optional on-connect) - "Create a request server on the given port. Whenevery anyone connects to it - call the given function with the newly created wire and the address of the - connector. If the function returns NIL, the connection is destroyed; - otherwise, it is accepted. This returns a manifestation of the server that - DESTROY-REQUEST-SERVER accepts to kill the request server." - (let* ((socket (ext:create-inet-listener port)) - (handler (system:add-fd-handler socket :input - #'(lambda (socket) - (multiple-value-bind - (newconn addr) - (ext:accept-tcp-connection socket) - (new-connection newconn addr on-connect)))))) - (make-request-server :socket socket - :handler handler))) - -;;; DESTROY-REQUEST-SERVER -- Public. -;;; -;;; Removes the request server from SERVER's list of file descriptors and -;;; closes the socket behind it. -;;; -(defun destroy-request-server (server) - "Quit accepting connections to the given request server." - (system:remove-fd-handler (request-server-handler server)) - (ext:close-socket (request-server-socket server)) - nil) - -;;; CONNECT-TO-REMOTE-SERVER -- Public. -;;; -;;; Just like the doc string says, connect to a remote server. A handler is -;;; installed to handle return values, etc. -;;; -(defun connect-to-remote-server (hostname port &optional on-death) - "Connect to a remote request server addressed with the given host and port - pair. This returns the created wire." - (let* ((socket (ext:connect-to-inet-socket hostname port)) - (wire (make-wire socket))) - (system:add-fd-handler socket :input - #'(lambda (socket) - (declare (ignore socket)) - (serve-requests wire on-death))) - wire)) diff --git a/code/rt-machdef.lisp b/code/rt-machdef.lisp deleted file mode 100644 index f858194598871df137b33bd67d3b637df78d2c90..0000000000000000000000000000000000000000 --- a/code/rt-machdef.lisp +++ /dev/null @@ -1,36 +0,0 @@ -;;; -*- Log: code.log; Package: Mach -*- -;;; -;;; ********************************************************************** -;;; 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/code/rt-machdef.lisp,v 1.3 1991/07/22 23:54:55 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Record definitions needed for the interface to Mach. -;;; -(in-package "MACH") - -(export '(sigcontext-onstack sigcontext-mask sigcontext-sp sigcontext-fp - sigcontext-ap sigcontext-iar sigcontext-icscs sigcontext-saveiar - sigcontext-regs sigcontext *sigcontext indirect-*sigcontext - sigcontext-pc)) - -(def-c-record sigcontext - (onstack unsigned-long) - (mask unsigned-long) - (floatsave system-area-pointer) - (sp system-area-pointer) - (fp system-area-pointer) - (ap system-area-pointer) - (iar system-area-pointer) - (icscs unsigned-long) - (saveiar system-area-pointer) - (regs int-array)) - -(defoperator (sigcontext-pc system-area-pointer) ((x sigcontext)) - `(sigcontext-iar (alien-value ,x))) diff --git a/code/rt-vm.lisp b/code/rt-vm.lisp deleted file mode 100644 index a69caa9cfedb1f71164530d8eb39683a66d48e9a..0000000000000000000000000000000000000000 --- a/code/rt-vm.lisp +++ /dev/null @@ -1,183 +0,0 @@ -;;; -*- 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/code/rt-vm.lisp,v 1.6 1992/03/10 10:21:34 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the RT specific runtime stuff. -;;; -(in-package "RT") -(use-package "SYSTEM") -(use-package "ALIEN") -(use-package "C-CALL") -(use-package "UNIX") - -(export '(fixup-code-object internal-error-arguments - sigcontext-register sigcontext-float-register - sigcontext-floating-point-modes extern-alien-name)) - - -;;;; The sigcontext structure. - -(def-alien-type sigcontext - (struct nil - (sc-onstack unsigned-long) - (sc-mask unsigned-long) - (sc-floatsave system-area-pointer) - (sc-sp system-area-pointer) - (sc-fp system-area-pointer) - (sc-ap system-area-pointer) - (sc-pc system-area-pointer) ; IBM calls it the iar. - (sc-icscs unsigned-long) - (sc-saveiar system-area-pointer) - (sc-regs (array unsigned-long 16)))) - - - -;;;; Add machine specific features to *features* - -(pushnew :ibm-pc-rt *features*) -(pushnew :ibmrt *features*) -(pushnew :rt *features*) - - - -;;;; MACHINE-TYPE and MACHINE-VERSION - -(defun machine-type () - "Returns a string describing the type of the local machine." - "IBM PC/RT") - -(defun machine-version () - "Returns a string describing the version of the local machine." - "IBM PC/RT") - - - -;;; FIXUP-CODE-OBJECT -- Interface -;;; -(defun fixup-code-object (code offset fixup kind) - (declare (type index offset) (type (unsigned-byte 32) fixup)) - (system:without-gcing - (let ((sap (sap+ (kernel:code-instructions code) offset))) - (ecase kind - (:cal - (setf (sap-ref-16 sap 2) - (ldb (byte 16 0) fixup))) - (:cau - (let ((high (ldb (byte 16 16) fixup))) - (setf (sap-ref-16 sap 2) - (if (logbitp 15 fixup) (1+ high) high)))) - (:ba - (unless (zerop (ash fixup -24)) - (warn "#x~8,'0X out of range for branch-absolute." fixup)) - (setf (sap-ref-8 sap 1) - (ldb (byte 8 16) fixup)) - (setf (sap-ref-16 sap 2) - (ldb (byte 16 0) fixup))))))) - - - -;;;; Internal-error-arguments. - -;;; INTERNAL-ERROR-ARGUMENTS -- interface. -;;; -;;; Given the sigcontext, extract the internal error arguments from the -;;; instruction stream. -;;; -(defun internal-error-arguments (scp) - (with-alien ((scp (* sigcontext) scp)) - (let ((pc (slot scp 'sc-pc))) - (declare (type system-area-pointer pc)) - (let* ((length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) - (declare (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) - (copy-from-system-area pc (* vm:byte-bits 5) - vector (* vm:word-bits - vm:vector-data-offset) - (* length vm:byte-bits)) - (let* ((index 0) - (error-number (c::read-var-integer vector index))) - (collect ((sc-offsets)) - (loop - (when (>= index length) - (return)) - (sc-offsets (c::read-var-integer vector index))) - (values error-number (sc-offsets)))))))) - - - -;;;; Sigcontext accessing stuff. - -;;; SIGCONTEXT-REGISTER -- Internal. -;;; -;;; An escape register saves the value of a register for a frame that someone -;;; interrupts. -;;; -(defun sigcontext-register (scp index) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (deref (slot scp 'sc-regs) index))) - -(defun %set-sigcontext-register (scp index new) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (setf (deref (slot scp 'sc-regs) index) new) - new)) - -(defsetf sigcontext-register %set-sigcontext-register) - - -;;; SIGCONTEXT-FLOAT-REGISTER -- Internal -;;; -;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. -;;; Format is the type of float to return. -;;; -(defun sigcontext-float-register (scp index format) - (declare (type (alien (* sigcontext)) scp) - (ignore scp index)) - ;; ### Some day we should figure out how to do this right. - (ecase format - (single-float 0.0s0) - (double-float 0.0d0))) -;;; -(defun %set-sigcontext-float-register (scp index format new-value) - (declare (type (alien (* sigcontext)) scp) - (ignore scp index format)) - ;; ### Some day we should figure out how to do this right. - new-value) -;;; -(defsetf sigcontext-float-register %set-sigcontext-float-register) - - -;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface -;;; -;;; Given a sigcontext pointer, return the floating point modes word in the -;;; same format as returned by FLOATING-POINT-MODES. -;;; -(defun sigcontext-floating-point-modes (scp) - (declare (ignore scp)) - ;; ### Some day we should figure out how to do this right. - 0) - - - - -;;; EXTERN-ALIEN-NAME -- interface. -;;; -;;; The loader uses this to convert alien names to the form they occure in -;;; the symbol table (for example, prepending an underscore). On the RT, -;;; we prepend an underscore. -;;; -(defun extern-alien-name (name) - (declare (type simple-base-string name)) - (concatenate 'string "_" name)) - diff --git a/code/run-program.lisp b/code/run-program.lisp deleted file mode 100644 index c5caaba9a82f90e0d52eabb017b778f9a77dc484..0000000000000000000000000000000000000000 --- a/code/run-program.lisp +++ /dev/null @@ -1,668 +0,0 @@ -;;; -*- Package: Extensions; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/run-program.lisp,v 1.12 1992/07/28 00:22:58 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; RUN-PROGRAM and friends. Facility for running unix programs from inside -;;; a lisp. -;;; -;;; Written by Jim Healy and Bill Chiles, November 1987, using an earlier -;;; version written by David McDonald. -;;; -;;; Completely re-written by William Lott, July 1989 - January 1990. -;;; - -(in-package "EXTENSIONS") - -(export '(run-program process-status process-exit-code process-core-dumped - process-wait process-kill process-input process-output process-plist - process-pty process-error process-status-hook process-alive-p - process-close process-pid process-p)) - - -;;;; Import WAIT3 from unix. - -(alien:def-alien-routine ("wait3" c-wait3) c-call:int - (status c-call:int :out) - (options c-call:int) - (rusage c-call:int)) - -(eval-when (load eval compile) - (defconstant wait-wstopped #o177) - (defconstant wait-wnohang 1) - (defconstant wait-wuntraced 2)) - -(defun wait3 (&optional do-not-hang check-for-stopped) - "Return any available status information on child processed. " - (multiple-value-bind (pid status) - (c-wait3 (logior (if do-not-hang - wait-wnohang - 0) - (if check-for-stopped - wait-wuntraced - 0)) - 0) - (cond ((or (minusp pid) - (zerop pid)) - nil) - ((eql (ldb (byte 8 0) status) - wait-wstopped) - (values pid - :stopped - (ldb (byte 8 8) status))) - ((zerop (ldb (byte 7 0) status)) - (values pid - :exited - (ldb (byte 8 8) status))) - (t - (let ((signal (ldb (byte 7 0) status))) - (values pid - (if (or (eql signal unix:sigstop) - (eql signal unix:sigtstp) - (eql signal unix:sigttin) - (eql signal unix:sigttou)) - :stopped - :signaled) - signal - (not (zerop (ldb (byte 1 7) status))))))))) - - - -;;;; Process control stuff. - -(defvar *active-processes* nil - "List of process structures for all active processes.") - -(defstruct (process (:print-function %print-process)) - pid ; PID of child process. - %status ; Either :RUNNING, :STOPPED, :EXITED, or :SIGNALED. - exit-code ; Either exit code or signal - core-dumped ; T if a core image was dumped. - pty ; Stream to child's pty or nil. - input ; Stream to child's input or nil. - output ; Stream from child's output or nil. - error ; Stream from child's error output or nil. - status-hook ; Closure to call when PROC changes status. - plist ; Place for clients to stash tings. - cookie ; List of the number of pipes from the subproc. - ) - -(defun %print-process (proc stream depth) - (declare (ignore depth)) - (format stream "#<process ~D ~S>" - (process-pid proc) - (process-status proc))) - -;;; PROCESS-STATUS -- Public. -;;; -(defun process-status (proc) - "Return the current status of process. The result is one of :running, - :stopped, :exited, :signaled." - (get-processes-status-changes) - (process-%status proc)) - - -;;; PROCESS-WAIT -- Public. -;;; -(defun process-wait (proc &optional check-for-stopped) - "Wait for PROC to quit running for some reason. Returns PROC." - (loop - (case (process-status proc) - (:running) - (:stopped - (when check-for-stopped - (return))) - (t - (when (zerop (car (process-cookie proc))) - (return)))) - (system:serve-all-events 1)) - proc) - - -;;; FIND-CURRENT-FOREGROUND-PROCESS -- internal -;;; -;;; Finds the current foreground process group id. -;;; -(defun find-current-foreground-process (proc) - (alien:with-alien ((result c-call:int)) - (multiple-value-bind - (wonp error) - (unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc)) - unix:TIOCGPGRP - (alien:alien-sap (alien:addr result))) - (unless wonp - (error "TIOCPGRP ioctl failed: ~S" - (unix:get-unix-error-msg error))) - result))) - -;;; PROCESS-KILL -- public -;;; -;;; Hand a process a signal. -;;; -(defun process-kill (proc signal &optional (whom :pid)) - "Hand SIGNAL to PROC. If whom is :pid, use the kill Unix system call. If - whom is :process-group, use the killpg Unix system call. If whom is - :pty-process-group deliver the signal to whichever process group is currently - in the foreground." - (let ((pid (ecase whom - ((:pid :process-group) - (process-pid proc)) - (:pty-process-group - (find-current-foreground-process proc))))) - (multiple-value-bind (okay errno) - (if (eq whom :pty-process-group) - (unix:unix-killpg pid signal) - (unix:unix-kill pid signal)) - (cond ((not okay) - (values nil errno)) - ((and (eql pid (process-pid proc)) - (= (unix:unix-signal-number signal) unix:sigcont)) - (setf (process-%status proc) :running) - (setf (process-exit-code proc) nil) - (when (process-status-hook proc) - (funcall (process-status-hook proc) proc)) - t) - (t - t))))) - -;;; PROCESS-ALIVE-P -- public -;;; -;;; Returns T if the process is still alive, NIL otherwise. -;;; -(defun process-alive-p (proc) - "Returns T if the process is still alive, NIL otherwise." - (let ((status (process-status proc))) - (if (or (eq status :running) - (eq status :stopped)) - t - nil))) - -;;; PROCESS-CLOSE -- public -;;; -;;; Close all the streams held open by PROC. -;;; -(defun process-close (proc) - "Close all streams connected to PROC and stop maintaining the status slot." - (macrolet ((frob (stream) - `(when ,stream (close ,stream)))) - (frob (process-pty proc)) - (frob (process-input proc)) - (frob (process-output proc)) - (frob (process-error proc)) - (system:without-interrupts - (setf *active-processes* (delete proc *active-processes*))) - proc)) - -;;; SIGCHLD-HANDLER -- Internal. -;;; -;;; This is the handler for sigchld signals that RUN-PROGRAM establishes. -;;; -(defun sigchld-handler (ignore1 ignore2 ignore3) - (declare (ignore ignore1 ignore2 ignore3)) - (get-processes-status-changes)) - -;;; GET-PROCESSES-STATUS-CHANGES -- Internal. -;;; -(defun get-processes-status-changes () - (loop - (multiple-value-bind (pid what code core) - (wait3 t t) - (unless pid - (return)) - (let ((proc (find pid *active-processes* :key #'process-pid))) - (when proc - (setf (process-%status proc) what) - (setf (process-exit-code proc) code) - (setf (process-core-dumped proc) core) - (when (process-status-hook proc) - (funcall (process-status-hook proc) proc)) - (when (or (eq what :exited) - (eq what :signaled)) - (system:without-interrupts - (setf *active-processes* - (delete proc *active-processes*))))))))) - - - -;;;; RUN-PROGRAM and close friends. - -(defvar *close-on-error* nil - "List of file descriptors to close when RUN-PROGRAM exits due to an error.") -(defvar *close-in-parent* nil - "List of file descriptors to close when RUN-PROGRAM returns in the parent.") -(defvar *handlers-installed* nil - "List of handlers installed by RUN-PROGRAM.") - - -;;; FIND-A-PTY -- internal -;;; -;;; Finds a pty that is not in use. Returns three values: the file descriptor -;;; for the master side of the pty, the file descriptor for the slave side of -;;; the pty, and the name of the tty device for the slave side. -;;; -(defun find-a-pty () - "Returns the master fd, the slave fd, and the name of the tty" - (dolist (char '(#\p #\q)) - (dotimes (digit 16) - (let* ((master-name (format nil "/dev/pty~C~X" char digit)) - (master-fd (unix:unix-open master-name - unix:o_rdwr - #o666))) - (when master-fd - (let* ((slave-name (format nil "/dev/tty~C~X" char digit)) - (slave-fd (unix:unix-open slave-name - unix:o_rdwr - #o666))) - (when slave-fd - ; Maybe put a vhangup here? - (alien:with-alien ((stuff (alien:struct unix:sgttyb))) - (let ((sap (alien:alien-sap stuff))) - (unix:unix-ioctl slave-fd unix:TIOCGETP sap) - (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP - (unix:unix-ioctl slave-fd unix:TIOCSETP sap) - (unix:unix-ioctl master-fd unix:TIOCGETP sap) - (setf (alien:slot stuff 'unix:sg-flags) - (logand (alien:slot stuff 'unix:sg-flags) - (lognot 8))) ; ~ECHO - (unix:unix-ioctl master-fd unix:TIOCSETP sap))) - (return-from find-a-pty - (values master-fd - slave-fd - slave-name))) - (unix:unix-close master-fd)))))) - (error "Could not find a pty.")) - -;;; OPEN-PTY -- internal -;;; -(defun open-pty (pty cookie) - (when pty - (multiple-value-bind - (master slave name) - (find-a-pty) - (push master *close-on-error*) - (push slave *close-in-parent*) - (when (streamp pty) - (multiple-value-bind (new-fd errno) (unix:unix-dup master) - (unless new-fd - (error "Could not UNIX:UNIX-DUP ~D: ~A" - master (unix:get-unix-error-msg errno))) - (push new-fd *close-on-error*) - (copy-descriptor-to-stream new-fd pty cookie))) - (values name - (system:make-fd-stream master :input t :output t))))) - -;;; SETUP-CHILD -- internal -;;; -;;; Execs the program after setting up the environment correctly. This -;;; routine never returns under any condition. -;;; -(defun setup-child (pfile args env stdin stdout stderr pty-name before-execve) - (unwind-protect - (handler-bind ((error #'(lambda (condition) - (declare (ignore condition)) - (unix:unix-exit 2)))) - ;; Put us in our own pgrp. - (unix:unix-setpgrp 0 (unix:unix-getpid)) - ;; If we want a pty, set it up. - (when pty-name - (let ((old-tty (unix:unix-open "/dev/tty" unix:o_rdwr 0))) - (when old-tty - (unix:unix-ioctl old-tty unix:TIOCNOTTY nil) - (unix:unix-close old-tty))) - (let ((new-tty (unix:unix-open pty-name unix:o_rdwr 0))) - (when new-tty - (unix:unix-dup2 new-tty 0) - (unix:unix-dup2 new-tty 1) - (unix:unix-dup2 new-tty 2)))) - ;; Setup the three standard descriptors. - (when stdin - (unix:unix-dup2 stdin 0)) - (when stdout - (unix:unix-dup2 stdout 1)) - (when stderr - (unix:unix-dup2 stderr 2)) - ;; Arange for all the unused FD's to be closed. - (do ((fd (1- (unix:unix-getdtablesize)) - (1- fd))) - ((= fd 3)) - (unix:unix-fcntl fd unix:f-setfd 1)) - ;; Do the before-execve - (when before-execve - (funcall before-execve)) - ;; Exec the program - (multiple-value-bind - (okay errno) - (unix:unix-execve pfile args env) - (declare (ignore okay)) - ;; If the magic number if bogus, try just a shell script. - (when (eql errno unix:ENOEXEC) - (unix:unix-execve "/bin/sh" (cons pfile args) env)))) - ;; If exec returns, we lose. - (unix:unix-exit 1))) - -;;; RUN-PROGRAM -- public -;;; -;;; RUN-PROGRAM uses fork and execve to run a different program. Strange -;;; stuff happens to keep the unix state of the world coherent. -;;; -;;; The child process needs to get it's input from somewhere, and send it's -;;; output (both standard and error) to somewhere. We have to do different -;;; things depending on where these somewheres really are. -;;; -;;; For input, there are five options: -;;; - T: Just leave fd 0 alone. Pretty simple. -;;; - "file": Read from the file. We need to open the file and pull the -;;; descriptor out of the stream. The parent should close this stream after -;;; the child is up and running to free any storage used in the parent. -;;; - NIL: Same as "file", but use "/dev/null" as the file. -;;; - :STREAM: Use unix-pipe to create two descriptors. Use system:make-fd-stream -;;; to create the output stream on the writeable descriptor, and pass the -;;; readable descriptor to the child. The parent must close the readable -;;; descriptor for EOF to be passed up correctly. -;;; - a stream: If it's a fd-stream, just pull the descriptor out of it. -;;; Otherwise make a pipe as in :STREAM, and copy everything across. -;;; -;;; For output, there are n options: -;;; - T: Leave descriptor 1 alone. -;;; - "file": dump output to the file. -;;; - NIL: dump output to /dev/null. -;;; - :STREAM: return a stream that can be read from. -;;; - a stream: if it's a fd-stream, use the descriptor in it. Otherwise, copy -;;; stuff from output to stream. -;;; -;;; For error, there are all the same options as output plus: -;;; - :OUTPUT: redirect to the same place as output. -;;; -;;; RUN-PROGRAM returns a process struct for the process if the fork worked, -;;; and NIL if it did not. -;;; -(defun run-program (program args - &key (env *environment-list*) (wait t) pty input - if-input-does-not-exist output (if-output-exists :error) - (error :output) (if-error-exists :error) status-hook - before-execve) - "Run-program creates a new process and runs the unix progam in the - file specified by the simple-string program. Args are the standard - arguments that can be passed to a Unix program, for no arguments - use NIL (which means just the name of the program is passed as arg 0). - - Run program will either return NIL or a PROCESS structure. See the CMU - Common Lisp Users Manual for details about the PROCESS structure. - - The keyword arguments have the following meanings: - :env - - An A-LIST mapping keyword environment variables to simple-string - values. - :wait - - If non-NIL (default), wait until the created process finishes. If - NIL, continue running Lisp until the program finishes. - :pty - - Either T, NIL, or a stream. Unless NIL, the subprocess is established - under a PTY. If :pty is a stream, all output to this pty is sent to - this stream, otherwise the PROCESS-PTY slot is filled in with a stream - connected to pty that can read output and write input. - :input - - Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - input for the current process is inherited. If NIL, /dev/null - is used. If a pathname, the file so specified is used. If a stream, - all the input is read from that stream and send to the subprocess. If - :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends - its output to the process. Defaults to NIL. - :if-input-does-not-exist (when :input is the name of a file) - - can be one of: - :error - generate an error. - :create - create an empty file. - nil (default) - return nil from run-program. - :output - - Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - input for the current process is inherited. If NIL, /dev/null - is used. If a pathname, the file so specified is used. If a stream, - all the output from the process is written to this stream. If - :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can - be read to get the output. Defaults to NIL. - :if-output-exists (when :input is the name of a file) - - can be one of: - :error (default) - generates an error if the file already exists. - :supersede - output from the program supersedes the file. - :append - output from the program is appended to the file. - nil - run-program returns nil without doing anything. - :error and :if-error-exists - - Same as :output and :if-output-exists, except that :error can also be - specified as :output in which case all error output is routed to the - same place as normal output. - :status-hook - - This is a function the system calls whenever the status of the - process changes. The function takes the process as an argument. - :before-execve - - This is a function, without arguments, RUN-PROGRAM runs in the child - process just before turning it into the specified program." - - ;; Make sure the interrupt handler is installed. - (system:enable-interrupt unix:sigchld #'sigchld-handler) - ;; Make sure all the args are okay. - (unless (every #'simple-string-p args) - (error "All args to program must be simple strings -- ~S." args)) - ;; Pre-pend the program to the argument list. - (push (namestring program) args) - ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup - ;; info. Also, establish proc at this level so we can return it. - (let (*close-on-error* *close-in-parent* *handlers-installed* proc) - (unwind-protect - (let ((pfile (namestring (truename (merge-pathnames program "path:")))) - (cookie (list 0))) - (multiple-value-bind - (stdin input-stream) - (get-descriptor-for input cookie :direction :input - :if-does-not-exist if-input-does-not-exist) - (multiple-value-bind - (stdout output-stream) - (get-descriptor-for output cookie :direction :output - :if-exists if-output-exists) - (multiple-value-bind - (stderr error-stream) - (if (eq error :output) - (values stdout output-stream) - (get-descriptor-for error cookie :direction :output - :if-exists if-error-exists)) - (multiple-value-bind (pty-name pty-stream) - (open-pty pty cookie) - ;; Make sure we are not notified about the child death before - ;; we have installed the process struct in *active-processes* - (system:without-interrupts - (multiple-value-bind - (child-pid errno) - (unix:unix-fork) - (cond ((null child-pid) - ;; This should only happen if the bozo has too - ;; many running procs. - (error "Could not fork child process: ~A" - (unix:get-unix-error-msg errno))) - ((zerop child-pid) - ;; We are the child. Note: setup-child NEVER - ;; returns - (setup-child pfile args env stdin stdout stderr - pty-name before-execve)) - (t - ;; We are the parent. - (setf proc (make-process :pid child-pid - :%status :running - :pty pty-stream - :input input-stream - :output output-stream - :error error-stream - :status-hook status-hook - :cookie cookie)) - (push proc *active-processes*)))))))))) - (dolist (fd *close-in-parent*) - (unix:unix-close fd)) - (unless proc - (dolist (fd *close-on-error*) - (unix:unix-close fd)) - (dolist (handler *handlers-installed*) - (system:remove-fd-handler handler)))) - (when (and wait proc) - (process-wait proc)) - proc)) - -;;; COPY-DESCRIPTOR-TO-STREAM -- internal -;;; -;;; Installs a handler for any input that shows up on the file descriptor. -;;; The handler reads the data and writes it to the stream. -;;; -(defun copy-descriptor-to-stream (descriptor stream cookie) - (incf (car cookie)) - (let ((string (make-string 256)) - handler) - (setf handler - (system:add-fd-handler descriptor :input - #'(lambda (fd) - (declare (ignore fd)) - (loop - (unless handler - (return)) - (multiple-value-bind - (result readable/errno) - (unix:unix-select (1+ descriptor) (ash 1 descriptor) - 0 0 0) - (cond ((null result) - (error "Could not select on sub-process: ~A" - (unix:get-unix-error-msg readable/errno))) - ((zerop result) - (return)))) - (alien:with-alien ((buf (alien:array c-call:char 256))) - (multiple-value-bind - (count errno) - (unix:unix-read descriptor (alien-sap buf) 256) - (cond ((or (and (null count) - (eql errno unix:eio)) - (eql count 0)) - (system:remove-fd-handler handler) - (setf handler nil) - (decf (car cookie)) - (unix:unix-close descriptor) - (return)) - ((null count) - (system:remove-fd-handler handler) - (setf handler nil) - (decf (car cookie)) - (error "Could not read input from sub-process: ~A" - (unix:get-unix-error-msg errno))) - (t - (kernel:copy-from-system-area - (alien-sap buf) 0 - string (* vm:vector-data-offset vm:word-bits) - (* count vm:byte-bits)) - (write-string string stream - :end count))))))))))) - -;;; GET-DESCRIPTOR-FOR -- internal -;;; -;;; Find a file descriptor to use for object given the direction. Returns -;;; the descriptor. If object is :STREAM, returns the created stream as the -;;; second value. -;;; -(defun get-descriptor-for (object cookie &rest keys &key direction - &allow-other-keys) - (cond ((eq object t) - ;; No new descriptor is needed. - (values nil nil)) - ((eq object nil) - ;; Use /dev/null. - (multiple-value-bind - (fd errno) - (unix:unix-open "/dev/null" - (case direction - (:input unix:o_rdonly) - (:output unix:o_wronly) - (t unix:o_rdwr)) - #o666) - (unless fd - (error "Could not open \"/dev/null\": ~A" - (unix:get-unix-error-msg errno))) - (push fd *close-in-parent*) - (values fd nil))) - ((eq object :stream) - (multiple-value-bind - (read-fd write-fd) - (unix:unix-pipe) - (unless read-fd - (error "Could not create pipe: ~A" - (unix:get-unix-error-msg write-fd))) - (case direction - (:input - (push read-fd *close-in-parent*) - (push write-fd *close-on-error*) - (let ((stream (system:make-fd-stream write-fd :output t))) - (values read-fd stream))) - (:output - (push read-fd *close-on-error*) - (push write-fd *close-in-parent*) - (let ((stream (system:make-fd-stream read-fd :input t))) - (values write-fd stream))) - (t - (unix:unix-close read-fd) - (unix:unix-close write-fd) - (error "Direction must be either :INPUT or :OUTPUT, not ~S" - direction))))) - ((or (pathnamep object) (stringp object)) - (with-open-stream (file (apply #'open object keys)) - (multiple-value-bind - (fd errno) - (unix:unix-dup (system:fd-stream-fd file)) - (cond (fd - (push fd *close-in-parent*) - (values fd nil)) - (t - (error "Could not duplicate file descriptor: ~A" - (unix:get-unix-error-msg errno))))))) - ((system:fd-stream-p object) - (values (system:fd-stream-fd object) nil)) - ((streamp object) - (ecase direction - (:input - (dotimes (count - 256 - (error "Could not open a temporary file in /tmp")) - (let* ((name (format nil "/tmp/.run-program-~D" count)) - (fd (unix:unix-open name - (logior unix:o_rdwr - unix:o_creat - unix:o_excl) - #o666))) - (unix:unix-unlink name) - (when fd - (let ((newline (string #\Newline))) - (loop - (multiple-value-bind - (line no-cr) - (read-line object nil nil) - (unless line - (return)) - (unix:unix-write fd line 0 (length line)) - (if no-cr - (return) - (unix:unix-write fd newline 0 1))))) - (unix:unix-lseek fd 0 unix:l_set) - (push fd *close-in-parent*) - (return (values fd nil)))))) - (:output - (multiple-value-bind (read-fd write-fd) - (unix:unix-pipe) - (unless read-fd - (error "Cound not create pipe: ~A" - (unix:get-unix-error-msg write-fd))) - (copy-descriptor-to-stream read-fd object cookie) - (push read-fd *close-on-error*) - (push write-fd *close-in-parent*) - (values write-fd nil))))) - (t - (error "Invalid option to run-program: ~S" object)))) - diff --git a/code/sap.lisp b/code/sap.lisp deleted file mode 100644 index 2884874632612e4bd76b3712a022f6bcbc5373a4..0000000000000000000000000000000000000000 --- a/code/sap.lisp +++ /dev/null @@ -1,214 +0,0 @@ -;;; -*- Package: SYSTEM -*- -;;; -;;; ********************************************************************** -;;; 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/code/sap.lisp,v 1.9 1992/03/02 02:23:17 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file holds the support for System Area Pointers (saps). -;;; -(in-package "SYSTEM") - -(export '(system-area-pointer sap-ref-8 sap-ref-16 sap-ref-32 sap-ref-sap - signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32 - sap+ sap- sap< sap<= sap= sap>= sap> - allocate-system-memory allocate-system-memory-at - reallocate-system-memory deallocate-system-memory)) - -(in-package "KERNEL") -(export '(%set-sap-ref-sap %set-sap-ref-single %set-sap-ref-double - %set-sap-ref-8 %set-signed-sap-ref-8 - %set-sap-ref-16 %set-signed-sap-ref-16 - %set-sap-ref-32 %set-signed-sap-ref-32)) -(in-package "SYSTEM") - -(use-package "KERNEL") - - - -;;;; Primitive SAP operations. - -(defun sap< (x y) - "Return T iff the SAP X points to a smaller address then the SAP Y." - (declare (type system-area-pointer x y)) - (sap< x y)) - -(defun sap<= (x y) - "Return T iff the SAP X points to a smaller or the same address as - the SAP Y." - (declare (type system-area-pointer x y)) - (sap<= x y)) - -(defun sap= (x y) - "Return T iff the SAP X points to the same address as the SAP Y." - (declare (type system-area-pointer x y)) - (sap= x y)) - -(defun sap>= (x y) - "Return T iff the SAP X points to a larger or the same address as - the SAP Y." - (declare (type system-area-pointer x y)) - (sap>= x y)) - -(defun sap> (x y) - "Return T iff the SAP X points to a larger address then the SAP Y." - (declare (type system-area-pointer x y)) - (sap> x y)) - -(defun sap+ (sap offset) - "Return a new sap OFFSET bytes from SAP." - (declare (type system-area-pointer sap) - (fixnum offset)) - (sap+ sap offset)) - -(defun sap- (sap1 sap2) - "Return the byte offset between SAP1 and SAP2." - (declare (type system-area-pointer sap1 sap2)) - (sap- sap1 sap2)) - -(defun sap-int (sap) - "Converts a System Area Pointer into an integer." - (declare (type system-area-pointer sap)) - (sap-int sap)) - -(defun int-sap (int) - "Converts an integer into a System Area Pointer." - (declare (type (unsigned-byte #.vm:word-bits) int)) - (int-sap int)) - -(defun sap-ref-8 (sap offset) - "Returns the 8-bit byte at OFFSET bytes from SAP." - (declare (type system-area-pointer sap) - (type index offset)) - (sap-ref-8 sap offset)) - -(defun sap-ref-16 (sap offset) - "Returns the 16-bit word at OFFSET bytes from SAP." - (declare (type system-area-pointer sap) - (type index offset)) - (sap-ref-16 sap offset)) - -(defun sap-ref-32 (sap offset) - "Returns the 32-bit dualword at OFFSET bytes from SAP." - (declare (type system-area-pointer sap) - (type index offset)) - (sap-ref-32 sap offset)) - -(defun sap-ref-sap (sap offset) - "Returns the 32-bit system-area-pointer at OFFSET bytes from SAP." - (declare (type system-area-pointer sap) - (type index offset)) - (sap-ref-sap sap offset)) - -(defun sap-ref-single (sap offset) - "Returns the 32-bit single-float at OFFSET bytes from SAP." - (declare (type system-area-pointer sap) - (type index offset)) - (sap-ref-single sap offset)) - -(defun sap-ref-double (sap offset) - "Returns the 64-bit double-float at OFFSET bytes from SAP." - (declare (type system-area-pointer sap) - (type index offset)) - (sap-ref-double sap offset)) - -(defun signed-sap-ref-8 (sap offset) - "Returns the signed 8-bit byte at OFFSET bytes from SAP." - (declare (type system-area-pointer sap) - (type index offset)) - (signed-sap-ref-8 sap offset)) - -(defun signed-sap-ref-16 (sap offset) - "Returns the signed 16-bit word at OFFSET bytes from SAP." - (declare (type system-area-pointer sap) - (type index offset)) - (signed-sap-ref-16 sap offset)) - -(defun signed-sap-ref-32 (sap offset) - "Returns the signed 32-bit dualword at OFFSET bytes from SAP." - (declare (type system-area-pointer sap) - (type index offset)) - (signed-sap-ref-32 sap offset)) - -(defun %set-sap-ref-8 (sap offset new-value) - (declare (type system-area-pointer sap) - (type index offset) - (type (unsigned-byte 8) new-value)) - (setf (sap-ref-8 sap offset) new-value)) - -(defun %set-sap-ref-16 (sap offset new-value) - (declare (type system-area-pointer sap) - (type index offset) - (type (unsigned-byte 16) new-value)) - (setf (sap-ref-16 sap offset) new-value)) - -(defun %set-sap-ref-32 (sap offset new-value) - (declare (type system-area-pointer sap) - (type index offset) - (type (unsigned-byte 32) new-value)) - (setf (sap-ref-32 sap offset) new-value)) - -(defun %set-signed-sap-ref-8 (sap offset new-value) - (declare (type system-area-pointer sap) - (type index offset) - (type (signed-byte 8) new-value)) - (setf (signed-sap-ref-8 sap offset) new-value)) - -(defun %set-signed-sap-ref-16 (sap offset new-value) - (declare (type system-area-pointer sap) - (type index offset) - (type (signed-byte 16) new-value)) - (setf (signed-sap-ref-16 sap offset) new-value)) - -(defun %set-signed-sap-ref-32 (sap offset new-value) - (declare (type system-area-pointer sap) - (type index offset) - (type (signed-byte 32) new-value)) - (setf (signed-sap-ref-32 sap offset) new-value)) - -(defun %set-sap-ref-sap (sap offset new-value) - (declare (type system-area-pointer sap new-value) - (type index offset)) - (setf (sap-ref-sap sap offset) new-value)) - -(defun %set-sap-ref-single (sap offset new-value) - (declare (type system-area-pointer sap) - (type index offset) - (type single-float new-value)) - (setf (sap-ref-single sap offset) new-value)) - -(defun %set-sap-ref-double (sap offset new-value) - (declare (type system-area-pointer sap) - (type index offset) - (type double-float new-value)) - (setf (sap-ref-double sap offset) new-value)) - - - -;;;; System memory allocation. - -(alien:def-alien-routine ("os_allocate" allocate-system-memory) - system-area-pointer - (bytes c-call:unsigned-long)) - -(alien:def-alien-routine ("os_allocate_at" allocate-system-memory-at) - system-area-pointer - (address system-area-pointer) - (bytes c-call:unsigned-long)) - -(alien:def-alien-routine ("os_reallocate" reallocate-system-memory) - system-area-pointer - (old system-area-pointer) - (old-size c-call:unsigned-long) - (new-size c-call:unsigned-long)) - -(alien:def-alien-routine ("os_deallocate" deallocate-system-memory) - c-call:void - (addr system-area-pointer) - (bytes c-call:unsigned-long)) diff --git a/code/save.lisp b/code/save.lisp deleted file mode 100644 index b77807accee8cc35692f91b696257487fe645cba..0000000000000000000000000000000000000000 --- a/code/save.lisp +++ /dev/null @@ -1,237 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/save.lisp,v 1.16 1992/08/06 01:44:17 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Dump the current lisp image into a core file. All the real work is done -;;; be C. Also contains various high-level initialization stuff: loading init -;;; files and parsing environment variables. -;;; -;;; Written by William Lott. -;;; -;;; -(in-package "LISP") - -(in-package "EXTENSIONS") -(export '(print-herald *herald-items* save-lisp *before-save-initializations* - *after-save-initializations* *environment-list* *editor-lisp-p*)) -(in-package "LISP") - -(defvar *before-save-initializations* nil - "This is a list of functions which are called before creating a saved core - image. These functions are executed in the child process which has no ports, - so they cannot do anything that tries to talk to the outside world.") - -(defvar *after-save-initializations* nil - "This is a list of functions which are called when a saved core image starts - up. The system itself should be initialized at this point, but applications - might not be.") - -(defvar *environment-list* nil - "An alist mapping environment variables (as keywords) to either values") - -(defvar *editor-lisp-p* nil - "This is true if and only if the lisp was started with the -edit switch.") - - - -;;; Filled in by the startup code. -(defvar lisp-environment-list) - - -(alien:def-alien-routine "save" (alien:boolean) - (file c-call:c-string)) - - -;;; PARSE-UNIX-SEARCH-LIST -- Internal -;;; -;;; Returns a list of the directories that are in the specified Unix -;;; environment variable. Return NIL if the variable is undefined. -;;; -(defun parse-unix-search-list (var) - (let ((path (cdr (assoc var ext::*environment-list*)))) - (when path - (do* ((i 0 (1+ p)) - (p (position #\: path :start i) - (position #\: path :start i)) - (pl ())) - ((null p) - (let ((s (subseq path i))) - (if (string= s "") - (push "default:" pl) - (push (concatenate 'simple-string s "/") pl))) - (nreverse pl)) - (let ((s (subseq path i p))) - (if (string= s "") - (push "default:" pl) - (push (concatenate 'simple-string s "/") pl))))))) - - -;;; ENVIRONMENT-INIT -- Internal -;;; -;;; Parse the LISP-ENVIRONMENT-LIST into a keyword alist. Set up default -;;; search lists. -;;; -(defun environment-init () - (setq *environment-list* ()) - (dolist (ele lisp-environment-list) - (let ((=pos (position #\= (the simple-string ele)))) - (when =pos - (push (cons (intern (string-upcase (subseq ele 0 =pos)) - *keyword-package*) - (subseq ele (1+ =pos))) - *environment-list*)))) - (setf (search-list "default:") (list (default-directory))) - (setf (search-list "path:") (parse-unix-search-list :path)) - (setf (search-list "home:") - (or (parse-unix-search-list :home) - (list (default-directory)))) - - (setf (search-list "library:") - (or (parse-unix-search-list :cmucllib) - '("/usr/misc/.cmucl/lib/")))) - -(defun save-lisp (core-file-name &key - (purify t) - (root-structures ()) - (constants nil) - (init-function - #'(lambda () - (throw 'top-level-catcher nil))) - (load-init-file t) - (site-init "library:site-init") - (print-herald t) - (process-command-line t)) - "Saves a CMU Common Lisp core image in the file of the specified name. The - following keywords are defined: - - :purify - If true, do a purifying GC which moves all dynamically allocated - objects into static space so that they stay pure. This takes somewhat - longer than the normal GC which is otherwise done, but GC's will done - less often and take less time in the resulting core file. - - :root-structures - :constants - These should be a list of the main entry points in any newly loaded - systems and a list of any large data structures that will never again - be changed. These need not be supplied, but locality and/or GC performance - will be better if they are. They are meaningless if :purify is NIL. - - :init-function - This is a function which is called when the created core file is - resumed. The default function simply aborts to the top level - read-eval-print loop. If the function returns it will be the value - of Save-Lisp. - - :load-init-file - If true, then look for an init.lisp or init.fasl file when the core - file is resumed. - - :site-init - If true, then the name of the site init file to load. The default is - library:site-init. No error if this does not exist. - - :print-herald - If true, print out the lisp system herald when starting." - - (when (fboundp 'eval:flush-interpreted-function-cache) - (eval:flush-interpreted-function-cache)) - (if purify - (purify :root-structures root-structures :constants constants) - (gc)) - (unless (save (unix-namestring core-file-name nil)) - (reinit) - (dolist (f *before-save-initializations*) (funcall f)) - (dolist (f *after-save-initializations*) (funcall f)) - (environment-init) - (when site-init (load site-init :if-does-not-exist nil :verbose nil)) - (when process-command-line (ext::process-command-strings)) - (setf *editor-lisp-p* nil) - (macrolet ((find-switch (name) - `(find ,name *command-line-switches* - :key #'cmd-switch-name - :test #'(lambda (x y) - (declare (simple-string x y)) - (string-equal x y))))) - (when (and process-command-line (find-switch "edit")) - (setf *editor-lisp-p* t)) - (when (and load-init-file - (not (and process-command-line (find-switch "noinit")))) - (let* ((cl-switch (find-switch "init")) - (name (and cl-switch - (or (cmd-switch-value cl-switch) - (car (cmd-switch-words cl-switch)))))) - (if name - (load (merge-pathnames name #p"home:") :if-does-not-exist nil) - (or (load "home:init" :if-does-not-exist nil) - (load "home:.cmucl-init" :if-does-not-exist nil)))))) - (when process-command-line - (ext::invoke-switch-demons *command-line-switches* - *command-switch-demons*)) - (when print-herald - (print-herald)) - (funcall init-function))) - - -(defvar *herald-items* () - "Determines what PRINT-HERALD prints (the system startup banner.) This is a - database which can be augmented by each loaded system. The format is a - property list which maps from subsystem names to the banner information for - that system. This list can be manipulated with GETF -- entries are printed - in, reverse order, so the newest entry is printed last. Usually the system - feature keyword is used as the system name. A given banner is a list of - strings and functions (or function names). Strings are printed, and - functions are called with an output stream argument.") - -(setf (getf *herald-items* :common-lisp) - `("CMU Common Lisp " - ,#'(lambda (stream) - (write-string (lisp-implementation-version) stream)) - ", running on " - ,#'(lambda (stream) (write-string (machine-instance) stream)))) - -(setf (getf *herald-items* :bugs) - '("Send bug reports and questions to cmucl-bugs@cs.cmu.edu." - terpri - "Loaded subsystems:")) - -;;; PRINT-HERALD -- Public -;;; -(defun print-herald (&optional (stream *standard-output*)) - "Print some descriptive information about the Lisp system version and - configuration." - (let ((res ())) - (do ((item *herald-items* (cddr item))) - ((null item)) - (push (second item) res)) - - (fresh-line stream) - (dolist (item res) - (dolist (thing item) - (typecase thing - (string - (write-string thing stream)) - (function (funcall thing stream)) - ((or symbol cons) - (funcall (fdefinition thing) stream)) - (t - (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing)))) - (fresh-line stream))) - - (values)) - - -;;;; Random functions used by worldload. - -(defun assert-user-package () - (unless (eq *package* (find-package "USER")) - (error "Change *PACKAGE* to the USER package and try again."))) diff --git a/code/scavhook.lisp b/code/scavhook.lisp deleted file mode 100644 index 78851b0518b9fea7527585ce7e18d277f744746e..0000000000000000000000000000000000000000 --- a/code/scavhook.lisp +++ /dev/null @@ -1,55 +0,0 @@ -;;; -*- Package: EXT -*- -;;; -;;; ********************************************************************** -;;; 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/code/scavhook.lisp,v 1.1 1991/07/30 00:40:04 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file implements the ``Scavenger Hook'' extension. -;;; -;;; Written by William Lott -;;; - -(in-package "EXT") - -(export '(scavenger-hook scavenger-hook-p make-scavenger-hook - scavenger-hook-value scavenger-hook-function)) - -(defun scavenger-hook-p (object) - "Returns T if OBJECT is a scavenger-hook, and NIL if not." - (scavenger-hook-p object)) - -(defun make-scavenger-hook (&key value (function (required-argument))) - "Create a new scavenger-hook with the specified VALUE and FUNCTION. For - as long as the scavenger-hook is alive, the scavenger in the garbage - collector will note whenever VALUE is moved, and arrange for FUNCTION - to be funcalled." - (declare (type function function)) - (c::%make-scavenger-hook value function)) - -(defun scavenger-hook-value (scavhook) - "Returns the VALUE being monitored by SCAVHOOK. Can be setf." - (declare (type scavenger-hook scavhook)) - (scavenger-hook-value scavhook)) - -(defun (setf scavenger-hook-value) (value scavhook) - (declare (type scavenger-hook scavhook)) - (setf (scavenger-hook-value scavhook) value)) - -(defun scavenger-hook-function (scavhook) - "Returns the FUNCTION invoked when the monitored value is moved. Can be - setf." - (declare (type scavenger-hook scavhook)) - (scavenger-hook-function scavhook)) - -(defun (setf scavenger-hook-function) (function scavhook) - (declare (type function function) - (type scavenger-hook scavhook)) - (setf (scavenger-hook-function scavhook) function)) - diff --git a/code/search-list.lisp b/code/search-list.lisp deleted file mode 100644 index 8c6ccdf8071919dee07ad1edb70aa87c90df9eef..0000000000000000000000000000000000000000 --- a/code/search-list.lisp +++ /dev/null @@ -1,159 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/search-list.lisp,v 1.3 1991/02/08 13:35:25 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Logical name (search list) hackery for Lisp'ers. -;;; -;;; Written by Bill Chiles. - -(in-package 'lisp) -(in-package "EXTENSIONS") -(export 'search-list) -(in-package 'lisp) - - -(defvar *search-list-table* (make-hash-table :test #'equal)) -(defvar *rsl-circularity-check* (make-hash-table :test #'equal)) - - -(defun search-list (name) - "Returns a list of strings that are the of name. - This is setf'able. If any provided string in a setting value - does end with a colon or slash, a slash is added. Also, the - list is copied." - (let ((dev (pathname-device name))) - (unless dev (error "No device in ~S." name)) - (copy-list (gethash dev *search-list-table*)))) - -(defun %set-search-list (name new-value) - (unless (listp new-value) - (error "New value for search-list ~S not a list -- ~S." - name new-value)) - (let ((dev (pathname-device name))) - (unless dev (error "No device in ~S." name)) - (nstring-downcase dev) - (setf (gethash dev *search-list-table*) - (mapcar #'(lambda (x) - (let ((x (if (pathnamep x) (namestring x) x))) - (declare (simple-string x)) - (let* ((len (length x)) - (char (schar x (1- len)))) - (if (or (char= char #\:) (char= char #\/)) - x - (concatenate 'simple-string x "/"))))) - new-value))) - new-value) - - -(defun resolve-search-list (name first-only-p) - "This takes a Sesame search-list name (\"default\") instead of the form - taken by SEARCH-LIST (\"default:\"). If first-only-p is non-nil, then - only the first complete expansion of name is returned. If, during the - expansion of name, an undefined search list is encountered, an error - is signaled." - (setf name (string-downcase name)) - (setf (gethash name *rsl-circularity-check*) t) - (unwind-protect - (resolve-search-list-aux name first-only-p) - (clrhash *rsl-circularity-check*))) - - -;;; RESOLVE-SEARCH-LIST-BODY is used in RESOLVE-SEARCH-LIST-AUX and -;;; RSL-FIRST. This means the former is recursive, and the former and -;;; latter are mutually recursive. This form first looks at an element of -;;; a list of expansions for a search list for a colon which means that the -;;; element needs to be further resolved. If there is no colon, execute -;;; the already-form. If there is a colon, grab the new element to resolve -;;; recursively. If this new element has been seen already, we have an -;;; infinite recursion brewing. Recursively expand this new element. If -;;; there are no expansions, signal an error with the offending search list; -;;; otherwise, execute the expanded-form if the argument element was only a -;;; search list, or the concat-form if the argument element was a search -;;; list followed by a directory sequence. The locals pos, len, and res -;;; are meant to be referenced at the call sites. -;;; -(eval-when (compile eval) -(defmacro resolve-search-list-body (first-only-p element expanded-form - concat-form already-form) - `(let ((pos (position #\: ,element :test #'char=)) - (len (length ,element))) - (declare (fixnum len)) - (if pos - (let ((dev (nstring-downcase (subseq ,element 0 pos)))) - (if (gethash dev *rsl-circularity-check*) - (error "Circularity in search list -- ~S." dev) - (setf (gethash dev *rsl-circularity-check*) t)) - (let ((res (resolve-search-list-aux dev ,first-only-p))) - (remhash dev *rsl-circularity-check*) - (if res - (if (= (the fixnum pos) (the fixnum (1- len))) - ,expanded-form - ,concat-form) - (error "Undefined search list -- ~S" - (subseq ,element 0 (1+ pos)))))) - ,already-form))) -) ; eval-when - -;;; RESOLVE-SEARCH-LIST-AUX takes a device/search-list string (that is, -;;; without the colon) and whether it should return the first expansion -;;; found. If dev is not defined, signal an error with the offending -;;; search list. If dev is defined, and first-only-p is non-nil, then just -;;; resolve the first possible expansion. Otherwise, we loop over all of -;;; the possible expansions resolving each one completely, appending the -;;; results in order as they appear in entry. If entry is just another -;;; search list, then append the result (res) of its expansion onto result. -;;; If entry is a search list followed by a directory spec, then -;;; concatenate each of the expansions of the search list with the -;;; directory, appending this to result. If entry is just a directory -;;; spec, then append the list of entry to result. -;;; -(defun resolve-search-list-aux (dev first-only-p) - (let ((entry (gethash dev *search-list-table*))) - (if entry - (if first-only-p - (rsl-first (car entry)) - (do ((entries entry (cdr entries)) - (result (cons nil nil))) - ((null entries) (cdr result)) - (let ((entry (car entries))) - (declare (simple-string entry)) - (resolve-search-list-body - nil entry (nconc result res) - (nconc result (rsl-concat res (subseq entry (1+ pos) len))) - (nconc result (list entry)))))) - (error "Undefined search list -- ~S" - (concatenate 'simple-string dev ":"))))) - -;;; RSL-FIRST takes a possible expansion and resolves it if necessary. -;;; If first is just another search list, then return the expansions -;;; of this search list. If first is another search list followed by -;;; directory spec, then concatenate each of the expansions of the -;;; search list with the directory, returning this list. If first is -;;; just a directory spec, then return the list of it. -;;; -(defun rsl-first (first) - (declare (simple-string first)) - (resolve-search-list-body t first res - (rsl-concat res (subseq first (1+ pos) len)) - (list first))) - -;;; RSL-CONCAT takes a list of expansions (prefixes) for a search list -;;; that was concatenated with a directory spec (suffix). Each prefix -;;; is concatenated with the suffix and stored back where the prefix -;;; was. The destructively modified prefixes is returned. -;;; -(defun rsl-concat (prefixes suffix) - (declare (simple-string suffix)) - (do ((ptr prefixes (cdr ptr))) - ((null ptr) prefixes) - (setf (car ptr) - (concatenate 'simple-string (the simple-string (car ptr)) suffix)))) diff --git a/code/seq.lisp b/code/seq.lisp deleted file mode 100644 index 4f52d5fa37c04c0263c7167051237d2d81c5cab0..0000000000000000000000000000000000000000 --- a/code/seq.lisp +++ /dev/null @@ -1,2314 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/seq.lisp,v 1.12 1992/05/15 19:25:14 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Functions to implement generic sequences for Spice Lisp. -;;; Written by Skef Wholey. -;;; Fixed up by Jim Muller on Friday the 13th, January, 1984. -;;; Gone over again by Bill Chiles. Next? -;;; -;;; Be careful when modifying code. A lot of the structure of the code is -;;; affected by the fact that compiler transforms use the lower level support -;;; functions. If transforms are written for some sequence operation, note -;;; how the end argument is handled in other operations with transforms. - -(in-package 'lisp) -(export '(elt subseq copy-seq coerce - length reverse nreverse make-sequence concatenate map some every - notany notevery reduce fill replace remove remove-if remove-if-not - delete delete-if delete-if-not remove-duplicates delete-duplicates - substitute substitute-if substitute-if-not nsubstitute nsubstitute-if - nsubstitute-if-not find find-if find-if-not position position-if - position-if-not count count-if count-if-not mismatch search - identity)) ; Yep, thet's whar it is. - - -;;; Spice-Lisp specific stuff and utilities: - -(eval-when (compile) - -;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence. - -(defmacro seq-dispatch (sequence list-form array-form) - `(if (listp ,sequence) - ,list-form - ,array-form)) - -(defmacro elt-slice (sequences n) - "Returns a list of the Nth element of each of the sequences. Used by MAP - and friends." - `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences)) - -(defmacro make-sequence-like (sequence length) - "Returns a sequence of the same type as SEQUENCE and the given LENGTH." - `(make-sequence-of-type (type-of ,sequence) ,length)) - -(defmacro type-specifier-atom (type) - "Returns the broad class of which TYPE is a specific subclass." - `(if (atom ,type) ,type (car ,type))) - -) ; eval-when - - - - -;;; RESULT-TYPE-OR-LOSE -- Internal -;;; -;;; Given an arbitrary type specifier, return a sane sequence type specifier -;;; that we can directly match. -;;; -(defun result-type-or-lose (type &optional nil-ok) - (cond - ((subtypep type 'nil) - (if nil-ok - nil - (error "NIL output type invalid for this sequence function."))) - ((dolist (seq-type '(list bit-vector string vector) nil) - (when (subtypep type seq-type) - (return seq-type)))) - (t - (error "~S is a bad type specifier for sequence functions." type)))) - - -(defun make-sequence-of-type (type length) - "Returns a sequence of the given TYPE and LENGTH." - (declare (fixnum length)) - (case (type-specifier-atom type) - (list (make-list length)) - ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2))) - ((string simple-string base-string simple-base-string) - (make-string length)) - (simple-vector (make-array length)) - ((array simple-array vector) - (if (listp type) - (make-array length :element-type (cadr type)) - (make-array length))) - (t - (make-sequence-of-type (result-type-or-lose type) length)))) - -(defun elt (sequence index) - "Returns the element of SEQUENCE specified by INDEX." - (etypecase sequence - (list - (do ((count index (1- count)) - (list sequence (cdr list))) - ((= count 0) (car list)) - (declare (fixnum count)) - (when (endp list) - (error "~S: index too large." index)))) - (vector - (when (>= index (length sequence)) - (error "~S: index too large." index)) - (aref sequence index)))) - -(defun %setelt (sequence index newval) - "Store NEWVAL as the component of SEQUENCE specified by INDEX." - (etypecase sequence - (list - (do ((count index (1- count)) - (seq sequence)) - ((= count 0) (rplaca seq newval) sequence) - (declare (fixnum count)) - (if (atom (cdr seq)) - (error "~S: index too large." index) - (setq seq (cdr seq))))) - (vector - (when (>= index (length sequence)) - (error "~S: index too large." index)) - (setf (aref sequence index) newval)))) - - -(defun length (sequence) - "Returns an integer that is the length of SEQUENCE." - (etypecase sequence - (vector (length (truly-the vector sequence))) - (list (length (truly-the list sequence))))) - -(defun make-sequence (type length &key (initial-element NIL iep)) - "Returns a sequence of the given Type and Length, with elements initialized - to :Initial-Element." - (declare (fixnum length)) - (let ((type (kernel::type-expand type))) - (cond ((subtypep type 'list) - (make-list length :initial-element initial-element)) - ((subtypep type 'string) - (if iep - (make-string length :initial-element initial-element) - (make-string length))) - ((subtypep type 'simple-vector) - (make-array length :initial-element initial-element)) - ((subtypep type 'bit-vector) - (if iep - (make-array length :element-type '(mod 2) - :initial-element initial-element) - (make-array length :element-type '(mod 2)))) - ((subtypep type 'vector) - (if (listp type) - (if iep - (make-array length :element-type (cadr type) - :initial-element initial-element) - (make-array length :element-type (cadr type) - :initial-element - (if (subtypep (cadr type) 'number) - 0 - NIL))) - (make-array length :initial-element initial-element))) - (t (error "~S is a bad type specifier for sequences." type))))) - - - -;;; Subseq: -;;; -;;; The support routines for SUBSEQ are used by compiler transforms, so we -;;; worry about dealing with end being supplied as or defaulting to nil -;;; at this level. - -(defun vector-subseq* (sequence start &optional end) - (declare (vector sequence) (fixnum start)) - (when (null end) (setf end (length sequence))) - (do ((old-index start (1+ old-index)) - (new-index 0 (1+ new-index)) - (copy (make-sequence-like sequence (- end start)))) - ((= old-index end) copy) - (declare (fixnum old-index new-index)) - (setf (aref copy new-index) (aref sequence old-index)))) - -(defun list-subseq* (sequence start &optional end) - (declare (list sequence) (fixnum start)) - (if (and end (>= start (the fixnum end))) - () - (let* ((groveled (nthcdr start sequence)) - (result (list (car groveled)))) - (if groveled - (do ((list (cdr groveled) (cdr list)) - (splice result (cdr (rplacd splice (list (car list))))) - (index (1+ start) (1+ index))) - ((or (atom list) (and end (= index (the fixnum end)))) - result) - (declare (fixnum index))) - ())))) - -;;; SUBSEQ cannot default end to the length of sequence since it is not -;;; an error to supply nil for its value. We must test for end being nil -;;; in the body of the function, and this is actually done in the support -;;; routines for other reasons (see above). -(defun subseq (sequence start &optional end) - "Returns a copy of a subsequence of SEQUENCE starting with element number - START and continuing to the end of SEQUENCE or the optional END." - (seq-dispatch sequence - (list-subseq* sequence start end) - (vector-subseq* sequence start end))) - - -;;; Copy-seq: - -(eval-when (compile eval) - -(defmacro vector-copy-seq (sequence type) - `(let ((length (length (the vector ,sequence)))) - (declare (fixnum length)) - (do ((index 0 (1+ index)) - (copy (make-sequence-of-type ,type length))) - ((= index length) copy) - (declare (fixnum index)) - (setf (aref copy index) (aref ,sequence index))))) - -(defmacro list-copy-seq (list) - `(if (atom ,list) '() - (let ((result (cons (car ,list) '()) )) - (do ((x (cdr ,list) (cdr x)) - (splice result - (cdr (rplacd splice (cons (car x) '() ))) )) - ((atom x) (unless (null x) - (rplacd splice x)) - result))))) - -) - -(defun copy-seq (sequence) - "Returns a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ." - (seq-dispatch sequence - (list-copy-seq* sequence) - (vector-copy-seq* sequence))) - -;;; Internal Frobs: - -(defun list-copy-seq* (sequence) - (list-copy-seq sequence)) - -(defun vector-copy-seq* (sequence) - (vector-copy-seq sequence (type-of sequence))) - - -;;; Fill: - -(eval-when (compile eval) - -(defmacro vector-fill (sequence item start end) - `(do ((index ,start (1+ index))) - ((= index (the fixnum ,end)) ,sequence) - (declare (fixnum index)) - (setf (aref ,sequence index) ,item))) - -(defmacro list-fill (sequence item start end) - `(do ((current (nthcdr ,start ,sequence) (cdr current)) - (index ,start (1+ index))) - ((or (atom current) (and end (= index (the fixnum ,end)))) - sequence) - (declare (fixnum index)) - (rplaca current ,item))) - -) - -;;; The support routines for FILL are used by compiler transforms, so we -;;; worry about dealing with end being supplied as or defaulting to nil -;;; at this level. - -(defun list-fill* (sequence item start end) - (declare (list sequence)) - (list-fill sequence item start end)) - -(defun vector-fill* (sequence item start end) - (declare (vector sequence)) - (when (null end) (setq end (length sequence))) - (vector-fill sequence item start end)) - -;;; FILL cannot default end to the length of sequence since it is not -;;; an error to supply nil for its value. We must test for end being nil -;;; in the body of the function, and this is actually done in the support -;;; routines for other reasons (see above). -(defun fill (sequence item &key (start 0) end) - "Replace the specified elements of SEQUENCE with ITEM." - (seq-dispatch sequence - (list-fill* sequence item start end) - (vector-fill* sequence item start end))) - - - -;;; Replace: - -(eval-when (compile eval) - -;;; If we are copying around in the same vector, be careful not to copy the -;;; same elements over repeatedly. We do this by copying backwards. -(defmacro mumble-replace-from-mumble () - `(if (and (eq target-sequence source-sequence) (> target-start source-start)) - (let ((nelts (min (- target-end target-start) (- source-end source-start)))) - (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1) - (1- target-index)) - (source-index (+ (the fixnum source-start) (the fixnum nelts) -1) - (1- source-index))) - ((= target-index (the fixnum (1- target-start))) target-sequence) - (declare (fixnum target-index source-index)) - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))) - (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index))) - ((or (= target-index (the fixnum target-end)) - (= source-index (the fixnum source-end))) - target-sequence) - (declare (fixnum target-index source-index)) - (setf (aref target-sequence target-index) - (aref source-sequence source-index))))) - -(defmacro list-replace-from-list () - `(if (and (eq target-sequence source-sequence) (> target-start source-start)) - (let ((new-elts (subseq source-sequence source-start - (+ (the fixnum source-start) - (the fixnum - (min (- (the fixnum target-end) - (the fixnum target-start)) - (- (the fixnum source-end) - (the fixnum source-start)))))))) - (do ((n new-elts (cdr n)) - (o (nthcdr target-start target-sequence) (cdr o))) - ((null n) target-sequence) - (rplaca o (car n)))) - (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index)) - (target-sequence-ref (nthcdr target-start target-sequence) - (cdr target-sequence-ref)) - (source-sequence-ref (nthcdr source-start source-sequence) - (cdr source-sequence-ref))) - ((or (= target-index (the fixnum target-end)) - (= source-index (the fixnum source-end)) - (null target-sequence-ref) (null source-sequence-ref)) - target-sequence) - (declare (fixnum target-index source-index)) - (rplaca target-sequence-ref (car source-sequence-ref))))) - -(defmacro list-replace-from-mumble () - `(do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index)) - (target-sequence-ref (nthcdr target-start target-sequence) - (cdr target-sequence-ref))) - ((or (= target-index (the fixnum target-end)) - (= source-index (the fixnum source-end)) - (null target-sequence-ref)) - target-sequence) - (declare (fixnum source-index target-index)) - (rplaca target-sequence-ref (aref source-sequence source-index)))) - -(defmacro mumble-replace-from-list () - `(do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index)) - (source-sequence (nthcdr source-start source-sequence) - (cdr source-sequence))) - ((or (= target-index (the fixnum target-end)) - (= source-index (the fixnum source-end)) - (null source-sequence)) - target-sequence) - (declare (fixnum target-index source-index)) - (setf (aref target-sequence target-index) (car source-sequence)))) - -) ; eval-when - -;;; The support routines for REPLACE are used by compiler transforms, so we -;;; worry about dealing with end being supplied as or defaulting to nil -;;; at this level. - -(defun list-replace-from-list* (target-sequence source-sequence target-start - target-end source-start source-end) - (when (null target-end) (setq target-end (length target-sequence))) - (when (null source-end) (setq source-end (length source-sequence))) - (list-replace-from-list)) - -(defun list-replace-from-vector* (target-sequence source-sequence target-start - target-end source-start source-end) - (when (null target-end) (setq target-end (length target-sequence))) - (when (null source-end) (setq source-end (length source-sequence))) - (list-replace-from-mumble)) - -(defun vector-replace-from-list* (target-sequence source-sequence target-start - target-end source-start source-end) - (when (null target-end) (setq target-end (length target-sequence))) - (when (null source-end) (setq source-end (length source-sequence))) - (mumble-replace-from-list)) - -(defun vector-replace-from-vector* (target-sequence source-sequence - target-start target-end source-start - source-end) - (when (null target-end) (setq target-end (length target-sequence))) - (when (null source-end) (setq source-end (length source-sequence))) - (mumble-replace-from-mumble)) - -;;; REPLACE cannot default end arguments to the length of sequence since it -;;; is not an error to supply nil for their values. We must test for ends -;;; being nil in the body of the function. -(defun replace (target-sequence source-sequence &key - ((:start1 target-start) 0) - ((:end1 target-end)) - ((:start2 source-start) 0) - ((:end2 source-end))) - "The target sequence is destructively modified by copying successive - elements into it from the source sequence." - (let ((target-end (or target-end (length target-sequence))) - (source-end (or source-end (length source-sequence)))) - (seq-dispatch target-sequence - (seq-dispatch source-sequence - (list-replace-from-list) - (list-replace-from-mumble)) - (seq-dispatch source-sequence - (mumble-replace-from-list) - (mumble-replace-from-mumble))))) - - -;;; Reverse: - -(eval-when (compile eval) - -(defmacro vector-reverse (sequence type) - `(let ((length (length ,sequence))) - (declare (fixnum length)) - (do ((forward-index 0 (1+ forward-index)) - (backward-index (1- length) (1- backward-index)) - (new-sequence (make-sequence-of-type ,type length))) - ((= forward-index length) new-sequence) - (declare (fixnum forward-index backward-index)) - (setf (aref new-sequence forward-index) - (aref ,sequence backward-index))))) - -(defmacro list-reverse-macro (sequence) - `(do ((new-list ())) - ((atom ,sequence) new-list) - (push (pop ,sequence) new-list))) - -) - -(defun reverse (sequence) - "Returns a new sequence containing the same elements but in reverse order." - (seq-dispatch sequence - (list-reverse* sequence) - (vector-reverse* sequence))) - -;;; Internal Frobs: - -(defun list-reverse* (sequence) - (list-reverse-macro sequence)) - -(defun vector-reverse* (sequence) - (vector-reverse sequence (type-of sequence))) - - -;;; Nreverse: - -(eval-when (compile eval) - -(defmacro vector-nreverse (sequence) - `(let ((length (length (the vector ,sequence)))) - (declare (fixnum length)) - (do ((left-index 0 (1+ left-index)) - (right-index (1- length) (1- right-index)) - (half-length (truncate length 2))) - ((= left-index half-length) ,sequence) - (declare (fixnum left-index right-index half-length)) - (rotatef (aref ,sequence left-index) - (aref ,sequence right-index))))) - -(defmacro list-nreverse-macro (list) - `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st))) - (2nd ,list 1st) - (3rd '() 2nd)) - ((atom 2nd) 3rd) - (rplacd 2nd 3rd))) - -) - - -(defun list-nreverse* (sequence) - (list-nreverse-macro sequence)) - -(defun vector-nreverse* (sequence) - (vector-nreverse sequence)) - -(defun nreverse (sequence) - "Returns a sequence of the same elements in reverse order; the argument - is destroyed." - (seq-dispatch sequence - (list-nreverse* sequence) - (vector-nreverse* sequence))) - - -;;; Concatenate: - -(eval-when (compile eval) - -(defmacro concatenate-to-list (sequences) - `(let ((result (list nil))) - (do ((sequences ,sequences (cdr sequences)) - (splice result)) - ((null sequences) (cdr result)) - (let ((sequence (car sequences))) - (seq-dispatch sequence - (do ((sequence sequence (cdr sequence))) - ((atom sequence)) - (setq splice - (cdr (rplacd splice (list (car sequence)))))) - (do ((index 0 (1+ index)) - (length (length sequence))) - ((= index length)) - (declare (fixnum index length)) - (setq splice - (cdr (rplacd splice - (list (aref sequence index))))))))))) - -(defmacro concatenate-to-mumble (output-type-spec sequences) - `(do ((seqs ,sequences (cdr seqs)) - (total-length 0) - (lengths ())) - ((null seqs) - (do ((sequences ,sequences (cdr sequences)) - (lengths lengths (cdr lengths)) - (index 0) - (result (make-sequence-of-type ,output-type-spec total-length))) - ((= index total-length) result) - (declare (fixnum index)) - (let ((sequence (car sequences))) - (seq-dispatch sequence - (do ((sequence sequence (cdr sequence))) - ((atom sequence)) - (setf (aref result index) (car sequence)) - (setq index (1+ index))) - (do ((jndex 0 (1+ jndex)) - (this-length (car lengths))) - ((= jndex this-length)) - (declare (fixnum jndex this-length)) - (setf (aref result index) - (aref sequence jndex)) - (setq index (1+ index))))))) - (let ((length (length (car seqs)))) - (declare (fixnum length)) - (setq lengths (nconc lengths (list length))) - (setq total-length (+ total-length length))))) - -) - -(defun concatenate (output-type-spec &rest sequences) - "Returns a new sequence of all the argument sequences concatenated together - which shares no structure with the original argument sequences of the - specified OUTPUT-TYPE-SPEC." - (case (type-specifier-atom output-type-spec) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string - simple-base-string) - (apply #'concat-to-simple* output-type-spec sequences)) - (list (apply #'concat-to-list* sequences)) - (t - (apply #'concatenate (result-type-or-lose output-type-spec) sequences)))) - -;;; Internal Frobs: - -(defun concat-to-list* (&rest sequences) - (concatenate-to-list sequences)) - -(defun concat-to-simple* (type &rest sequences) - (concatenate-to-mumble type sequences)) - - -;;; Map: - -(eval-when (compile eval) - -(defmacro map-to-list (function sequences) - `(do ((seqs more-sequences (cdr seqs)) - (min-length (length first-sequence))) - ((null seqs) - (let ((result (list nil))) - (do ((index 0 (1+ index)) - (splice result)) - ((= index min-length) (cdr result)) - (declare (fixnum index)) - (setq splice - (cdr (rplacd splice - (list (apply ,function (elt-slice ,sequences - index))))))))) - (declare (fixnum min-length)) - (let ((length (length (car seqs)))) - (declare (fixnum length)) - (if (< length min-length) - (setq min-length length))))) - -(defmacro map-to-simple (output-type-spec function sequences) - `(do ((seqs more-sequences (cdr seqs)) - (min-length (length first-sequence))) - ((null seqs) - (do ((index 0 (1+ index)) - (result (make-sequence-of-type ,output-type-spec min-length))) - ((= index min-length) result) - (declare (fixnum index)) - (setf (aref result index) - (apply ,function (elt-slice ,sequences index))))) - (declare (fixnum min-length)) - (let ((length (length (car seqs)))) - (declare (fixnum length)) - (if (< length min-length) - (setq min-length length))))) - -(defmacro map-for-effect (function sequences) - `(do ((seqs more-sequences (cdr seqs)) - (min-length (length first-sequence))) - ((null seqs) - (do ((index 0 (1+ index))) - ((= index min-length) nil) - (apply ,function (elt-slice ,sequences index)))) - (declare (fixnum min-length)) - (let ((length (length (car seqs)))) - (declare (fixnum length)) - (if (< length min-length) - (setq min-length length))))) - - -) - -(defun map (output-type-spec function first-sequence &rest more-sequences) - "FUNCTION must take as many arguments as there are sequences provided. The - result is a sequence such that element i is the result of applying FUNCTION - to element i of each of the argument sequences." - (let ((sequences (cons first-sequence more-sequences))) - (case (type-specifier-atom output-type-spec) - ((nil) (map-for-effect function sequences)) - (list (map-to-list function sequences)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string simple-base-string) - (map-to-simple output-type-spec function sequences)) - (t - (apply #'map (result-type-or-lose output-type-spec t) - function sequences))))) - - -;;; Quantifiers: - -(eval-when (compile eval) -(defmacro defquantifier (name doc-string every-result abort-sense abort-value) - `(defun ,name (predicate first-sequence &rest more-sequences) - ,doc-string - (do ((seqs more-sequences (cdr seqs)) - (length (length first-sequence)) - (sequences (cons first-sequence more-sequences))) - ((null seqs) - (do ((index 0 (1+ index))) - ((= index length) ,every-result) - (declare (fixnum index)) - (let ((result (apply predicate (elt-slice sequences index)))) - (if ,(if abort-sense 'result '(not result)) - (return ,abort-value))))) - (declare (fixnum length)) - (let ((this (length (car seqs)))) - (declare (fixnum this)) - (if (< this length) (setq length this)))))) -) ; eval-when - -(defquantifier some - "PREDICATE is applied to the elements with index 0 of the sequences, then - possibly to those with index 1, and so on. SOME returns the first - non-() value encountered, or () if the end of a sequence is reached." - nil t result) - -(defquantifier every - "PREDICATE is applied to the elements with index 0 of the sequences, then - possibly to those with index 1, and so on. EVERY returns () as soon - as any invocation of PREDICATE returns (), or T if every invocation - is non-()." - t nil nil) - -(defquantifier notany - "PREDICATE is applied to the elements with index 0 of the sequences, then - possibly to those with index 1, and so on. NOTANY returns () as soon - as any invocation of PREDICATE returns a non-() value, or T if the end - of a sequence is reached." - t t nil) - -(defquantifier notevery - "PREDICATE is applied to the elements with index 0 of the sequences, then - possibly to those with index 1, and so on. NOTEVERY returns T as soon - as any invocation of PREDICATE returns (), or () if every invocation - is non-()." - nil nil t) - - - -;;; Reduce: - -(eval-when (compile eval) - -(defmacro mumble-reduce (function sequence key start end initial-value ref) - `(do ((index ,start (1+ index)) - (value ,initial-value)) - ((= index (the fixnum ,end)) value) - (declare (fixnum index)) - (setq value (funcall ,function value - (apply-key ,key (,ref ,sequence index)))))) - -(defmacro mumble-reduce-from-end (function sequence key start end initial-value ref) - `(do ((index (1- ,end) (1- index)) - (value ,initial-value) - (terminus (1- ,start))) - ((= index terminus) value) - (declare (fixnum index terminus)) - (setq value (funcall ,function - (apply-key ,key (,ref ,sequence index)) - value)))) - -(defmacro list-reduce (function sequence key start end initial-value ivp) - `(let ((sequence (nthcdr ,start ,sequence))) - (do ((count (if ,ivp ,start (1+ (the fixnum ,start))) - (1+ count)) - (sequence (if ,ivp sequence (cdr sequence)) - (cdr sequence)) - (value (if ,ivp ,initial-value (apply-key ,key (car sequence))) - (funcall ,function value (apply-key ,key (car sequence))))) - ((= count (the fixnum ,end)) value) - (declare (fixnum count))))) - -(defmacro list-reduce-from-end (function sequence key start end initial-value ivp) - `(let ((sequence (nthcdr (- (the fixnum (length ,sequence)) (the fixnum ,end)) - (reverse ,sequence)))) - (do ((count (if ,ivp ,start (1+ (the fixnum ,start))) - (1+ count)) - (sequence (if ,ivp sequence (cdr sequence)) - (cdr sequence)) - (value (if ,ivp ,initial-value (apply-key ,key (car sequence))) - (funcall ,function (apply-key ,key (car sequence)) value))) - ((= count (the fixnum ,end)) value) - (declare (fixnum count))))) - -) - -(defun reduce (function sequence &key key from-end (start 0) - end (initial-value nil ivp)) - "The specified Sequence is ``reduced'' using the given Function. - See manual for details." - (declare (type index start)) - (let ((start start) - (end (or end (length sequence)))) - (declare (type index start end)) - (cond ((= end start) - (if ivp initial-value (funcall function))) - ((listp sequence) - (if from-end - (list-reduce-from-end function sequence key start end - initial-value ivp) - (list-reduce function sequence key start end - initial-value ivp))) - (from-end - (when (not ivp) - (setq end (1- (the fixnum end))) - (setq initial-value (apply-key key (aref sequence end)))) - (mumble-reduce-from-end function sequence key start end - initial-value aref)) - (t - (when (not ivp) - (setq initial-value (apply-key key (aref sequence start))) - (setq start (1+ start))) - (mumble-reduce function sequence key start end - initial-value aref))))) - - -;;; Coerce: - -(defun coerce (object output-type-spec) - "Coerces the Object to an object of type Output-Type-Spec." - (cond - ((typep object output-type-spec) - object) - ((eq output-type-spec 'character) - (character object)) - ((eq output-type-spec 'function) - (eval `#',object)) - ((numberp object) - (case output-type-spec - ((short-float single-float float) - (%single-float object)) - ((double-float long-float) - (%double-float object)) - (complex - (complex object)) - (t - (error "~S can't be converted to type ~S." object output-type-spec)))) - (t - (typecase object - (list - (case (type-specifier-atom output-type-spec) - ((simple-string string simple-base-string base-string) - (list-to-string* object)) - ((simple-bit-vector bit-vector) (list-to-bit-vector* object)) - ((simple-vector vector array simple-array) - (list-to-vector* object output-type-spec)) - (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) - (simple-string - (case (type-specifier-atom output-type-spec) - (list (vector-to-list* object)) - ;; Can't coerce a string to a bit-vector! - ((simple-vector vector array simple-array) - (vector-to-vector* object output-type-spec)) - (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) - (simple-bit-vector - (case (type-specifier-atom output-type-spec) - (list (vector-to-list* object)) - ;; Can't coerce a bit-vector to a string! - ((simple-vector vector array simple-array) - (vector-to-vector* object output-type-spec)) - (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) - (simple-vector - (case (type-specifier-atom output-type-spec) - (list (vector-to-list* object)) - ((simple-string string simple-base-string base-string) - (vector-to-string* object)) - ((simple-bit-vector bit-vector) (vector-to-bit-vector* object)) - ((vector array simple-array) (vector-to-vector* object output-type-spec)) - (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) - (string - (case (type-specifier-atom output-type-spec) - (list (vector-to-list* object)) - ((simple-string simple-base-string) - (string-to-simple-string* object)) - ;; Can't coerce a string to a bit-vector! - ((simple-vector vector simple-array array) - (vector-to-vector* object output-type-spec)) - (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) - (bit-vector - (case (type-specifier-atom output-type-spec) - (list (vector-to-list* object)) - ;; Can't coerce a bit-vector to a string! - (simple-bit-vector (bit-vector-to-simple-bit-vector* object)) - ((simple-vector vector array simple-array) - (vector-to-vector* object output-type-spec)) - (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) - (vector - (case (type-specifier-atom output-type-spec) - (list (vector-to-list* object)) - ((simple-string string base-string simple-base-string) - (vector-to-string* object)) - ((simple-bit-vector bit-vector) (vector-to-bit-vector* object)) - ((simple-vector vector array simple-array) - (vector-to-vector* object output-type-spec)) - (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) - (t (error "~S is an inappropriate type of object for coerce." object)))))) - - -;;; Internal Frobs: - -(macrolet ((frob (name result access src-type &optional typep) - `(defun ,name (object ,@(if typep '(type) ())) - (do* ((index 0 (1+ index)) - (length (length (the ,(case src-type - (:list 'list) - (:vector 'vector)) - object))) - (result ,result)) - ((= index length) result) - (declare (fixnum length index)) - (setf (,access result index) - ,(case src-type - (:list '(pop object)) - (:vector '(aref object index)))))))) - - (frob list-to-string* (make-string length) schar :list) - - (frob list-to-bit-vector* (make-array length :element-type '(mod 2)) - sbit :list) - - (frob list-to-vector* (make-sequence-of-type type length) - aref :list t) - - (frob vector-to-vector* (make-sequence-of-type type length) - aref :vector t) - - (frob vector-to-string* (make-string length) schar :vector) - - (frob vector-to-bit-vector* (make-array length :element-type '(mod 2)) - sbit :vector)) - -(defun vector-to-list* (object) - (let ((result (list nil)) - (length (length object))) - (declare (fixnum length)) - (do ((index 0 (1+ index)) - (splice result (cdr splice))) - ((= index length) (cdr result)) - (declare (fixnum index)) - (rplacd splice (list (aref object index)))))) - -(defun string-to-simple-string* (object) - (if (simple-string-p object) - object - (with-array-data ((data object) - (start) - (end (length object))) - (declare (simple-string data)) - (subseq data start end)))) - -(defun bit-vector-to-simple-bit-vector* (object) - (if (simple-bit-vector-p object) - object - (with-array-data ((data object) - (start) - (end (length object))) - (declare (simple-bit-vector data)) - (subseq data start end)))) - - -;;; Delete: - -(eval-when (compile eval) - -(defmacro mumble-delete (pred) - `(do ((index start (1+ index)) - (jndex start) - (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) - (do ((index index (1+ index)) ; copy the rest of the vector - (jndex jndex (1+ jndex))) - ((= index (the fixnum length)) - (shrink-vector sequence jndex)) - (declare (fixnum index jndex)) - (setf (aref sequence jndex) (aref sequence index)))) - (declare (fixnum index jndex number-zapped)) - (setf (aref sequence jndex) (aref sequence index)) - (if ,pred - (setq number-zapped (1+ number-zapped)) - (setq jndex (1+ jndex))))) - -(defmacro mumble-delete-from-end (pred) - `(do ((index (1- (the fixnum end)) (1- index)) ; find the losers - (number-zapped 0) - (losers ()) - this-element - (terminus (1- start))) - ((or (= index terminus) (= number-zapped (the fixnum count))) - (do ((losers losers) ; delete the losers - (index start (1+ index)) - (jndex start)) - ((or (null losers) (= index (the fixnum end))) - (do ((index index (1+ index)) ; copy the rest of the vector - (jndex jndex (1+ jndex))) - ((= index (the fixnum length)) - (shrink-vector sequence jndex)) - (declare (fixnum index jndex)) - (setf (aref sequence jndex) (aref sequence index)))) - (declare (fixnum index jndex)) - (setf (aref sequence jndex) (aref sequence index)) - (if (= index (the fixnum (car losers))) - (pop losers) - (setq jndex (1+ jndex))))) - (declare (fixnum index number-zapped terminus)) - (setq this-element (aref sequence index)) - (when ,pred - (setq number-zapped (1+ number-zapped)) - (push index losers)))) - -(defmacro normal-mumble-delete () - `(mumble-delete - (if test-not - (not (funcall test-not item (apply-key key (aref sequence index)))) - (funcall test item (apply-key key (aref sequence index)))))) - -(defmacro normal-mumble-delete-from-end () - `(mumble-delete-from-end - (if test-not - (not (funcall test-not item (apply-key key this-element))) - (funcall test item (apply-key key this-element))))) - -(defmacro list-delete (pred) - `(let ((handle (cons nil sequence))) - (do ((current (nthcdr start sequence) (cdr current)) - (previous (nthcdr start handle)) - (index start (1+ index)) - (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) - (cdr handle)) - (declare (fixnum index number-zapped)) - (cond (,pred - (rplacd previous (cdr current)) - (setq number-zapped (1+ number-zapped))) - (t - (setq previous (cdr previous))))))) - -(defmacro list-delete-from-end (pred) - `(let* ((reverse (nreverse (the list sequence))) - (handle (cons nil reverse))) - (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse) - (cdr current)) - (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle)) - (index start (1+ index)) - (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) - (nreverse (cdr handle))) - (declare (fixnum index number-zapped)) - (cond (,pred - (rplacd previous (cdr current)) - (setq number-zapped (1+ number-zapped))) - (t - (setq previous (cdr previous))))))) - -(defmacro normal-list-delete () - '(list-delete - (if test-not - (not (funcall test-not item (apply-key key (car current)))) - (funcall test item (apply-key key (car current)))))) - -(defmacro normal-list-delete-from-end () - '(list-delete-from-end - (if test-not - (not (funcall test-not item (apply-key key (car current)))) - (funcall test item (apply-key key (car current)))))) -) - -(defun delete (item sequence &key from-end (test #'eql) test-not (start 0) - end (count most-positive-fixnum) key) - "Returns a sequence formed by destructively removing the specified Item from - the given Sequence." - (declare (fixnum start count)) - (let* ((length (length sequence)) - (end (or end length ))) - (declare (type index length end)) - (seq-dispatch sequence - (if from-end - (normal-list-delete-from-end) - (normal-list-delete)) - (if from-end - (normal-mumble-delete-from-end) - (normal-mumble-delete))))) - -(eval-when (compile eval) - -(defmacro if-mumble-delete () - `(mumble-delete - (funcall predicate (apply-key key (aref sequence index))))) - -(defmacro if-mumble-delete-from-end () - `(mumble-delete-from-end - (funcall predicate (apply-key key this-element)))) - -(defmacro if-list-delete () - '(list-delete - (funcall predicate (apply-key key (car current))))) - -(defmacro if-list-delete-from-end () - '(list-delete-from-end - (funcall predicate (apply-key key (car current))))) - -) - -(defun delete-if (predicate sequence &key from-end (start 0) key - end (count most-positive-fixnum)) - "Returns a sequence formed by destructively removing the elements satisfying - the specified Predicate from the given Sequence." - (declare (fixnum start count)) - (let* ((length (length sequence)) - (end (or end length))) - (declare (type index length end)) - (seq-dispatch sequence - (if from-end - (if-list-delete-from-end) - (if-list-delete)) - (if from-end - (if-mumble-delete-from-end) - (if-mumble-delete))))) - -(eval-when (compile eval) - -(defmacro if-not-mumble-delete () - `(mumble-delete - (not (funcall predicate (apply-key key (aref sequence index)))))) - -(defmacro if-not-mumble-delete-from-end () - `(mumble-delete-from-end - (not (funcall predicate (apply-key key this-element))))) - -(defmacro if-not-list-delete () - '(list-delete - (not (funcall predicate (apply-key key (car current)))))) - -(defmacro if-not-list-delete-from-end () - '(list-delete-from-end - (not (funcall predicate (apply-key key (car current)))))) - -) - -(defun delete-if-not (predicate sequence &key from-end (start 0) - end key (count most-positive-fixnum)) - "Returns a sequence formed by destructively removing the elements not - satisfying the specified Predicate from the given Sequence." - (declare (fixnum start count)) - (let* ((length (length sequence)) - (end (or end length))) - (declare (type index length end)) - (seq-dispatch sequence - (if from-end - (if-not-list-delete-from-end) - (if-not-list-delete)) - (if from-end - (if-not-mumble-delete-from-end) - (if-not-mumble-delete))))) - - -;;; Remove: - -(eval-when (compile eval) - -;;; MUMBLE-REMOVE-MACRO does not include (removes) each element that -;;; satisfies the predicate. -(defmacro mumble-remove-macro (bump left begin finish right pred) - `(do ((index ,begin (,bump index)) - (result - (do ((index ,left (,bump index)) - (result (make-sequence-like sequence length))) - ((= index (the fixnum ,begin)) result) - (declare (fixnum index)) - (setf (aref result index) (aref sequence index)))) - (new-index ,begin) - (number-zapped 0) - (this-element)) - ((or (= index (the fixnum ,finish)) (= number-zapped (the fixnum count))) - (do ((index index (,bump index)) - (new-index new-index (,bump new-index))) - ((= index (the fixnum ,right)) (shrink-vector result new-index)) - (declare (fixnum index new-index)) - (setf (aref result new-index) (aref sequence index)))) - (declare (fixnum index new-index number-zapped)) - (setq this-element (aref sequence index)) - (cond (,pred (setq number-zapped (1+ number-zapped))) - (t (setf (aref result new-index) this-element) - (setq new-index (,bump new-index)))))) - -(defmacro mumble-remove (pred) - `(mumble-remove-macro 1+ 0 start end length ,pred)) - -(defmacro mumble-remove-from-end (pred) - `(let ((sequence (copy-seq sequence))) - (mumble-delete-from-end ,pred))) - -(defmacro normal-mumble-remove () - `(mumble-remove - (if test-not - (not (funcall test-not item (apply-key key this-element))) - (funcall test item (apply-key key this-element))))) - -(defmacro normal-mumble-remove-from-end () - `(mumble-remove-from-end - (if test-not - (not (funcall test-not item (apply-key key this-element))) - (funcall test item (apply-key key this-element))))) - -(defmacro if-mumble-remove () - `(mumble-remove (funcall predicate (apply-key key this-element)))) - -(defmacro if-mumble-remove-from-end () - `(mumble-remove-from-end (funcall predicate (apply-key key this-element)))) - -(defmacro if-not-mumble-remove () - `(mumble-remove (not (funcall predicate (apply-key key this-element))))) - -(defmacro if-not-mumble-remove-from-end () - `(mumble-remove-from-end - (not (funcall predicate (apply-key key this-element))))) - -;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies -;;; the predicate. -(defmacro list-remove-macro (pred reverse?) - `(let* ((sequence ,(if reverse? - '(reverse (the list sequence)) - 'sequence)) - (splice (list nil)) - (results (do ((index 0 (1+ index)) - (before-start splice)) - ((= index (the fixnum start)) before-start) - (declare (fixnum index)) - (setq splice - (cdr (rplacd splice (list (pop sequence)))))))) - (do ((index start (1+ index)) - (this-element) - (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) - (do ((index index (1+ index))) - ((null sequence) - ,(if reverse? - '(nreverse (the list (cdr results))) - '(cdr results))) - (declare (fixnum index)) - (setq splice (cdr (rplacd splice (list (pop sequence))))))) - (declare (fixnum index number-zapped)) - (setq this-element (pop sequence)) - (if ,pred - (setq number-zapped (1+ number-zapped)) - (setq splice (cdr (rplacd splice (list this-element)))))))) - -(defmacro list-remove (pred) - `(list-remove-macro ,pred nil)) - -(defmacro list-remove-from-end (pred) - `(list-remove-macro ,pred t)) - -(defmacro normal-list-remove () - `(list-remove - (if test-not - (not (funcall test-not item (apply-key key this-element))) - (funcall test item (apply-key key this-element))))) - -(defmacro normal-list-remove-from-end () - `(list-remove-from-end - (if test-not - (not (funcall test-not item (apply-key key this-element))) - (funcall test item (apply-key key this-element))))) - -(defmacro if-list-remove () - `(list-remove - (funcall predicate (apply-key key this-element)))) - -(defmacro if-list-remove-from-end () - `(list-remove-from-end - (funcall predicate (apply-key key this-element)))) - -(defmacro if-not-list-remove () - `(list-remove - (not (funcall predicate (apply-key key this-element))))) - -(defmacro if-not-list-remove-from-end () - `(list-remove-from-end - (not (funcall predicate (apply-key key this-element))))) - -) - -(defun remove (item sequence &key from-end (test #'eql) test-not (start 0) - end (count most-positive-fixnum) key) - "Returns a copy of SEQUENCE with elements satisfying the test (default is - EQL) with ITEM removed." - (declare (fixnum start count)) - (let* ((length (length sequence)) - (end (or end length))) - (declare (type index length end)) - (seq-dispatch sequence - (if from-end - (normal-list-remove-from-end) - (normal-list-remove)) - (if from-end - (normal-mumble-remove-from-end) - (normal-mumble-remove))))) - -(defun remove-if (predicate sequence &key from-end (start 0) - end (count most-positive-fixnum) key) - "Returns a copy of sequence with elements such that predicate(element) - is non-null are removed" - (declare (fixnum start count)) - (let* ((length (length sequence)) - (end (or end length))) - (declare (type index length end)) - (seq-dispatch sequence - (if from-end - (if-list-remove-from-end) - (if-list-remove)) - (if from-end - (if-mumble-remove-from-end) - (if-mumble-remove))))) - -(defun remove-if-not (predicate sequence &key - from-end (start 0) end - (count most-positive-fixnum) key) - "Returns a copy of sequence with elements such that predicate(element) - is null are removed" - (declare (fixnum start count)) - (let* ((length (length sequence)) - (end (or end length))) - (declare (type index length end)) - (seq-dispatch sequence - (if from-end - (if-not-list-remove-from-end) - (if-not-list-remove)) - (if from-end - (if-not-mumble-remove-from-end) - (if-not-mumble-remove))))) - - -;;; Remove-Duplicates: - -;;; Remove duplicates from a list. If from-end, remove the later duplicates, -;;; not the earlier ones. Thus if we check from-end we don't copy an item -;;; if we look into the already copied structure (from after :start) and see -;;; the item. If we check from beginning we check into the rest of the -;;; original list up to the :end marker (this we have to do by running a -;;; do loop down the list that far and using our test. -(defun list-remove-duplicates* (list test test-not start end key from-end) - (declare (fixnum start)) - (let* ((result (list ())) ; Put a marker on the beginning to splice with. - (splice result) - (current list)) - (do ((index 0 (1+ index))) - ((= index start)) - (declare (fixnum index)) - (setq splice (cdr (rplacd splice (list (car current))))) - (setq current (cdr current))) - (do ((index 0 (1+ index))) - ((or (and end (= index (the fixnum end))) - (atom current))) - (declare (fixnum index)) - (if (or (and from-end - (not (member (apply-key key (car current)) - (nthcdr (1+ start) result) - :test test - :test-not test-not - :key (if key key #'identity)))) - (and (not from-end) - (not (do ((it (apply-key key (car current))) - (l (cdr current) (cdr l)) - (i (1+ index) (1+ i))) - ((or (atom l) (and end (= i (the fixnum end)))) - ()) - (declare (fixnum i)) - (if (if test-not - (not (funcall test-not (apply-key key (car l)) it)) - (funcall test (apply-key key (car l)) it)) - (return t)))))) - (setq splice (cdr (rplacd splice (list (car current)))))) - (setq current (cdr current))) - (do () - ((atom current)) - (setq splice (cdr (rplacd splice (list (car current))))) - (setq current (cdr current))) - (cdr result))) - - - -(defun vector-remove-duplicates* (vector test test-not start end key from-end - &optional (length (length vector))) - (declare (vector vector) (fixnum start length)) - (when (null end) (setf end (length vector))) - (let ((result (make-sequence-like vector length)) - (index 0) - (jndex start)) - (declare (fixnum index jndex)) - (do () - ((= index start)) - (setf (aref result index) (aref vector index)) - (setq index (1+ index))) - (do ((elt)) - ((= index end)) - (setq elt (aref vector index)) - (unless (or (and from-end - (position (apply-key key elt) result :start start - :end jndex :test test :test-not test-not :key key)) - (and (not from-end) - (position (apply-key key elt) vector :start (1+ index) - :end end :test test :test-not test-not :key key))) - (setf (aref result jndex) elt) - (setq jndex (1+ jndex))) - (setq index (1+ index))) - (do () - ((= index length)) - (setf (aref result jndex) (aref vector index)) - (setq index (1+ index)) - (setq jndex (1+ jndex))) - (shrink-vector result jndex))) - - -(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) from-end - end key) - "The elements of Sequence are examined, and if any two match, one is - discarded. The resulting sequence is returned." - (declare (fixnum start)) - (seq-dispatch sequence - (if sequence - (list-remove-duplicates* sequence test test-not - start end key from-end)) - (vector-remove-duplicates* sequence test test-not - start end key from-end))) - - - -;;; Delete-Duplicates: - - -(defun list-delete-duplicates* (list test test-not key from-end start end) - (declare (fixnum start)) - (let ((handle (cons nil list))) - (do ((current (nthcdr start list) (cdr current)) - (previous (nthcdr start handle)) - (index start (1+ index))) - ((or (and end (= index (the fixnum end))) (null current)) - (cdr handle)) - (declare (fixnum index)) - (if (do ((x (if from-end - (nthcdr (1+ start) handle) - (cdr current)) - (cdr x)) - (i (1+ index) (1+ i))) - ((or (null x) - (and (not from-end) end (= i (the fixnum end))) - (eq x current)) - nil) - (declare (fixnum i)) - (if (if test-not - (not (funcall test-not - (apply-key key (car current)) - (apply-key key (car x)))) - (funcall test - (apply-key key (car current)) - (apply-key key (car x)))) - (return t))) - (rplacd previous (cdr current)) - (setq previous (cdr previous)))))) - - -(defun vector-delete-duplicates* (vector test test-not key from-end start end - &optional (length (length vector))) - (declare (vector vector) (fixnum start length)) - (when (null end) (setf end (length vector))) - (do ((index start (1+ index)) - (jndex start)) - ((= index end) - (do ((index index (1+ index)) ; copy the rest of the vector - (jndex jndex (1+ jndex))) - ((= index length) - (shrink-vector vector jndex) - vector) - (setf (aref vector jndex) (aref vector index)))) - (declare (fixnum index jndex)) - (setf (aref vector jndex) (aref vector index)) - (unless (position (apply-key key (aref vector index)) vector :key key - :start (if from-end start (1+ index)) :test test - :end (if from-end jndex end) :test-not test-not) - (setq jndex (1+ jndex))))) - - -(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end - end key) - "The elements of Sequence are examined, and if any two match, one is - discarded. The resulting sequence, which may be formed by destroying the - given sequence, is returned." - (seq-dispatch sequence - (if sequence - (list-delete-duplicates* sequence test test-not key from-end start end)) - (vector-delete-duplicates* sequence test test-not key from-end start end))) - -(defun list-substitute* (pred new list start end count key test test-not old) - (declare (fixnum start end count)) - (let* ((result (list nil)) - elt - (splice result) - (list list)) ; Get a local list for a stepper. - (do ((index 0 (1+ index))) - ((= index start)) - (declare (fixnum index)) - (setq splice (cdr (rplacd splice (list (car list))))) - (setq list (cdr list))) - (do ((index start (1+ index))) - ((or (= index end) (null list) (= count 0))) - (declare (fixnum index)) - (setq elt (car list)) - (setq splice - (cdr (rplacd splice - (list - (cond - ((case pred - (normal - (if test-not - (not - (funcall test-not old (apply-key key elt))) - (funcall test old (apply-key key elt)))) - (if (funcall test (apply-key key elt))) - (if-not (not (funcall test (apply-key key elt))))) - (setq count (1- count)) - new) - (t elt)))))) - (setq list (cdr list))) - (do () - ((null list)) - (setq splice (cdr (rplacd splice (list (car list))))) - (setq list (cdr list))) - (cdr result))) - -;;; Replace old with new in sequence moving from left to right by incrementer -;;; on each pass through the loop. Called by all three substitute functions. -(defun vector-substitute* (pred new sequence incrementer left right length - start end count key test test-not old) - (declare (fixnum start count end incrementer right)) - (let ((result (make-sequence-like sequence length)) - (index left)) - (declare (fixnum index)) - (do () - ((= index start)) - (setf (aref result index) (aref sequence index)) - (setq index (+ index incrementer))) - (do ((elt)) - ((or (= index end) (= count 0))) - (setq elt (aref sequence index)) - (setf (aref result index) - (cond ((case pred - (normal - (if test-not - (not (funcall test-not old (apply-key key elt))) - (funcall test old (apply-key key elt)))) - (if (funcall test (apply-key key elt))) - (if-not (not (funcall test (apply-key key elt))))) - (setq count (1- count)) - new) - (t elt))) - (setq index (+ index incrementer))) - (do () - ((= index right)) - (setf (aref result index) (aref sequence index)) - (setq index (+ index incrementer))) - result)) - -(eval-when (compile eval) - - -(defmacro subst-dispatch (pred) - `(if (listp sequence) - (if from-end - (nreverse (list-substitute* ,pred new (reverse sequence) - (- (the fixnum length) (the fixnum end)) - (- (the fixnum length) (the fixnum start)) - count key test test-not old)) - (list-substitute* ,pred new sequence start end count key test test-not - old)) - (if from-end - (vector-substitute* ,pred new sequence -1 (1- (the fixnum length)) - -1 length (1- (the fixnum end)) - (1- (the fixnum start)) count key test test-not old) - (vector-substitute* ,pred new sequence 1 0 length length - start end count key test test-not old)))) - -) - - -;;; Substitute: - -(defun substitute (new old sequence &key from-end (test #'eql) test-not - (start 0) (count most-positive-fixnum) - end key) - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements equal to Old are replaced with New. See manual - for details." - (declare (fixnum start count)) - (let* ((length (length sequence)) - (end (or end length))) - (declare (type index length end)) - (subst-dispatch 'normal))) - - -;;; Substitute-If: - -(defun substitute-if (new test sequence &key from-end (start 0) - end (count most-positive-fixnum) key) - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements satisfying the Test are replaced with New. See - manual for details." - (declare (fixnum start count)) - (let* ((length (length sequence)) - (end (or end length)) - test-not - old) - (declare (type index length end)) - (subst-dispatch 'if))) - - -;;; Substitute-If-Not: - -(defun substitute-if-not (new test sequence &key from-end (start 0) - end (count most-positive-fixnum) key) - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements not satisfying the Test are replaced with New. - See manual for details." - (declare (fixnum start count)) - (let* ((length (length sequence)) - (end (or end length)) - test-not - old) - (declare (type index length end)) - (subst-dispatch 'if-not))) - - - -;;; NSubstitute: - -(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not - end (count most-positive-fixnum) key (start 0)) - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements equal to Old are replaced with New. The Sequence - may be destroyed. See manual for details." - (declare (fixnum count start)) - (let ((end (or end (length sequence)))) - (if (listp sequence) - (if from-end - (nreverse (nlist-substitute* - new old (nreverse (the list sequence)) - test test-not start end count key)) - (nlist-substitute* new old sequence - test test-not start end count key)) - (if from-end - (nvector-substitute* new old sequence -1 - test test-not (1- end) (1- start) count key) - (nvector-substitute* new old sequence 1 - test test-not start end count key))))) - -(defun nlist-substitute* (new old sequence test test-not start end count key) - (declare (fixnum start count end)) - (do ((list (nthcdr start sequence) (cdr list)) - (index start (1+ index))) - ((or (= index end) (null list) (= count 0)) sequence) - (declare (fixnum index)) - (when (if test-not - (not (funcall test-not old (apply-key key (car list)))) - (funcall test old (apply-key key (car list)))) - (rplaca list new) - (setq count (1- count))))) - -(defun nvector-substitute* (new old sequence incrementer - test test-not start end count key) - (declare (fixnum start incrementer count end)) - (do ((index start (+ index incrementer))) - ((or (= index end) (= count 0)) sequence) - (declare (fixnum index)) - (when (if test-not - (not (funcall test-not old (apply-key key (aref sequence index)))) - (funcall test old (apply-key key (aref sequence index)))) - (setf (aref sequence index) new) - (setq count (1- count))))) - - -;;; NSubstitute-If: - -(defun nsubstitute-if (new test sequence &key from-end (start 0) - end (count most-positive-fixnum) key) - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements satisfying the Test are replaced with New. The - Sequence may be destroyed. See manual for details." - (declare (fixnum start count)) - (let ((end (or end (length sequence)))) - (declare (fixnum end)) - (if (listp sequence) - (if from-end - (nreverse (nlist-substitute-if* - new test (nreverse (the list sequence)) - start end count key)) - (nlist-substitute-if* new test sequence - start end count key)) - (if from-end - (nvector-substitute-if* new test sequence -1 - (1- end) (1- start) count key) - (nvector-substitute-if* new test sequence 1 - start end count key))))) - -(defun nlist-substitute-if* (new test sequence start end count key) - (declare (fixnum end)) - (do ((list (nthcdr start sequence) (cdr list)) - (index start (1+ index))) - ((or (= index end) (null list) (= count 0)) sequence) - (when (funcall test (apply-key key (car list))) - (rplaca list new) - (setq count (1- count))))) - -(defun nvector-substitute-if* (new test sequence incrementer - start end count key) - (do ((index start (+ index incrementer))) - ((or (= index end) (= count 0)) sequence) - (when (funcall test (apply-key key (aref sequence index))) - (setf (aref sequence index) new) - (setq count (1- count))))) - - -;;; NSubstitute-If-Not: - -(defun nsubstitute-if-not (new test sequence &key from-end (start 0) - end (count most-positive-fixnum) key) - "Returns a sequence of the same kind as Sequence with the same elements - except that all elements not satisfying the Test are replaced with New. - The Sequence may be destroyed. See manual for details." - (declare (fixnum start count)) - (let ((end (or end (length sequence)))) - (declare (fixnum end)) - (if (listp sequence) - (if from-end - (nreverse (nlist-substitute-if-not* - new test (nreverse (the list sequence)) - start end count key)) - (nlist-substitute-if-not* new test sequence - start end count key)) - (if from-end - (nvector-substitute-if-not* new test sequence -1 - (1- end) (1- start) count key) - (nvector-substitute-if-not* new test sequence 1 - start end count key))))) - -(defun nlist-substitute-if-not* (new test sequence start end count key) - (declare (fixnum end)) - (do ((list (nthcdr start sequence) (cdr list)) - (index start (1+ index))) - ((or (= index end) (null list) (= count 0)) sequence) - (when (not (funcall test (apply-key key (car list)))) - (rplaca list new) - (setq count (1- count))))) - -(defun nvector-substitute-if-not* (new test sequence incrementer - start end count key) - (do ((index start (+ index incrementer))) - ((or (= index end) (= count 0)) sequence) - (when (not (funcall test (apply-key key (aref sequence index)))) - (setf (aref sequence index) new) - (setq count (1- count))))) - - -;;; Locater macros used by FIND and POSITION. - -(eval-when (compile eval) - -(defmacro vector-locater-macro (sequence body-form return-type) - `(let ((incrementer (if from-end -1 1)) - (start (if from-end (1- (the fixnum end)) start)) - (end (if from-end (1- (the fixnum start)) end))) - (declare (fixnum start end incrementer)) - (do ((index start (+ index incrementer)) - ,@(case return-type (:position nil) (:element '(current)))) - ((= index end) ()) - (declare (fixnum index)) - ,@(case return-type - (:position nil) - (:element `((setf current (aref ,sequence index))))) - ,body-form))) - -(defmacro locater-test-not (item sequence seq-type return-type) - (let ((seq-ref (case return-type - (:position - (case seq-type - (:vector `(aref ,sequence index)) - (:list `(pop ,sequence)))) - (:element 'current))) - (return (case return-type - (:position 'index) - (:element 'current)))) - `(if test-not - (if (not (funcall test-not ,item (apply-key key ,seq-ref))) - (return ,return)) - (if (funcall test ,item (apply-key key ,seq-ref)) - (return ,return))))) - -(defmacro vector-locater (item sequence return-type) - `(vector-locater-macro ,sequence - (locater-test-not ,item ,sequence :vector ,return-type) - ,return-type)) - -(defmacro locater-if-test (test sequence seq-type return-type sense) - (let ((seq-ref (case return-type - (:position - (case seq-type - (:vector `(aref ,sequence index)) - (:list `(pop ,sequence)))) - (:element 'current))) - (return (case return-type - (:position 'index) - (:element 'current)))) - (if sense - `(if (funcall ,test (apply-key key ,seq-ref)) - (return ,return)) - `(if (not (funcall ,test (apply-key key ,seq-ref))) - (return ,return))))) - -(defmacro vector-locater-if-macro (test sequence return-type sense) - `(vector-locater-macro ,sequence - (locater-if-test ,test ,sequence :vector ,return-type ,sense) - ,return-type)) - -(defmacro vector-locater-if (test sequence return-type) - `(vector-locater-if-macro ,test ,sequence ,return-type t)) - -(defmacro vector-locater-if-not (test sequence return-type) - `(vector-locater-if-macro ,test ,sequence ,return-type nil)) - - -(defmacro list-locater-macro (sequence body-form return-type) - `(if from-end - (do ((sequence (nthcdr (- (the fixnum (length sequence)) - (the fixnum end)) - (reverse (the list ,sequence)))) - (index (1- (the fixnum end)) (1- index)) - (terminus (1- (the fixnum start))) - ,@(case return-type (:position nil) (:element '(current)))) - ((or (= index terminus) (null sequence)) ()) - (declare (fixnum index terminus)) - ,@(case return-type - (:position nil) - (:element `((setf current (pop ,sequence))))) - ,body-form) - (do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - ,@(case return-type (:position nil) (:element '(current)))) - ((or (= index (the fixnum end)) (null sequence)) ()) - (declare (fixnum index)) - ,@(case return-type - (:position nil) - (:element `((setf current (pop ,sequence))))) - ,body-form))) - -(defmacro list-locater (item sequence return-type) - `(list-locater-macro ,sequence - (locater-test-not ,item ,sequence :list ,return-type) - ,return-type)) - -(defmacro list-locater-if-macro (test sequence return-type sense) - `(list-locater-macro ,sequence - (locater-if-test ,test ,sequence :list ,return-type ,sense) - ,return-type)) - -(defmacro list-locater-if (test sequence return-type) - `(list-locater-if-macro ,test ,sequence ,return-type t)) - -(defmacro list-locater-if-not (test sequence return-type) - `(list-locater-if-macro ,test ,sequence ,return-type nil)) - -) ; eval-when - - -;;; Position: - -(eval-when (compile eval) - -(defmacro vector-position (item sequence) - `(vector-locater ,item ,sequence :position)) - -(defmacro list-position (item sequence) - `(list-locater ,item ,sequence :position)) - -) ; eval-when - - -;;; POSITION cannot default end to the length of sequence since it is not -;;; an error to supply nil for its value. We must test for end being nil -;;; in the body of the function, and this is actually done in the support -;;; routines for other reasons (see below). -(defun position (item sequence &key from-end (test #'eql) test-not (start 0) - end key) - "Returns the zero-origin index of the first element in SEQUENCE - satisfying the test (default is EQL) with the given ITEM" - (seq-dispatch sequence - (list-position* item sequence from-end test test-not start end key) - (vector-position* item sequence from-end test test-not start end key))) - - -;;; The support routines for SUBSEQ are used by compiler transforms, so we -;;; worry about dealing with end being supplied as or defaulting to nil -;;; at this level. - -(defun list-position* (item sequence from-end test test-not start end key) - (declare (fixnum start)) - (when (null end) (setf end (length sequence))) - (list-position item sequence)) - -(defun vector-position* (item sequence from-end test test-not start end key) - (declare (fixnum start)) - (when (null end) (setf end (length sequence))) - (vector-position item sequence)) - - -;;; Position-if: - -(eval-when (compile eval) - -(defmacro vector-position-if (test sequence) - `(vector-locater-if ,test ,sequence :position)) - - -(defmacro list-position-if (test sequence) - `(list-locater-if ,test ,sequence :position)) - -) - -(defun position-if (test sequence &key from-end (start 0) key end) - "Returns the zero-origin index of the first element satisfying test(el)" - (declare (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-position-if test sequence) - (vector-position-if test sequence)))) - - -;;; Position-if-not: - -(eval-when (compile eval) - -(defmacro vector-position-if-not (test sequence) - `(vector-locater-if-not ,test ,sequence :position)) - -(defmacro list-position-if-not (test sequence) - `(list-locater-if-not ,test ,sequence :position)) - -) - -(defun position-if-not (test sequence &key from-end (start 0) key end) - "Returns the zero-origin index of the first element not satisfying test(el)" - (declare (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-position-if-not test sequence) - (vector-position-if-not test sequence)))) - - -;;; Find: - -(eval-when (compile eval) - -(defmacro vector-find (item sequence) - `(vector-locater ,item ,sequence :element)) - -(defmacro list-find (item sequence) - `(list-locater ,item ,sequence :element)) - -) - -;;; FIND cannot default end to the length of sequence since it is not -;;; an error to supply nil for its value. We must test for end being nil -;;; in the body of the function, and this is actually done in the support -;;; routines for other reasons (see above). -(defun find (item sequence &key from-end (test #'eql) test-not (start 0) - end key) - "Returns the first element in SEQUENCE satisfying the test (default - is EQL) with the given ITEM" - (declare (fixnum start)) - (seq-dispatch sequence - (list-find* item sequence from-end test test-not start end key) - (vector-find* item sequence from-end test test-not start end key))) - - -;;; The support routines for FIND are used by compiler transforms, so we -;;; worry about dealing with end being supplied as or defaulting to nil -;;; at this level. - -(defun list-find* (item sequence from-end test test-not start end key) - (when (null end) (setf end (length sequence))) - (list-find item sequence)) - -(defun vector-find* (item sequence from-end test test-not start end key) - (when (null end) (setf end (length sequence))) - (vector-find item sequence)) - - -;;; Find-if: - -(eval-when (compile eval) - -(defmacro vector-find-if (test sequence) - `(vector-locater-if ,test ,sequence :element)) - -(defmacro list-find-if (test sequence) - `(list-locater-if ,test ,sequence :element)) - -) - -(defun find-if (test sequence &key from-end (start 0) end key) - "Returns the zero-origin index of the first element satisfying the test." - (declare (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-find-if test sequence) - (vector-find-if test sequence)))) - - -;;; Find-if-not: - -(eval-when (compile eval) - -(defmacro vector-find-if-not (test sequence) - `(vector-locater-if-not ,test ,sequence :element)) - -(defmacro list-find-if-not (test sequence) - `(list-locater-if-not ,test ,sequence :element)) - -) - -(defun find-if-not (test sequence &key from-end (start 0) end key) - "Returns the zero-origin index of the first element not satisfying the test." - (declare (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-find-if-not test sequence) - (vector-find-if-not test sequence)))) - - -;;; Count: - -(eval-when (compile eval) - -(defmacro vector-count (item sequence) - `(do ((index start (1+ index)) - (count 0)) - ((= index (the fixnum end)) count) - (declare (fixnum index count)) - (if test-not - (if (funcall test-not ,item (apply-key key (aref ,sequence index))) - (setq count (1+ count))) - (if (funcall test ,item (apply-key key (aref ,sequence index))) - (setq count (1+ count)))))) - -(defmacro list-count (item sequence) - `(do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - (count 0)) - ((or (= index (the fixnum end)) (null sequence)) count) - (declare (fixnum index count)) - (if test-not - (if (funcall test-not ,item (apply-key key (pop sequence))) - (setq count (1+ count))) - (if (funcall test ,item (apply-key key (pop sequence))) - (setq count (1+ count)))))) - -) - -(defun count (item sequence &key from-end (test #'eql) test-not (start 0) - end key) - "Returns the number of elements in SEQUENCE satisfying a test with ITEM, - which defaults to EQL." - (declare (ignore from-end) (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-count item sequence) - (vector-count item sequence)))) - - -;;; Count-if: - -(eval-when (compile eval) - -(defmacro vector-count-if (predicate sequence) - `(do ((index start (1+ index)) - (count 0)) - ((= index (the fixnum end)) count) - (declare (fixnum index count)) - (if (funcall ,predicate (apply-key key (aref ,sequence index))) - (setq count (1+ count))))) - -(defmacro list-count-if (predicate sequence) - `(do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - (count 0)) - ((or (= index (the fixnum end)) (null sequence)) count) - (declare (fixnum index count)) - (if (funcall ,predicate (apply-key key (pop sequence))) - (setq count (1+ count))))) - -) - -(defun count-if (test sequence &key from-end (start 0) end key) - "Returns the number of elements in SEQUENCE satisfying TEST(el)." - (declare (ignore from-end) (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-count-if test sequence) - (vector-count-if test sequence)))) - - -;;; Count-if-not: - -(eval-when (compile eval) - -(defmacro vector-count-if-not (predicate sequence) - `(do ((index start (1+ index)) - (count 0)) - ((= index (the fixnum end)) count) - (declare (fixnum index count)) - (if (not (funcall ,predicate (apply-key key (aref ,sequence index)))) - (setq count (1+ count))))) - -(defmacro list-count-if-not (predicate sequence) - `(do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - (count 0)) - ((or (= index (the fixnum end)) (null sequence)) count) - (declare (fixnum index count)) - (if (not (funcall ,predicate (apply-key key (pop sequence)))) - (setq count (1+ count))))) - -) - -(defun count-if-not (test sequence &key from-end (start 0) end key) - "Returns the number of elements in SEQUENCE not satisfying TEST(el)." - (declare (ignore from-end) (fixnum start)) - (let ((end (or end (length sequence)))) - (declare (type index end)) - (seq-dispatch sequence - (list-count-if-not test sequence) - (vector-count-if-not test sequence)))) - - -;;; Mismatch utilities: - -(eval-when (compile eval) - - -(defmacro match-vars (&rest body) - `(let ((inc (if from-end -1 1)) - (start1 (if from-end (1- (the fixnum end1)) start1)) - (start2 (if from-end (1- (the fixnum end2)) start2)) - (end1 (if from-end (1- (the fixnum start1)) end1)) - (end2 (if from-end (1- (the fixnum start2)) end2))) - (declare (fixnum inc start1 start2 end1 end2)) - ,@body)) - -(defmacro matchify-list ((sequence start length end) &body body) - (declare (ignore end)) ;; ### Should END be used below? - `(let ((,sequence (if from-end - (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1) - (reverse (the list ,sequence))) - (nthcdr ,start ,sequence)))) - (declare (type list ,sequence)) - ,@body)) - -) - -;;; Mismatch: - -(eval-when (compile eval) - -(defmacro if-mismatch (elt1 elt2) - `(cond ((= (the fixnum index1) (the fixnum end1)) - (return (if (= (the fixnum index2) (the fixnum end2)) - nil - (if from-end - (1+ (the fixnum index1)) - (the fixnum index1))))) - ((= (the fixnum index2) (the fixnum end2)) - (return (if from-end (1+ (the fixnum index1)) index1))) - (test-not - (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) - (return (if from-end (1+ (the fixnum index1)) index1)))) - (t (if (not (funcall test (apply-key key ,elt1) - (apply-key key ,elt2))) - (return (if from-end (1+ (the fixnum index1)) index1)))))) - -(defmacro mumble-mumble-mismatch () - `(do ((index1 start1 (+ index1 (the fixnum inc))) - (index2 start2 (+ index2 (the fixnum inc)))) - (()) - (declare (fixnum index1 index2)) - (if-mismatch (aref sequence1 index1) (aref sequence2 index2)))) - -(defmacro mumble-list-mismatch () - `(do ((index1 start1 (+ index1 (the fixnum inc))) - (index2 start2 (+ index2 (the fixnum inc)))) - (()) - (declare (fixnum index1 index2)) - (if-mismatch (aref sequence1 index1) (pop sequence2)))) - -(defmacro list-mumble-mismatch () - `(do ((index1 start1 (+ index1 (the fixnum inc))) - (index2 start2 (+ index2 (the fixnum inc)))) - (()) - (declare (fixnum index1 index2)) - (if-mismatch (pop sequence1) (aref sequence2 index2)))) - -(defmacro list-list-mismatch () - `(do ((sequence1 sequence1) - (sequence2 sequence2) - (index1 start1 (+ index1 (the fixnum inc))) - (index2 start2 (+ index2 (the fixnum inc)))) - (()) - (declare (fixnum index1 index2)) - (if-mismatch (pop sequence1) (pop sequence2)))) - -) - -(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not - (start1 0) end1 (start2 0) end2 key) - "The specified subsequences of Sequence1 and Sequence2 are compared - element-wise. If they are of equal length and match in every element, the - result is Nil. Otherwise, the result is a non-negative integer, the index - within Sequence1 of the leftmost position at which they fail to match; or, - if one is shorter than and a matching prefix of the other, the index within - Sequence1 beyond the last position tested is returned. If a non-Nil - :From-End keyword argument is given, then one plus the index of the - rightmost position in which the sequences differ is returned." - (declare (fixnum start1 start2)) - (let* ((length1 (length sequence1)) - (end1 (or end1 length1)) - (length2 (length sequence2)) - (end2 (or end2 length2))) - (declare (type index length1 end1 length2 end2)) - (match-vars - (seq-dispatch sequence1 - (matchify-list (sequence1 start1 length1 end1) - (seq-dispatch sequence2 - (matchify-list (sequence2 start2 length2 end2) - (list-list-mismatch)) - (list-mumble-mismatch))) - (seq-dispatch sequence2 - (matchify-list (sequence2 start2 length2 end2) - (mumble-list-mismatch)) - (mumble-mumble-mismatch)))))) - - -;;; Search comparison functions: - -(eval-when (compile eval) - -;;; Compare two elements and return if they don't match: - -(defmacro compare-elements (elt1 elt2) - `(if test-not - (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) - (return nil) - t) - (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2))) - (return nil) - t))) - -(defmacro search-compare-list-list (main sub) - `(do ((main ,main (cdr main)) - (jndex start1 (1+ jndex)) - (sub (nthcdr start1 ,sub) (cdr sub))) - ((or (null main) (null sub) (= (the fixnum end1) jndex)) - t) - (declare (fixnum jndex)) - (compare-elements (car main) (car sub)))) - -(defmacro search-compare-list-vector (main sub) - `(do ((main ,main (cdr main)) - (index start1 (1+ index))) - ((or (null main) (= index (the fixnum end1))) t) - (declare (fixnum index)) - (compare-elements (car main) (aref ,sub index)))) - -(defmacro search-compare-vector-list (main sub index) - `(do ((sub (nthcdr start1 ,sub) (cdr sub)) - (jndex start1 (1+ jndex)) - (index ,index (1+ index))) - ((or (= (the fixnum end1) jndex) (null sub)) t) - (declare (fixnum jndex index)) - (compare-elements (aref ,main index) (car sub)))) - -(defmacro search-compare-vector-vector (main sub index) - `(do ((index ,index (1+ index)) - (sub-index start1 (1+ sub-index))) - ((= sub-index (the fixnum end1)) t) - (declare (fixnum sub-index index)) - (compare-elements (aref ,main index) (aref ,sub sub-index)))) - -(defmacro search-compare (main-type main sub index) - (if (eq main-type 'list) - `(seq-dispatch ,sub - (search-compare-list-list ,main ,sub) - (search-compare-list-vector ,main ,sub)) - `(seq-dispatch ,sub - (search-compare-vector-list ,main ,sub ,index) - (search-compare-vector-vector ,main ,sub ,index)))) - -) - -(eval-when (compile eval) - -(defmacro list-search (main sub) - `(do ((main (nthcdr start2 ,main) (cdr main)) - (index2 start2 (1+ index2)) - (terminus (- (the fixnum end2) - (the fixnum (- (the fixnum end1) - (the fixnum start1))))) - (last-match ())) - ((> index2 terminus) last-match) - (declare (fixnum index2 terminus)) - (if (search-compare list main ,sub index2) - (if from-end - (setq last-match index2) - (return index2))))) - - -(defmacro vector-search (main sub) - `(do ((index2 start2 (1+ index2)) - (terminus (- (the fixnum end2) - (the fixnum (- (the fixnum end1) - (the fixnum start1))))) - (last-match ())) - ((> index2 terminus) last-match) - (declare (fixnum index2 terminus)) - (if (search-compare vector ,main ,sub index2) - (if from-end - (setq last-match index2) - (return index2))))) - -) - - -(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not - (start1 0) end1 (start2 0) end2 key) - "A search is conducted using EQL for the first subsequence of sequence2 - which element-wise matches sequence1. If there is such a subsequence in - sequence2, the index of the its leftmost element is returned; - otherwise () is returned." - (declare (fixnum start1 start2)) - (let ((end1 (or end1 (length sequence1))) - (end2 (or end2 (length sequence2)))) - (seq-dispatch sequence2 - (list-search sequence2 sequence1) - (vector-search sequence2 sequence1)))) diff --git a/code/setf-funs.lisp b/code/setf-funs.lisp deleted file mode 100644 index dae863f225fa9de44d8f51dc5dd6de90c900b4e7..0000000000000000000000000000000000000000 --- a/code/setf-funs.lisp +++ /dev/null @@ -1,64 +0,0 @@ -;;; -*- Package: Kernel -*- -;;; -;;; ********************************************************************** -;;; 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/code/setf-funs.lisp,v 1.2 1991/05/08 15:57:49 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Stuff to automatically generate SETF functions for all the standard -;;; functions that are currently implemented with setf macros. -;;; -(in-package "KERNEL") - -(eval-when (compile eval) - -(defun compute-one-setter (name type) - (let* ((args (second type)) - (res (type-specifier - (single-value-type - (values-specifier-type (third type))))) - (arglist (loop repeat (1+ (length args)) collect (gensym)))) - (cond - ((null (intersection args lambda-list-keywords)) - `(defun (setf ,name) ,arglist - (declare ,@(mapcar #'(lambda (arg type) - `(type ,type ,arg)) - arglist - (cons res args))) - (setf (,name ,@(rest arglist)) ,(first arglist)))) - ((ignore-errors (get-setf-method `(apply #',name args))) - `(defun (setf ,name) (newval &rest args) - (setf (apply #',name args) newval))) - (t - (warn "Hairy setf expander for function ~S." name) - nil)))) - - -(defmacro define-setters (packages &rest ignore) - (collect ((res)) - (dolist (pkg packages) - (do-external-symbols (sym pkg) - (when (and (fboundp sym) - (eq (info function kind sym) :function) - (or (info setf inverse sym) - (info setf expander sym)) - (not (member sym ignore))) - (let ((type (type-specifier (info function type sym)))) - (assert (consp type)) - (res `(declaim (inline (setf ,sym)))) - (res (compute-one-setter sym type)))))) - `(progn ,@(res)))) - -); eval-when (compile eval) - -(define-setters ("LISP") - ;; Have explicit definitions... - aref bit sbit - ;; Semantically silly... - getf apply ldb mask-field logbitp) diff --git a/code/signal.lisp b/code/signal.lisp deleted file mode 100644 index 1ba22cb09c0a12e9c0d9ba413493ef682e252c62..0000000000000000000000000000000000000000 --- a/code/signal.lisp +++ /dev/null @@ -1,359 +0,0 @@ -;;; -*- Package: UNIX -*- -;;; -;;; ********************************************************************** -;;; 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/code/signal.lisp,v 1.17 1992/07/09 19:27:05 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.17 1992/07/09 19:27:05 wlott Exp $ -;;; -;;; Code for handling UNIX signals. -;;; -;;; Written by William Lott. -;;; - -(in-package "UNIX") -(use-package "KERNEL") -(export '(unix-signal-name unix-signal-description unix-signal-number - sigmask unix-sigblock unix-sigpause unix-sigsetmask unix-kill - unix-killpg)) - -(in-package "KERNEL") -(export '(signal-init)) - -(in-package "SYSTEM") -(export '(without-interrupts with-interrupts with-enabled-interrupts - enable-interrupt ignore-interrupt default-interrupt)) - -(in-package "UNIX") - -;;; These should probably be somewhere, but I don't know where. -;;; -(defconstant sig_dfl 0) -(defconstant sig_ign 1) - -(proclaim '(special lisp::lisp-command-line-list)) - - - -;;;; Utilities for dealing with signal names and numbers. - -(defstruct (unix-signal - (:constructor make-unix-signal (%name %number %description))) - %name ; Signal keyword - (%number nil :type integer) ; UNIX signal number - (%description nil :type string)) ; Documentation - -(defvar *unix-signals* nil - "A list of unix signal structures.") - -(eval-when (compile eval) -(defmacro def-unix-signal (name number description) - (let ((symbol (intern (symbol-name name)))) - `(progn - (push (make-unix-signal ,name ,number ,description) *unix-signals*) - ;; - ;; This is to make the new signal lookup stuff compatible with - ;; old code which expects the symbol with the same print name as - ;; our keywords to be a constant with a value equal to the signal - ;; number. - (defconstant ,symbol ,number ,description) - (export ',symbol)))) -) ;eval-when - -(defun unix-signal-or-lose (arg) - (let ((signal (find arg *unix-signals* - :key (etypecase arg - (symbol #'unix-signal-%name) - (number #'unix-signal-%number))))) - (unless signal - (error "~S is not a valid signal name or number." arg)) - signal)) - -(defun unix-signal-name (signal) - "Return the name of the signal as a string. Signal should be a valid - signal number or a keyword of the standard UNIX signal name." - (symbol-name (unix-signal-%name (unix-signal-or-lose signal)))) - -(defun unix-signal-description (signal) - "Return a string describing signal. Signal should be a valid signal - number or a keyword of the standard UNIX signal name." - (unix-signal-%description (unix-signal-or-lose signal))) - -(defun unix-signal-number (signal) - "Return the number of the given signal. Signal should be a valid - signal number or a keyword of the standard UNIX signal name." - (unix-signal-%number (unix-signal-or-lose signal))) - -;;; Known signals -;;; -(def-unix-signal :CHECK 0 "Check") -(def-unix-signal :SIGHUP 1 "Hangup") -(def-unix-signal :SIGINT 2 "Interrupt") -(def-unix-signal :SIGQUIT 3 "Quit") -(def-unix-signal :SIGILL 4 "Illegal instruction") -(def-unix-signal :SIGTRAP 5 "Trace trap") -(def-unix-signal :SIGIOT 6 "Iot instruction") -(def-unix-signal :SIGEMT 7 "Emt instruction") -(def-unix-signal :SIGFPE 8 "Floating point exception") -(def-unix-signal :SIGKILL 9 "Kill") -(def-unix-signal :SIGBUS 10 "Bus error") -(def-unix-signal :SIGSEGV 11 "Segmentation violation") -(def-unix-signal :SIGSYS 12 "Bad argument to system call") -(def-unix-signal :SIGPIPE 13 "Write on a pipe with no one to read it") -(def-unix-signal :SIGALRM 14 "Alarm clock") -(def-unix-signal :SIGTERM 15 "Software termination signal") -(def-unix-signal :SIGURG 16 "Urgent condition present on socket") -(def-unix-signal :SIGSTOP 17 "Stop") -(def-unix-signal :SIGTSTP 18 "Stop signal generated from keyboard") -(def-unix-signal :SIGCONT 19 "Continue after stop") -(def-unix-signal :SIGCHLD 20 "Child status has changed") -(def-unix-signal :SIGTTIN 21 "Background read attempted from control terminal") -(def-unix-signal :SIGTTOU 22 "Background write attempted to control terminal") -(def-unix-signal :SIGIO 23 "I/O is possible on a descriptor") -(def-unix-signal :SIGXCPU 24 "Cpu time limit exceeded") -(def-unix-signal :SIGXFSZ 25 "File size limit exceeded") -(def-unix-signal :SIGVTALRM 26 "Virtual time alarm") -(def-unix-signal :SIGPROF 27 "Profiling timer alarm") -(def-unix-signal :SIGWINCH 28 "Window size change") -(def-unix-signal :SIGUSR1 30 "User defined signal 1") -(def-unix-signal :SIGUSR2 31 "User defined signal 2") -;;; -;;; These are Mach Specific -(def-unix-signal :SIGEMSG 30 "Mach Emergency message") -(def-unix-signal :SIGMSG 31 "Mach message") - -;;; SIGMASK -- Public -;;; -(defmacro sigmask (&rest signals) - "Returns a mask given a set of signals." - (apply #'logior - (mapcar #'(lambda (signal) - (ash 1 (1- (unix-signal-number signal)))) - signals))) - - -;;;; System calls that deal with signals. - -(proclaim '(inline real-unix-kill)) - -(alien:def-alien-routine ("kill" real-unix-kill) c-call:int - (pid c-call:int) - (signal c-call:int)) - -(defun unix-kill (pid signal) - "Unix-kill sends the signal signal to the process with process - id pid. Signal should be a valid signal number or a keyword of the - standard UNIX signal name." - (real-unix-kill pid (unix-signal-number signal))) - - -(proclaim '(inline real-unix-killpg)) - -(alien:def-alien-routine ("killpg" real-unix-killpg) c-call:int - (pgrp c-call:int) - (signal c-call:int)) - -(defun unix-killpg (pgrp signal) - "Unix-killpg sends the signal signal to the all the process in process - group PGRP. Signal should be a valid signal number or a keyword of - the standard UNIX signal name." - (real-unix-killpg pgrp (unix-signal-number signal))) - - -(alien:def-alien-routine ("sigblock" unix-sigblock) c-call:unsigned-long - "Unix-sigblock cause the signals specified in mask to be - added to the set of signals currently being blocked from - delivery. The macro sigmask is provided to create masks." - (mask c-call:unsigned-long)) - - -(alien:def-alien-routine ("sigpause" unix-sigpause) c-call:void - "Unix-sigpause sets the set of masked signals to its argument - and then waits for a signal to arrive, restoring the previous - mask upon its return." - (mask c-call:unsigned-long)) - - -(alien:def-alien-routine ("sigsetmask" unix-sigsetmask) c-call:unsigned-long - "Unix-sigsetmask sets the current set of masked signals (those - begin blocked from delivery) to the argument. The macro sigmask - can be used to create the mask. The previous value of the signal - mask is returned." - (mask c-call:unsigned-long)) - - - -;;;; C routines that actually do all the work of establishing signal handlers. - -(alien:def-alien-routine ("install_handler" install-handler) - c-call:unsigned-long - (signal c-call:int) - (handler c-call:unsigned-long)) - - - -;;;; Interface to enabling and disabling signal handlers. - -(defun enable-interrupt (signal handler) - (declare (type (or function (member :default :ignore)) handler)) - (without-gcing - (let ((result (install-handler (unix-signal-number signal) - (case handler - (:default sig_dfl) - (:ignore sig_ign) - (t - (kernel:get-lisp-obj-address handler)))))) - (cond ((= result sig_dfl) :default) - ((= result sig_ign) :ignore) - (t (the function (kernel:make-lisp-obj result))))))) - -(defun default-interrupt (signal) - (enable-interrupt signal :default)) - -(defun ignore-interrupt (signal) - (enable-interrupt signal :ignore)) - - - -;;;; Default LISP signal handlers. - -;;; Most of these just call ERROR to report the presence of the signal. - -(defmacro define-signal-handler (name what &optional (function 'error)) - `(defun ,name (signal code scp) - (declare (ignore signal code) - (type system-area-pointer scp)) - (system:without-hemlock - (,function ,(concatenate 'simple-string what " at #x~x.") - (with-alien ((scp (* sigcontext) scp)) - (sap-int (vm:sigcontext-program-counter scp))))))) - -(define-signal-handler sigint-handler "Interrupted" break) -(define-signal-handler sigill-handler "Illegal Instruction") -(define-signal-handler sigtrap-handler "Breakpoint/Trap") -(define-signal-handler sigiot-handler "SIGIOT") -(define-signal-handler sigemt-handler "SIGEMT") -(define-signal-handler sigbus-handler "Bus Error") -(define-signal-handler sigsegv-handler "Segmentation Violation") -(define-signal-handler sigsys-handler "Bad Argument to a System Call") -(define-signal-handler sigpipe-handler "SIGPIPE") -(define-signal-handler sigalrm-handler "SIGALRM") - -(defun sigquit-handler (signal code scp) - (declare (ignore signal code scp)) - (throw 'lisp::top-level-catcher nil)) - -(defun signal-init () - "Enable all the default signals that Lisp knows how to deal with." - (unless (member "-monitor" lisp::lisp-command-line-list :test #'string=) - (enable-interrupt :sigint #'sigint-handler)) - (enable-interrupt :sigquit #'sigquit-handler) - (enable-interrupt :sigill #'sigill-handler) - (enable-interrupt :sigtrap #'sigtrap-handler) - (enable-interrupt :sigiot #'sigiot-handler) - (enable-interrupt :sigemt #'sigemt-handler) - (enable-interrupt :sigfpe #'vm:sigfpe-handler) - (enable-interrupt :sigbus #'sigbus-handler) - (enable-interrupt :sigsegv #'sigsegv-handler) - (enable-interrupt :sigsys #'sigsys-handler) - (enable-interrupt :sigpipe #'sigpipe-handler) - (enable-interrupt :sigalrm #'sigalrm-handler) - nil) - - - -;;;; Macros for dynamically enabling and disabling signal handling. - -;;; Notes on how the without-interrupts/with-interrupts stuff works. -;;; -;;; Before invoking the supplied handler for any of the signals that can be -;;; blocked, the C interrupt support code checks to see if *interrupts-enabled* -;;; has been bound to NIL. If so, it saves the signal number and the value of -;;; the signal mask (from the sigcontext), sets the signal mask to block all -;;; blockable signals, sets *interrupt-pending* and returns without handling -;;; the signal. -;;; -;;; When we drop out the without interrupts, we check to see if -;;; *interrupt-pending* has been set. If so, we call do-pending-interrupt, -;;; which generates a SIGTRAP. The C code invokes the handler for the saved -;;; signal instead of the SIGTRAP after replacing the signal mask in the -;;; sigcontext with the saved value. When that hander returns, the original -;;; signal mask is installed, allowing any other pending signals to be handled. -;;; -;;; This means that the cost of without-interrupts is just a special binding in -;;; the case when no signals are delivered (the normal case). It's only when -;;; a signal is actually delivered that we use any system calls, and by then -;;; the cost of the extra system calls are lost in the noise when compared -;;; with the cost of delivering the signal in the first place. -;;; - -(defvar *interrupts-enabled* t) -(defvar *interrupt-pending* nil) - -;;; DO-PENDING-INTERRUPT -- internal -;;; -;;; Magically converted by the compiler into a break instruction. -;;; -(defun do-pending-interrupt () - (do-pending-interrupt)) - -;;; WITHOUT-INTERRUPTS -- puiblic -;;; -(defmacro without-interrupts (&body body) - "Execute BODY in a context impervious to interrupts." - (let ((name (gensym))) - `(flet ((,name () ,@body)) - (if *interrupts-enabled* - (unwind-protect - (let ((*interrupts-enabled* nil)) - (,name)) - (when *interrupt-pending* - (do-pending-interrupt))) - (,name))))) - -;;; WITH-INTERRUPTS -- puiblic -;;; -(defmacro with-interrupts (&body body) - "Allow interrupts while executing BODY. As interrupts are normally allowed, - this is only useful inside a WITHOUT-INTERRUPTS." - (let ((name (gensym))) - `(flet ((,name () ,@body)) - (if *interrupts-enabled* - (,name) - (let ((*interrupts-enabled* t)) - (when *interrupt-pending* - (do-pending-interrupt)) - (,name)))))) - - -;;;; WITH-ENABLED-INTERRUPTS - -(defmacro with-enabled-interrupts (interrupt-list &body body) - "With-enabled-interrupts ({(interrupt function)}*) {form}* - Establish function as a handler for the Unix signal interrupt which - should be a number between 1 and 31 inclusive." - (let ((il (gensym)) - (it (gensym))) - `(let ((,il NIL)) - (unwind-protect - (progn - ,@(do* ((item interrupt-list (cdr item)) - (intr (caar item) (caar item)) - (ifcn (cadar item) (cadar item)) - (forms NIL)) - ((null item) (nreverse forms)) - (when (symbolp intr) - (setq intr (symbol-value intr))) - (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il) - forms)) - ,@body) - (dolist (,it (nreverse ,il)) - (enable-interrupt (car ,it) (cadr ,it))))))) - diff --git a/code/sort.lisp b/code/sort.lisp deleted file mode 100644 index 10c9e55bf8ff1777e9db78bb486b7b25c3439622..0000000000000000000000000000000000000000 --- a/code/sort.lisp +++ /dev/null @@ -1,446 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/sort.lisp,v 1.2 1991/02/08 13:35:46 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Sort functions for Spice Lisp -;;; these functions are part of the standard spice lisp environment. -;;; -;;; Written by Jim Large -;;; Hacked on and maintained by Skef Wholey -;;; Rewritten by Bill Chiles -;;; -;;; ******************************************************************* - -(in-package 'lisp) - -(export '(sort stable-sort merge)) - - - -(defun sort (sequence predicate &key key) - "Destructively sorts sequence. Predicate should returns non-Nil if - Arg1 is to precede Arg2." - (typecase sequence - (simple-vector - (if (> (the fixnum (length (the simple-vector sequence))) 0) - (sort-simple-vector sequence predicate key) - sequence)) - (list - (sort-list sequence predicate key)) - (vector - (if (> (the fixnum (length sequence)) 0) - (sort-vector sequence predicate key) - sequence)) - (t - (error "~S is not a sequence." sequence)))) - - - -;;; Sorting Vectors - -;;; Sorting is done with a heap sort. - -(eval-when (compile eval) - -;;; HEAPIFY, assuming both sons of root are heaps, percolates the root element -;;; through the sons to form a heap at root. Root and max are zero based -;;; coordinates, but the heap algorithm only works on arrays indexed from 1 -;;; through N (not 0 through N-1); This is because a root at I has sons at 2*I -;;; and 2*I+1 which does not work for a root at 0. Because of this, boundaries, -;;; roots, and termination are computed using 1..N indexes. - -(defmacro heapify (seq vector-ref root max pred key) - (let ((heap-root (gensym)) (heap-max (gensym)) (root-ele (gensym)) - (root-key (gensym)) (heap-max/2 (gensym)) (heap-l-son (gensym)) - (one-son (gensym)) (one-son-ele (gensym)) (one-son-key (gensym)) - (r-son-ele (gensym)) (r-son-key (gensym)) (var-root (gensym))) - `(let* ((,var-root ,root) ; necessary to not clobber calling root var. - (,heap-root (1+ ,root)) - (,heap-max (1+ ,max)) - (,root-ele (,vector-ref ,seq ,root)) - (,root-key (apply-key ,key ,root-ele)) - (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2) - (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2)) - (loop - (if (> ,heap-root ,heap-max/2) (return)) - (let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root) - ;; l-son index in seq (0..N-1) is one less than heap computation - (,one-son (1- ,heap-l-son)) - (,one-son-ele (,vector-ref ,seq ,one-son)) - (,one-son-key (apply-key ,key ,one-son-ele))) - (declare (fixnum ,heap-l-son ,one-son)) - (if (< ,heap-l-son ,heap-max) - ;; there is a right son. - (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son)) - (,r-son-key (apply-key ,key ,r-son-ele))) - ;; choose the greater of the two sons. - (when (funcall ,pred ,one-son-key ,r-son-key) - (setf ,one-son ,heap-l-son) - (setf ,one-son-ele ,r-son-ele) - (setf ,one-son-key ,r-son-key)))) - ;; if greater son is less than root, then we've formed a heap again. - (if (funcall ,pred ,one-son-key ,root-key) (return)) - ;; else put greater son at root and make greater son node be the root. - (setf (,vector-ref ,seq ,var-root) ,one-son-ele) - (setf ,heap-root (1+ ,one-son)) ; one plus to be in heap coordinates. - (setf ,var-root ,one-son))) ; actual index into vector for root ele. - ;; now really put percolated value into heap at the appropriate root node. - (setf (,vector-ref ,seq ,var-root) ,root-ele)))) - - -;;; BUILD-HEAP rearranges seq elements into a heap to start heap sorting. -(defmacro build-heap (seq type len-1 pred key) - (let ((i (gensym))) - `(do ((,i (floor ,len-1 2) (1- ,i))) - ((minusp ,i) ,seq) - (declare (fixnum ,i)) - (heapify ,seq ,type ,i ,len-1 ,pred ,key)))) - -) ; eval-when - - -;;; Make simple-vector and miscellaneous vector sorting functions. -(macrolet ((frob-rob (fun-name vector-ref) - `(defun ,fun-name (seq pred key) - (let ((len-1 (1- (length (the vector seq))))) - (declare (fixnum len-1)) - (build-heap seq ,vector-ref len-1 pred key) - (do* ((i len-1 i-1) - (i-1 (1- i) (1- i-1))) - ((zerop i) seq) - (declare (fixnum i i-1)) - (rotatef (,vector-ref seq 0) (,vector-ref seq i)) - (heapify seq ,vector-ref 0 i-1 pred key)))))) - - (frob-rob sort-vector aref) - - (frob-rob sort-simple-vector svref)) - - - -;;;; Stable Sorting - -(defun stable-sort (sequence predicate &key key) - "Destructively sorts sequence. Predicate should returns non-Nil if - Arg1 is to precede Arg2." - (typecase sequence - (simple-vector - (stable-sort-simple-vector sequence predicate key)) - (list - (sort-list sequence predicate key)) - (vector - (stable-sort-vector sequence predicate key)) - (t - (error "~S is not a sequence." sequence)))) - - -;;; Stable Sorting Lists - - -;;; SORT-LIST uses a bottom up merge sort. First a pass is made over -;;; the list grabbing one element at a time and merging it with the next one -;;; form pairs of sorted elements. Then n is doubled, and elements are taken -;;; in runs of two, merging one run with the next to form quadruples of sorted -;;; elements. This continues until n is large enough that the inner loop only -;;; runs for one iteration; that is, there are only two runs that can be merged, -;;; the first run starting at the beginning of the list, and the second being -;;; the remaining elements. - -(defun sort-list (list pred key) - (let ((head (cons :header list)) ; head holds on to everything - (n 1) ; bottom-up size of lists to be merged - unsorted ; unsorted is the remaining list to be - ; broken into n size lists and merged - list-1 ; list-1 is one length n list to be merged - last) ; last points to the last visited cell - (declare (fixnum n)) - (loop - ;; start collecting runs of n at the first element - (setf unsorted (cdr head)) - ;; tack on the first merge of two n-runs to the head holder - (setf last head) - (let ((n-1 (1- n))) - (declare (fixnum n-1)) - (loop - (setf list-1 unsorted) - (let ((temp (nthcdr n-1 list-1)) - list-2) - (cond (temp - ;; there are enough elements for a second run - (setf list-2 (cdr temp)) - (setf (cdr temp) nil) - (setf temp (nthcdr n-1 list-2)) - (cond (temp - (setf unsorted (cdr temp)) - (setf (cdr temp) nil)) - ;; the second run goes off the end of the list - (t (setf unsorted nil))) - (multiple-value-bind (merged-head merged-last) - (merge-lists* list-1 list-2 pred key) - (setf (cdr last) merged-head) - (setf last merged-last)) - (if (null unsorted) (return))) - ;; if there is only one run, then tack it on to the end - (t (setf (cdr last) list-1) - (return))))) - (setf n (ash n 1)) ; (+ n n) - ;; If the inner loop only executed once, then there were only enough - ;; elements for two runs given n, so all the elements have been merged - ;; into one list. This may waste one outer iteration to realize. - (if (eq list-1 (cdr head)) - (return list-1)))))) - - -;;; APPLY-PRED saves us a function call sometimes. -(eval-when (compile eval) - (defmacro apply-pred (one two pred key) - `(if ,key - (funcall ,pred (funcall ,key ,one) - (funcall ,key ,two)) - (funcall ,pred ,one ,two))) -) ; eval-when - -(defvar *merge-lists-header* (list :header)) - -;;; MERGE-LISTS* originally written by Jim Large. -;;; modified to return a pointer to the end of the result -;;; and to not cons header each time its called. -;;; It destructively merges list-1 with list-2. In the resulting -;;; list, elements of list-2 are guaranteed to come after equal elements -;;; of list-1. -(defun merge-lists* (list-1 list-2 pred key) - (do* ((result *merge-lists-header*) - (P result)) ; P points to last cell of result - ((or (null list-1) (null list-2)) ; done when either list used up - (if (null list-1) ; in which case, append the - (rplacd p list-2) ; other list - (rplacd p list-1)) - (do ((drag p lead) - (lead (cdr p) (cdr lead))) - ((null lead) - (values (prog1 (cdr result) ; return the result sans header - (rplacd result nil)) ; (free memory, be careful) - drag)))) ; and return pointer to last element - (cond ((apply-pred (car list-2) (car list-1) pred key) - (rplacd p list-2) ; append the lesser list to last cell of - (setq p (cdr p)) ; result. Note: test must bo done for - (pop list-2)) ; list-2 < list-1 so merge will be - (T (rplacd p list-1) ; stable for list-1 - (setq p (cdr p)) - (pop list-1))))) - - - -;;; Stable Sort Vectors - -;;; Stable sorting vectors is done with the same algorithm used for lists, -;;; using a temporary vector to merge back and forth between it and the -;;; given vector to sort. - - -(eval-when (compile eval) - -;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences, -;;; start-1 (inclusive) ... end-1 (exclusive) and -;;; end-1 (inclusive) ... end-2 (exclusive), -;;; and merges them into a target vector starting at index start-1. - -(defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2 - pred key source-ref target-ref) - (let ((i (gensym)) - (j (gensym)) - (target-i (gensym))) - `(let ((,i ,start-1) - (,j ,end-1) ; start-2 - (,target-i ,start-1)) - (declare (fixnum ,i ,j ,target-i)) - (loop - (cond ((= ,i ,end-1) - (loop (if (= ,j ,end-2) (return)) - (setf (,target-ref ,target ,target-i) - (,source-ref ,source ,j)) - (incf ,target-i) - (incf ,j)) - (return)) - ((= ,j ,end-2) - (loop (if (= ,i ,end-1) (return)) - (setf (,target-ref ,target ,target-i) - (,source-ref ,source ,i)) - (incf ,target-i) - (incf ,i)) - (return)) - ((apply-pred (,source-ref ,source ,j) - (,source-ref ,source ,i) - ,pred ,key) - (setf (,target-ref ,target ,target-i) - (,source-ref ,source ,j)) - (incf ,j)) - (t (setf (,target-ref ,target ,target-i) - (,source-ref ,source ,i)) - (incf ,i))) - (incf ,target-i))))) - - -;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but -;;; it uses a temporary vector. Direction determines whether we are merging -;;; into the temporary (T) or back into the given vector (NIL). - -(defmacro vector-merge-sort (vector pred key vector-ref) - (let ((vector-len (gensym)) (n (gensym)) - (direction (gensym)) (unsorted (gensym)) - (start-1 (gensym)) (end-1 (gensym)) - (end-2 (gensym)) (temp-len (gensym)) - (i (gensym))) - `(let ((,vector-len (length (the vector ,vector))) - (,n 1) ; bottom-up size of contiguous runs to be merged - (,direction t) ; t vector --> temp nil temp --> vector - (,temp-len (length (the simple-vector *merge-sort-temp-vector*))) - (,unsorted 0) ; unsorted..vector-len are the elements that need - ; to be merged for a given n - (,start-1 0)) ; one n-len subsequence to be merged with the next - (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1)) - (if (> ,vector-len ,temp-len) - (setf *merge-sort-temp-vector* - (make-array (max ,vector-len (+ ,temp-len ,temp-len))))) - (loop - ;; for each n, we start taking n-runs from the start of the vector - (setf ,unsorted 0) - (loop - (setf ,start-1 ,unsorted) - (let ((,end-1 (+ ,start-1 ,n))) - (declare (fixnum ,end-1)) - (cond ((< ,end-1 ,vector-len) - ;; there are enough elements for a second run - (let ((,end-2 (+ ,end-1 ,n))) - (declare (fixnum ,end-2)) - (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len)) - (setf ,unsorted ,end-2) - (if ,direction - (stable-sort-merge-vectors* - ,vector *merge-sort-temp-vector* - ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref) - (stable-sort-merge-vectors* - *merge-sort-temp-vector* ,vector - ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref)) - (if (= ,unsorted ,vector-len) (return)))) - ;; if there is only one run, copy those elements to the end - (t (if ,direction - (do ((,i ,start-1 (1+ ,i))) - ((= ,i ,vector-len)) - (declare (fixnum ,i)) - (setf (svref *merge-sort-temp-vector* ,i) - (,vector-ref ,vector ,i))) - (do ((,i ,start-1 (1+ ,i))) - ((= ,i ,vector-len)) - (declare (fixnum ,i)) - (setf (,vector-ref ,vector ,i) - (svref *merge-sort-temp-vector* ,i)))) - (return))))) - ;; If the inner loop only executed once, then there were only enough - ;; elements for two subsequences given n, so all the elements have - ;; been merged into one list. Start-1 will have remained 0 upon exit. - (when (zerop ,start-1) - (if ,direction - ;; if we just merged into the temporary, copy it all back - ;; to the given vector. - (dotimes (,i ,vector-len) - (setf (,vector-ref ,vector ,i) - (svref *merge-sort-temp-vector* ,i)))) - (return ,vector)) - (setf ,n (ash ,n 1)) ; (* 2 n) - (setf ,direction (not ,direction)))))) - -) ; eval-when - - -;;; Temporary vector for stable sorting vectors. -(defvar *merge-sort-temp-vector* - (make-array 50)) - -(proclaim '(simple-vector *merge-sort-temp-vector*)) - -(defun stable-sort-simple-vector (vector pred key) - (declare (simple-vector vector)) - (vector-merge-sort vector pred key svref)) - -(defun stable-sort-vector (vector pred key) - (vector-merge-sort vector pred key aref)) - - - -;;;; Merge - -(eval-when (compile eval) - -;;; MERGE-VECTORS returns a new vector which contains an interleaving -;;; of the elements of vector-1 and vector-2. Elements from vector-2 are -;;; chosen only if they are strictly less than elements of vector-1, -;;; (pred elt-2 elt-1), as specified in the manual. - -(defmacro merge-vectors (vector-1 length-1 vector-2 length-2 - result-vector pred key access) - (let ((result-i (gensym)) - (i (gensym)) - (j (gensym))) - `(let* ((,result-i 0) - (,i 0) - (,j 0)) - (declare (fixnum ,result-i ,i ,j)) - (loop - (cond ((= ,i ,length-1) - (loop (if (= ,j ,length-2) (return)) - (setf (,access ,result-vector ,result-i) - (,access ,vector-2 ,j)) - (incf ,result-i) - (incf ,j)) - (return ,result-vector)) - ((= ,j ,length-2) - (loop (if (= ,i ,length-1) (return)) - (setf (,access ,result-vector ,result-i) - (,access ,vector-1 ,i)) - (incf ,result-i) - (incf ,i)) - (return ,result-vector)) - ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i) - ,pred ,key) - (setf (,access ,result-vector ,result-i) - (,access ,vector-2 ,j)) - (incf ,j)) - (t (setf (,access ,result-vector ,result-i) - (,access ,vector-1 ,i)) - (incf ,i))) - (incf ,result-i))))) - -) ; eval-when - -(defun merge (result-type sequence1 sequence2 predicate &key key) - "The sequences Sequence1 and Sequence2 are destructively merged into - a sequence of type Result-Type using the Predicate to order the elements." - (if (eq result-type 'list) - (let ((result (merge-lists* (coerce sequence1 'list) - (coerce sequence2 'list) - predicate key))) - result) - (let* ((vector-1 (coerce sequence1 'vector)) - (vector-2 (coerce sequence2 'vector)) - (length-1 (length vector-1)) - (length-2 (length vector-2)) - (result (make-sequence-of-type result-type (+ length-1 length-2)))) - (declare (vector vector-1 vector-2) - (fixnum length-1 length-2)) - (if (and (simple-vector-p result) - (simple-vector-p vector-1) - (simple-vector-p vector-2)) - (merge-vectors vector-1 length-1 vector-2 length-2 - result predicate key svref) - (merge-vectors vector-1 length-1 vector-2 length-2 - result predicate key aref))))) diff --git a/code/sparc-machdef.lisp b/code/sparc-machdef.lisp deleted file mode 100644 index 5baee104cc36a704575350b1034e59440561a0c7..0000000000000000000000000000000000000000 --- a/code/sparc-machdef.lisp +++ /dev/null @@ -1,35 +0,0 @@ -;;; -*- Log: code.log; Package: Mach -*- -;;; -;;; ********************************************************************** -;;; 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/code/sparc-machdef.lisp,v 1.2 1991/02/08 13:35:49 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Record definitions needed for the interface to Mach. -;;; -(in-package "MACH") - -(export '(sigcontext-onstack sigcontext-mask sigcontext-sp sigcontext-pc - sigcontext-npc sigcontext-psr sigcontext-g1 sigcontext-o0 - sigcontext-regs sigcontext-fpregs sigcontext-y sigcontext-fsr - sigcontext *sigcontext indirect-*sigcontext)) - -(def-c-record sigcontext - (onstack unsigned-long) - (mask unsigned-long) - (sp system-area-pointer) - (pc system-area-pointer) - (npc system-area-pointer) - (psr unsigned-long) - (g1 unsigned-long) - (o0 unsigned-long) - (regs int-array) - (fpregs int-array) - (y unsigned-long) - (fsr unsigned-long)) diff --git a/code/sparc-vm.lisp b/code/sparc-vm.lisp deleted file mode 100644 index 8029e14858849178d534a30b8980e09eb66ff29e..0000000000000000000000000000000000000000 --- a/code/sparc-vm.lisp +++ /dev/null @@ -1,253 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/code/sparc-vm.lisp,v 1.15 1992/10/08 22:10:21 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the SPARC specific runtime stuff. -;;; -(in-package "SPARC") -(use-package "SYSTEM") -(use-package "UNIX") - -(export '(fixup-code-object internal-error-arguments - sigcontext-program-counter sigcontext-register - sigcontext-float-register sigcontext-floating-point-modes - extern-alien-name sanctify-for-execution)) - - -;;;; The sigcontext structure. - -(def-alien-type sigcontext-regs - (struct nil - (regs (array unsigned-long 32)) - (fpregs (array unsigned-long 32)) - (y unsigned-long) - (fsr unsigned-long))) - -(def-alien-type sigcontext - (struct nil - (sc-onstack unsigned-long) - (sc-mask unsigned-long) - (sc-sp system-area-pointer) - (sc-pc system-area-pointer) - (sc-npc system-area-pointer) - (sc-psr unsigned-long) - (sc-g1 (* sigcontext-regs)) - (sc-o0 unsigned-long))) - - -;;;; Add machine specific features to *features* - -(pushnew :SPARCstation *features*) -(pushnew :sparc *features*) -(pushnew :sun4 *features*) - - - -;;;; MACHINE-TYPE and MACHINE-VERSION - -(defun machine-type () - "Returns a string describing the type of the local machine." - "SPARCstation") - -(defun machine-version () - "Returns a string describing the version of the local machine." - "SPARCstation") - - - -;;; FIXUP-CODE-OBJECT -- Interface -;;; -(defun fixup-code-object (code offset fixup kind) - (declare (type index offset)) - (unless (zerop (rem offset vm:word-bytes)) - (error "Unaligned instruction? offset=#x~X." offset)) - (system:without-gcing - (let ((sap (truly-the system-area-pointer - (%primitive c::code-instructions code)))) - (ecase kind - (:call - (error "Can't deal with CALL fixups, yet.")) - (:sethi - (setf (ldb (byte 22 0) (sap-ref-32 sap offset)) - (ldb (byte 22 10) fixup))) - (:add - (setf (ldb (byte 10 0) (sap-ref-32 sap offset)) - (ldb (byte 10 0) fixup))))))) - - - -;;;; Internal-error-arguments. - -;;; INTERNAL-ERROR-ARGUMENTS -- interface. -;;; -;;; Given the sigcontext, extract the internal error arguments from the -;;; instruction stream. -;;; -(defun internal-error-arguments (scp) - (declare (type (alien (* sigcontext)) scp)) - (let* ((pc (with-alien ((scp (* sigcontext) scp)) - (slot scp 'sc-pc))) - (bad-inst (sap-ref-32 pc 0)) - (op (ldb (byte 2 30) bad-inst)) - (op2 (ldb (byte 3 22) bad-inst)) - (op3 (ldb (byte 6 19) bad-inst))) - (declare (type system-area-pointer pc)) - (cond ((and (= op #b00) (= op2 #b000)) - (args-for-unimp-inst scp)) - ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000)) - (args-for-tagged-add-inst scp bad-inst)) - ((and (= op #b10) (= op3 #b111010)) - (args-for-tcc-inst bad-inst)) - (t - (values #.(error-number-or-lose 'unknown-error) nil))))) - -(defun args-for-unimp-inst (scp) - (declare (type (alien (* sigcontext)) scp)) - (let* ((pc (with-alien ((scp (* sigcontext) scp)) - (slot scp 'sc-pc))) - (length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) - (declare (type system-area-pointer pc) - (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) - (copy-from-system-area pc (* sparc:byte-bits 5) - vector (* sparc:word-bits - sparc:vector-data-offset) - (* length sparc:byte-bits)) - (let* ((index 0) - (error-number (c::read-var-integer vector index))) - (collect ((sc-offsets)) - (loop - (when (>= index length) - (return)) - (sc-offsets (c::read-var-integer vector index))) - (values error-number (sc-offsets)))))) - -(defun args-for-tagged-add-inst (scp bad-inst) - (declare (type (alien (* sigcontext)) scp)) - (let* ((rs1 (ldb (byte 5 14) bad-inst)) - (op1 (di::make-lisp-obj (sigcontext-register scp rs1)))) - (if (fixnump op1) - (if (zerop (ldb (byte 1 13) bad-inst)) - (let* ((rs2 (ldb (byte 5 0) bad-inst)) - (op2 (di::make-lisp-obj (sigcontext-register scp rs2)))) - (if (fixnump op2) - (values #.(error-number-or-lose 'unknown-error) nil) - (values #.(error-number-or-lose 'object-not-fixnum-error) - (list (c::make-sc-offset - sparc:descriptor-reg-sc-number - rs2))))) - (values #.(error-number-or-lose 'unknown-error) nil)) - (values #.(error-number-or-lose 'object-not-fixnum-error) - (list (c::make-sc-offset sparc:descriptor-reg-sc-number - rs1)))))) - -(defun args-for-tcc-inst (bad-inst) - (let* ((trap-number (ldb (byte 8 0) bad-inst)) - (reg (ldb (byte 5 8) bad-inst))) - (values (case trap-number - (#.sparc:object-not-list-trap - #.(error-number-or-lose 'object-not-list-error)) - (#.sparc:object-not-structure-trap - #.(error-number-or-lose 'object-not-structure-error)) - (t - #.(error-number-or-lose 'unknown-error))) - (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg))))) - - -;;;; Sigcontext access functions. - -;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. -;;; -(defun sigcontext-program-counter (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (slot scp 'sc-pc))) - -;;; SIGCONTEXT-REGISTER -- Interface. -;;; -;;; An escape register saves the value of a register for a frame that someone -;;; interrupts. -;;; -(defun sigcontext-register (scp index) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (deref (slot (slot scp 'sc-g1) 'regs) index))) - -(defun %set-sigcontext-register (scp index new) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (setf (deref (slot (slot scp 'sc-g1) 'regs) index) new) - new)) - -(defsetf sigcontext-register %set-sigcontext-register) - - -;;; SIGCONTEXT-FLOAT-REGISTER -- Interface -;;; -;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. -;;; Format is the type of float to return. -;;; -(defun sigcontext-float-register (scp index format) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs)))) - (ecase format - (single-float (system:sap-ref-single sap (* index vm:word-bytes))) - (double-float (system:sap-ref-double sap (* index vm:word-bytes))))))) -;;; -(defun %set-sigcontext-float-register (scp index format new-value) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs)))) - (ecase format - (single-float - (setf (sap-ref-single sap (* index vm:word-bytes)) new-value)) - (double-float - (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) -;;; -(defsetf sigcontext-float-register %set-sigcontext-float-register) - - -;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface -;;; -;;; Given a sigcontext pointer, return the floating point modes word in the -;;; same format as returned by FLOATING-POINT-MODES. -;;; -(defun sigcontext-floating-point-modes (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (slot (slot scp 'sc-g1) 'fsr))) - - - -;;; EXTERN-ALIEN-NAME -- interface. -;;; -;;; The loader uses this to convert alien names to the form they occure in -;;; the symbol table (for example, prepending an underscore). On the SPARC, -;;; we prepend an underscore. -;;; -(defun extern-alien-name (name) - (declare (type simple-base-string name)) - (concatenate 'string "_" name)) - - - -;;; SANCTIFY-FOR-EXECUTION -- Interface. -;;; -;;; Do whatever is necessary to make the given code component executable. -;;; On the sparc, we don't need to do anything, because the i and d caches -;;; are unified. -;;; -(defun sanctify-for-execution (component) - (declare (ignore component)) - nil) diff --git a/code/stream.lisp b/code/stream.lisp deleted file mode 100644 index 5f7e4c506dd23926f995bb059374d25cff332b7e..0000000000000000000000000000000000000000 --- a/code/stream.lisp +++ /dev/null @@ -1,1380 +0,0 @@ -;;; -*- Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/stream.lisp,v 1.15 1992/12/11 15:56:52 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Stream functions for Spice Lisp. -;;; Written by Skef Wholey and Rob MacLachlan. -;;; -;;; This file contains the OS-independent stream functions. -;;; -(in-package "LISP") - -(export '(broadcast-stream make-broadcast-stream broadcast-stream-streams - synonym-stream make-synonym-stream synonym-stream-symbol - concatenated-stream make-concatenated-stream - concatenated-stream-streams - two-way-stream make-two-way-stream two-way-stream-input-stream - two-way-stream-output-stream - echo-stream make-echo-stream echo-stream-input-stream - echo-stream-output-stream - make-string-input-stream make-string-output-stream - get-output-stream-string stream-element-type input-stream-p - output-stream-p open-stream-p interactive-stream-p - close read-line read-char - unread-char peek-char listen read-char-no-hang clear-input read-byte - write-char write-string write-line terpri fresh-line - finish-output force-output clear-output write-byte - stream streamp string-stream - *standard-input* *standard-output* - *error-output* *query-io* *debug-io* *terminal-io* *trace-output*)) - -(in-package 'system) -(export '(make-indenting-stream read-n-bytes)) -(in-package 'lisp) - -(deftype string-stream () - '(or string-input-stream string-output-stream - fill-pointer-output-stream)) - -;;;; Standard streams: -;;; -;;; The initialization of these streams is performed by Stream-Init, -;;; which lives in the file of machine-specific stream functions. -;;; -(defvar *terminal-io* () "Terminal I/O stream.") -(defvar *standard-input* () "Default input stream.") -(defvar *standard-output* () "Default output stream.") -(defvar *error-output* () "Error output stream.") -(defvar *query-io* () "Query I/O stream.") -(defvar *trace-output* () "Trace output stream.") -(defvar *debug-io* () "Interactive debugging stream.") - -(defun ill-in (stream &rest ignore) - (declare (ignore ignore)) - (error "~S is not a character input stream." stream)) -(defun ill-out (stream &rest ignore) - (declare (ignore ignore)) - (error "~S is not a character output stream." stream)) -(defun ill-bin (stream &rest ignore) - (declare (ignore ignore)) - (error "~S is not a binary input stream." stream)) -(defun ill-bout (stream &rest ignore) - (declare (ignore ignore)) - (error "~S is not a binary output stream." stream)) -(defun closed-flame (stream &rest ignore) - (declare (ignore ignore)) - (error "~S is closed." stream)) -(defun do-nothing (&rest ignore) - (declare (ignore ignore))) - -(defun %print-stream (structure stream d) - (declare (ignore d structure)) - (write-string "#<Bare Stream>" stream)) - -;;; HOW THE STREAM STRUCTURE IS USED: -;;; -;;; Many of the slots of the stream structure contain functions -;;; which are called to perform some operation on the stream. Closed -;;; streams have #'Closed-Flame in all of their function slots. If -;;; one side of an I/O or echo stream is closed, the whole stream is -;;; considered closed. The functions in the operation slots take -;;; arguments as follows: -;;; -;;; In: Stream, Eof-Errorp, Eof-Value -;;; Bin: Stream, Eof-Errorp, Eof-Value -;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp -;;; Out: Stream, Character -;;; Bout: Stream, Integer -;;; Sout: Stream, String, Start, End -;;; Misc: Stream, Operation, &Optional Arg1, Arg2 -;;; -;;; In order to save space, some of the less common stream operations -;;; are handled by just one function, the Misc method. This function -;;; is passed a keyword which indicates the operation to perform. -;;; The following keywords are used: -;;; :read-line - Do a read-line. -;;; :listen - Return the following values: -;;; t if any input waiting. -;;; :eof if at eof. -;;; nil if no input is available and not at eof. -;;; :unread - Unread the character Arg. -;;; :close - Do any stream specific stuff to close the stream. -;;; The methods are set to closed-flame by the close -;;; function, so that need not be done by this -;;; function. -;;; :clear-input - Clear any unread input -;;; :finish-output, -;;; :force-output - Cause output to happen -;;; :clear-output - Clear any undone output -;;; :element-type - Return the type of element the stream deals with. -;;; :line-length - Return the length of a line of output. -;;; :charpos - Return current output position on the line. -;;; :file-length - Return the file length of a file stream. -;;; :file-position - Return or change the current position of a file stream. -;;; :file-name - Return the name of an associated file. -;;; :interactive-p - Is this an interactive device? -;;; -;;; In order to do almost anything useful, it is necessary to -;;; define a new type of structure that includes stream, so that the -;;; stream can have some state information. -;;; -;;; THE STREAM IN-BUFFER: -;;; -;;; The In-Buffer in the stream holds characters or bytes that -;;; are ready to be read by some input function. If there is any -;;; stuff in the In-Buffer, then the reading function can use it -;;; without calling any stream method. Any stream may put stuff in -;;; the In-Buffer, and may also assume that any input in the In-Buffer -;;; has been consumed before any in-method is called. If a text -;;; stream has in In-Buffer, then the first character should not be -;;; used to buffer normal input so that it is free for unreading into. -;;; -;;; The In-Buffer slot is a vector In-Buffer-Length long. The -;;; In-Index is the index in the In-Buffer of the first available -;;; object. The available objects are thus between In-Index and the -;;; length of the In-Buffer. -;;; -;;; When this buffer is only accessed by the normal stream -;;; functions, the number of function calls is halved, thus -;;; potentially doubling the speed of simple operations. If the -;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all -;;; function call overhead is removed, vastly speeding up these -;;; important operations. -;;; -;;; If a stream does not have an In-Buffer, then the In-Buffer slot -;;; must be nil, and the In-Index must be In-Buffer-Length. These are -;;; the default values for the slots. - -;;; Stream manipulation functions. - -(defun input-stream-p (stream) - "Returns non-nil if the given Stream can perform input operations." - (and (streamp stream) - (not (eq (stream-in stream) #'closed-flame)) - (or (not (eq (stream-in stream) #'ill-in)) - (not (eq (stream-bin stream) #'ill-bin))))) - -(defun output-stream-p (stream) - "Returns non-nil if the given Stream can perform output operations." - (and (streamp stream) - (not (eq (stream-in stream) #'closed-flame)) - (or (not (eq (stream-out stream) #'ill-out)) - (not (eq (stream-bout stream) #'ill-bout))))) - -(defun open-stream-p (stream) - "Return true if Stream is not closed." - (declare (type stream stream)) - (not (eq (stream-in stream) #'closed-flame))) - -(defun stream-element-type (stream) - "Returns a type specifier for the kind of object returned by the Stream." - (if (streamp stream) - (funcall (stream-misc stream) stream :element-type) - (error "~S is not a stream." stream))) - -(defun interactive-stream-p (stream) - "Return true if Stream does I/O on a terminal or other interactive device." - (declare (type stream stream)) - (funcall (stream-misc stream) stream :interactive-p)) - -(defun close (stream &key abort) - "Closes the given Stream. No more I/O may be performed, but inquiries - may still be made. If :Abort is non-nil, an attempt is made to clean - up the side effects of having created the stream." - (if (streamp stream) - (unless (eq (stream-in stream) #'closed-flame) - (funcall (stream-misc stream) stream :close abort)) - (error "~S is not a stream." stream)) - t) - -(defun set-closed-flame (stream) - (setf (stream-in stream) #'closed-flame) - (setf (stream-bin stream) #'closed-flame) - (setf (stream-n-bin stream) #'closed-flame) - (setf (stream-in stream) #'closed-flame) - (setf (stream-out stream) #'closed-flame) - (setf (stream-bout stream) #'closed-flame) - (setf (stream-sout stream) #'closed-flame) - (setf (stream-misc stream) #'closed-flame)) - -;;; Input functions: - -(defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value - recursive-p) - "Returns a line of text read from the Stream as a string, discarding the - newline character." - (declare (ignore recursive-p)) - (let* ((stream (in-synonym-of stream)) - (buffer (stream-in-buffer stream)) - (index (stream-in-index stream))) - (declare (fixnum index)) - (if (simple-string-p buffer) - (let ((nl (%sp-find-character buffer index in-buffer-length - #\newline))) - (if nl - (values (prog1 (subseq (the simple-string buffer) index nl) - (setf (stream-in-index stream) - (1+ (the fixnum nl)))) - nil) - (multiple-value-bind (str eofp) - (funcall (stream-misc stream) stream - :read-line eof-errorp eof-value) - (if (= index in-buffer-length) - (values str eofp) - (let ((first (subseq buffer index in-buffer-length))) - (setf (stream-in-index stream) in-buffer-length) - (if (eq str eof-value) - (values first t) - (values (concatenate 'simple-string first - (the simple-string str)) - eofp))))))) - (funcall (stream-misc stream) stream :read-line eof-errorp - eof-value)))) - - -;;; We proclaim them inline here, then proclaim them notinline at EOF, -;;; so, except in this file, they are not inline by default, but they can be. -;;; -(proclaim '(inline read-char unread-char read-byte listen)) -(defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value - recursive-p) - "Inputs a character from Stream and returns it." - (declare (ignore recursive-p)) - (let* ((stream (in-synonym-of stream)) - (index (stream-in-index stream))) - (declare (fixnum index)) - (if (eql index in-buffer-length) - (funcall (stream-in stream) stream eof-errorp eof-value) - (prog1 (aref (stream-in-buffer stream) index) - (setf (stream-in-index stream) (1+ index)))))) - -(defun unread-char (character &optional (stream *standard-input*)) - "Puts the Character back on the front of the input Stream." - (let* ((stream (in-synonym-of stream)) - (index (1- (the fixnum (stream-in-index stream)))) - (buffer (stream-in-buffer stream))) - (declare (fixnum index)) - (when (minusp index) (error "Nothing to unread.")) - (if buffer - (setf (aref (the simple-array buffer) index) character - (stream-in-index stream) index) - (funcall (stream-misc stream) stream :unread character))) - nil) - -(defun peek-char (&optional (peek-type nil) (stream *standard-input*) - (eof-errorp t) eof-value recursive-p) - "Peeks at the next character in the input Stream. See manual for details." - (declare (ignore recursive-p)) - (let* ((stream (in-synonym-of stream)) - (char (read-char stream eof-errorp eof-value))) - (cond ((eq char eof-value) char) - ((characterp peek-type) - (do ((char char (read-char stream eof-errorp eof-value))) - ((or (eq char eof-value) (char= char peek-type)) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - ((eq peek-type t) - (do ((char char (read-char stream eof-errorp eof-value))) - ((or (eq char eof-value) (not (whitespace-char-p char))) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - (t - (unread-char char stream) - char)))) - -(defun listen (&optional (stream *standard-input*)) - "Returns T if a character is availible on the given Stream." - (let ((stream (in-synonym-of stream))) - (or (/= (the fixnum (stream-in-index stream)) in-buffer-length) - ;; Test for t explicitly since misc methods return :eof sometimes. - (eq (funcall (stream-misc stream) stream :listen) t)))) - -(defun read-char-no-hang (&optional (stream *standard-input*) - (eof-errorp t) eof-value recursive-p) - "Returns the next character from the Stream if one is availible, or nil." - (declare (ignore recursive-p)) - (let ((stream (in-synonym-of stream))) - (if (funcall (stream-misc stream) stream :listen) - ;; On t or :eof get READ-CHAR to do the work. - (read-char stream eof-errorp eof-value) - nil))) - -(defun clear-input (&optional (stream *standard-input*)) - "Clears any buffered input associated with the Stream." - (let ((stream (in-synonym-of stream))) - (setf (stream-in-index stream) in-buffer-length) - (funcall (stream-misc stream) stream :clear-input) - nil)) - -(defun read-byte (stream &optional (eof-errorp t) eof-value) - "Returns the next byte of the Stream." - (let* ((stream (in-synonym-of stream)) - (index (stream-in-index stream))) - (declare (fixnum index)) - (if (eql index in-buffer-length) - (funcall (stream-bin stream) stream eof-errorp eof-value) - (prog1 (aref (stream-in-buffer stream) index) - (setf (stream-in-index stream) (1+ index)))))) - -(defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t)) - "Reads Numbytes bytes into the Buffer starting at Start, and returns - the number of bytes actually read if the end of file was hit before Numbytes - bytes were read (and Eof-Errorp is false)." - (declare (fixnum numbytes)) - (let* ((stream (in-synonym-of stream)) - (in-buffer (stream-in-buffer stream)) - (index (stream-in-index stream)) - (num-buffered (- in-buffer-length index))) - (declare (fixnum index num-buffered)) - (cond - ((not in-buffer) - (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp)) - ((not (typep in-buffer - '(or simple-string (simple-array (unsigned-byte 8) (*))))) - (error "N-Bin only works on 8-bit-like streams.")) - ((<= numbytes num-buffered) - (%primitive byte-blt in-buffer index buffer start (+ start numbytes)) - (setf (stream-in-index stream) (+ index numbytes)) - numbytes) - (t - (let ((end (+ start num-buffered))) - (%primitive byte-blt in-buffer index buffer start end) - (setf (stream-in-index stream) in-buffer-length) - (+ (with-in-stream stream stream-n-bin buffer end - (- numbytes num-buffered) - eof-errorp) - num-buffered)))))) - -;;; Output functions: - -(defun write-char (character &optional (stream *standard-output*)) - "Outputs the Character to the Stream." - (with-out-stream stream stream-out character) - character) - -(defun terpri (&optional (stream *standard-output*)) - "Outputs a new line to the Stream." - (with-out-stream stream stream-out #\newline) - nil) - -(defun fresh-line (&optional (stream *standard-output*)) - "Outputs a new line to the Stream if it is not positioned at the begining of - a line. Returns T if it output a new line, nil otherwise." - (let ((stream (out-synonym-of stream))) - (when (/= (or (charpos stream) 1) 0) - (funcall (stream-out stream) stream #\newline) - t))) - -(defun write-string (string &optional (stream *standard-output*) - &key (start 0) (end (length (the vector string)))) - "Outputs the String to the given Stream." - (write-string* string stream start end)) - -(defun write-string* (string &optional (stream *standard-output*) - (start 0) (end (length (the vector string)))) - (declare (fixnum start end)) - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) (offset-end end)) - (with-out-stream stream stream-sout data offset-start offset-end)) - (with-out-stream stream stream-sout string start end)) - string) - -(defun write-line (string &optional (stream *standard-output*) - &key (start 0) (end (length string))) - "Outputs the String to the given Stream, followed by a newline character." - (write-line* string stream start end)) - -(defun write-line* (string &optional (stream *standard-output*) - (start 0) (end (length string))) - (declare (fixnum start end)) - (let ((stream (out-synonym-of stream))) - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) (offset-end end)) - (with-out-stream stream stream-sout data offset-start offset-end)) - (with-out-stream stream stream-sout string start end)) - (funcall (stream-out stream) stream #\newline)) - string) - -(defun charpos (&optional (stream *standard-output*)) - "Returns the number of characters on the current line of output of the given - Stream, or Nil if that information is not availible." - (with-out-stream stream stream-misc :charpos)) - -(defun line-length (&optional (stream *standard-output*)) - "Returns the number of characters that will fit on a line of output on the - given Stream, or Nil if that information is not available." - (with-out-stream stream stream-misc :line-length)) - -(defun finish-output (&optional (stream *standard-output*)) - "Attempts to ensure that all output sent to the the Stream has reached its - destination, and only then returns." - (with-out-stream stream stream-misc :finish-output) - nil) - -(defun force-output (&optional (stream *standard-output*)) - "Attempts to force any buffered output to be sent." - (with-out-stream stream stream-misc :force-output) - nil) - -(defun clear-output (&optional (stream *standard-output*)) - "Clears the given output Stream." - (with-out-stream stream stream-misc :clear-output) - nil) - -(defun write-byte (integer stream) - "Outputs the Integer to the binary Stream." - (with-out-stream stream stream-bout integer) - integer) - -;;;; Broadcast streams: - -(defstruct (broadcast-stream (:include stream - (out #'broadcast-out) - (bout #'broadcast-bout) - (sout #'broadcast-sout) - (misc #'broadcast-misc)) - (:print-function %print-broadcast-stream) - (:constructor make-broadcast-stream (&rest streams))) - ;; This is a list of all the streams we broadcast to. - (streams () :type list :read-only t)) - -(setf (documentation 'make-broadcast-stream 'function) - "Returns an ouput stream which sends its output to all of the given streams.") - -(defun %print-broadcast-stream (s stream d) - (declare (ignore s d)) - (write-string "#<Broadcast Stream>" stream)) - -(macrolet ((out-fun (fun method &rest args) - `(defun ,fun (stream ,@args) - (dolist (stream (broadcast-stream-streams stream)) - (funcall (,method stream) stream ,@args))))) - (out-fun broadcast-out stream-out char) - (out-fun broadcast-bout stream-bout byte) - (out-fun broadcast-sout stream-sout string start end)) - -(defun broadcast-misc (stream operation &optional arg1 arg2) - (let ((streams (broadcast-stream-streams stream))) - (case operation - (:charpos - (dolist (stream streams) - (let ((charpos (funcall (stream-misc stream) stream :charpos))) - (if charpos (return charpos))))) - (:line-length - (let ((min nil)) - (dolist (stream streams min) - (let ((res (funcall (stream-misc stream) stream :line-length))) - (when res (setq min (if min (min res min) res))))))) - (:element-type - (let (res) - (dolist (stream streams (if (> (length res) 1) `(and ,@res) res)) - (pushnew (funcall (stream-misc stream) stream :element-type) res - :test #'equal)))) - (t - (let ((res nil)) - (dolist (stream streams res) - (setq res (funcall (stream-misc stream) stream operation - arg1 arg2)))))))) - -;;;; Synonym Streams: - -(defstruct (synonym-stream (:include stream - (in #'synonym-in) - (bin #'synonym-bin) - (n-bin #'synonym-n-bin) - (out #'synonym-out) - (bout #'synonym-bout) - (sout #'synonym-sout) - (misc #'synonym-misc)) - (:print-function %print-synonym-stream) - (:constructor make-synonym-stream (symbol))) - ;; This is the symbol, the value of which is the stream we are synonym to. - (symbol nil :type symbol :read-only t)) - -(defun %print-synonym-stream (s stream d) - (declare (ignore d)) - (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s))) - -(setf (documentation 'make-synonym-stream 'function) - "Returns a stream which performs its operations on the stream which is the - value of the dynamic variable named by Symbol.") - -;;; The output simple output methods just call the corresponding method -;;; in the synonymed stream. -;;; -(macrolet ((out-fun (name slot &rest args) - `(defun ,name (stream ,@args) - (declare (optimize (safety 1))) - (let ((syn (symbol-value (synonym-stream-symbol stream)))) - (funcall (,slot syn) syn ,@args))))) - (out-fun synonym-out stream-out ch) - (out-fun synonym-bout stream-bout n) - (out-fun synonym-sout stream-sout string start end)) - - -;;; Bind synonym stream to this so that SPIO can turn on the right frob in -;;; the icon when we are in a terminal input wait. -;;; -(defvar *previous-stream* nil) - -;;; For the input methods, we just call the corresponding function on the -;;; synonymed stream. These functions deal with getting input out of -;;; the In-Buffer if there is any. -;;; -(macrolet ((in-fun (name fun &rest args) - `(defun ,name (stream ,@args) - (declare (optimize (safety 1))) - (let ((*previous-stream* stream)) - (,fun (symbol-value (synonym-stream-symbol stream)) ,@args))))) - (in-fun synonym-in read-char eof-errorp eof-value) - (in-fun synonym-bin read-byte eof-errorp eof-value) - (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp)) - - -;;; Synonym-Misc -- Internal -;;; -;;; We have to special-case the operations which could look at stuff in -;;; the in-buffer. -;;; -(defun synonym-misc (stream operation &optional arg1 arg2) - (declare (optimize (safety 1))) - (let ((syn (symbol-value (synonym-stream-symbol stream))) - (*previous-stream* stream)) - (case operation - (:read-line (read-line syn)) - (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length) - (funcall (stream-misc syn) syn :listen))) - (t - (funcall (stream-misc syn) syn operation arg1 arg2))))) - -;;;; Two-Way streams: - -(defstruct (two-way-stream - (:include stream - (in #'two-way-in) - (bin #'two-way-bin) - (n-bin #'two-way-n-bin) - (out #'two-way-out) - (bout #'two-way-bout) - (sout #'two-way-sout) - (misc #'two-way-misc)) - (:print-function %print-two-way-stream) - (:constructor make-two-way-stream (input-stream output-stream))) - ;; We read from this stream... - (input-stream (required-argument) :type stream :read-only t) - ;; And write to this one - (output-stream (required-argument) :type stream :read-only t)) - -(defun %print-two-way-stream (s stream d) - (declare (ignore d)) - (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>" - (two-way-stream-input-stream s) - (two-way-stream-output-stream s))) - -(setf (documentation 'make-two-way-stream 'function) - "Returns a bidirectional stream which gets its input from Input-Stream and - sends its output to Output-Stream.") - -(macrolet ((out-fun (name slot &rest args) - `(defun ,name (stream ,@args) - (let ((syn (two-way-stream-output-stream stream))) - (funcall (,slot syn) syn ,@args))))) - (out-fun two-way-out stream-out ch) - (out-fun two-way-bout stream-bout n) - (out-fun two-way-sout stream-sout string start end)) - -(macrolet ((in-fun (name fun &rest args) - `(defun ,name (stream ,@args) - (force-output (two-way-stream-output-stream stream)) - (,fun (two-way-stream-input-stream stream) ,@args)))) - (in-fun two-way-in read-char eof-errorp eof-value) - (in-fun two-way-bin read-byte eof-errorp eof-value) - (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp)) - -(defun two-way-misc (stream operation &optional arg1 arg2) - (let* ((in (two-way-stream-input-stream stream)) - (in-method (stream-misc in)) - (out (two-way-stream-output-stream stream)) - (out-method (stream-misc out))) - (case operation - (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length) - (funcall in-method in :listen))) - (:read-line - (force-output out) - (read-line in arg1 arg2)) - ((:finish-output :force-output :clear-output) - (funcall out-method out operation arg1 arg2)) - ((:clear-input :unread) - (funcall in-method in operation arg1 arg2)) - (:element-type - (let ((in-type (funcall in-method in :element-type)) - (out-type (funcall out-method out :element-type))) - (if (equal in-type out-type) - in-type `(and ,in-type ,out-type)))) - (:close - (funcall in-method in :close arg1) - (funcall out-method out :close arg1) - (set-closed-flame stream)) - (t - (or (funcall in-method in operation arg1 arg2) - (funcall out-method out operation arg1 arg2)))))) - -;;;; Concatenated Streams: - -(defstruct (concatenated-stream - (:include stream - (in #'concatenated-in) - (bin #'concatenated-bin) - (misc #'concatenated-misc)) - (:print-function %print-concatenated-stream) - (:constructor - make-concatenated-stream (&rest streams &aux (current streams)))) - ;; The car of this is the stream we are reading from now. - current - ;; This is a list of all the streams. We need to remember them so that - ;; we can close them. - (streams nil :type list :read-only t)) - -(defun %print-concatenated-stream (s stream d) - (declare (ignore d)) - (format stream "#<Concatenated Stream, Streams = ~S>" - (concatenated-stream-streams s))) - -(setf (documentation 'make-concatenated-stream 'function) - "Returns a stream which takes its input from each of the Streams in turn, - going on to the next at EOF.") - -(macrolet ((in-fun (name fun) - `(defun ,name (stream eof-errorp eof-value) - (do ((current (concatenated-stream-current stream) (cdr current))) - ((null current) - (eof-or-lose stream eof-errorp eof-value)) - (let* ((stream (car current)) - (result (,fun stream nil nil))) - (when result (return result))) - (setf (concatenated-stream-current stream) current))))) - (in-fun concatenated-in read-char) - (in-fun concatenated-bin read-byte)) - -;;; Concatenated-Readline is somewhat hairy, since we may need to -;;; do several readlines and concatenate the result if the lines are -;;; terminated by eof. -;;; -(defun concatenated-readline (stream eof-errorp eof-value) - ;; Loop until we find a stream that will give us something or we error - ;; out. - (do ((current (concatenated-stream-current stream) (cdr current))) - ((null current) - (eof-or-lose stream eof-errorp eof-value)) - (setf (concatenated-stream-current stream) current) - (let ((this (car current))) - (multiple-value-bind (result eofp) - (read-line this nil :eof) - (declare (type (or simple-string (member :eof)) result)) - ;; Once we have found some input, we loop until we either find a - ;; line not terminated by eof or hit eof on the last stream. - (unless (eq result :eof) - (do ((current (cdr current) (cdr current)) - (new "")) - ((or (not eofp) (null current)) - (return-from concatenated-readline (values result eofp))) - (declare (type (or simple-string (member :eof)) new)) - (setf (concatenated-stream-current stream) current) - (let ((this (car current))) - (multiple-value-setq (new eofp) - (read-line this nil :eof)) - (if (eq new :eof) - (setq eofp t) - (setq result (concatenate 'simple-string result new)))))))))) - -(defun concatenated-misc (stream operation &optional arg1 arg2) - (if (eq operation :read-line) - (concatenated-readline stream arg1 arg2) - (let ((left (concatenated-stream-current stream))) - (when left - (let* ((current (car left)) - (misc (stream-misc current))) - (case operation - (:listen - (loop - (let ((stuff (funcall misc current :listen))) - (cond ((eq stuff :eof) - ;; Advance current, and try again. - (pop (concatenated-stream-current stream)) - (setf current - (car (concatenated-stream-current stream))) - (unless current - ;; No further streams. EOF. - (return :eof)) - (setf misc (stream-misc current))) - (stuff - ;; Stuff's available. - (return t)) - (t - ;; Nothing available yet. - (return nil)))))) - (:close - (dolist (stream (concatenated-stream-streams stream)) - (funcall (stream-misc stream) stream :close arg1)) - (set-closed-flame stream)) - (t - (funcall misc current operation arg1 arg2)))))))) - -;;;; Echo Streams: - -(defstruct (echo-stream - (:include two-way-stream - (in #'echo-in) - (bin #'echo-bin) - (misc #'echo-misc) - (n-bin #'ill-bin)) - (:print-function %print-echo-stream) - (:constructor make-echo-stream (input-stream output-stream))) - unread-stuff) - - -(macrolet ((in-fun (name fun out-slot &rest args) - `(defun ,name (stream ,@args) - (or (pop (echo-stream-unread-stuff stream)) - (let* ((in (echo-stream-input-stream stream)) - (out (echo-stream-output-stream stream)) - (result (,fun in ,@args))) - (funcall (,out-slot out) out result) - result))))) - (in-fun echo-in read-char stream-out eof-errorp eof-value) - (in-fun echo-bin read-byte stream-bout eof-errorp eof-value)) - -(defun echo-misc (stream operation &optional arg1 arg2) - (let* ((in (two-way-stream-input-stream stream)) - (in-method (stream-misc in)) - (out (two-way-stream-output-stream stream)) - (out-method (stream-misc out))) - (case operation - (:listen (or (not (null (echo-stream-unread-stuff stream))) - (/= (the fixnum (stream-in-index in)) in-buffer-length) - (funcall in-method in :listen))) - (:unread (push arg1 (echo-stream-unread-stuff stream))) - (:read-line - (let* ((stuff (echo-stream-unread-stuff stream)) - (newline-pos (position #\newline stuff))) - (if newline-pos - (progn - (setf (echo-stream-unread-stuff stream) - (subseq stuff (1+ newline-pos))) - (values (coerce (subseq stuff 0 newline-pos) 'simple-string) - nil)) - (multiple-value-bind (result eofp) - (read-line in arg1 arg2) - (if eofp - (write-string result out) - (write-line result out)) - (setf (echo-stream-unread-stuff stream) nil) - (values (if stuff - (concatenate 'simple-string stuff result) - result) - eofp))))) - (:element-type - (let ((in-type (funcall in-method in :element-type)) - (out-type (funcall out-method out :element-type))) - (if (equal in-type out-type) - in-type `(and ,in-type ,out-type)))) - (:close - (funcall in-method in :close arg1) - (funcall out-method out :close arg1) - (set-closed-flame stream)) - (t - (or (funcall in-method in operation arg1 arg2) - (funcall out-method out operation arg1 arg2)))))) - -(defun %print-echo-stream (s stream d) - (declare (ignore d)) - (format stream "#<Echo Stream, Input = ~S, Output = ~S>" - (two-way-stream-input-stream s) - (two-way-stream-output-stream s))) - -(setf (documentation 'make-echo-stream 'function) - "Returns a bidirectional stream which gets its input from Input-Stream and - sends its output to Output-Stream. In addition, all input is echoed to - the output stream") - -;;;; String Input Streams: - -(defstruct (string-input-stream - (:include stream - (in #'string-inch) - (misc #'string-in-misc)) - (:print-function %print-string-input-stream) - ;(:constructor nil) - (:constructor internal-make-string-input-stream - (string current end))) - (string nil :type simple-string) - (current nil :type fixnum) - (end nil :type fixnum)) - -(defun %print-string-input-stream (s stream d) - (declare (ignore s d)) - (write-string "#<String-Input Stream>" stream)) - -(defun string-inch (stream eof-errorp eof-value) - (let ((string (string-input-stream-string stream)) - (index (string-input-stream-current stream))) - (declare (simple-string string) (fixnum index)) - (cond ((= index (the fixnum (string-input-stream-end stream))) - (eof-or-lose stream eof-errorp eof-value)) - (t - (setf (string-input-stream-current stream) (1+ index)) - (aref string index))))) - -(defun string-in-misc (stream operation &optional arg1 arg2) - (case operation - (:file-position - (if arg1 - (setf (string-input-stream-current stream) arg1) - (string-input-stream-current stream))) - (:file-length (length (string-input-stream-string stream))) - (:read-line - (let ((string (string-input-stream-string stream)) - (current (string-input-stream-current stream)) - (end (string-input-stream-end stream))) - (declare (simple-string string) (fixnum current end)) - (if (= current end) - (eof-or-lose stream arg1 arg2) - (let ((pos (position #\newline string :start current :end end))) - (if pos - (let* ((res-length (- (the fixnum pos) current)) - (result (make-string res-length))) - (%primitive byte-blt string current result 0 res-length) - (setf (string-input-stream-current stream) - (1+ (the fixnum pos))) - (values result nil)) - (let* ((res-length (- end current)) - (result (make-string res-length))) - (%primitive byte-blt string current result 0 res-length) - (setf (string-input-stream-current stream) end) - (values result t))))))) - (:unread (decf (string-input-stream-current stream))) - (:listen (or (/= (the fixnum (string-input-stream-current stream)) - (the fixnum (string-input-stream-end stream))) - :eof)) - (:element-type 'string-char))) - -(defun make-string-input-stream (string &optional - (start 0) (end (length string))) - "Returns an input stream which will supply the characters of String between - Start and End in order." - (if (stringp string) - (internal-make-string-input-stream (coerce string 'simple-string) - start end) - (error "~S is not a string." string))) - -;;;; String Output Streams: - -(defstruct (string-output-stream - (:include stream - (out #'string-ouch) - (sout #'string-sout) - (misc #'string-out-misc)) - (:print-function %print-string-output-stream) - (:constructor make-string-output-stream ())) - ;; The string we throw stuff in. - (string (make-string 40) :type simple-string) - ;; Index of the next location to use. - (index 0 :type fixnum)) - -(defun %print-string-output-stream (s stream d) - (declare (ignore s d)) - (write-string "#<String-Output Stream>" stream)) - -(setf (documentation 'make-string-output-stream 'function) - "Returns an Output stream which will accumulate all output given it for - the benefit of the function Get-Output-Stream-String.") - -(defun string-ouch (stream character) - (let ((current (string-output-stream-index stream)) - (workspace (string-output-stream-string stream))) - (declare (simple-string workspace) (fixnum current)) - (if (= current (the fixnum (length workspace))) - (let ((new-workspace (make-string (* current 2)))) - (%primitive byte-blt workspace 0 new-workspace 0 current) - (setf (aref new-workspace current) character) - (setf (string-output-stream-string stream) new-workspace)) - (setf (aref workspace current) character)) - (setf (string-output-stream-index stream) (1+ current)))) - -(defun string-sout (stream string start end) - (declare (simple-string string) (fixnum start end)) - (let* ((current (string-output-stream-index stream)) - (length (- end start)) - (dst-end (+ length current)) - (workspace (string-output-stream-string stream))) - (declare (simple-string workspace) - (fixnum current length dst-end)) - (if (> dst-end (the fixnum (length workspace))) - (let ((new-workspace (make-string (+ (* current 2) length)))) - (%primitive byte-blt workspace 0 new-workspace 0 current) - (%primitive byte-blt string start new-workspace current dst-end) - (setf (string-output-stream-string stream) new-workspace)) - (%primitive byte-blt string start workspace current dst-end)) - (setf (string-output-stream-index stream) dst-end))) - -(defun string-out-misc (stream operation &optional arg1 arg2) - (declare (ignore arg2)) - (case operation - (:file-position - (if (null arg1) - (string-output-stream-index stream))) - (:charpos - (do ((index (1- (the fixnum (string-output-stream-index stream))) - (1- index)) - (count 0 (1+ count)) - (string (string-output-stream-string stream))) - ((< index 0) count) - (declare (simple-string string) - (fixnum index count)) - (if (char= (schar string index) #\newline) - (return count)))) - (:element-type 'string-char))) - -(defun get-output-stream-string (stream) - "Returns a string of all the characters sent to a stream made by - Make-String-Output-Stream since the last call to this function." - (if (streamp stream) - (let* ((length (string-output-stream-index stream)) - (result (make-string length))) - (%primitive byte-blt (string-output-stream-string stream) 0 - result 0 length) - (setf (string-output-stream-index stream) 0) - result) - (error "~S is not a string stream."))) - -(defun dump-output-stream-string (in-stream out-stream) - "Dumps the characters buffer up in the In-Stream to the Out-Stream as - Get-Output-Stream-String would return them." - (write-string (string-output-stream-string in-stream) out-stream - :start 0 :end (string-output-stream-index in-stream)) - (setf (string-output-stream-index in-stream) 0)) - -;;;; Fill-pointer streams: -;;; -;;; Fill pointer string output streams are not explicitly mentioned in -;;; the CLM, but they are required for the implementation of With-Output-To-String. - -(defstruct (fill-pointer-output-stream - (:include stream - (out #'fill-pointer-ouch) - (sout #'fill-pointer-sout) - (misc #'fill-pointer-misc)) - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (write-string "#<Fill-Pointer String Output Stream>" stream))) - (:constructor make-fill-pointer-output-stream (string))) - ;; The string we throw stuff in. - string) - - -(defun fill-pointer-ouch (stream character) - (let* ((buffer (fill-pointer-output-stream-string stream)) - (current (fill-pointer buffer)) - (current+1 (1+ current))) - (declare (fixnum current)) - (with-array-data ((workspace buffer) (start) (end)) - (declare (simple-string workspace)) - (let ((offset-current (+ start current))) - (declare (fixnum offset-current)) - (if (= offset-current end) - (let* ((new-length (* current 2)) - (new-workspace (make-string new-length))) - (declare (simple-string new-workspace)) - (%primitive byte-blt workspace start new-workspace 0 current) - (setf workspace new-workspace) - (setf offset-current current) - (set-array-header buffer workspace new-length - current+1 0 new-length nil)) - (setf (fill-pointer buffer) current+1)) - (setf (schar workspace offset-current) character))) - current+1)) - - -(defun fill-pointer-sout (stream string start end) - (declare (simple-string string) (fixnum start end)) - (let* ((buffer (fill-pointer-output-stream-string stream)) - (current (fill-pointer buffer)) - (string-len (- end start)) - (dst-end (+ string-len current))) - (declare (fixnum current dst-end string-len)) - (with-array-data ((workspace buffer) (dst-start) (dst-length)) - (declare (simple-string workspace)) - (let ((offset-dst-end (+ dst-start dst-end)) - (offset-current (+ dst-start current))) - (declare (fixnum offset-dst-end offset-current)) - (if (> offset-dst-end dst-length) - (let* ((new-length (+ (the fixnum (* current 2)) string-len)) - (new-workspace (make-string new-length))) - (declare (simple-string new-workspace)) - (%primitive byte-blt workspace dst-start new-workspace 0 current) - (setf workspace new-workspace) - (setf offset-current current) - (setf offset-dst-end dst-end) - (set-array-header buffer workspace new-length - dst-end 0 new-length nil)) - (setf (fill-pointer buffer) dst-end)) - (%primitive byte-blt string start - workspace offset-current offset-dst-end))) - dst-end)) - - -(defun fill-pointer-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) - (case operation - (:charpos - (let* ((buffer (fill-pointer-output-stream-string stream)) - (current (fill-pointer buffer))) - (with-array-data ((string buffer) (start) (end current)) - (declare (simple-string string) (ignore start)) - (let ((found (position #\newline string :test #'char= - :end end :from-end t))) - (if found - (- end (the fixnum found)) - current))))) - (:element-type 'string-char))) - -;;;; Indenting streams: - -(defstruct (indenting-stream (:include stream - (out #'indenting-out) - (sout #'indenting-sout) - (misc #'indenting-misc)) - (:print-function %print-indenting-stream) - (:constructor make-indenting-stream (stream))) - ;; The stream we're based on: - stream - ;; How much we indent on each line: - (indentation 0)) - -(setf (documentation 'make-indenting-stream 'function) - "Returns an ouput stream which indents its output by some amount.") - -(defun %print-indenting-stream (s stream d) - (declare (ignore s d)) - (write-string "#<Indenting Stream>" stream)) - -;;; Indenting-Indent writes the right number of spaces needed to indent output on -;;; the given Stream based on the specified Sub-Stream. - -(defmacro indenting-indent (stream sub-stream) - `(do ((i 0 (+ i 60)) - (indentation (indenting-stream-indentation ,stream))) - ((>= i indentation)) - (funcall (stream-sout ,sub-stream) ,sub-stream - " " - 0 (min 60 (- indentation i))))) - -;;; Indenting-Out writes a character to an indenting stream. - -(defun indenting-out (stream char) - (let ((sub-stream (indenting-stream-stream stream))) - (funcall (stream-out sub-stream) sub-stream char) - (if (char= char #\newline) - (indenting-indent stream sub-stream)))) - -;;; Indenting-Sout writes a string to an indenting stream. - -(defun indenting-sout (stream string start end) - (declare (simple-string string) (fixnum start end)) - (do ((i start) - (sub-stream (indenting-stream-stream stream))) - ((= i end)) - (let ((newline (position #\newline string :start i :end end))) - (cond (newline - (funcall (stream-sout sub-stream) sub-stream string i (1+ newline)) - (indenting-indent stream sub-stream) - (setq i (+ newline 1))) - (t - (funcall (stream-sout sub-stream) sub-stream string i end) - (setq i end)))))) - -;;; Indenting-Misc just treats just the :Line-Length message differently. -;;; Indenting-Charpos says the charpos is the charpos of the base stream minus -;;; the stream's indentation. - -(defun indenting-misc (stream operation &optional arg1 arg2) - (let* ((sub-stream (indenting-stream-stream stream)) - (method (stream-misc sub-stream))) - (case operation - (:line-length - (let ((line-length (funcall method sub-stream operation))) - (if line-length - (- line-length (indenting-stream-indentation stream))))) - (:charpos - (let* ((sub-stream (indenting-stream-stream stream)) - (charpos (funcall method sub-stream operation))) - (if charpos - (- charpos (indenting-stream-indentation stream))))) - (t - (funcall method sub-stream operation arg1 arg2))))) - -(proclaim '(maybe-inline read-char unread-char read-byte listen)) - - - -;;;; Case frobbing streams, used by format ~(...~). - -(in-package "EXT") -(export '(make-case-frob-stream)) -(in-package "LISP") - -(defstruct (case-frob-stream - (:include stream - (:misc #'case-frob-misc)) - (:constructor %make-case-frob-stream (target out sout))) - (target (required-argument) :type stream)) - -(defun make-case-frob-stream (target kind) - "Returns a stream that sends all output to the stream TARGET, but modifies - the case of letters, depending on KIND, which should be one of: - :upcase - convert to upper case. - :downcase - convert to lower case. - :capitalize - convert the first letter of words to upper case and the - rest of the word to lower case. - :capitalize-first - convert the first letter of the first word to upper - case and everything else to lower case." - (declare (type stream target) - (type (member :upcase :downcase :capitalize :capitalize-first) - kind) - (values stream)) - (if (case-frob-stream-p target) - ;; If we are going to be writing to a stream that already does case - ;; frobbing, why bother frobbing the case just so it can frob it - ;; again? - target - (multiple-value-bind - (out sout) - (ecase kind - (:upcase - (values #'case-frob-upcase-out - #'case-frob-upcase-sout)) - (:downcase - (values #'case-frob-downcase-out - #'case-frob-downcase-sout)) - (:capitalize - (values #'case-frob-capitalize-out - #'case-frob-capitalize-sout)) - (:capitalize-first - (values #'case-frob-capitalize-first-out - #'case-frob-capitalize-first-sout))) - (%make-case-frob-stream target out sout)))) - -(defun case-frob-misc (stream op &optional arg1 arg2) - (declare (type case-frob-stream stream)) - (case op - (:close) - (t - (let ((target (case-frob-stream-target stream))) - (funcall (stream-misc target) target op arg1 arg2))))) - - -(defun case-frob-upcase-out (stream char) - (declare (type case-frob-stream stream) - (type base-character char)) - (let ((target (case-frob-stream-target stream))) - (funcall (stream-out target) target (char-upcase char)))) - -(defun case-frob-upcase-sout (stream str start end) - (declare (type case-frob-stream stream) - (type simple-base-string str) - (type index start) - (type (or index null) end)) - (let* ((target (case-frob-stream-target stream)) - (len (length str)) - (end (or end len))) - (funcall (stream-sout target) target - (if (and (zerop start) (= len end)) - (string-upcase str) - (nstring-upcase (subseq str start end))) - 0 - (- end start)))) - -(defun case-frob-downcase-out (stream char) - (declare (type case-frob-stream stream) - (type base-character char)) - (let ((target (case-frob-stream-target stream))) - (funcall (stream-out target) target (char-downcase char)))) - -(defun case-frob-downcase-sout (stream str start end) - (declare (type case-frob-stream stream) - (type simple-base-string str) - (type index start) - (type (or index null) end)) - (let* ((target (case-frob-stream-target stream)) - (len (length str)) - (end (or end len))) - (funcall (stream-sout target) target - (if (and (zerop start) (= len end)) - (string-downcase str) - (nstring-downcase (subseq str start end))) - 0 - (- end start)))) - -(defun case-frob-capitalize-out (stream char) - (declare (type case-frob-stream stream) - (type base-character char)) - (let ((target (case-frob-stream-target stream))) - (cond ((alphanumericp char) - (funcall (stream-out target) target (char-upcase char)) - (setf (case-frob-stream-out stream) - #'case-frob-capitalize-aux-out) - (setf (case-frob-stream-sout stream) - #'case-frob-capitalize-aux-sout)) - (t - (funcall (stream-out target) target char))))) - -(defun case-frob-capitalize-sout (stream str start end) - (declare (type case-frob-stream stream) - (type simple-base-string str) - (type index start) - (type (or index null) end)) - (let* ((target (case-frob-stream-target stream)) - (str (subseq str start end)) - (len (length str)) - (inside-word nil)) - (dotimes (i len) - (let ((char (schar str i))) - (cond ((not (alphanumericp char)) - (setf inside-word nil)) - (inside-word - (setf (schar str i) (char-downcase char))) - (t - (setf inside-word t) - (setf (schar str i) (char-upcase char)))))) - (when inside-word - (setf (case-frob-stream-out stream) - #'case-frob-capitalize-aux-out) - (setf (case-frob-stream-sout stream) - #'case-frob-capitalize-aux-sout)) - (funcall (stream-sout target) target str 0 len))) - -(defun case-frob-capitalize-aux-out (stream char) - (declare (type case-frob-stream stream) - (type base-character char)) - (let ((target (case-frob-stream-target stream))) - (cond ((alphanumericp char) - (funcall (stream-out target) target (char-downcase char))) - (t - (funcall (stream-out target) target char) - (setf (case-frob-stream-out stream) - #'case-frob-capitalize-out) - (setf (case-frob-stream-sout stream) - #'case-frob-capitalize-sout))))) - -(defun case-frob-capitalize-aux-sout (stream str start end) - (declare (type case-frob-stream stream) - (type simple-base-string str) - (type index start) - (type (or index null) end)) - (let* ((target (case-frob-stream-target stream)) - (str (subseq str start end)) - (len (length str)) - (inside-word t)) - (dotimes (i len) - (let ((char (schar str i))) - (cond ((not (alphanumericp char)) - (setf inside-word nil)) - (inside-word - (setf (schar str i) (char-downcase char))) - (t - (setf inside-word t) - (setf (schar str i) (char-upcase char)))))) - (unless inside-word - (setf (case-frob-stream-out stream) - #'case-frob-capitalize-out) - (setf (case-frob-stream-sout stream) - #'case-frob-capitalize-sout)) - (funcall (stream-sout target) target str 0 len))) - -(defun case-frob-capitalize-first-out (stream char) - (declare (type case-frob-stream stream) - (type base-character char)) - (let ((target (case-frob-stream-target stream))) - (cond ((alphanumericp char) - (funcall (stream-out target) target (char-upcase char)) - (setf (case-frob-stream-out stream) - #'case-frob-downcase-out) - (setf (case-frob-stream-sout stream) - #'case-frob-downcase-sout)) - (t - (funcall (stream-out target) target char))))) - -(defun case-frob-capitalize-first-sout (stream str start end) - (declare (type case-frob-stream stream) - (type simple-base-string str) - (type index start) - (type (or index null) end)) - (let* ((target (case-frob-stream-target stream)) - (str (subseq str start end)) - (len (length str))) - (dotimes (i len) - (let ((char (schar str i))) - (when (alphanumericp char) - (setf (schar str i) (char-upcase char)) - (do ((i (1+ i) (1+ i))) - ((= i len)) - (setf (schar str i) (char-downcase (schar str i)))) - (setf (case-frob-stream-out stream) - #'case-frob-downcase-out) - (setf (case-frob-stream-sout stream) - #'case-frob-downcase-sout) - (return)))) - (funcall (stream-sout target) target str 0 len))) - - - -;;;; Public interface from "EXTENSIONS" package. - -(in-package "EXT") - -(export '(get-stream-command stream-command stream-command-p stream-command-name - stream-command-args make-stream-command)) - -(defstruct (stream-command (:print-function print-stream-command) - (:constructor make-stream-command - (name &optional args))) - (name nil :type symbol) - (args nil :type list)) - -(defun print-stream-command (obj str n) - (declare (ignore n)) - (format str "#<Stream-Cmd ~S>" (stream-command-name obj))) - - -;;; GET-STREAM-COMMAND -- Public. -;;; -;;; We can't simply call the stream's misc method because because nil is an -;;; ambiguous return value: does it mean text arrived, or does it mean the -;;; stream's misc method had no :get-command implementation. We can't return -;;; nil until there is text input. We don't need to loop because any stream -;;; implementing :get-command would wait until it had some input. If the -;;; LISTEN fails, then we have some random stream we must wait on. -;;; -(defun get-stream-command (stream) - "This takes a stream and waits for text or a command to appear on it. If - text appears before a command, this returns nil, and otherwise it returns - a command." - (let ((cmdp (funcall (lisp::stream-misc stream) stream :get-command))) - (cond (cmdp) - ((listen stream) - nil) - (t - ;; This waits for input and returns nil when it arrives. - (unread-char (read-char stream) stream))))) diff --git a/code/string.lisp b/code/string.lisp deleted file mode 100644 index 03f3284c02ae00230fcbf1bab8328b33acf84aca..0000000000000000000000000000000000000000 --- a/code/string.lisp +++ /dev/null @@ -1,554 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;; -;;; ********************************************************************** -;;; 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/code/string.lisp,v 1.6 1992/05/15 17:50:40 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Functions to implement strings for Spice Lisp -;;; Written by David Dill -;;; Rewritten by Skef Wholey, Bill Chiles and Rob MacLachlan. -;;; -;;; Runs in the standard Spice Lisp environment. -;;; -;;; **************************************************************** -;;; -(in-package "LISP") -(export '(char schar string - string= string-equal string< string> string<= string>= string/= - string-lessp string-greaterp string-not-lessp string-not-greaterp - string-not-equal - make-string - string-trim string-left-trim string-right-trim - string-upcase - string-downcase string-capitalize nstring-upcase nstring-downcase - nstring-capitalize)) - - -(defun string (X) - "Coerces X into a string. If X is a string, X is returned. If X is a - symbol, X's pname is returned. If X is a character then a one element - string containing that character is returned. If X cannot be coerced - into a string, an error occurs." - (cond ((stringp x) x) - ((symbolp x) (symbol-name x)) - ((characterp x) - (let ((res (make-string 1))) - (setf (schar res 0) x) res)) - (t - (error "~S cannot be coerced to a string." x)))) - - -;;; With-One-String is used to set up some string hacking things. The keywords -;;; are parsed, and the string is hacked into a simple-string. - -(eval-when (compile) - -(defmacro with-one-string (string start end cum-offset &rest forms) - `(let ((,string (if (stringp ,string) ,string (string ,string)))) - (with-array-data ((,string ,string :offset-var ,cum-offset) - (,start ,start) - (,end (or ,end (length (the vector ,string))))) - ,@forms))) - -) - -;;; With-String is like With-One-String, but doesn't parse keywords. - -(eval-when (compile) - -(defmacro with-string (string &rest forms) - `(let ((,string (if (stringp ,string) ,string (string ,string)))) - (with-array-data ((,string ,string) - (start) - (end (length (the vector ,string)))) - ,@forms))) - -) - -;;; With-Two-Strings is used to set up string comparison operations. The -;;; keywords are parsed, and the strings are hacked into simple-strings. - -(eval-when (compile) - -(defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1 - start2 end2 &rest forms) - `(let ((,string1 (if (stringp ,string1) ,string1 (string ,string1))) - (,string2 (if (stringp ,string2) ,string2 (string ,string2)))) - (with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1) - (,start1 ,start1) - (,end1 (or ,end1 (length (the vector ,string1))))) - (with-array-data ((,string2 ,string2) - (,start2 ,start2) - (,end2 (or ,end2 (length (the vector ,string2))))) - ,@forms)))) - -) - - -(defun char (string index) - "Given a string and a non-negative integer index less than the length of - the string, returns the character object representing the character at - that position in the string." - (declare (optimize (safety 1))) - (char string index)) - -(defun %charset (string index new-el) - (declare (optimize (safety 1))) - (setf (char string index) new-el)) - -(defun schar (string index) - "SCHAR returns the character object at an indexed position in a string - just as CHAR does, except the string must be a simple-string." - (declare (optimize (safety 1))) - (schar string index)) - -(defun %scharset (string index new-el) - (declare (optimize (safety 1))) - (setf (schar string index) new-el)) - -(defun string=* (string1 string2 start1 end1 start2 end2) - (with-two-strings string1 string2 start1 end1 offset1 start2 end2 - (not (%sp-string-compare string1 start1 end1 string2 start2 end2)))) - - -(defun string/=* (string1 string2 start1 end1 start2 end2) - (with-two-strings string1 string2 start1 end1 offset1 start2 end2 - (let ((comparison (%sp-string-compare string1 start1 end1 - string2 start2 end2))) - (if comparison (- (the fixnum comparison) offset1))))) - -(eval-when (compile eval) - -;;; Lessp is true if the desired expansion is for string<* or string<=*. -;;; Equalp is true if the desired expansion is for string<=* or string>=*. -(defmacro string<>=*-body (lessp equalp) - (let ((offset1 (gensym))) - `(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2 - (let ((index (%sp-string-compare string1 start1 end1 - string2 start2 end2))) - (if index - (cond ((= (the fixnum index) - ,(if lessp `(the fixnum end1) `(the fixnum end2))) - (- (the fixnum index) ,offset1)) - ((= (the fixnum index) - ,(if lessp `(the fixnum end2) `(the fixnum end1))) - nil) - ((,(if lessp 'char< 'char>) - (schar string1 index) - (schar string2 (+ (the fixnum index) (- start2 start1)))) - (- (the fixnum index) ,offset1)) - (t nil)) - ,(if equalp `(- (the fixnum end1) ,offset1) 'nil)))))) -) ; eval-when - -(defun string<* (string1 string2 start1 end1 start2 end2) - (declare (fixnum start1 start2)) - (string<>=*-body t nil)) - -(defun string>* (string1 string2 start1 end1 start2 end2) - (declare (fixnum start1 start2)) - (string<>=*-body nil nil)) - -(defun string<=* (string1 string2 start1 end1 start2 end2) - (declare (fixnum start1 start2)) - (string<>=*-body t t)) - -(defun string>=* (string1 string2 start1 end1 start2 end2) - (declare (fixnum start1 start2)) - (string<>=*-body nil t)) - - - -(defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings, if the first string is lexicographically less than - the second string, returns the longest common prefix (using char=) - of the two strings. Otherwise, returns ()." - (string<* string1 string2 start1 end1 start2 end2)) - -(defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings, if the first string is lexicographically greater than - the second string, returns the longest common prefix (using char=) - of the two strings. Otherwise, returns ()." - (string>* string1 string2 start1 end1 start2 end2)) - - -(defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings, if the first string is lexicographically less than - or equal to the second string, returns the longest common prefix - (using char=) of the two strings. Otherwise, returns ()." - (string<=* string1 string2 start1 end1 start2 end2)) - -(defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings, if the first string is lexicographically greater - than or equal to the second string, returns the longest common prefix - (using char=) of the two strings. Otherwise, returns ()." - (string>=* string1 string2 start1 end1 start2 end2)) - -(defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings (string1 and string2), and optional integers start1, - start2, end1 and end2, compares characters in string1 to characters in - string2 (using char=)." - (string=* string1 string2 start1 end1 start2 end2)) - -(defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings, if the first string is not lexicographically equal - to the second string, returns the longest common prefix (using char=) - of the two strings. Otherwise, returns ()." - (string/=* string1 string2 start1 end1 start2 end2)) - - -(eval-when (compile eval) - -;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for -;;; STRING-EQUAL and STRING-NOT-EQUAL. -(defmacro string-not-equal-loop (end end-value - &optional (abort-value nil abortp)) - (declare (fixnum end)) - (let ((end-test (if (= end 1) - `(= index1 (the fixnum end1)) - `(= index2 (the fixnum end2))))) - `(do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2))) - (,(if abortp - end-test - `(or ,end-test - (not (char-equal (schar string1 index1) - (schar string2 index2))))) - ,end-value) - (declare (fixnum index1 index2)) - ,@(if abortp - `((if (not (char-equal (schar string1 index1) - (schar string2 index2))) - (return ,abort-value))))))) - -) ; eval-when - -(defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings (string1 and string2), and optional integers start1, - start2, end1 and end2, compares characters in string1 to characters in - string2 (using char-equal)." - (declare (fixnum start1 start2)) - (with-two-strings string1 string2 start1 end1 offset1 start2 end2 - (let ((slen1 (- (the fixnum end1) start1)) - (slen2 (- (the fixnum end2) start2))) - (declare (fixnum slen1 slen2)) - (if (or (minusp slen1) (minusp slen2)) - ;;prevent endless looping later. - (error "Improper bounds for string comparison.")) - (if (= slen1 slen2) - ;;return () immediately if lengths aren't equal. - (string-not-equal-loop 1 t nil))))) - -(defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings, if the first string is not lexicographically equal - to the second string, returns the longest common prefix (using char-equal) - of the two strings. Otherwise, returns ()." - (with-two-strings string1 string2 start1 end1 offset1 start2 end2 - (let ((slen1 (- end1 start1)) - (slen2 (- end2 start2))) - (declare (fixnum slen1 slen2)) - (if (or (minusp slen1) (minusp slen2)) - ;;prevent endless looping later. - (error "Improper bounds for string comparison.")) - (cond ((or (minusp slen1) (or (minusp slen2))) - (error "Improper substring for comparison.")) - ((= slen1 slen2) - (string-not-equal-loop 1 nil (- index1 offset1))) - ((< slen1 slen2) - (string-not-equal-loop 1 (- index1 offset1))) - (t - (string-not-equal-loop 2 (- index1 offset1))))))) - - - -(eval-when (compile eval) - -;;; STRING-LESS-GREATER-EQUAL-TESTS returns a test on the lengths of string1 -;;; and string2 and a test on the current characters from string1 and string2 -;;; for the following macro. -(defun string-less-greater-equal-tests (lessp equalp) - (if lessp - (if equalp - ;; STRING-NOT-GREATERP - (values '<= `(not (char-greaterp char1 char2))) - ;; STRING-LESSP - (values '< `(char-lessp char1 char2))) - (if equalp - ;; STRING-NOT-LESSP - (values '>= `(not (char-lessp char1 char2))) - ;; STRING-GREATERP - (values '> `(char-greaterp char1 char2))))) - -(defmacro string-less-greater-equal (lessp equalp) - (multiple-value-bind (length-test character-test) - (string-less-greater-equal-tests lessp equalp) - `(with-two-strings string1 string2 start1 end1 offset1 start2 end2 - (let ((slen1 (- (the fixnum end1) start1)) - (slen2 (- (the fixnum end2) start2))) - (declare (fixnum slen1 slen2)) - (if (or (minusp slen1) (minusp slen2)) - ;;prevent endless looping later. - (error "Improper bounds for string comparison.")) - (do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2)) - (char1) - (char2)) - ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2))) - (if (,length-test slen1 slen2) (- index1 offset1))) - (declare (fixnum index1 index2)) - (setq char1 (schar string1 index1)) - (setq char2 (schar string2 index2)) - (if (not (char-equal char1 char2)) - (if ,character-test - (return (- index1 offset1)) - (return ())))))))) - -) ; eval-when - -(defun string-lessp* (string1 string2 start1 end1 start2 end2) - (declare (fixnum start1 start2)) - (string-less-greater-equal t nil)) - -(defun string-greaterp* (string1 string2 start1 end1 start2 end2) - (declare (fixnum start1 start2)) - (string-less-greater-equal nil nil)) - -(defun string-not-lessp* (string1 string2 start1 end1 start2 end2) - (declare (fixnum start1 start2)) - (string-less-greater-equal nil t)) - -(defun string-not-greaterp* (string1 string2 start1 end1 start2 end2) - (declare (fixnum start1 start2)) - (string-less-greater-equal t t)) - -(defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings, if the first string is lexicographically less than - the second string, returns the longest common prefix (using char-equal) - of the two strings. Otherwise, returns ()." - (string-lessp* string1 string2 start1 end1 start2 end2)) - -(defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings, if the first string is lexicographically greater than - the second string, returns the longest common prefix (using char-equal) - of the two strings. Otherwise, returns ()." - (string-greaterp* string1 string2 start1 end1 start2 end2)) - -(defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2) - "Given two strings, if the first string is lexicographically greater - than or equal to the second string, returns the longest common prefix - (using char-equal) of the two strings. Otherwise, returns ()." - (string-not-lessp* string1 string2 start1 end1 start2 end2)) - -(defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0) - end2) - "Given two strings, if the first string is lexicographically less than - or equal to the second string, returns the longest common prefix - (using char-equal) of the two strings. Otherwise, returns ()." - (string-not-greaterp* string1 string2 start1 end1 start2 end2)) - - -(defun make-string (count &key ((:initial-element fill-char))) - "Given a character count and an optional fill character, makes and returns - a new string Count long filled with the fill character." - (declare (fixnum count)) - (if fill-char - (do ((i 0 (1+ i)) - (string (make-string count))) - ((= i count) string) - (declare (fixnum i)) - (setf (schar string i) fill-char)) - (make-string count))) - -(defun string-upcase (string &key (start 0) end) - "Given a string, returns a new string that is a copy of it with - all lower case alphabetic characters converted to uppercase." - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset)) - (newstring (make-string slen))) - (declare (fixnum offset-slen)) - (do ((index offset (1+ index)) - (new-index 0 (1+ new-index))) - ((= index start)) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) (schar string index))) - (do ((index start (1+ index)) - (new-index (- start offset) (1+ new-index))) - ((= index (the fixnum end))) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) - (char-upcase (schar string index)))) - (do ((index end (1+ index)) - (new-index (- (the fixnum end) offset) (1+ new-index))) - ((= index offset-slen)) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) (schar string index))) - newstring)))) - -(defun string-downcase (string &key (start 0) end) - "Given a string, returns a new string that is a copy of it with - all upper case alphabetic characters converted to lowercase." - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset)) - (newstring (make-string slen))) - (declare (fixnum offset-slen)) - (do ((index offset (1+ index)) - (new-index 0 (1+ new-index))) - ((= index start)) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) (schar string index))) - (do ((index start (1+ index)) - (new-index (- start offset) (1+ new-index))) - ((= index (the fixnum end))) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) - (char-downcase (schar string index)))) - (do ((index end (1+ index)) - (new-index (- (the fixnum end) offset) (1+ new-index))) - ((= index offset-slen)) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) (schar string index))) - newstring)))) - -(defun string-capitalize (string &key (start 0) end) - "Given a string, returns a copy of the string with the first - character of each ``word'' converted to upper-case, and remaining - chars in the word converted to lower case. A ``word'' is defined - to be a string of case-modifiable characters delimited by - non-case-modifiable chars." - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset)) - (newstring (make-string slen))) - (declare (fixnum offset-slen)) - (do ((index offset (1+ index)) - (new-index 0 (1+ new-index))) - ((= index start)) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) (schar string index))) - (do ((index start (1+ index)) - (new-index (- start offset) (1+ new-index)) - (newword t) - (char ())) - ((= index (the fixnum end))) - (declare (fixnum index new-index)) - (setq char (schar string index)) - (cond ((not (alphanumericp char)) - (setq newword t)) - (newword - ;;char is first case-modifiable after non-case-modifiable - (setq char (char-upcase char)) - (setq newword ())) - ;;char is case-modifiable, but not first - (t (setq char (char-downcase char)))) - (setf (schar newstring new-index) char)) - (do ((index end (1+ index)) - (new-index (- (the fixnum end) offset) (1+ new-index))) - ((= index offset-slen)) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) (schar string index))) - newstring)))) - -(defun nstring-upcase (string &key (start 0) end) - "Given a string, returns that string with all lower case alphabetic - characters converted to uppercase." - (declare (fixnum start)) - (let ((save-header string)) - (with-one-string string start end offset - (do ((index start (1+ index))) - ((= index (the fixnum end))) - (declare (fixnum index)) - (setf (schar string index) (char-upcase (schar string index))))) - save-header)) - -(defun nstring-downcase (string &key (start 0) end) - "Given a string, returns that string with all upper case alphabetic - characters converted to lowercase." - (declare (fixnum start)) - (let ((save-header string)) - (with-one-string string start end offset - (do ((index start (1+ index))) - ((= index (the fixnum end))) - (declare (fixnum index)) - (setf (schar string index) (char-downcase (schar string index))))) - save-header)) - -(defun nstring-capitalize (string &key (start 0) end) - "Given a string, returns that string with the first - character of each ``word'' converted to upper-case, and remaining - chars in the word converted to lower case. A ``word'' is defined - to be a string of case-modifiable characters delimited by - non-case-modifiable chars." - (declare (fixnum start)) - (let ((save-header string)) - (with-one-string string start end offset - (do ((index start (1+ index)) - (newword t) - (char ())) - ((= index (the fixnum end))) - (declare (fixnum index)) - (setq char (schar string index)) - (cond ((not (alphanumericp char)) - (setq newword t)) - (newword - ;;char is first case-modifiable after non-case-modifiable - (setf (schar string index) (char-upcase char)) - (setq newword ())) - (t - (setf (schar string index) (char-downcase char)))))) - save-header)) - -(defun string-left-trim (char-bag string) - "Given a set of characters (a list or string) and a string, returns - a copy of the string with the characters in the set removed from the - left end." - (with-string string - (do ((index start (1+ index))) - ((or (= index (the fixnum end)) - (not (find (schar string index) char-bag))) - (subseq (the simple-string string) index end)) - (declare (fixnum index))))) - -(defun string-right-trim (char-bag string) - "Given a set of characters (a list or string) and a string, returns - a copy of the string with the characters in the set removed from the - right end." - (with-string string - (do ((index (1- (the fixnum end)) (1- index))) - ((or (< index start) (not (find (schar string index) char-bag))) - (subseq (the simple-string string) start (1+ index))) - (declare (fixnum index))))) - -(defun string-trim (char-bag string) - "Given a set of characters (a list or string) and a string, returns a - copy of the string with the characters in the set removed from both - ends." - (with-string string - (let* ((left-end (do ((index start (1+ index))) - ((or (= index (the fixnum end)) - (not (find (schar string index) char-bag))) - index) - (declare (fixnum index)))) - (right-end (do ((index (1- (the fixnum end)) (1- index))) - ((or (< index left-end) - (not (find (schar string index) char-bag))) - (1+ index)) - (declare (fixnum index))))) - (subseq (the simple-string string) left-end right-end)))) diff --git a/code/sunos-os.lisp b/code/sunos-os.lisp deleted file mode 100644 index 6aa1901bf10dc117abffeb05145ac4d903dd27dc..0000000000000000000000000000000000000000 --- a/code/sunos-os.lisp +++ /dev/null @@ -1,82 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/sunos-os.lisp,v 1.6 1992/05/15 17:52:00 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; OS interface functions for CMU CL under Mach. From Miles Bader and David -;;; Axmark. -;;; -(in-package "SYSTEM") -(use-package "EXTENSIONS") -(export '(get-system-info get-page-size os-init)) - -(pushnew :sunos *features*) -(setq *software-type* "SunOS") - -(defconstant foreign-segment-start #x00C00000) ; ### Not right??? -(defconstant foreign-segment-size #x00400000) - -(defvar *software-version* nil "Version string for supporting software") -(defun software-version () - "Returns a string describing version of the supporting software." - (unless *software-version* - (setf *software-version* - (let ((version-line - (with-output-to-string (stream) - (run-program - "/bin/sh" - '("-c" "strings /vmunix|grep -i 'sunos release'") - :output stream - :pty nil - :error nil)))) - (let* ((first-space (position #\Space version-line)) - (second-space (position #\Space version-line - :start (1+ first-space))) - (third-space (position #\Space version-line - :start (1+ second-space)))) - (subseq version-line (1+ second-space) third-space))))) - *software-version*) - - -;;; OS-INIT -- interface. -;;; -;;; Other OS dependent initializations. -;;; -(defun os-init () - ;; Decache version on save, because it might not be the same when we restart. - (setq *software-version* nil)) - -;;; GET-SYSTEM-INFO -- Interface -;;; -;;; Return system time, user time and number of page faults. -;;; -(defun get-system-info () - (multiple-value-bind - (err? utime stime maxrss ixrss idrss isrss minflt majflt) - (unix:unix-getrusage unix:rusage_self) - (declare (ignore maxrss ixrss idrss isrss minflt)) - (cond ((null err?) - (error "Unix system call getrusage failed: ~A." - (unix:get-unix-error-msg utime))) - (T - (values utime stime majflt))))) - - -;;; GET-PAGE-SIZE -- Interface -;;; -;;; Return the system page size. -;;; -(defun get-page-size () - (multiple-value-bind (val err) - (unix:unix-getpagesize) - (unless val - (error "Getpagesize failed: ~A" (unix:get-unix-error-msg err))) - val)) diff --git a/code/symbol.lisp b/code/symbol.lisp deleted file mode 100644 index 47021277f60b8b67c86344533a26e4aacc95a165..0000000000000000000000000000000000000000 --- a/code/symbol.lisp +++ /dev/null @@ -1,228 +0,0 @@ -;;; -*- Log: code.log; Package: Lisp -*- -;;;; -;;; ********************************************************************** -;;; 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/code/symbol.lisp,v 1.13 1992/12/11 17:16:00 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Symbol manipulating functions for Spice Lisp. -;;; -;;; Written by Scott Fahlman. -;;; Hacked on and maintained by Skef Wholey. -;;; -;;; Many of these are trivial interpreter entries to functions -;;; open-coded by the compiler. -;;; -(in-package "LISP") -(export '(get remprop symbol-plist getf get-properties symbol-name - make-symbol copy-symbol gensym gentemp *gensym-counter* - symbol-package keywordp makunbound symbol-value symbol-function - boundp set)) - -(in-package "KERNEL") -(export '(%set-symbol-value %set-symbol-plist %set-symbol-package fset)) - -(in-package "LISP") - -(declaim (maybe-inline get %put getf remprop %putf get-properties keywordp)) - -(defun symbol-value (variable) - "VARIABLE must evaluate to a symbol. This symbol's current special - value is returned." - (declare (optimize (safety 1))) - (symbol-value variable)) - -(defun boundp (variable) - "VARIABLE must evaluate to a symbol. Return NIL if this symbol is - unbound, T if it has a value." - (boundp variable)) - -(defun set (variable new-value) - "VARIABLE must evaluate to a symbol. This symbol's special value cell is - set to the specified new value." - (declare (type symbol variable)) - (cond ((null variable) - (error "Nihil ex nihil, can't set NIL.")) - ((eq variable t) - (error "Veritas aeterna, can't set T.")) - ((and (boundp '*keyword-package*) - (keywordp variable)) - (error "Can't set keywords.")) - (t - (%set-symbol-value variable new-value)))) - -(defun %set-symbol-value (symbol new-value) - (%set-symbol-value symbol new-value)) - -(defun makunbound (variable) - "VARIABLE must evaluate to a symbol. This symbol is made unbound, - removing any value it may currently have." - (set variable - (%primitive make-other-immediate-type 0 vm:unbound-marker-type)) - variable) - -(defun symbol-function (variable) - "VARIABLE must evaluate to a symbol. This symbol's current definition - is returned. Settable with SETF." - (raw-definition variable)) - -(defun fset (symbol new-value) - (declare (type symbol symbol) (type function new-value)) - (setf (raw-definition symbol) new-value)) - - -(defun symbol-plist (variable) - "VARIABLE must evaluate to a symbol. Return its property list." - (symbol-plist variable)) - -(defun %set-symbol-plist (symbol new-value) - (setf (symbol-plist symbol) new-value)) - -(defun symbol-name (variable) - "VARIABLE must evaluate to a symbol. Return its print name." - (symbol-name variable)) - -(defun symbol-package (variable) - "VARIABLE must evaluate to a symbol. Return its package." - (symbol-package variable)) - -(defun %set-symbol-package (symbol package) - (declare (type symbol symbol)) - (%set-symbol-package symbol package)) - -(defun make-symbol (string) - "Make and return a new symbol with the STRING as its print name." - (make-symbol string)) - -(defun get (symbol indicator &optional (default nil)) - "Look on the property list of SYMBOL for the specified INDICATOR. If this - is found, return the associated value, else return DEFAULT." - (do ((pl (symbol-plist symbol) (cddr pl))) - ((atom pl) default) - (cond ((atom (cdr pl)) - (error "~S has an odd number of items in its property list." - symbol)) - ((eq (car pl) indicator) - (return (cadr pl)))))) - -(defun %put (symbol indicator value) - "The VALUE is added as a property of SYMBOL under the specified INDICATOR. - Returns VALUE." - (do ((pl (symbol-plist symbol) (cddr pl))) - ((endp pl) - (setf (symbol-plist symbol) - (list* indicator value (symbol-plist symbol))) - value) - (cond ((endp (cdr pl)) - (error "~S has an odd number of items in its property list." - symbol)) - ((eq (car pl) indicator) - (rplaca (cdr pl) value) - (return value))))) - -(defun remprop (symbol indicator) - "Look on property list of SYMBOL for property with specified - INDICATOR. If found, splice this indicator and its value out of - the plist, and return the tail of the original list starting with - INDICATOR. If not found, return () with no side effects." - (do ((pl (symbol-plist symbol) (cddr pl)) - (prev nil pl)) - ((atom pl) nil) - (cond ((atom (cdr pl)) - (error "~S has an odd number of items in its property list." - symbol)) - ((eq (car pl) indicator) - (cond (prev (rplacd (cdr prev) (cddr pl))) - (t - (setf (symbol-plist symbol) (cddr pl)))) - (return pl))))) - -(defun getf (place indicator &optional (default ())) - "Searches the property list stored in Place for an indicator EQ to Indicator. - If one is found, the corresponding value is returned, else the Default is - returned." - (do ((plist place (cddr plist))) - ((null plist) default) - (cond ((atom (cdr plist)) - (error "~S is a malformed property list." - place)) - ((eq (car plist) indicator) - (return (cadr plist)))))) - -(defun %putf (place property new-value) - (declare (type list place)) - (do ((plist place (cddr plist))) - ((endp plist) (list* property new-value place)) - (declare (type list plist)) - (when (eq (car plist) property) - (setf (cadr plist) new-value) - (return place)))) - - -(defun get-properties (place indicator-list) - "Like GETF, except that Indicator-List is a list of indicators which will - be looked for in the property list stored in Place. Three values are - returned, see manual for details." - (do ((plist place (cddr plist))) - ((null plist) (values nil nil nil)) - (cond ((atom (cdr plist)) - (error "~S is a malformed proprty list." - place)) - ((memq (car plist) indicator-list) - (return (values (car plist) (cadr plist) plist)))))) - -(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol) - "Make and return a new uninterned symbol with the same print name - as SYMBOL. If COPY-PROPS is null, the new symbol has no properties. - Else, it has a copy of SYMBOL's property list." - (setq new-symbol (make-symbol (symbol-name symbol))) - (if copy-props - (setf (symbol-plist new-symbol) (copy-list (symbol-plist symbol)))) - new-symbol) - -(proclaim '(special *keyword-package*)) - -(defun keywordp (object) - "Returns true if Object is a symbol in the keyword package." - (and (symbolp object) - (eq (symbol-package object) *keyword-package*))) - - -;;;; Gensym and friends. - -(defvar *gensym-counter* 0 - "Counter for generating unique GENSYM symbols.") - -(defun gensym (&optional string) - "Creates a new uninterned symbol whose name is a prefix string (defaults - to \"G\"), followed by a decimal number. String, when supplied, will - alter the prefix if it is a string, or the decimal number if it is a - number, of this symbol. The number, defaultly *gensym-counter*, is - incremented by each call to GENSYM." - (make-symbol - (concatenate 'simple-string - (if (stringp string) string "G") - (quick-integer-to-string - (if (integerp string) string (incf *gensym-counter*)))))) - -(defvar *gentemp-counter* 0) -(declaim (type index *gentemp-counter*)) - -(defun gentemp (&optional (prefix t) (package *package*)) - "Creates a new symbol interned in package Package with the given Prefix." - (loop - (let ((*print-base* 10) - (*print-radix* nil) - (*print-pretty* nil) - (new-pname (format nil "~A~D" - (string prefix) (incf *gentemp-counter*)))) - (multiple-value-bind (symbol existsp) - (find-symbol new-pname package) - (declare (ignore symbol)) - (unless existsp (return (values (intern new-pname package)))))))) diff --git a/code/time.lisp b/code/time.lisp deleted file mode 100644 index c7c8b2d0fdcabb99749fb6102c83173d9cae4ed7..0000000000000000000000000000000000000000 --- a/code/time.lisp +++ /dev/null @@ -1,387 +0,0 @@ -;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/time.lisp,v 1.13 1992/08/05 20:08:28 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the definitions for the Spice Lisp time functions. -;;; They are mostly fairly straightforwardly implemented as calls to the -;;; time server. -;;; -;;; Written by Rob MacLachlan. -;;; -(in-package 'lisp) -(export '(internal-time-units-per-second get-internal-real-time - get-internal-run-time get-universal-time - get-decoded-time encode-universal-time decode-universal-time)) - -(defconstant internal-time-units-per-second 100 - "The number of internal time units that fit into a second. See - Get-Internal-Real-Time and Get-Internal-Run-Time.") - -(defconstant micro-seconds-per-internal-time-unit - (/ 1000000 internal-time-units-per-second)) - - -(defmacro not-leap-year (year) - (let ((sym (gensym))) - `(let ((,sym ,year)) - (cond ((eq (mod ,sym 4) 0) - (and (eq (mod ,sym 100) 0) - (not (eq (mod ,sym 400) 0)))) - (T T))))) - - -;;; The base number of seconds for our internal "epoch". We initialize this to -;;; the time of the first call to G-I-R-T, and then subtract this out of the -;;; result. -;;; -(defvar *internal-real-time-base-seconds* nil) -(declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*)) - -;;; Get-Internal-Real-Time -- Public -;;; -(defun get-internal-real-time () - "Return the real time in the internal time format. This is useful for - finding elapsed time. See Internal-Time-Units-Per-Second." - (locally (declare (optimize (speed 3) (safety 0))) - (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday) - (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds)) - (let ((base *internal-real-time-base-seconds*) - (uint (truncate useconds - micro-seconds-per-internal-time-unit))) - (declare (type (unsigned-byte 32) uint)) - (cond (base - (truly-the (unsigned-byte 32) - (+ (the (unsigned-byte 32) - (* (the (unsigned-byte 32) (- seconds base)) - internal-time-units-per-second)) - uint))) - (t - (setq *internal-real-time-base-seconds* seconds) - uint)))))) - - -;;; Get-Internal-Run-Time -- Public -;;; -(defun get-internal-run-time () - "Return the run time in the internal time format. This is useful for - finding CPU usage." - (declare (values (unsigned-byte 32))) - (locally (declare (optimize (speed 3) (safety 0))) - (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec) - (unix:unix-fast-getrusage unix:rusage_self) - (declare (ignore ignore) - (type (unsigned-byte 31) utime-sec stime-sec) - (type (mod 1000000) utime-usec stime-usec)) - (+ (the (unsigned-byte 32) - (* (the (unsigned-byte 32) (+ utime-sec stime-sec)) - internal-time-units-per-second)) - (truncate (+ utime-usec stime-usec) - micro-seconds-per-internal-time-unit))))) - - -;;; Subtract from the returned Internal_Time to get the universal time. -;;; The offset between our time base and the Perq one is 2145 weeks and -;;; five days. -;;; -(defconstant seconds-in-week (* 60 60 24 7)) -(defconstant weeks-offset 2145) -(defconstant seconds-offset 432000) -(defconstant minutes-per-day (* 24 60)) -(defconstant quarter-days-per-year (1+ (* 365 4))) -(defconstant quarter-days-per-century 146097) -(defconstant november-17-1858 678882) -(defconstant weekday-november-17-1858 2) -(defconstant unix-to-universal-time 2208988800) - -;;; Make-Universal-Time -- Internal -;;; -;;; Convert a Unix Internal_Time into a universal time. -;;; -(defun make-universal-time (weeks msec) - (+ (* (- weeks weeks-offset) seconds-in-week) - (- (truncate msec 1000) seconds-offset))) - - -;;; Get-Universal-Time -- Public -;;; -;;; -(defun get-universal-time () - "Returns a single integer for the current time of - day in universal time format." - (multiple-value-bind (res secs) (unix:unix-gettimeofday) - (declare (ignore res)) - (+ secs unix-to-universal-time))) - -(defun get-decoded-time () - "Returns nine values specifying the current time as follows: - second, minute, hour, date, month, year, day of week (0 = Monday), T - (daylight savings times) or NIL (standard time), and timezone." - (decode-universal-time (get-universal-time))) - -(defun decode-universal-time (universal-time &optional time-zone) - "Converts a universal-time to decoded time format returning the following - nine values: second, minute, hour, date, month, year, day of week (0 = - Monday), T (daylight savings time) or NIL (standard time), and timezone. - Completely ignores daylight-savings-time when time-zone is supplied." - (declare (type (or fixnum null) time-zone)) - (multiple-value-bind (weeks secs) - (truncate (+ universal-time seconds-offset) - seconds-in-week) - (let ((weeks (+ weeks weeks-offset)) - (second NIL) - (minute NIL) - (hour NIL) - (date NIL) - (month NIL) - (year NIL) - (day NIL) - (daylight NIL) - (timezone (if (null time-zone) - (multiple-value-bind (res s us tz) - (unix:unix-gettimeofday) - (declare (ignore s us)) - (if res tz 0)) - (* time-zone 60)))) - (declare (fixnum timezone)) - (multiple-value-bind (t1 seconds) (truncate secs 60) - (setq second seconds) - (setq t1 (- t1 timezone)) - (let* ((tday (if (< t1 0) - (1- (truncate (1+ t1) minutes-per-day)) - (truncate t1 minutes-per-day)))) - (multiple-value-setq (hour minute) - (truncate (- t1 (* tday minutes-per-day)) 60)) - (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) - (tcent (truncate t2 quarter-days-per-century))) - (setq t2 (mod t2 quarter-days-per-century)) - (setq t2 (+ (- t2 (mod t2 4)) 3)) - (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year))) - (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year) - 4)))) - (setq day (mod (+ tday weekday-november-17-1858) 7)) - (unless time-zone - (if (setq daylight (dst-check days-since-mar0 hour day)) - (cond ((eq hour 23) - (setq hour 0) - (setq day (mod (1+ day) 7)) - (setq days-since-mar0 (1+ days-since-mar0)) - (if (>= days-since-mar0 366) - (if (or (> days-since-mar0 366) - (not-leap-year (1+ year))) - (setq days-since-mar0 368)))) - (T (setq hour (1+ hour)))))) - (let ((t3 (+ (* days-since-mar0 5) 456))) - (cond ((>= t3 1989) - (setq t3 (- t3 1836)) - (setq year (1+ year)))) - (multiple-value-setq (month t3) (truncate t3 153)) - (setq date (1+ (truncate t3 5)))))))) - (values second minute hour date month year day - daylight (truncate timezone 60))))) - -;;; Encode-Universal-Time -- Public -;;; -;;; Just do a TimeUser:T_UserToInt. If the year is between 0 and 99 we -;;; have to figure out which the "obvious" year is. -;;; - -(defun encode-universal-time (second minute hour date month year - &optional time-zone) - "The time values specified in decoded format are converted to - universal time, which is returned." - (let* ((year (if (< year 100) - (multiple-value-bind (sec min hour day month now-year) - (get-decoded-time) - (declare (ignore sec min hour day month)) - (do ((y (+ year (* 100 (1- (truncate now-year 100)))) - (+ y 100))) - ((<= (abs (- y now-year)) 50) y))) - year)) - (zone (if time-zone (* time-zone 60) - (multiple-value-bind (res s us tz) (unix:unix-gettimeofday) - (declare (ignore s us)) - (if res tz)))) - (tmonth (- month 3))) - (cond ((< tmonth 0) - (setq tmonth (+ tmonth 12)) - (setq year (1- year)))) - (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date))) - (multiple-value-bind (tcent tyear) (truncate year 100) - (let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4) - (truncate (* tyear quarter-days-per-year) 4) - days-since-mar0) - november-17-1858)) - (daylight (dst-check days-since-mar0 (1- hour) - (mod (+ tday weekday-november-17-1858) 7))) - (tminutes (+ (* hour 60) minute zone))) - (if daylight (setq tminutes (- tminutes 60))) - (do ((i tminutes (+ i minutes-per-day))) - ((>= i 0) (setq tminutes i)) - (declare (fixnum i)) - (decf tday 1)) - (do ((i tminutes (- i minutes-per-day))) - ((< i minutes-per-day) (setq tminutes i)) - (declare (fixnum i)) - (incf tday 1)) - (multiple-value-bind (weeks dpart) (truncate tday 7) - (make-universal-time weeks (* (+ (* (+ (* dpart minutes-per-day) - tminutes) 60) - second) 1000)))))))) - -;;; Dst-check -- Internal -(defconstant april-1 (+ (truncate (+ (* (- 4 3) 153) 2) 5) 1)) -(defconstant october-31 (+ (truncate (+ (* (- 10 3) 153) 2) 5) 31)) - -(eval-when (compile eval) - - (defmacro dst-check-start-of-month-ge (day hour weekday daybound) - (let ((d (gensym)) - (h (gensym)) - (w (gensym)) - (db (gensym))) - `(let ((,d ,day) - (,h ,hour) - (,w ,weekday) - (,db ,daybound)) - (declare (fixnum ,d ,h ,w ,db)) - (cond ((< ,d ,db) NIL) - ((> (the fixnum (- ,d ,w)) ,db) T) - ((and (eq ,w 6) (> ,h 0)) T) - (T NIL))))) - - (defmacro dst-check-end-of-month-ge (day hour weekday daybound) - (let ((d (gensym)) - (h (gensym)) - (w (gensym)) - (db (gensym))) - `(let ((,d ,day) - (,h ,hour) - (,w ,weekday) - (,db ,daybound)) - (declare (fixnum ,d ,h ,w ,db)) - (cond ((< (the fixnum (+ ,d 6)) ,db) NIL) - ((> (the fixnum (- (the fixnum (+ ,d 6)) ,w)) ,db) T) - ((and (eq ,w 6) (> ,h 0)) T) - (T NIL))))) - ) - -(defun dst-check (day hour weekday) - (and (dst-check-start-of-month-ge day hour weekday april-1) - (not (dst-check-end-of-month-ge day hour weekday october-31)))) - -;;;; Time: - -(defmacro time (form) - "Evaluates the Form and prints timing information on *Trace-Output*." - `(%time #'(lambda () ,form))) - -;;; MASSAGE-TIME-FUNCTION -- Internal -;;; -;;; Try to compile the closure arg to %TIME if it is interpreted. -;;; -(defun massage-time-function (fun) - (cond - ((eval:interpreted-function-p fun) - (multiple-value-bind (def env-p) - (function-lambda-expression fun) - (declare (ignore def)) - (cond - (env-p - (warn "TIME form in a non-null environment, forced to interpret.~@ - Compiling entire form will produce more accurate times.") - fun) - (t - (compile nil fun))))) - (t fun))) - -;;; TIME-GET-SYS-INFO -- Internal -;;; -;;; Return all the files that we want time to report. -;;; -(defun time-get-sys-info () - (multiple-value-bind (user sys faults) - (system:get-system-info) - (values user sys faults (get-bytes-consed)))) - -;;; %TIME -- Internal -;;; -;;; The guts of the TIME macro. Compute overheads, run the (compiled) -;;; function, report the times. -;;; -(defun %time (fun) - (let ((fun (massage-time-function fun)) - old-run-utime - new-run-utime - old-run-stime - new-run-stime - old-real-time - new-real-time - old-page-faults - new-page-faults - real-time-overhead - run-utime-overhead - run-stime-overhead - page-faults-overhead - old-bytes-consed - new-bytes-consed - cons-overhead) - ;; Calculate the overhead... - (multiple-value-setq - (old-run-utime old-run-stime old-page-faults old-bytes-consed) - (time-get-sys-info)) - ;; Do it a second time to make sure everything is faulted in. - (multiple-value-setq - (old-run-utime old-run-stime old-page-faults old-bytes-consed) - (time-get-sys-info)) - (multiple-value-setq - (new-run-utime new-run-stime new-page-faults new-bytes-consed) - (time-get-sys-info)) - (setq run-utime-overhead (- new-run-utime old-run-utime)) - (setq run-stime-overhead (- new-run-stime old-run-stime)) - (setq page-faults-overhead (- new-page-faults old-page-faults)) - (setq old-real-time (get-internal-real-time)) - (setq old-real-time (get-internal-real-time)) - (setq new-real-time (get-internal-real-time)) - (setq real-time-overhead (- new-real-time old-real-time)) - (setq cons-overhead (- new-bytes-consed old-bytes-consed)) - ;; Now get the initial times. - (multiple-value-setq - (old-run-utime old-run-stime old-page-faults old-bytes-consed) - (time-get-sys-info)) - (setq old-real-time (get-internal-real-time)) - (let ((start-gc-run-time *gc-run-time*)) - (multiple-value-prog1 - ;; Execute the form and return its values. - (funcall fun) - (multiple-value-setq - (new-run-utime new-run-stime new-page-faults new-bytes-consed) - (time-get-sys-info)) - (setq new-real-time (- (get-internal-real-time) real-time-overhead)) - (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0))) - (format *trace-output* - "~&Evaluation took:~% ~ - ~S second~:P of real time~% ~ - ~S second~:P of user run time~% ~ - ~S second~:P of system run time~% ~ - ~@[[Run times include ~S second~:P GC run time]~% ~]~ - ~S page fault~:P and~% ~ - ~S bytes consed.~%" - (max (/ (- new-real-time old-real-time) - (float internal-time-units-per-second)) - 0.0) - (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) - (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0) - (unless (zerop gc-run-time) - (/ (float gc-run-time) - (float internal-time-units-per-second))) - (max (- new-page-faults old-page-faults) 0) - (max (- new-bytes-consed old-bytes-consed) 0))))))) diff --git a/code/vm.lisp b/code/vm.lisp deleted file mode 100644 index b424e782b627fe1394b970d5d540a8d6aad1e5cf..0000000000000000000000000000000000000000 --- a/code/vm.lisp +++ /dev/null @@ -1,83 +0,0 @@ -;;; -*- Log: code.log; Package: MACH -*- -;;; -;;; ********************************************************************** -;;; 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/code/vm.lisp,v 1.2 1991/02/08 13:36:37 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/vm.lisp,v 1.2 1991/02/08 13:36:37 ram Exp $ -;;; -;;; This file contains stubs for interfacing MACH's vm primitives. -;;; -(in-package "MACH") - -(export '(vm_allocate vm_copy vm_deallocate vm_statistics)) - -(def-c-pointer *sap system-area-pointer) - - -(def-c-routine ("vm_allocate" vm_allocate) (int) - (task port) - (address *sap :in-out) - (size unsigned-long) - (anywhere boolean)) - -(def-c-routine ("vm_copy" vm_copy) (int) - (task port) - (source system-area-pointer) - (count unsigned-long) - (dest system-area-pointer)) - -(def-c-routine ("vm_deallocate" vm_deallocate) (int) - (task port) - (address system-area-pointer) - (size unsigned-long)) - - - - -;;;; vm_statistics - -(def-c-record vm_statistics - (pagesize long) - (free_count long) - (active_count long) - (inactive_count long) - (wire_count long) - (zero_fill_count long) - (reactivations long) - (pageins long) - (pageouts long) - (faults long) - (cow_faults long) - (lookups long) - (hits long)) - -(def-c-routine ("vm_statistics" %vm_statistics) (int) - (task port) - (vm_stats system-area-pointer)) - -(defun vm_statistics (task) - (with-stack-alien (vm_stats vm_statistics (c-sizeof 'vm_statistics)) - (values - (%vm_statistics task (alien-sap (alien-value vm_stats))) - (alien-access (vm_statistics-pagesize (alien-value vm_stats))) - (alien-access (vm_statistics-free_count (alien-value vm_stats))) - (alien-access (vm_statistics-active_count (alien-value vm_stats))) - (alien-access (vm_statistics-inactive_count (alien-value vm_stats))) - (alien-access (vm_statistics-wire_count (alien-value vm_stats))) - (alien-access (vm_statistics-zero_fill_count (alien-value vm_stats))) - (alien-access (vm_statistics-reactivations (alien-value vm_stats))) - (alien-access (vm_statistics-pageins (alien-value vm_stats))) - (alien-access (vm_statistics-pageouts (alien-value vm_stats))) - (alien-access (vm_statistics-faults (alien-value vm_stats))) - (alien-access (vm_statistics-cow_faults (alien-value vm_stats))) - (alien-access (vm_statistics-lookups (alien-value vm_stats))) - (alien-access (vm_statistics-hits (alien-value vm_stats)))))) - diff --git a/code/weak.lisp b/code/weak.lisp deleted file mode 100644 index 67e86647ee0e52954c68d3935a5c6072b16bd96d..0000000000000000000000000000000000000000 --- a/code/weak.lisp +++ /dev/null @@ -1,46 +0,0 @@ -;;; -*- Mode: Lisp; Package: EXTENSIONS; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/code/weak.lisp,v 1.2 1991/02/08 13:36:39 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/weak.lisp,v 1.2 1991/02/08 13:36:39 ram Exp $ -;;; -;;; Weak Pointer Support. -;;; -;;; Written by Christopher Hoover. -;;; - -(in-package "EXTENSIONS") - -(export '(weak-pointer weak-pointer-p make-weak-pointer weak-pointer-value)) - -(defun make-weak-pointer (object) - "Allocates and returns a weak pointer which points to OBJECT." - (c::%make-weak-pointer object nil)) - -(defun weak-pointer-value (weak-pointer) - "If WEAK-POINTER is valid, returns the value of WEAK-POINTER and T. - If the referent of WEAK-POINTER has been garbage collected, returns - the values NIL and NIL. The value may be set with SETF." - (declare (type weak-pointer weak-pointer)) - (without-gcing - (let ((value (c::%weak-pointer-value weak-pointer)) - (broken (c::%weak-pointer-broken weak-pointer))) - (values value (not broken))))) - -(defun set-weak-pointer-value (weak-pointer new-value) - (declare (type weak-pointer weak-pointer)) - (without-gcing - (setf (c::%weak-pointer-value weak-pointer) new-value) - (setf (c::%weak-pointer-broken weak-pointer) nil) - new-value)) - -(defsetf weak-pointer-value set-weak-pointer-value) diff --git a/code/wire.lisp b/code/wire.lisp deleted file mode 100644 index d7daa7512f78e24d0fab05007e9e62c13d325300..0000000000000000000000000000000000000000 --- a/code/wire.lisp +++ /dev/null @@ -1,668 +0,0 @@ -;;; -*- Log: code.log; Package: wire -*- -;;; -;;; ********************************************************************** -;;; 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/code/wire.lisp,v 1.9 1992/05/15 17:51:43 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains an interface to internet domain sockets. -;;; -;;; Written by William Lott. -;;; - -(in-package "WIRE") - -(export '(remote-object-p remote-object - remote-object-local-p remote-object-eq - remote-object-value make-remote-object forget-remote-translation - make-wire wire-p wire-fd wire-listen wire-get-byte wire-get-number - wire-get-string wire-get-object wire-force-output wire-output-byte - wire-output-number wire-output-string wire-output-object - wire-output-funcall wire-error wire-eof wire-io-error - *current-wire* wire-get-bignum wire-output-bignum)) - - -(eval-when (compile load eval) ;For macros in remote.lisp. - -(defconstant buffer-size 2048) - -(defconstant initial-cache-size 16) - -(defconstant funcall0-op 0) -(defconstant funcall1-op 1) -(defconstant funcall2-op 2) -(defconstant funcall3-op 3) -(defconstant funcall4-op 4) -(defconstant funcall5-op 5) -(defconstant funcall-op 6) -(defconstant number-op 7) -(defconstant string-op 8) -(defconstant symbol-op 9) -(defconstant save-op 10) -(defconstant lookup-op 11) -(defconstant remote-op 12) -(defconstant cons-op 13) -(defconstant bignum-op 14) - -) ;eval-when - - -(defvar *current-wire* nil - "The wire the form we are currently evaluating came across.") - -(defvar *this-host* nil - "Unique identifier for this host.") -(defvar *this-pid* nil - "Unique identifier for this process.") - -(defvar *object-to-id* (make-hash-table :test 'eq) - "Hash table mapping local objects to the corresponding remote id.") -(defvar *id-to-object* (make-hash-table :test 'eql) - "Hash table mapping remote id's to the curresponding local object.") -(defvar *next-id* 0 - "Next available id for remote objects.") - - -(defstruct (wire - (:constructor make-wire (fd)) - (:print-function - (lambda (wire stream depth) - (declare (ignore depth)) - (format stream - "#<wire fd=~a>" - (wire-fd wire))))) - fd - - (ibuf (make-string buffer-size)) - (ibuf-offset 0) - (ibuf-end 0) - (object-cache (make-array initial-cache-size)) - - (obuf (make-string buffer-size)) - (obuf-end 0) - (cache-index 0) - (object-hash (make-hash-table :test 'eq))) - -(defstruct (remote-object - (:constructor %make-remote-object (host pid id)) - (:print-function - (lambda (obj stream depth) - (declare (ignore depth)) - (format stream "#<Remote Object: [~x:~a] ~s>" - (remote-object-host obj) - (remote-object-pid obj) - (remote-object-id obj))))) - host - pid - id) - -(define-condition wire-error (error) - (wire) - (:report (lambda (condition stream) - (format stream "There is a problem with ~A." - (wire-error-wire condition))))) - -(define-condition wire-eof (wire-error) - () - (:report (lambda (condition stream) - (format stream "Recieved EOF on ~A." - (wire-eof-wire condition))))) - -(define-condition wire-io-error (wire-error) - ((when :init-form "using") - (msg :init-form "Failed.")) - (:report (lambda (condition stream) - (format stream "Error ~A ~A: ~A." - (wire-io-error-when condition) - (wire-io-error-wire condition) - (wire-io-error-msg condition))))) - - -;;; Remote Object Randomness - -;;; REMOTE-OBJECT-LOCAL-P -- public -;;; -;;; First, make sure the *this-host* and *this-pid* are set. Then test to -;;; see if the remote object's host and pid fields are *this-host* and -;;; *this-pid* - -(defun remote-object-local-p (remote) - "Returns T iff the given remote object is defined locally." - (declare (type remote-object remote)) - (unless *this-host* - (setf *this-host* (unix:unix-gethostid)) - (setf *this-pid* (unix:unix-getpid))) - (and (eql (remote-object-host remote) *this-host*) - (eql (remote-object-pid remote) *this-pid*))) - -;;; REMOTE-OBJECT-EQ -- public -;;; -;;; Remote objects are considered EQ if they refer to the same object, ie -;;; Their host, pid, and id fields are the same (eql, cause they are all -;;; numbers). - -(defun remote-object-eq (remote1 remote2) - "Returns T iff the two objects refer to the same (eq) object in the same - process." - (declare (type remote-object remote1 remote2)) - (and (eql (remote-object-host remote1) - (remote-object-host remote2)) - (eql (remote-object-pid remote1) - (remote-object-pid remote2)) - (eql (remote-object-id remote1) - (remote-object-id remote2)))) - -;;; REMOTE-OBJECT-VALUE --- public -;;; -;;; First assure that the remote object is defined locally. If so, look up -;;; the id in *id-to-objects*. -;;; table. This will only happen if FORGET-REMOTE-TRANSLATION has been called -;;; on the local object. - -(defun remote-object-value (remote) - "Return the associated value for the given remote object. It is an error if - the remote object was not created in this process or if - FORGET-REMOTE-TRANSLATION has been called on this remote object." - (declare (type remote-object remote)) - (unless (remote-object-local-p remote) - (error "~S is defined is a different process." remote)) - (multiple-value-bind - (value found) - (gethash (remote-object-id remote) - *id-to-object*) - (unless found - (cerror - "Use the value of NIL" - "No value for ~S -- FORGET-REMOTE-TRANSLATION was called to early." - remote)) - value)) - -;;; MAKE-REMOTE-OBJECT --- public -;;; -;;; Convert the given local object to a remote object. If the local object is -;;; alread entered in the *object-to-id* hash table, just use the old id. -;;; Otherwise, grab the next id and put add both mappings to the two hash -;;; tables. - -(defun make-remote-object (local) - "Convert the given local object to a remote object." - (unless *this-host* - (setf *this-host* (unix:unix-gethostid)) - (setf *this-pid* (unix:unix-getpid))) - (let ((id (gethash local *object-to-id*))) - (unless id - (setf id *next-id*) - (setf (gethash local *object-to-id*) id) - (setf (gethash id *id-to-object*) local) - (incf *next-id*)) - (%make-remote-object *this-host* *this-pid* id))) - -;;; FORGET-REMOTE-TRANSLATION -- public -;;; -;;; Remove any translation information about the given object. If there is -;;; currenlt no translation for the object, don't bother doing anything. -;;; Otherwise remove it from the *object-to-id* hashtable, and remove the id -;;; from the *id-to-object* hashtable. - -(defun forget-remote-translation (local) - "Forget the translation from the given local to the corresponding remote -object. Passing that remote object to remote-object-value will new return NIL." - (let ((id (gethash local *object-to-id*))) - (when id - (remhash local *object-to-id*) - (remhash id *id-to-object*))) - (values)) - - -;;; Wire input routeins. - -;;; WIRE-LISTEN -- public -;;; -;;; If nothing is in the current input buffer, select on the file descriptor. - -(defun wire-listen (wire) - "Return T iff anything is in the input buffer or available on the socket." - (or (< (wire-ibuf-offset wire) - (wire-ibuf-end wire)) - (multiple-value-bind - (number error) - (unix:unix-select (1+ (wire-fd wire)) - (ash 1 (wire-fd wire)) - 0 - 0 - 0) - (unless number - (error 'wire-io-error - :wire wire - :when "listening to" - :msg (unix:get-unix-error-msg error))) - (not (zerop number))))) - - -;;; FILL-INPUT-BUFFER -- Internal -;;; -;;; Fill the input buffer from the socket. If we get an error reading, signal -;;; a wire-io-error. If we get an EOF, signal a wire-eof error. If we get any -;;; data, set the ibuf-end index. - -(defun fill-input-buffer (wire) - "Read data off the socket, filling the input buffer. The buffer is cleared -first. If fill-input-buffer returns, it is guarenteed that there will be at -least one byte in the input buffer. If EOF was reached, as wire-eof error -is signaled." - (setf (wire-ibuf-offset wire) 0 - (wire-ibuf-end wire) 0) - (let ((fd (wire-fd wire)) - (ibuf (wire-ibuf wire))) - (unless ibuf - (error 'wire-eof :wire wire)) - - (multiple-value-bind - (bytes error) - (system:without-gcing - (unix:unix-read fd (system:vector-sap ibuf) buffer-size)) - (cond ((null bytes) - (error 'wire-io-error - :wire wire - :when "reading" - :msg (unix:get-unix-error-msg error))) - ((zerop bytes) - (setf (wire-ibuf wire) nil) - (error 'wire-eof :wire wire)) - (t - (setf (wire-ibuf-end wire) bytes))))) - (values)) - -;;; WIRE-GET-BYTE -- public -;;; -;;; Check to see if there is anything in the input buffer. If not, use -;;; FILL-INPUT-BUFFER to get something. Return the next byte, adjusting -;;; the input offset index. - -(defun wire-get-byte (wire) - "Return the next byte from the wire." - (when (<= (wire-ibuf-end wire) - (wire-ibuf-offset wire)) - (fill-input-buffer wire)) - (prog1 - (char-int (schar (wire-ibuf wire) - (wire-ibuf-offset wire))) - (incf (wire-ibuf-offset wire)))) - -;;; WIRE-GET-NUMBER -- public -;;; -;;; Just read four bytes and pack them together with normal math ops. - -(defun wire-get-number (wire &optional (signed t)) - "Read a number off the wire. Numbers are 4 bytes in network order. -The optional argument controls weather or not the number should be considered -signed (defaults to T)." - (let* ((b1 (wire-get-byte wire)) - (b2 (wire-get-byte wire)) - (b3 (wire-get-byte wire)) - (b4 (wire-get-byte wire)) - (unsigned - (+ b4 (* 256 (+ b3 (* 256 (+ b2 (* 256 b1)))))))) - (if (and signed (> b1 127)) - (logior (ash -1 32) unsigned) - unsigned))) - -;;; WIRE-GET-BIGNUM -- public -;;; -;;; Extracts a number, which might be a bignum. -;;; -(defun wire-get-bignum (wire) - "Reads an arbitrary integer sent by WIRE-OUTPUT-BIGNUM from the wire and - return it." - (let ((count-and-sign (wire-get-number wire))) - (do ((count (abs count-and-sign) (1- count)) - (result 0 (+ (ash result 32) (wire-get-number wire nil)))) - ((not (plusp count)) - (if (minusp count-and-sign) - (- result) - result))))) - -;;; WIRE-GET-STRING -- public -;;; -;;; Use WIRE-GET-NUMBER to read the length, then keep pulling stuff out of -;;; the input buffer and re-filling it with FILL-INPUT-BUFFER until we've read -;;; the entire string. - -(defun wire-get-string (wire) - "Reads a string from the wire. The first four bytes spec the size." - (let* ((length (wire-get-number wire)) - (result (make-string length)) - (offset 0) - (ibuf (wire-ibuf wire))) - (declare (simple-string result ibuf) - (integer length offset)) - (loop - (let ((avail (- (wire-ibuf-end wire) - (wire-ibuf-offset wire)))) - (declare (integer avail)) - (cond ((<= length avail) - (replace result - ibuf - :start1 offset - :start2 (wire-ibuf-offset wire)) - (incf (wire-ibuf-offset wire) length) - (return nil)) - ((zerop avail) - (fill-input-buffer wire)) - (t - (replace result - ibuf - :start1 offset - :start2 (wire-ibuf-offset wire) - :end2 (wire-ibuf-end wire)) - (incf offset avail) - (decf length avail) - (incf (wire-ibuf-offset wire) avail))))) - result)) - -;;; WIRE-GET-OBJECT -- public -;;; -;;; First, read a byte to determine the type of the object to read. Then, -;;; depending on the type, call WIRE-GET-NUMBER, WIRE-GET-STRING, or whatever -;;; to read the necessary data. Note, funcall objects are funcalled. - -(defun wire-get-object (wire) - "Reads the next object from the wire and returns it." - (let ((identifier (wire-get-byte wire)) - (*current-wire* wire)) - (declare (fixnum identifier)) - (cond ((eql identifier lookup-op) - (let ((index (wire-get-number wire)) - (cache (wire-object-cache wire))) - (declare (integer index)) - (declare (simple-vector cache)) - (when (< index (length cache)) - (svref cache index)))) - ((eql identifier number-op) - (wire-get-number wire)) - ((eql identifier bignum-op) - (wire-get-bignum wire)) - ((eql identifier string-op) - (wire-get-string wire)) - ((eql identifier symbol-op) - (let* ((symbol-name (wire-get-string wire)) - (package-name (wire-get-string wire)) - (package (find-package package-name))) - (unless package - (error "Attempt to read symbol, ~A, of wire into non-existent ~ - package, ~A." - symbol-name package-name)) - (intern symbol-name package))) - ((eql identifier cons-op) - (cons (wire-get-object wire) - (wire-get-object wire))) - ((eql identifier remote-op) - (let ((host (wire-get-number wire nil)) - (pid (wire-get-number wire)) - (id (wire-get-number wire))) - (%make-remote-object host pid id))) - ((eql identifier save-op) - (let ((index (wire-get-number wire)) - (cache (wire-object-cache wire))) - (declare (integer index)) - (declare (simple-vector cache)) - (when (>= index (length cache)) - (do ((newsize (* (length cache) 2) - (* newsize 2))) - ((< index newsize) - (let ((newcache (make-array newsize))) - (declare (simple-vector newcache)) - (replace newcache cache) - (setf cache newcache) - (setf (wire-object-cache wire) cache))))) - (setf (svref cache index) - (wire-get-object wire)))) - ((eql identifier funcall0-op) - (funcall (wire-get-object wire))) - ((eql identifier funcall1-op) - (funcall (wire-get-object wire) - (wire-get-object wire))) - ((eql identifier funcall2-op) - (funcall (wire-get-object wire) - (wire-get-object wire) - (wire-get-object wire))) - ((eql identifier funcall3-op) - (funcall (wire-get-object wire) - (wire-get-object wire) - (wire-get-object wire) - (wire-get-object wire))) - ((eql identifier funcall4-op) - (funcall (wire-get-object wire) - (wire-get-object wire) - (wire-get-object wire) - (wire-get-object wire) - (wire-get-object wire))) - ((eql identifier funcall5-op) - (funcall (wire-get-object wire) - (wire-get-object wire) - (wire-get-object wire) - (wire-get-object wire) - (wire-get-object wire) - (wire-get-object wire))) - ((eql identifier funcall-op) - (let ((arg-count (wire-get-byte wire)) - (function (wire-get-object wire)) - (args '()) - (last-cons nil) - (this-cons nil)) - (loop - (when (zerop arg-count) - (return nil)) - (setf this-cons (cons (wire-get-object wire) - nil)) - (if (null last-cons) - (setf args this-cons) - (setf (cdr last-cons) this-cons)) - (setf last-cons this-cons) - (decf arg-count)) - (apply function args)))))) - - -;;; Wire output routines. - -;;; WRITE-STUFF -- internal -;;; -;;; Slightly better interface to unix:unix-write. Choaks on errors. - -(defmacro write-stuff (fd string-form &optional end) - (let ((string (gensym)) - (length (gensym)) - (result (gensym)) - (error (gensym))) - `(let* ((,string ,string-form) - ,@(unless end - `((,length (length ,string))))) - (multiple-value-bind - (,result ,error) - (unix:unix-write ,fd ,string 0 ,(or end length)) - (cond ((null ,result) - (error 'wire-io-error - :wire wire - :when "writing" - :msg (unix:get-unix-error-msg ,error))) - ((eql ,result ,(or end length)) - ) - (t - (error 'wire-io-error - :wire wire - :when "writing" - :msg "Not everything wrote."))))))) - -;;; WIRE-FORCE-OUTPUT -- internal -;;; -;;; Output any stuff remaining in the output buffer. - -(defun wire-force-output (wire) - "Send any info still in the output buffer down the wire and clear it. Nothing -harmfull will happen if called when the output buffer is empty." - (unless (zerop (wire-obuf-end wire)) - (write-stuff (wire-fd wire) - (wire-obuf wire) - (wire-obuf-end wire)) - (setf (wire-obuf-end wire) 0)) - (values)) - -;;; WIRE-OUTPUT-BYTE -- public -;;; -;;; Stick the byte in the output buffer. If there is no space, flush the -;;; buffer using WIRE-FORCE-OUTPUT. - -(defun wire-output-byte (wire byte) - "Output the given (8-bit) byte on the wire." - (declare (integer byte)) - (let ((fill-pointer (wire-obuf-end wire)) - (obuf (wire-obuf wire))) - (when (>= fill-pointer (length obuf)) - (wire-force-output wire) - (setf fill-pointer 0)) - (setf (schar obuf fill-pointer) - (code-char byte)) - (setf (wire-obuf-end wire) (1+ fill-pointer))) - (values)) - -;;; WIRE-OUTPUT-NUMBER -- public -;;; -;;; Output the number. Note, we don't care if the number is signed or not, -;;; because we just crank out the low 32 bits. -;;; -(defun wire-output-number (wire number) - "Output the given (32-bit) number on the wire." - (declare (integer number)) - (wire-output-byte wire (+ 0 (ldb (byte 8 24) number))) - (wire-output-byte wire (ldb (byte 8 16) number)) - (wire-output-byte wire (ldb (byte 8 8) number)) - (wire-output-byte wire (ldb (byte 8 0) number)) - (values)) - -;;; WIRE-OUTPUT-BIGNUM -- public -;;; -;;; Output an arbitrary integer. -;;; -(defun wire-output-bignum (wire number) - "Outputs an arbitrary integer, but less effeciently than WIRE-OUTPUT-NUMBER." - (do ((digits 0 (1+ digits)) - (remaining (abs number) (ash remaining -32)) - (words nil (cons (ldb (byte 32 0) remaining) words))) - ((zerop remaining) - (wire-output-number wire - (if (minusp number) - (- digits) - digits)) - (dolist (word words) - (wire-output-number wire word))))) - -;;; WIRE-OUTPUT-STRING -- public -;;; -;;; Output the string. Strings are represented by the length as a number, -;;; followed by the bytes of the string. -;;; -(defun wire-output-string (wire string) - "Output the given string. First output the length using WIRE-OUTPUT-NUMBER, -then output the bytes." - (declare (simple-string string)) - (let ((length (length string))) - (declare (integer length)) - (wire-output-number wire length) - (let* ((obuf (wire-obuf wire)) - (obuf-end (wire-obuf-end wire)) - (available (- (length obuf) - obuf-end))) - (declare (simple-string obuf) - (integer available)) - (cond ((>= available length) - (replace obuf string - :start1 obuf-end) - (incf (wire-obuf-end wire) length)) - ((> length (length obuf)) - (wire-force-output wire) - (write-stuff (wire-fd wire) - string)) - (t - (wire-force-output wire) - (replace obuf string) - (setf (wire-obuf-end wire) length))))) - (values)) - -;;; WIRE-OUTPUT-OBJECT -- public -;;; -;;; Output the given object. If the optional argument is non-nil, cache -;;; the object to enhance the performance of sending it multiple times. -;;; Caching defaults to yes for symbols, and nil for everything else. - -(defun wire-output-object (wire object &optional (cache-it (symbolp object))) - "Output the given object on the given wire. If cache-it is T, enter this -object in the cache for future reference." - (let ((cache-index (gethash object - (wire-object-hash wire)))) - (cond - (cache-index - (wire-output-byte wire lookup-op) - (wire-output-number wire cache-index)) - (t - (when cache-it - (wire-output-byte wire save-op) - (let ((index (wire-cache-index wire))) - (wire-output-number wire index) - (setf (gethash object (wire-object-hash wire)) - index) - (setf (wire-cache-index wire) (1+ index)))) - (typecase object - (integer - (cond ((typep object '(signed-byte 32)) - (wire-output-byte wire number-op) - (wire-output-number wire object)) - (t - (wire-output-byte wire bignum-op) - (wire-output-bignum wire object)))) - (simple-string - (wire-output-byte wire string-op) - (wire-output-string wire object)) - (symbol - (wire-output-byte wire symbol-op) - (wire-output-string wire (symbol-name object)) - (wire-output-string wire (package-name (symbol-package object)))) - (cons - (wire-output-byte wire cons-op) - (wire-output-object wire (car object)) - (wire-output-object wire (cdr object))) - (remote-object - (wire-output-byte wire remote-op) - (wire-output-number wire (remote-object-host object)) - (wire-output-number wire (remote-object-pid object)) - (wire-output-number wire (remote-object-id object))) - (t - (error "Error: Cannot output objects of type ~s across a wire." - (type-of object))))))) - (values)) - -;;; WIRE-OUTPUT-FUNCALL -- public -;;; -;;; Send the funcall down the wire. Arguments are evaluated locally in the -;;; lexical environment of the WIRE-OUTPUT-FUNCALL. - -(defmacro wire-output-funcall (wire-form function &rest args) - "Send the function and args down the wire as a funcall." - (let ((num-args (length args)) - (wire (gensym))) - `(let ((,wire ,wire-form)) - ,@(if (> num-args 5) - `((wire-output-byte ,wire funcall-op) - (wire-output-byte ,wire ,num-args)) - `((wire-output-byte ,wire ,(+ funcall0-op num-args)))) - (wire-output-object ,wire ,function) - ,@(mapcar #'(lambda (arg) - `(wire-output-object ,wire ,arg)) - args) - (values)))) - diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp deleted file mode 100644 index 8bd0360c6a82d5b6373a03b95e348276d405a0c8..0000000000000000000000000000000000000000 --- a/compiler/aliencomp.lisp +++ /dev/null @@ -1,701 +0,0 @@ -;;; -*- Log: C.Log; Package: C -*- -;;; -;;; ********************************************************************** -;;; 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/aliencomp.lisp,v 1.21 1992/03/22 23:47:05 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains transforms and other stuff used to compile Alien -;;; operations. -;;; -;;; Rewritten once again, this time by William Lott and Rob MacLachlan. -;;; -(in-package "C") -(use-package "ALIEN") -(use-package "SYSTEM") - -(export '(%alien-funcall)) - - -;;;; defknowns - -(defknown %sap-alien (system-area-pointer alien-type) alien-value - (flushable movable)) -(defknown alien-sap (alien-value) system-area-pointer - (flushable movable)) - -(defknown slot (alien-value symbol) t - (flushable recursive)) -(defknown %set-slot (alien-value symbol t) t - (recursive)) -(defknown %slot-addr (alien-value symbol) (alien (* t)) - (flushable movable recursive)) - -(defknown deref (alien-value &rest index) t - (flushable)) -(defknown %set-deref (alien-value t &rest index) t - ()) -(defknown %deref-addr (alien-value &rest index) (alien (* t)) - (flushable movable)) - -(defknown %heap-alien (heap-alien-info) t - (flushable)) -(defknown %set-heap-alien (heap-alien-info t) t - ()) -(defknown %heap-alien-addr (heap-alien-info) (alien (* t)) - (flushable movable)) - -(defknown make-local-alien (local-alien-info) t - ()) -(defknown note-local-alien-type (local-alien-info t) null - ()) -(defknown local-alien (local-alien-info t) t - (flushable)) -(defknown %local-alien-forced-to-memory-p (local-alien-info) (member t nil) - (movable)) -(defknown %set-local-alien (local-alien-info t t) t - ()) -(defknown %local-alien-addr (local-alien-info t) (alien (* t)) - (flushable movable)) -(defknown dispose-local-alien (local-alien-info t) t - ()) - -(defknown %cast (alien-value alien-type) alien - (flushable movable)) - -(defknown naturalize (t alien-type) alien - (flushable movable)) -(defknown deport (alien alien-type) t - (flushable movable)) -(defknown extract-alien-value (system-area-pointer index alien-type) t - (flushable)) -(defknown deposit-alien-value (system-area-pointer index alien-type t) t - ()) - -(defknown alien-funcall (alien-value &rest *) * - (any recursive)) -(defknown %alien-funcall (system-area-pointer alien-type &rest *) *) - - -;;;; Cosmetic transforms. - -(deftransform slot ((object slot) - ((alien (* t)) symbol)) - '(slot (deref object) slot)) - -(deftransform %set-slot ((object slot value) - ((alien (* t)) symbol t)) - '(%set-slot (deref object) slot value)) - -(deftransform %slot-addr ((object slot) - ((alien (* t)) symbol)) - '(%slot-addr (deref object) slot)) - - -;;;; SLOT support - -(defun find-slot-offset-and-type (alien slot) - (unless (constant-continuation-p slot) - (give-up "Slot is not constant, so cannot open code access.")) - (let ((type (continuation-type alien))) - (unless (alien-type-type-p type) - (give-up)) - (let ((alien-type (alien-type-type-alien-type type))) - (unless (alien-record-type-p alien-type) - (give-up)) - (let* ((slot-name (continuation-value slot)) - (field (find slot-name (alien-record-type-fields alien-type) - :key #'alien-record-field-name))) - (unless field - (abort-transform "~S doesn't have a slot named ~S" alien slot-name)) - (values (alien-record-field-offset field) - (alien-record-field-type field)))))) - -#+nil ;; Shouldn't be necessary. -(defoptimizer (slot derive-type) ((alien slot)) - (block nil - (catch 'give-up - (multiple-value-bind (slot-offset slot-type) - (find-slot-offset-and-type alien slot) - (declare (ignore slot-offset)) - (return (make-alien-type-type slot-type)))) - *wild-type*)) - -(deftransform slot ((alien slot) * * :important t) - (multiple-value-bind (slot-offset slot-type) - (find-slot-offset-and-type alien slot) - `(extract-alien-value (alien-sap alien) - ,slot-offset - ',slot-type))) - -#+nil ;; ### But what about coersions? -(defoptimizer (%set-slot derive-type) ((alien slot value)) - (block nil - (catch 'give-up - (multiple-value-bind (slot-offset slot-type) - (find-slot-offset-and-type alien slot) - (declare (ignore slot-offset)) - (let ((type (make-alien-type-type slot-type))) - (assert-continuation-type value type) - (return type)))) - *wild-type*)) - -(deftransform %set-slot ((alien slot value) * * :important t) - (multiple-value-bind (slot-offset slot-type) - (find-slot-offset-and-type alien slot) - `(deposit-alien-value (alien-sap alien) - ,slot-offset - ',slot-type - value))) - -(defoptimizer (%slot-addr derive-type) ((alien slot)) - (block nil - (catch 'give-up - (multiple-value-bind (slot-offset slot-type) - (find-slot-offset-and-type alien slot) - (declare (ignore slot-offset)) - (return (make-alien-type-type - (make-alien-pointer-type :to slot-type))))) - *wild-type*)) - -(deftransform %slot-addr ((alien slot) * * :important t) - (multiple-value-bind (slot-offset slot-type) - (find-slot-offset-and-type alien slot) - `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset vm:byte-bits)) - ',(make-alien-pointer-type :to slot-type)))) - - - -;;;; DEREF support. - -(defun find-deref-alien-type (alien) - (let ((alien-type (continuation-type alien))) - (unless (alien-type-type-p alien-type) - (give-up)) - (let ((alien-type (alien-type-type-alien-type alien-type))) - (if (alien-type-p alien-type) - alien-type - (give-up))))) - -(defun find-deref-element-type (alien) - (let ((alien-type (find-deref-alien-type alien))) - (typecase alien-type - (alien-pointer-type - (alien-pointer-type-to alien-type)) - (alien-array-type - (alien-array-type-element-type alien-type)) - (t - (give-up))))) - -(defun compute-deref-guts (alien indices) - (let ((alien-type (find-deref-alien-type alien))) - (typecase alien-type - (alien-pointer-type - (when (cdr indices) - (abort-transform "Too many indices for pointer deref: ~D" - (length indices))) - (let ((element-type (alien-pointer-type-to alien-type))) - (if indices - (let ((bits (alien-type-bits element-type)) - (alignment (alien-type-alignment element-type))) - (unless bits - (abort-transform "Unknown element size.")) - (unless alignment - (abort-transform "Unknown element alignment.")) - (values '(offset) - `(* offset - ,(align-offset bits alignment)) - element-type)) - (values nil 0 element-type)))) - (alien-array-type - (let* ((element-type (alien-array-type-element-type alien-type)) - (bits (alien-type-bits element-type)) - (alignment (alien-type-alignment element-type)) - (dims (alien-array-type-dimensions alien-type))) - (unless (= (length indices) (length dims)) - (give-up "Incorrect number of indices.")) - (unless bits - (give-up "Element size unknown.")) - (unless alignment - (give-up "Element alignment unknown.")) - (if (null dims) - (values nil 0 element-type) - (let* ((arg (gensym)) - (args (list arg)) - (offsetexpr arg)) - (dolist (dim (cdr dims)) - (let ((arg (gensym))) - (push arg args) - (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg)))) - (values (reverse args) - `(* ,offsetexpr - ,(align-offset bits alignment)) - element-type))))) - (t - (abort-transform "~S not either a pointer or array type." - alien-type))))) - - -#+nil ;; Shouldn't be necessary. -(defoptimizer (deref derive-type) ((alien &rest noise)) - (declare (ignore noise)) - (block nil - (catch 'give-up - (return (make-alien-type-type (find-deref-element-type alien)))) - *wild-type*)) - -(deftransform deref ((alien &rest indices) * * :important t) - (multiple-value-bind - (indices-args offset-expr element-type) - (compute-deref-guts alien indices) - `(lambda (alien ,@indices-args) - (extract-alien-value (alien-sap alien) - ,offset-expr - ',element-type)))) - -#+nil ;; ### Again, the value might be coerced. -(defoptimizer (%set-deref derive-type) ((alien value &rest noise)) - (declare (ignore noise)) - (block nil - (catch 'give-up - (let ((type (make-alien-type-type - (make-alien-pointer-type - :to (find-deref-element-type alien))))) - (assert-continuation-type value type) - (return type))) - *wild-type*)) - -(deftransform %set-deref ((alien value &rest indices) * * :important t) - (multiple-value-bind - (indices-args offset-expr element-type) - (compute-deref-guts alien indices) - `(lambda (alien value ,@indices-args) - (deposit-alien-value (alien-sap alien) - ,offset-expr - ',element-type - value)))) - -(defoptimizer (%deref-addr derive-type) ((alien &rest noise)) - (declare (ignore noise)) - (block nil - (catch 'give-up - (return (make-alien-type-type - (make-alien-pointer-type - :to (find-deref-element-type alien))))) - *wild-type*)) - -(deftransform %deref-addr ((alien &rest indices) * * :important t) - (multiple-value-bind - (indices-args offset-expr element-type) - (compute-deref-guts alien indices) - `(lambda (alien ,@indices-args) - (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr vm:byte-bits)) - ',(make-alien-pointer-type :to element-type))))) - - - -;;;; Heap Alien Support. - -(defun heap-alien-sap-and-type (info) - (unless (constant-continuation-p info) - (give-up "Info not constant; can't open code.")) - (let ((info (continuation-value info))) - (values (heap-alien-info-sap-form info) - (heap-alien-info-type info)))) - -#+nil ;; Shouldn't be necessary. -(defoptimizer (%heap-alien derive-type) ((info)) - (block nil - (catch 'give-up - (multiple-value-bind (sap type) - (heap-alien-sap-and-type info) - (declare (ignore sap)) - (return (make-alien-type-type type)))) - *wild-type*)) - -(deftransform %heap-alien ((info) * * :important t) - (multiple-value-bind (sap type) - (heap-alien-sap-and-type info) - `(extract-alien-value ,sap 0 ',type))) - -#+nil ;; ### Again, deposit value might change the type. -(defoptimizer (%set-heap-alien derive-type) ((info value)) - (block nil - (catch 'give-up - (multiple-value-bind (sap type) - (heap-alien-sap-and-type info) - (declare (ignore sap)) - (let ((type (make-alien-type-type type))) - (assert-continuation-type value type) - (return type)))) - *wild-type*)) - -(deftransform %set-heap-alien ((info value) (heap-alien-info *) * :important t) - (multiple-value-bind (sap type) - (heap-alien-sap-and-type info) - `(deposit-alien-value ,sap 0 ',type value))) - -(defoptimizer (%heap-alien-addr derive-type) ((info)) - (block nil - (catch 'give-up - (multiple-value-bind (sap type) - (heap-alien-sap-and-type info) - (declare (ignore sap)) - (return (make-alien-type-type (make-alien-pointer-type :to type))))) - *wild-type*)) - -(deftransform %heap-alien-addr ((info) * * :important t) - (multiple-value-bind (sap type) - (heap-alien-sap-and-type info) - `(%sap-alien ,sap ',type))) - - -;;;; Local (stack or register) alien support. - -(deftransform make-local-alien ((info) * * :important t) - (unless (constant-continuation-p info) - (abort-transform "Local Alien Info isn't constant?")) - (let* ((info (continuation-value info)) - (alien-type (local-alien-info-type info)) - (bits (alien-type-bits alien-type))) - (unless bits - (abort-transform "Unknown size: ~S" (unparse-alien-type alien-type))) - (if (local-alien-info-force-to-memory-p info) - `(truly-the system-area-pointer - (%primitive alloc-number-stack-space - ,(ceiling (alien-type-bits alien-type) - vm:byte-bits))) - (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type)) - (alien-rep-type (specifier-type alien-rep-type-spec))) - (cond ((csubtypep (specifier-type 'system-area-pointer) - alien-rep-type) - '(int-sap 0)) - ((ctypep 0 alien-rep-type) 0) - ((ctypep 0.0f0 alien-rep-type) 0.0f0) - ((ctypep 0.0d0 alien-rep-type) 0.0d0) - (t - (compiler-error - "Aliens of type ~S cannot be represented immediately." - (unparse-alien-type alien-type)))))))) - -(deftransform note-local-alien-type ((info var) * * :important t) - (unless (constant-continuation-p info) - (abort-transform "Local Alien Info isn't constant?")) - (let ((info (continuation-value info))) - (unless (local-alien-info-force-to-memory-p info) - (let ((var-node (continuation-use var))) - (when (ref-p var-node) - (propagate-to-refs (ref-leaf var-node) - (specifier-type - (compute-alien-rep-type - (local-alien-info-type info)))))))) - 'nil) - -(deftransform local-alien ((info var) * * :important t) - (unless (constant-continuation-p info) - (abort-transform "Local Alien Info isn't constant?")) - (let* ((info (continuation-value info)) - (alien-type (local-alien-info-type info))) - (if (local-alien-info-force-to-memory-p info) - `(extract-alien-value var 0 ',alien-type) - `(naturalize var ',alien-type)))) - -(deftransform %local-alien-forced-to-memory-p ((info) * * :important t) - (unless (constant-continuation-p info) - (abort-transform "Local Alien Info isn't constant?")) - (let ((info (continuation-value info))) - (local-alien-info-force-to-memory-p info))) - -(deftransform %set-local-alien ((info var value) * * :important t) - (unless (constant-continuation-p info) - (abort-transform "Local Alien Info isn't constant?")) - (let* ((info (continuation-value info)) - (alien-type (local-alien-info-type info))) - (if (local-alien-info-force-to-memory-p info) - `(deposit-alien-value var 0 ',alien-type value) - '(error "This should be dead-code eleminated.")))) - -(defoptimizer (%local-alien-addr derive-type) ((info var)) - (if (constant-continuation-p info) - (let* ((info (continuation-value info)) - (alien-type (local-alien-info-type info))) - (make-alien-type-type (make-alien-pointer-type :to alien-type))) - *wild-type*)) - -(deftransform %local-alien-addr ((info var) * * :important t) - (unless (constant-continuation-p info) - (abort-transform "Local Alien Info isn't constant?")) - (let* ((info (continuation-value info)) - (alien-type (local-alien-info-type info))) - (if (local-alien-info-force-to-memory-p info) - `(%sap-alien var ',(make-alien-pointer-type :to alien-type)) - (error "This shouldn't happen.")))) - -(deftransform dispose-local-alien ((info var) * * :important t) - (unless (constant-continuation-p info) - (abort-transform "Local Alien Info isn't constant?")) - (let* ((info (continuation-value info)) - (alien-type (local-alien-info-type info))) - (if (local-alien-info-force-to-memory-p info) - `(%primitive dealloc-number-stack-space - ,(ceiling (alien-type-bits alien-type) - vm:byte-bits)) - nil))) - - -;;;; %CAST - -(defoptimizer (%cast derive-type) ((alien type)) - (or (when (constant-continuation-p type) - (let ((alien-type (continuation-value type))) - (when (alien-type-p alien-type) - (make-alien-type-type alien-type)))) - *wild-type*)) - -(deftransform %cast ((alien target-type) * * :important t) - (unless (constant-continuation-p target-type) - (give-up "Alien type not constant; cannot open code.")) - (let ((target-type (continuation-value target-type))) - (cond ((or (alien-pointer-type-p target-type) - (alien-array-type-p target-type) - (alien-function-type-p target-type)) - `(naturalize (alien-sap alien) ',target-type)) - (t - (abort-transform "Cannot cast to alien type ~S" target-type))))) - - -;;;; alien-sap, %sap-alien, %addr, etc - -(deftransform alien-sap ((alien) * * :important t) - (let ((alien-node (continuation-use alien))) - (typecase alien-node - (combination - (extract-function-args alien '%sap-alien 2) - '(lambda (sap type) - (declare (ignore type)) - sap)) - (t - (give-up))))) - -(defoptimizer (%sap-alien derive-type) ((sap type)) - (declare (ignore sap)) - (if (constant-continuation-p type) - (make-alien-type-type (continuation-value type)) - *wild-type*)) - -(deftransform %sap-alien ((sap type) * * :important t) - (give-up "Could not optimize away %SAP-ALIEN: forced to do runtime ~@ - allocation of alien-value structure.")) - - - -;;;; Extract/deposit magic - -(eval-when (compile eval) - (defmacro compiler-error-if-loses (form) - `(handler-case - ,form - (error (condition) - (compiler-error "~A" condition))))) - -(deftransform naturalize ((object type) * * :important t) - (unless (constant-continuation-p type) - (give-up "Type not constant at compile time; can't open code.")) - (compiler-error-if-loses - (compute-naturalize-lambda (continuation-value type)))) - -(deftransform deport ((alien type) * * :important t) - (unless (constant-continuation-p type) - (give-up "Type not constant at compile time; can't open code.")) - (compiler-error-if-loses - (compute-deport-lambda (continuation-value type)))) - -(deftransform extract-alien-value ((sap offset type) * * :important t) - (unless (constant-continuation-p type) - (give-up "Type not constant at compile time; can't open code.")) - (compiler-error-if-loses - (compute-extract-lambda (continuation-value type)))) - -(deftransform deposit-alien-value ((sap offset type value) * * :important t) - (unless (constant-continuation-p type) - (give-up "Type not constant at compile time; can't open code.")) - (compiler-error-if-loses - (compute-deposit-lambda (continuation-value type)))) - - -;;;; Hack to clean up divisions. - -(defun count-low-order-zeros (thing) - (typecase thing - (continuation - (if (constant-continuation-p thing) - (count-low-order-zeros (continuation-value thing)) - (count-low-order-zeros (continuation-use thing)))) - (combination - (case (continuation-function-name (combination-fun thing)) - ((+ -) - (let ((min most-positive-fixnum) - (itype (specifier-type 'integer))) - (dolist (arg (combination-args thing) min) - (if (csubtypep (continuation-type arg) itype) - (setf min (min min (count-low-order-zeros arg))) - (return 0))))) - (* - (let ((result 0) - (itype (specifier-type 'integer))) - (dolist (arg (combination-args thing) result) - (if (csubtypep (continuation-type arg) itype) - (setf result (+ result (count-low-order-zeros arg))) - (return 0))))) - (ash - (let ((args (combination-args thing))) - (if (= (length args) 2) - (let ((amount (second args))) - (if (constant-continuation-p amount) - (max (+ (count-low-order-zeros (first args)) - (continuation-value amount)) - 0) - 0)) - 0))) - (t - 0))) - (integer - (if (zerop thing) - most-positive-fixnum - (do ((result 0 (1+ result)) - (num thing (ash num -1))) - ((logbitp 0 num) result)))) - (t - 0))) - -(deftransform / ((numerator denominator) (integer integer)) - (unless (constant-continuation-p denominator) - (give-up)) - (let* ((denominator (continuation-value denominator)) - (bits (1- (integer-length denominator)))) - (unless (= (ash 1 bits) denominator) - (give-up)) - (let ((alignment (count-low-order-zeros numerator))) - (unless (>= alignment bits) - (give-up)) - `(ash numerator ,(- bits))))) - -(deftransform ash ((value amount)) - (let ((value-node (continuation-use value))) - (unless (and (combination-p value-node) - (eq (continuation-function-name (combination-fun value-node)) - 'ash)) - (give-up)) - (let ((inside-args (combination-args value-node))) - (unless (= (length inside-args) 2) - (give-up)) - (let ((inside-amount (second inside-args))) - (unless (and (constant-continuation-p inside-amount) - (not (minusp (continuation-value inside-amount)))) - (give-up))))) - (extract-function-args value 'ash 2) - '(lambda (value amount1 amount2) - (ash value (+ amount1 amount2)))) - - -;;;; ALIEN-FUNCALL support. - -(deftransform alien-funcall ((function &rest args) - ((alien (* t)) &rest *) * - :important t) - (let ((names (loop repeat (length args) collect (gensym)))) - `(lambda (function ,@names) - (alien-funcall (deref function) ,@names)))) - -(deftransform alien-funcall ((function &rest args) * * :important t) - (let ((type (continuation-type function))) - (unless (alien-type-type-p type) - (give-up "Can't tell function type at compile time.")) - (let ((alien-type (alien-type-type-alien-type type))) - (unless (alien-function-type-p alien-type) - (give-up)) - (let ((arg-types (alien-function-type-arg-types alien-type))) - (unless (= (length args) (length arg-types)) - (abort-transform "Wrong number of arguments. Expected ~D, got ~D." - (length arg-types) (length args))) - (collect ((params) (deports)) - (dolist (arg-type arg-types) - (let ((param (gensym))) - (params param) - (deports `(deport ,param ',arg-type)))) - (let ((return-type (alien-function-type-result-type alien-type)) - (body `(%alien-funcall (deport function ',alien-type) - ',alien-type - ,@(deports)))) - (if (alien-values-type-p return-type) - (collect ((temps) (results)) - (dolist (type (alien-values-type-values return-type)) - (let ((temp (gensym))) - (temps temp) - (results `(naturalize ,temp ',type)))) - (setf body - `(multiple-value-bind - ,(temps) - ,body - (values ,@(results))))) - (setf body `(naturalize ,body ',return-type))) - `(lambda (function ,@(params)) - ,body))))))) - -(defoptimizer (%alien-funcall derive-type) ((function type &rest args)) - (declare (ignore function args)) - (unless (constant-continuation-p type) - (error "Something is broken.")) - (let ((type (continuation-value type))) - (unless (alien-function-type-p type) - (error "Something is broken.")) - (specifier-type - (compute-alien-rep-type - (alien-function-type-result-type type))))) - -(defoptimizer (%alien-funcall ltn-annotate) - ((function type &rest args) node policy) - (setf (basic-combination-info node) :funny) - (setf (node-tail-p node) nil) - (annotate-ordinary-continuation function policy) - (dolist (arg args) - (annotate-ordinary-continuation arg policy))) - -(defoptimizer (%alien-funcall ir2-convert) - ((function type &rest args) call block) - (let ((type (if (constant-continuation-p type) - (continuation-value type) - (error "Something is broken."))) - (cont (node-cont call)) - (args args)) - (multiple-value-bind (nsp stack-frame-size arg-tns result-tns) - (make-call-out-tns type) - (vop alloc-number-stack-space call block stack-frame-size nsp) - (dolist (tn arg-tns) - (let* ((arg (pop args)) - (sc (tn-sc tn)) - (scn (sc-number sc)) - (temp-tn (make-representation-tn (tn-primitive-type tn) scn)) - (move-arg-vops (svref (sc-move-arg-vops sc) scn))) - (assert arg) - (assert (= (length move-arg-vops) 1) () - "No unique move-arg-vop for moves in SC ~S." - (sc-name sc)) - (emit-move call block (continuation-tn call block arg) temp-tn) - (emit-move-arg-template call block (first move-arg-vops) - temp-tn nsp tn))) - (assert (null args)) - (unless (listp result-tns) - (setf result-tns (list result-tns))) - (vop* call-out call block - ((continuation-tn call block function) - (reference-tn-list arg-tns nil)) - ((reference-tn-list result-tns t))) - (vop dealloc-number-stack-space call block stack-frame-size) - (move-continuation-result call block result-tns cont)))) diff --git a/compiler/alloc.lisp b/compiler/alloc.lisp deleted file mode 100644 index 77d3408fb2c8036bb6519c8358b347644c77ea16..0000000000000000000000000000000000000000 --- a/compiler/alloc.lisp +++ /dev/null @@ -1,343 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/alloc.lisp,v 1.10 1992/09/07 15:33:08 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Some storage allocation hacks for the compiler. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") - - -;;; A hack we we to defeat compile-time type checking in deinitializing slots -;;; where there isn't any convenient legal value. -;;; -(defvar *undefined* '**undefined**) - - -;;; ZAP-IN -- Internal -;;; -;;; A convenient macro for iterating over linked lists when we are -;;; clobbering the next link as we go. -;;; -(defmacro zap-in ((var in slot) &body body) - (let ((next (gensym))) - `(let ((,var ,in) ,next) - (when ,var - (loop - (setq ,next (,slot ,var)) - ,@body - (unless ,next (return)) - (setq ,var ,next)))))) - - -;;; DEFALLOCATERS -- Internal -;;; -;;; Define some structure freelisting operations. -;;; -(defmacro defallocators (&rest specs) - "defallocators {((name lambda-list [real-lambda-list]) thread-slot - (deinit-form*) - (reinit-form*))}*" - (collect ((hook-forms) - (forms)) - (dolist (spec specs) - (let* ((names (first spec)) - (name (first names)) - (lambda-list (second names)) - (real-lambda-list (or (third names) lambda-list)) - (fun-name (symbolicate "MAKE-" name)) - (unfun-name (symbolicate "UNMAKE-" name)) - (real-fun-name (symbolicate "REALLY-MAKE-" name)) - (var-name (symbolicate "*" name "-FREE-LIST*")) - (slot (second spec))) - (forms `(proclaim '(inline ,fun-name ,unfun-name))) - (forms `(defvar ,var-name nil)) - (forms `(defun ,fun-name ,lambda-list - (declare (optimize (safety 0))) - (let ((structure ,var-name)) - (cond (structure - (setq ,var-name (,slot structure)) - ,@(fourth spec) - structure) - (t - (,real-fun-name ,@real-lambda-list)))))) - - (forms `(defun ,unfun-name (structure) - (declare (optimize (safety 0))) - ,@(third spec) - #+nil - (when (find-in #',slot structure ,var-name) - (error "~S already deallocated!" structure)) - (setf (,slot structure) ,var-name) - (setq ,var-name structure))) - - (hook-forms - `(progn - (zap-in (structure ,var-name ,slot) - (setf (,slot structure) nil)) - (setq ,var-name nil))))) - - `(progn - ,@(forms) - (defun defallocator-deallocation-hook () - (declare (optimize (safety 0))) - ,@(hook-forms)) - (pushnew 'defallocator-deallocation-hook ext:*before-gc-hooks*)))) - - -(defmacro node-deinits () - '(progn - (setf (node-derived-type structure) *wild-type*) - (setf (node-lexenv structure) *undefined*) - (setf (node-source-path structure) nil) - (setf (node-reoptimize structure) t) - (setf (node-cont structure) nil) - (setf (node-prev structure) nil) - (setf (node-tail-p structure) nil))) - -(defmacro node-inits () - '(progn - (setf (node-lexenv structure) *lexical-environment*) - (setf (node-source-path structure) *current-path*))) - - -(defallocators - ((continuation (&optional dest) (dest)) continuation-info - ((setf (continuation-kind structure) :unused) - (setf (continuation-dest structure) nil) - (setf (continuation-next structure) nil) - (setf (continuation-asserted-type structure) *wild-type*) - (setf (continuation-%derived-type structure) nil) - (setf (continuation-use structure) nil) - (setf (continuation-block structure) nil) - (setf (continuation-reoptimize structure) t) - (setf (continuation-%type-check structure) t)) - ((setf (continuation-info structure) nil) - (setf (continuation-dest structure) dest))) - - ((block (start)) block-next - ((setf (block-pred structure) nil) - (setf (block-succ structure) nil) - (setf (block-start structure) nil) - (setf (block-start-uses structure) nil) - (setf (block-last structure) nil) - (setf (block-next structure) nil) - (setf (block-prev structure) nil) - (setf (block-flags structure) - (block-attributes reoptimize flush-p type-check type-asserted - test-modified)) - (setf (block-kill structure) nil) - (setf (block-gen structure) nil) - (setf (block-in structure) nil) - (setf (block-out structure) nil) - (setf (block-flag structure) nil) - (setf (block-info structure) nil) - (setf (block-test-constraint structure) nil)) - ((setf (block-component structure) *current-component*) - (setf (block-start structure) start))) - - ((ref (derived-type leaf)) node-source-path - ((node-deinits) - (setf (ref-leaf structure) *undefined*)) - ((node-inits) - (setf (node-derived-type structure) derived-type) - (setf (ref-leaf structure) leaf))) - - ((combination (fun)) node-source-path - ((node-deinits) - (setf (basic-combination-fun structure) *undefined*) - (setf (basic-combination-args structure) nil) - (setf (basic-combination-kind structure) :full) - (setf (basic-combination-info structure) nil)) - ((node-inits) - (setf (basic-combination-fun structure) fun))) - - ((ir2-block (block)) ir2-block-next - ((setf (ir2-block-number structure) nil) - (setf (ir2-block-block structure) *undefined*) - (setf (ir2-block-prev structure) nil) - (setf (ir2-block-pushed structure) nil) - (setf (ir2-block-popped structure) nil) - (setf (ir2-block-start-stack structure) nil) - (setf (ir2-block-end-stack structure) nil) - (setf (ir2-block-start-vop structure) nil) - (setf (ir2-block-last-vop structure) nil) - (setf (ir2-block-local-tn-count structure) 0) - (let ((ltns (ir2-block-local-tns structure))) - (dotimes (i local-tn-limit) - (setf (svref ltns i) nil))) - (clear-bit-vector (ir2-block-written structure)) - (clear-bit-vector (ir2-block-live-in structure)) - (setf (ir2-block-global-tns structure) nil) - (setf (ir2-block-%label structure) nil) - (setf (ir2-block-locations structure) nil)) - ((setf (ir2-block-next structure) nil) - (setf (ir2-block-block structure) block))) - - ((vop (block node info args results)) vop-next - ((setf (vop-block structure) *undefined*) - (setf (vop-prev structure) nil) - (setf (vop-args structure) nil) - (setf (vop-results structure) nil) - (setf (vop-temps structure) nil) - (setf (vop-refs structure) nil) - (setf (vop-codegen-info structure) nil) - (setf (vop-node structure) nil) - (setf (vop-save-set structure) nil)) - ((setf (vop-next structure) nil) - (setf (vop-block structure) block) - (setf (vop-node structure) node) - (setf (vop-info structure) info) - (setf (vop-args structure) args) - (setf (vop-results structure) results))) - - ((tn-ref (tn write-p)) tn-ref-next - ((setf (tn-ref-tn structure) *undefined*) - (setf (tn-ref-vop structure) nil) - (setf (tn-ref-next-ref structure) nil) - (setf (tn-ref-across structure) nil) - (setf (tn-ref-target structure) nil) - (setf (tn-ref-load-tn structure) nil)) - ((setf (tn-ref-next structure) nil) - (setf (tn-ref-tn structure) tn) - (setf (tn-ref-write-p structure) write-p))) - - ((tn (number kind primitive-type sc)) tn-next - ((setf (tn-leaf structure) nil) - (setf (tn-reads structure) nil) - (setf (tn-writes structure) nil) - (setf (tn-next* structure) nil) - (setf (tn-local structure) nil) - (setf (tn-local-number structure) nil) - ;; - ;; Has been clobbered in global TNs... - (if (tn-global-conflicts structure) - (setf (tn-local-conflicts structure) - (make-array local-tn-limit :element-type 'bit - :initial-element 0)) - (clear-bit-vector (tn-local-conflicts structure))) - - (setf (tn-global-conflicts structure) nil) - (setf (tn-current-conflict structure) nil) - (setf (tn-save-tn structure) nil) - (setf (tn-offset structure) nil) - (setf (tn-environment structure) nil) - (setf (tn-cost structure) 0)) - ((setf (tn-next structure) nil) - (setf (tn-number structure) number) - (setf (tn-kind structure) kind) - (setf (tn-primitive-type structure) primitive-type) - (setf (tn-sc structure) sc))) - - ((global-conflicts (kind tn block number)) global-conflicts-next - ((setf (global-conflicts-block structure) *undefined*) - (clear-bit-vector (global-conflicts-conflicts structure)) - (setf (global-conflicts-tn structure) *undefined*) - (setf (global-conflicts-tn-next structure) nil)) - ((setf (global-conflicts-next structure) nil) - (setf (global-conflicts-kind structure) kind) - (setf (global-conflicts-tn structure) tn) - (setf (global-conflicts-block structure) block) - (setf (global-conflicts-number structure) number)))) - - -;;; NUKE-IR2-COMPONENT -- Interface -;;; -;;; Destroy the connectivity of the IR2 as much as possible in an attempt to -;;; reduce GC lossage. -;;; -(defun nuke-ir2-component (component) - (declare (type component component)) - (zap-in (block (block-info (component-head component)) ir2-block-next) - (zap-in (conf (ir2-block-global-tns block) global-conflicts-next) - (unmake-global-conflicts conf)) - - (zap-in (vop (ir2-block-start-vop block) vop-next) - (zap-in (ref (vop-refs vop) tn-ref-next-ref) - (let ((ltn (tn-ref-load-tn ref))) - (when ltn - (unmake-tn ltn))) - (unmake-tn-ref ref)) - (unmake-vop vop)) - (unmake-ir2-block block)) - - (let ((2comp (component-info component))) - (macrolet ((blast (slot) - `(progn - (zap-in (tn (,slot 2comp) tn-next) - (unmake-tn tn)) - (setf (,slot 2comp) nil)))) - (blast ir2-component-normal-tns) - (blast ir2-component-restricted-tns) - (blast ir2-component-wired-tns) - (blast ir2-component-constant-tns)) - (setf (ir2-component-component-tns 2comp) nil) - (setf (ir2-component-nfp 2comp) nil) - (setf (ir2-component-values-receivers 2comp) nil) - (setf (ir2-component-constants 2comp) '#()) - (setf (ir2-component-format 2comp) nil) - (setf (ir2-component-entries 2comp) nil)) - - (undefined-value)) - - -;;; MACERATE-IR1-COMPONENT -- Interface -;;; -(defun macerate-ir1-component (component) - (declare (type component component) (optimize (safety 0))) - (zap-in (block (component-head component) block-next) - (when (block-start block) - (let ((cont (block-start block)) - (last-cont (node-cont (block-last block))) - next-cont - node) - (loop - (setq node (continuation-next cont)) - (setq next-cont (node-cont node)) - (typecase node - (ref (unmake-ref node)) - (combination (unmake-combination node)) - (t - (let ((structure node)) - (node-deinits)))) - (unmake-continuation cont) - (when (eq next-cont last-cont) - (when (eq (continuation-block next-cont) block) - (unmake-continuation next-cont)) - (return)) - (setq cont next-cont)))) - (unmake-block block)) - - (dolist (fun (component-lambdas component)) - (setf (leaf-refs fun) nil) - (let ((tails (lambda-tail-set fun))) - (when tails - (setf (tail-set-info tails) nil))) - (let ((env (lambda-environment fun))) - (setf (environment-info env) nil) - (setf (environment-function env) *undefined*) - (dolist (nlx (environment-nlx-info env)) - (setf (nlx-info-info nlx) nil))) - (macrolet ((frob (fun) - `(progn - (dolist (var (lambda-vars ,fun)) - (setf (leaf-refs var) nil) - (setf (basic-var-sets var) nil) - (setf (leaf-info var) nil)) - (setf (lambda-vars ,fun) nil) - (setf (lambda-environment ,fun) nil)))) - (frob fun) - (dolist (let (lambda-lets fun)) - (frob let) - (setf (lambda-home let) nil)) - (setf (lambda-lets fun) nil)))) diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp deleted file mode 100644 index 28ea744e454485d4cdba15dd7d23d9fce877a459..0000000000000000000000000000000000000000 --- a/compiler/array-tran.lisp +++ /dev/null @@ -1,571 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/array-tran.lisp,v 1.14 1991/11/12 14:14:14 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains array specific optimizers and transforms. -;;; -;;; Extracted from srctran and extended by William Lott. -;;; -(in-package "C") - - -;;;; Derive-Type Optimizers - -;;; ASSERT-ARRAY-RANK -- internal -;;; -;;; Array operations that use a specific number of indices implicitly assert -;;; that the array is of that rank. -;;; -(defun assert-array-rank (array rank) - (assert-continuation-type - array - (specifier-type `(array * ,(make-list rank :initial-element '*))))) - -;;; EXTRACT-ELEMENT-TYPE -- internal -;;; -;;; Array access functions return an object from the array, hence it's type -;;; is going to be the array element type. -;;; -(defun extract-element-type (array) - (let ((type (continuation-type array))) - (if (array-type-p type) - (array-type-element-type type) - *universal-type*))) - -;;; ASSERT-NEW-VALUE-TYPE -- internal -;;; -;;; The ``new-value'' for array setters must fit in the array, and the -;;; return type is going to be the same as the new-value for setf functions. -;;; -(defun assert-new-value-type (new-value array) - (let ((type (continuation-type array))) - (when (array-type-p type) - (assert-continuation-type new-value (array-type-element-type type)))) - (continuation-type new-value)) - -;;; Unsupplied-Or-NIL -- Internal -;;; -;;; Return true if Arg is NIL, or is a constant-continuation whose value is -;;; NIL, false otherwise. -;;; -(defun unsupplied-or-nil (arg) - (declare (type (or continuation null) arg)) - (or (not arg) - (and (constant-continuation-p arg) - (not (continuation-value arg))))) - - -;;; ARRAY-IN-BOUNDS-P -- derive-type optimizer. -;;; -(defoptimizer (array-in-bounds-p derive-type) ((array &rest indices)) - (assert-array-rank array (length indices)) - *universal-type*) - -;;; AREF -- derive-type optimizer. -;;; -(defoptimizer (aref derive-type) ((array &rest indices)) - (assert-array-rank array (length indices)) - (extract-element-type array)) - -;;; %ASET -- derive-type optimizer. -;;; -(defoptimizer (%aset derive-type) ((array &rest stuff)) - (assert-array-rank array (1- (length stuff))) - (assert-new-value-type (car (last stuff)) array)) - -;;; DATA-VECTOR-REF -- derive-type optimizer. -;;; -(defoptimizer (data-vector-ref derive-type) ((array index)) - (extract-element-type array)) - -;;; DATA-VECTOR-SET -- derive-type optimizer. -;;; -(defoptimizer (data-vector-set derive-type) ((array index new-value)) - (assert-new-value-type new-value array)) - -;;; %WITH-ARRAY-DATA -- derive-type optimizer. -;;; -;;; Figure out the type of the data vector if we know the argument element -;;; type. -;;; -(defoptimizer (%with-array-data derive-type) ((array start end)) - (let ((atype (continuation-type array))) - (when (array-type-p atype) - (values-specifier-type - `(values (simple-array ,(type-specifier - (array-type-element-type atype)) - (*)) - index index index))))) - - -;;; ARRAY-ROW-MAJOR-INDEX -- derive-type optimizer. -;;; -(defoptimizer (array-row-major-index derive-type) ((array &rest indices)) - (assert-array-rank array (length indices)) - *universal-type*) - -;;; ROW-MAJOR-AREF -- derive-type optimizer. -;;; -(defoptimizer (row-major-aref derive-type) ((array index)) - (extract-element-type array)) - -;;; %SET-ROW-MAJOR-AREF -- derive-type optimizer. -;;; -(defoptimizer (%set-row-major-aref derive-type) ((array index new-value)) - (assert-new-value-type new-value array)) - -;;; MAKE-ARRAY -- derive-type optimizer. -;;; -(defoptimizer (make-array derive-type) - ((dims &key initial-element element-type initial-contents - adjustable fill-pointer displaced-index-offset displaced-to)) - (let ((simple (and (unsupplied-or-nil adjustable) - (unsupplied-or-nil displaced-to) - (unsupplied-or-nil fill-pointer)))) - (specifier-type - `(,(if simple 'simple-array 'array) - ,(cond ((not element-type) 't) - ((constant-continuation-p element-type) - (continuation-value element-type)) - (t - '*)) - ,(cond ((not simple) - '*) - ((constant-continuation-p dims) - (let ((val (continuation-value dims))) - (if (listp val) val (list val)))) - ((csubtypep (continuation-type dims) - (specifier-type 'integer)) - '(*)) - (t - '*)))))) - - -;;;; Constructors. - -;;; VECTOR -- source-transform. -;;; -;;; Convert VECTOR into a make-array followed by setfs of all the elements. -;;; -(def-source-transform vector (&rest elements) - (let ((len (length elements)) - (n -1)) - (once-only ((n-vec `(make-array ,len))) - `(progn - ,@(mapcar #'(lambda (el) - (once-only ((n-val el)) - `(locally (declare (optimize (safety 0))) - (setf (svref ,n-vec ,(incf n)) ,n-val)))) - elements) - ,n-vec)))) - - -;;; MAKE-STRING -- source-transform. -;;; -;;; Just convert it into a make-array. -;;; -(def-source-transform make-string (length &key (initial-element #\NULL)) - `(make-array (the index ,length) - :element-type 'base-char - :initial-element ,initial-element)) - -(defconstant array-info - '((base-char #\NULL 8 vm:simple-string-type) - (single-float 0.0s0 32 vm:simple-array-single-float-type) - (double-float 0.0d0 64 vm:simple-array-double-float-type) - (bit 0 1 vm:simple-bit-vector-type) - ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type) - ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type) - ((unsigned-byte 8) 0 8 vm:simple-array-unsigned-byte-8-type) - ((unsigned-byte 16) 0 16 vm:simple-array-unsigned-byte-16-type) - ((unsigned-byte 32) 0 32 vm:simple-array-unsigned-byte-32-type) - (t 0 32 vm:simple-vector-type))) - -;;; MAKE-ARRAY -- source-transform. -;;; -;;; The integer type restriction on the length assures that it will be a -;;; vector. The lack of adjustable, fill-pointer, and displaced-to keywords -;;; assures that it will be simple. -;;; -(deftransform make-array ((length &key initial-element element-type) - (integer &rest *)) - (let* ((eltype (cond ((not element-type) t) - ((not (constant-continuation-p element-type)) - (give-up "Element-Type is not constant.")) - (t - (continuation-value element-type)))) - (len (if (constant-continuation-p length) - (continuation-value length) - '*)) - (spec `(simple-array ,eltype (,len))) - (eltype-type (specifier-type eltype))) - (multiple-value-bind - (default-initial-element element-size typecode) - (dolist (info array-info - (give-up "Cannot open-code creation of ~S" spec)) - (when (csubtypep eltype-type (specifier-type (car info))) - (return (values-list (cdr info))))) - (let* ((nwords-form - (if (>= element-size vm:word-bits) - `(* length ,(/ element-size vm:word-bits)) - (let ((elements-per-word (/ 32 element-size))) - `(truncate (+ length - ,(if (eq 'vm:simple-string-type typecode) - elements-per-word - (1- elements-per-word))) - ,elements-per-word)))) - (constructor - `(truly-the ,spec - (allocate-vector ,typecode length ,nwords-form)))) - (values - (if (and default-initial-element - (or (null initial-element) - (and (constant-continuation-p initial-element) - (eql (continuation-value initial-element) - default-initial-element)))) - constructor - `(truly-the ,spec (fill ,constructor initial-element))) - '((declare (type index length)))))))) - -;;; MAKE-ARRAY -- transform. -;;; -;;; The list type restriction does not assure that the result will be a -;;; multi-dimensional array. But the lack of -;;; -(deftransform make-array ((dims &key initial-element element-type) - (list &rest *)) - (unless (or (null element-type) (constant-continuation-p element-type)) - (give-up "Element-type not constant; cannot open code array creation")) - (unless (constant-continuation-p dims) - (give-up "Dimension list not constant; cannot open code array creation")) - (let ((dims (continuation-value dims))) - (unless (every #'integerp dims) - (give-up "Dimension list contains something other than an integer: ~S" - dims)) - (if (= (length dims) 1) - `(make-array ',(car dims) - ,@(when initial-element - '(:initial-element initial-element)) - ,@(when element-type - '(:element-type element-type))) - (let* ((total-size (reduce #'* dims)) - (rank (length dims)) - (spec `(simple-array - ,(cond ((null element-type) t) - ((constant-continuation-p element-type) - (continuation-value element-type)) - (t '*)) - ,(make-list rank :initial-element '*)))) - `(let ((header (make-array-header vm:simple-array-type ,rank))) - (setf (%array-fill-pointer header) ,total-size) - (setf (%array-fill-pointer-p header) nil) - (setf (%array-available-elements header) ,total-size) - (setf (%array-data-vector header) - (make-array ,total-size - ,@(when element-type - '(:element-type element-type)) - ,@(when initial-element - '(:initial-element initial-element)))) - (setf (%array-displaced-p header) nil) - ,@(let ((axis -1)) - (mapcar #'(lambda (dim) - `(setf (%array-dimension header ,(incf axis)) - ,dim)) - dims)) - (truly-the ,spec header)))))) - - -;;;; Random properties of arrays. - -;;; Transforms for various random array properties. If the property is know -;;; at compile time because of a type spec, use that constant value. - -;;; ARRAY-RANK -- transform. -;;; -;;; If we can tell the rank from the type info, use it instead. -;;; -(deftransform array-rank ((array)) - (let ((array-type (continuation-type array))) - (unless (array-type-p array-type) - (give-up)) - (let ((dims (array-type-dimensions array-type))) - (if (not (listp dims)) - (give-up "Array rank not known at compile time: ~S" dims) - (length dims))))) - -;;; ARRAY-DIMENSION -- transform. -;;; -;;; If we know the dimensions at compile time, just use it. Otherwise, if -;;; we can tell that the axis is in bounds, convert to %array-dimension -;;; (which just indirects the array header) or length (if it's simple and a -;;; vector). -;;; -(deftransform array-dimension ((array axis) - (array index)) - (unless (constant-continuation-p axis) - (give-up "Axis not constant.")) - (let ((array-type (continuation-type array)) - (axis (continuation-value axis))) - (unless (array-type-p array-type) - (give-up)) - (let ((dims (array-type-dimensions array-type))) - (unless (listp dims) - (give-up - "Array dimensions unknown, must call array-dimension at runtime.")) - (unless (> (length dims) axis) - (abort-transform "Array has dimensions ~S, ~D is too large." - dims axis)) - (let ((dim (nth axis dims))) - (cond ((integerp dim) - dim) - ((= (length dims) 1) - (ecase (array-type-complexp array-type) - ((t) - '(%array-dimension array 0)) - ((nil) - '(length array)) - (* - (give-up "Can't tell if array is simple.")))) - (t - '(%array-dimension array axis))))))) - -;;; LENGTH -- transform. -;;; -;;; If the length has been declared and it's simple, just return it. -;;; -(deftransform length ((vector) - ((simple-array * (*)))) - (let ((type (continuation-type vector))) - (unless (array-type-p type) - (give-up)) - (let ((dims (array-type-dimensions type))) - (unless (and (listp dims) (integerp (car dims))) - (give-up "Vector length unknown, must call length at runtime.")) - (car dims)))) - -;;; LENGTH -- transform. -;;; -;;; All vectors can get their length by using vector-length. If it's simple, -;;; it will extract the length slot from the vector. It it's complex, it will -;;; extract the fill pointer slot from the array header. -;;; -(deftransform length ((vector) (vector)) - '(vector-length vector)) - - -;;; If a simple array with known dimensions, then vector-length is a -;;; compile-time constant. -;;; -(deftransform vector-length ((vector) ((simple-array * (*)))) - (let ((vtype (continuation-type vector))) - (if (array-type-p vtype) - (let ((dim (first (array-type-dimensions vtype)))) - (when (eq dim '*) (give-up)) - dim) - (give-up)))) - - -;;; ARRAY-TOTAL-SIZE -- transform. -;;; -;;; Again, if we can tell the results from the type, just use it. Otherwise, -;;; if we know the rank, convert into a computation based on array-dimension. -;;; We can wrap a truly-the index around the multiplications because we know -;;; that the total size must be an index. -;;; -(deftransform array-total-size ((array) - (array)) - (let ((array-type (continuation-type array))) - (unless (array-type-p array-type) - (give-up)) - (let ((dims (array-type-dimensions array-type))) - (unless (listp dims) - (give-up "Can't tell the rank at compile time.")) - (if (member '* dims) - (do ((form 1 `(truly-the index - (* (array-dimension array ,i) ,form))) - (i 0 (1+ i))) - ((= i (length dims)) form)) - (reduce #'* dims))))) - -;;; ARRAY-HAS-FILL-POINTER-P -- transform. -;;; -;;; Only complex vectors have fill pointers. -;;; -(deftransform array-has-fill-pointer-p ((array)) - (let ((array-type (continuation-type array))) - (unless (array-type-p array-type) - (give-up)) - (let ((dims (array-type-dimensions array-type))) - (if (and (listp dims) (not (= (length dims) 1))) - nil - (ecase (array-type-complexp array-type) - ((t) - t) - ((nil) - nil) - (* - (give-up "Array type ambiguous; must call ~ - array-has-fill-pointer-p at runtime."))))))) - -;;; %CHECK-BOUND -- transform. -;;; -;;; Primitive used to verify indicies into arrays. If we can tell at -;;; compile-time or we are generating unsafe code, don't bother with the VOP. -;;; -(deftransform %check-bound ((array dimension index)) - (unless (constant-continuation-p dimension) - (give-up)) - (let ((dim (continuation-value dimension))) - `(the (integer 0 ,dim) index))) -;;; -(deftransform %check-bound ((array dimension index) * * - :policy (and (> speed safety) (= safety 0))) - 'index) - - -;;; WITH-ROW-MAJOR-INDEX -- internal. -;;; -;;; Handy macro for computing the row-major index given a set of indices. We -;;; wrap each index with a call to %check-bound to assure that everything -;;; works out correctly. We can wrap all the interior arith with truly-the -;;; index because we know the the resultant row-major index must be an index. -;;; -(eval-when (compile eval) -;;; -(defmacro with-row-major-index ((array indices index &optional new-value) - &rest body) - `(let (n-indices dims) - (dotimes (i (length ,indices)) - (push (make-symbol (format nil "INDEX-~D" i)) n-indices) - (push (make-symbol (format nil "DIM-~D" i)) dims)) - (setf n-indices (nreverse n-indices)) - (setf dims (nreverse dims)) - `(lambda (,',array ,@n-indices ,@',(when new-value (list new-value))) - (let* (,@(let ((,index -1)) - (mapcar #'(lambda (name) - `(,name (array-dimension ,',array - ,(incf ,index)))) - dims)) - (,',index - ,(if (null dims) - 0 - (do* ((dims dims (cdr dims)) - (indices n-indices (cdr indices)) - (last-dim nil (car dims)) - (form `(%check-bound ,',array - ,(car dims) - ,(car indices)) - `(truly-the index - (+ (truly-the index - (* ,form - ,last-dim)) - (%check-bound - ,',array - ,(car dims) - ,(car indices)))))) - ((null (cdr dims)) form))))) - ,',@body)))) -;;; -); eval-when - -;;; ARRAY-ROW-MAJOR-INDEX -- transform. -;;; -;;; Just return the index after computing it. -;;; -(deftransform array-row-major-index ((array &rest indices)) - (with-row-major-index (array indices index) - index)) - - - -;;;; Array accessors: - -;;; SVREF, %SVSET, SCHAR, %SCHARSET, CHAR, -;;; %CHARSET, SBIT, %SBITSET, BIT, %BITSET -;;; -- source transforms. -;;; -;;; We convert all typed array accessors into aref and %aset with type -;;; assertions on the array. -;;; -(macrolet ((frob (reffer setter type) - `(progn - (def-source-transform ,reffer (a &rest i) - `(aref (the ,',type ,a) ,@i)) - (def-source-transform ,setter (a &rest i) - `(%aset (the ,',type ,a) ,@i))))) - (frob svref %svset simple-vector) - (frob schar %scharset simple-string) - (frob char %charset string) - (frob sbit %sbitset (simple-array bit)) - (frob bit %bitset (array bit))) - -;;; AREF, %ASET -- transform. -;;; -;;; Convert into a data-vector-ref (or set) with the set of indices replaced -;;; with the an expression for the row major index. -;;; -(deftransform aref ((array &rest indices)) - (with-row-major-index (array indices index) - (data-vector-ref array index))) -;;; -(deftransform %aset ((array &rest stuff)) - (let ((indices (butlast stuff))) - (with-row-major-index (array indices index new-value) - (data-vector-set array index new-value)))) - -;;; ROW-MAJOR-AREF, %SET-ROW-MAJOR-AREF -- transform. -;;; -;;; Just convert into a data-vector-ref (or set) after checking that the -;;; index is inside the array total size. -;;; -(deftransform row-major-aref ((array index)) - `(data-vector-ref array (%check-bound array (array-total-size array) index))) -;;; -(deftransform %set-row-major-aref ((array index new-value)) - `(data-vector-set array - (%check-bound array (array-total-size array) index) - new-value)) - - -;;;; Bit-vector array operation canonicalization: -;;; -;;; We convert all bit-vector operations to have the result array specified. -;;; This allows any result allocation to be open-coded, and eliminates the need -;;; for any VM-dependent transforms to handle these cases. - -(dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 - bit-andc2 bit-orc1 bit-orc2)) - ;; - ;; Make a result array if result is NIL or unsupplied. - (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array) - '(bit-vector bit-vector &optional null) '* - :eval-name t :policy (>= speed space)) - `(,fun bit-array-1 bit-array-2 - (make-array (length bit-array-1) :element-type 'bit))) - ;; - ;; If result its T, make it the first arg. - (deftransform fun ((bit-array-1 bit-array-2 result-bit-array) - '(bit-vector bit-vector (member t)) '* - :eval-name t) - `(,fun bit-array-1 bit-array-2 bit-array-1))) - -;;; Similar for BIT-NOT, but there is only one arg... -;;; -(deftransform bit-not ((bit-array-1 &optional result-bit-array) - (bit-vector &optional null) * - :policy (>= speed space)) - '(bit-not bit-array-1 - (make-array (length bit-array-1) :element-type 'bit))) -;;; -(deftransform bit-not ((bit-array-1 result-bit-array) - (bit-vector (constant-argument t))) - '(bit-not bit-array-1 bit-array-1))) diff --git a/compiler/backend.lisp b/compiler/backend.lisp deleted file mode 100644 index 1e5daeeb2ca70bcdd1538ba2c85f1d8b57c9b371..0000000000000000000000000000000000000000 --- a/compiler/backend.lisp +++ /dev/null @@ -1,318 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/backend.lisp,v 1.26 1992/08/04 08:31:33 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file isolates all the backend specific data so that we can compile -;;; and use different backends. -;;; -;;; Written by William Lott. -;;; -(in-package "C") - -(export '(*backend* *target-backend* *native-backend* backend - backend-name backend-version backend-fasl-file-type - backend-fasl-file-implementation backend-fasl-file-version - backend-register-save-penalty backend-byte-order - backend-any-primitive-type backend-info-environment - backend-instruction-formats backend-instruction-flavors - backend-assembler-resources backend-special-arg-types - backend-disassem-params backend-internal-errors - backend-assembler-params backend-page-size - - ;; The various backends need to call these support routines - def-vm-support-routine make-stack-pointer-tn primitive-type - primitive-type-of emit-nop location-number)) - - -;;;; VM support routine stuff. - -(eval-when (compile eval) - -(defmacro def-vm-support-routines (&rest routines) - `(progn - (eval-when (compile load eval) - (defparameter vm-support-routines ',routines)) - (defstruct (vm-support-routines - (:print-function %print-vm-support-routines)) - ,@(mapcar #'(lambda (routine) - `(,routine nil :type (or function null))) - routines)) - ,@(mapcar - #'(lambda (name) - `(defun ,name (&rest args) - (apply (or (,(symbolicate "VM-SUPPORT-ROUTINES-" name) - (backend-support-routines *backend*)) - (error "Machine specific support routine ~S ~ - undefined for ~S" - ',name *backend*)) - args))) - routines))) - -); eval-when - -(def-vm-support-routines - ;; From VM.LISP - immediate-constant-sc - location-print-name - - ;; From PRIMTYPE.LISP - primitive-type-of - primitive-type - - ;; From C-CALL.LISP - make-call-out-tns - - ;; From CALL.LISP - standard-argument-location - make-return-pc-passing-location - make-old-fp-passing-location - make-old-fp-save-location - make-return-pc-save-location - make-argument-count-location - make-nfp-tn - make-stack-pointer-tn - make-number-stack-pointer-tn - make-unknown-values-locations - select-component-format - - ;; From NLX.LISP - make-nlx-sp-tn - make-dynamic-state-tns - - ;; From SUPPORT.LISP - generate-call-sequence - generate-return-sequence - - ;; For use with scheduler. - emit-nop - location-number) - -(defprinter vm-support-routines) - -(defmacro def-vm-support-routine (name ll &body body) - (unless (member (intern (string name) (find-package "C")) - vm-support-routines) - (warn "Unknown VM support routine: ~A" name)) - (let ((local-name (symbolicate (backend-name *target-backend*) "-" name))) - `(progn - (defun ,local-name ,ll ,@body) - (setf (,(intern (concatenate 'simple-string - "VM-SUPPORT-ROUTINES-" - (string name)) - (find-package "C")) - (backend-support-routines *target-backend*)) - #',local-name)))) - - - -;;;; The backend structure. - -(defstruct (backend - (:print-function %print-backend)) - ;; The name of this backend. Something like ``PMAX'' - (name nil) - - ;; The version string for this backend. - ;; Something like ``DECstation 3100/Mach 0.0'' - (version nil) - - ;; Information about fasl files for this backend. - (fasl-file-type nil) - (fasl-file-implementation nil) - (fasl-file-version nil) - - ;; The VM support routines. - (support-routines (make-vm-support-routines) :type vm-support-routines) - - ;; The number of references that a TN must have to offset the overhead of - ;; saving the TN across a call. - (register-save-penalty 0) - - ;; The byte order of the target machine. Should either be :big-endian - ;; which has the MSB first (RT) or :little-endian which has the MSB last - ;; (VAX). - (byte-order nil :type (or null (member :little-endian :big-endian))) - - ;; Translates from SC numbers to SC info structures. SC numbers are always - ;; used instead of names at run time, so changing this vector changes all the - ;; references. - (sc-numbers (make-array sc-number-limit :initial-element nil) - :type sc-vector) - - ;; A list of all the SBs defined, so that we can easily iterate over them. - (sb-list () :type list) - - ;; Translates from template names to template structures. - (template-names (make-hash-table :test #'eq) :type hash-table) - - ;; Hashtable from SC and SB names the corresponding structures. The META - ;; versions are only used at meta-compile and load times, so the defining - ;; macros can change these at meta-compile time without breaking the - ;; compiler. - (sc-names (make-hash-table :test #'eq) :type hash-table) - (sb-names (make-hash-table :test #'eq) :type hash-table) - (meta-sc-names (make-hash-table :test #'eq) :type hash-table) - (meta-sb-names (make-hash-table :test #'eq) :type hash-table) - - ;; Like *SC-Numbers*, but is updated at meta-compile time. - (meta-sc-numbers (make-array sc-number-limit :initial-element nil) - :type sc-vector) - - ;; Translates from primitive type names to the corresponding primitive-type - ;; structure. - (primitive-type-names (make-hash-table :test #'eq) :type hash-table) - - ;; Establishes a convenient handle on primitive type unions, or whatever. - ;; These names can only be used as the :arg-types or :result-types for VOPs - ;; and can map to anything else that can be used as :arg-types or - ;; :result-types (e.g. :or, :constant). - (primitive-type-aliases (make-hash-table :test #'eq) :type hash-table) - - ;; Meta-compile time translation from names to primitive types. - (meta-primitive-type-names (make-hash-table :test #'eq) :type hash-table) - - ;; The primitive type T is somewhat magical, in that it is the only - ;; primitive type that overlaps with other primitive types. An object - ;; of primitive-type T is in the canonical descriptor (boxed or pointer) - ;; representation. - ;; - ;; We stick the T primitive-type in a variable so that people who have to - ;; special-case it can get at it conveniently. This is done by the machine - ;; specific VM definition, since the DEF-PRIMITIVE-TYPE for T must specify - ;; the SCs that boxed objects can be allocated in. - (any-primitive-type nil :type (or null primitive-type)) - - ;; Hashtable translating from VOP names to the corresponding VOP-Parse - ;; structures. This information is only used at meta-compile time. - (parsed-vops (make-hash-table :test #'eq) :type hash-table) - - ;; The backend specific aspects of the info environment. - (info-environment nil :type list) - - ;; Support for the assembler. - (instruction-formats (make-hash-table :test #'eq) :type hash-table) - (instruction-flavors (make-hash-table :test #'equal) :type hash-table) - (special-arg-types (make-hash-table :test #'eq) :type hash-table) - (assembler-resources nil :type list) - - ;; The backend specific features list, if any. During a compilation, - ;; *features* is bound to *features* - misfeatures + features. - (%features nil :type list) - (misfeatures nil :type list) - - ;; Disassembler information. - (disassem-params nil :type t) - - ;; Mappings between CTYPE structures and the corresponding predicate. - ;; The type->predicate mapping hash is an alist because there is no - ;; such thing as a type= hash table. - (predicate-types (make-hash-table :test #'eq) :type hash-table) - (type-predicates nil :type list) - - ;; Vector of the internal errors defined for this backend, or NIL if - ;; they haven't been installed yet. - (internal-errors nil :type (or simple-vector null)) - - ;; Assembler parameters. - (assembler-params nil :type t) - - ;; The maximum number of bytes per page on this system. Used by genesis. - (page-size 0 :type index)) - - -(defprinter backend - name) - - -(defvar *native-backend* (make-backend) - "The backend for the machine we are running on. Do not change this.") -(defvar *target-backend* *native-backend* - "The backend we are attempting to compile.") -(defvar *backend* *native-backend* - "The backend we are using to compile with.") - - - -;;;; Other utility functions for fiddling with the backend. - -(export '(backend-features target-featurep backend-featurep native-featurep)) - -(defun backend-features (backend) - "Compute the *FEATURES* list to use with BACKEND." - (union (backend-%features backend) - (set-difference *features* - (backend-misfeatures backend)))) - -(defun target-featurep (feature) - "Same as EXT:FEATUREP, except use the features found in *TARGET-BACKEND*." - (let ((*features* (backend-features *target-backend*))) - (featurep feature))) - -(defun backend-featurep (feature) - "Same as EXT:FEATUREP, except use the features found in *BACKEND*." - (let ((*features* (backend-features *backend*))) - (featurep feature))) - -(defun native-featurep (feature) - "Same as EXT:FEATUREP, except use the features found in *NATIVE-BACKEND*." - (let ((*features* (backend-features *native-backend*))) - (featurep feature))) - - -;;; NEW-BACKEND -;;; -;;; Utility for creating a new backend structure for use with cross -;;; compilers. -;;; -(defun new-backend (name features misfeatures) - ;; If VM names a different package, rename that package so that VM doesn't - ;; name it. - (let ((pkg (find-package "VM"))) - (when pkg - (let ((pkg-name (package-name pkg))) - (unless (string= pkg-name name) - (rename-package pkg pkg-name - (remove "VM" (package-nicknames pkg) - :test #'string=)) - (unuse-package pkg "C"))))) - ;; Make sure VM names our package, creating it if necessary. - (let* ((pkg (or (find-package name) - (make-package name :nicknames '("VM")))) - (nicknames (package-nicknames pkg))) - (unless (member "VM" nicknames :test #'string=) - (rename-package pkg name (cons "VM" nicknames))) - ;; And make sure we are using the necessary packages. - (use-package '("C-CALL" "ALIEN-INTERNALS" "ALIEN" "BIGNUM" "UNIX" - "LISP" "KERNEL" "EXTENSIONS" "SYSTEM" "C") - pkg)) - ;; Make sure the native info env list is stored in *native-backend* - (unless (backend-info-environment *native-backend*) - (setf (backend-info-environment *native-backend*) *info-environment*)) - ;; Cons up a backend structure, filling in the info-env and features slots. - (let ((backend (make-backend - :name name - :info-environment - (cons (make-info-environment - :name - (concatenate 'string name " backend")) - (remove-if #'(lambda (name) - (let ((len (length name))) - (and (> len 8) - (string= name " backend" - :start1 (- len 8))))) - *info-environment* - :key #'info-env-name)) - :%features features - :misfeatures misfeatures))) - (setf *target-backend* backend) - (define-standard-type-predicates) - backend)) diff --git a/compiler/bit-util.lisp b/compiler/bit-util.lisp deleted file mode 100644 index 1536c9715300c3a4ac0166dcf12414192d9e2265..0000000000000000000000000000000000000000 --- a/compiler/bit-util.lisp +++ /dev/null @@ -1,57 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/bit-util.lisp,v 1.4 1991/02/20 14:56:42 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Bit-vector hacking utilities, potentially implementation-dependent for -;;; speed. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(declaim (inline clear-bit-vector set-bit-vector bit-vector-replace - bit-vector-copy)) - -;;; Clear-Bit-Vector -- Interface -;;; -;;; Clear a bit-vector to zeros. -;;; -(defun clear-bit-vector (vec) - (declare (type simple-bit-vector vec)) - (bit-xor vec vec t)) - - -;;; Set-Bit-Vector -- Interface -;;; -;;; Fill a bit vector with ones. -;;; -(defun set-bit-vector (vec) - (declare (type simple-bit-vector vec)) - (bit-orc2 vec vec t)) - - -;;; Bit-Vector-Replace -- Interface -;;; -;;; Replace the bits in To with the bits in From. -;;; -(defun bit-vector-replace (to from) - (declare (type simple-bit-vector to from)) - (bit-ior from from to)) - - -;;; Bit-Vector-Copy -- Interface -;;; -;;; Copy a bit-vector. -;;; -(defun bit-vector-copy (vec) - (declare (type simple-bit-vector vec)) - (bit-ior vec vec (make-array (length vec) :element-type 'bit))) diff --git a/compiler/byte-comp.lisp b/compiler/byte-comp.lisp deleted file mode 100644 index 8fcbea1da4a8549d4b3f63711eba4499c2169a13..0000000000000000000000000000000000000000 --- a/compiler/byte-comp.lisp +++ /dev/null @@ -1,1804 +0,0 @@ -;;; -*- Package: C -*- -;;; -;;; ********************************************************************** -;;; 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/byte-comp.lisp,v 1.4 1992/09/07 15:33:39 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the noise to byte-compile stuff. It uses the -;;; same front end as the real compiler, but generates a byte-code instead -;;; of native code. -;;; -;;; Written by William Lott -;;; - -(in-package "C") - -;;; ### Remaining work: -;;; -;;; - add more inline operations & calls to two-arg functions. structure slots -;;; - Breakpoints/debugging info. -;;; - The XEP needs to have the name, arglist, etc. in it. (?) -;;; compact small integer XEP slots into fixnum sub-fields. -;;; - - -;;;; Stuff to emit noise. - -;;; Note: we use the regular assembler, but we don't use any ``instructions'' -;;; because there is no way to keep our byte-code instructions seperate from -;;; the instructions used by the native backend. Besides, we don't want to do -;;; any scheduling or anything like that, anyway. - -(declaim (inline output-byte)) -(defun output-byte (segment byte) - (declare (type new-assem:segment segment) - (type (unsigned-byte 8) byte)) - (new-assem:emit-byte segment byte)) - - -;;; OUTPUT-EXTENDED-OPERAND -- Internal -;;; -;;; Output Operand as 1 or 4 bytes, using #xFF as the extend code. -;;; -(defun output-extended-operand (segment operand) - (declare (type (unsigned-byte 24) operand)) - (cond ((<= operand 254) - (output-byte segment operand)) - (t - (output-byte segment #xFF) - (output-byte segment (ldb (byte 8 16) operand)) - (output-byte segment (ldb (byte 8 8) operand)) - (output-byte segment (ldb (byte 8 0) operand))))) - - -;;; OUTPUT-BYTE-WITH-OPERAND -- internal. -;;; -;;; Output a byte, logior'ing in a 4 bit immediate constant. If that -;;; immediate won't fit, then emit it as the next 1-4 bytes. -;;; -(defun output-byte-with-operand (segment byte operand) - (declare (type new-assem:segment segment) - (type (unsigned-byte 8) byte) - (type (unsigned-byte 24) operand)) - (cond ((<= operand 14) - (output-byte segment (logior byte operand))) - (t - (output-byte segment (logior byte 15)) - (output-extended-operand segment operand))) - (undefined-value)) - - -;;; OUTPUT-LABEL -- internal. -;;; -(defun output-label (segment label) - (declare (type new-assem:segment segment) - (type new-assem:label label)) - (new-assem:assemble (segment) - (new-assem:emit-label label))) - -;;; OUTPUT-REFERENCE -- internal. -;;; -;;; Output a reference to LABEL. If RELATIVE is NIL, then this reference -;;; can never be relative. -;;; -(defun output-reference (segment label) - (declare (type new-assem:segment segment) - (type new-assem:label label)) - (new-assem:emit-back-patch - segment - 3 - #'(lambda (segment posn) - (declare (type new-assem:segment segment) - (ignore posn)) - (let ((target (new-assem:label-position label))) - (assert (<= 0 target (1- (ash 1 24)))) - (output-byte segment (ldb (byte 8 16) target)) - (output-byte segment (ldb (byte 8 8) target)) - (output-byte segment (ldb (byte 8 0) target)))))) - -;;; OUTPUT-BRANCH -- internal. -;;; -;;; Output some branch byte-sequence. -;;; -(defun output-branch (segment kind label) - (declare (type new-assem:segment segment) - (type (unsigned-byte 8) kind) - (type new-assem:label label)) - (new-assem:emit-chooser - segment 4 1 - #'(lambda (segment posn delta) - (when (<= (- (ash 1 7)) - (- (new-assem:label-position label posn delta) posn 2) - (1- (ash 1 7))) - (new-assem:emit-chooser - segment 2 1 - #'(lambda (segment posn delta) - (declare (ignore segment) (type index posn delta)) - (when (zerop (- (new-assem:label-position label posn delta) - posn 2)) - ;; Don't emit anything, because the branch is to the following - ;; instruction. - t)) - #'(lambda (segment posn) - ;; We know we fit in one byte. - (declare (type new-assem:segment segment) - (type index posn)) - (output-byte segment (logior kind 1)) - (output-byte segment - (ldb (byte 8 0) - (- (new-assem:label-position label) posn 2))))) - t)) - #'(lambda (segment posn) - (declare (type new-assem:segment segment) - (ignore posn)) - (let ((target (new-assem:label-position label))) - (assert (<= 0 target (1- (ash 1 24)))) - (output-byte segment kind) - (output-byte segment (ldb (byte 8 16) target)) - (output-byte segment (ldb (byte 8 8) target)) - (output-byte segment (ldb (byte 8 0) target)))))) - -;;; BYTE-OUTPUT-LENGTH -- internal interface. -;;; -;;; Called by the dumping stuff to find out exactly how much noise it needs -;;; to dump. -;;; -(defun byte-output-length (segment) - (declare (type new-assem:segment segment)) - (new-assem:finalize-segment segment)) - - - -;;;; System constants, Xops, and inline functions. - -(defvar *system-constants* (make-array 256)) -(defvar *system-constant-codes* (make-hash-table :test #'eq)) - -(eval-when (compile eval) - (defmacro def-system-constant (index form) - `(let ((val ,form)) - (setf (svref *system-constants* ,index) val) - (setf (gethash val *system-constant-codes*) ,index)))) - -(def-system-constant 0 nil) -(def-system-constant 1 t) -(def-system-constant 2 :start) -(def-system-constant 3 :end) -(def-system-constant 4 :test) -(def-system-constant 5 :count) -(def-system-constant 6 :test-not) -(def-system-constant 7 :key) -(def-system-constant 8 :from-end) -(def-system-constant 9 :type) - -(defparameter *xop-names* - '(breakpoint; 0 - dup; 1 - type-check; 2 - fdefn-function-or-lose; 3 - default-unknown-values; 4 - xop5 - xop6 - xop7 - merge-unknown-values - make-closure - throw - catch - breakup - return-from - tagbody - go - unwind-protect)) - -(defun xop-index-or-lose (name) - (or (position name *xop-names* :test #'eq) - (error "Unknown XOP ~S" name))) - - -(defstruct inline-function-info - function - number - type) - -(defparameter *inline-functions* - (let ((number -1)) - (mapcar #'(lambda (stuff) - (destructuring-bind (name arg-types result-type) stuff - (make-inline-function-info - :function name - :number (incf number) - :type (specifier-type - `(function ,arg-types ,result-type))))) - '((+ (fixnum fixnum) fixnum) - (- (fixnum fixnum) fixnum) - (make-value-cell (t) t) - (value-cell-ref (t) t) - (value-cell-setf (t t) t) - (symbol-value (symbol) t) - (setf-symbol-value (t symbol) t) - (%byte-special-bind (t symbol) (values)) - (%byte-special-unbind () (values)) - (cons-unique-tag () t))))) - -(defun inline-function-number-or-lose (function) - (let ((info (find function *inline-functions* - :key #'inline-function-info-function))) - (if info - (inline-function-info-number info) - (error "Unknown inline function: ~S" function)))) - - - -;;;; Annotations hung off the IR1 while compiling. - - -(defstruct byte-component-info - (constants (make-array 10 :adjustable t :fill-pointer 0))) - - -(defstruct byte-lambda-info - (label nil :type (or null label)) - (stack-size 0 :type index) - (interesting t :type (member t nil))) - -(defun block-interesting (block) - (byte-lambda-info-interesting (lambda-info (block-home-lambda block)))) - -(defstruct byte-lambda-var-info - (argp nil :type (member t nil)) - (offset 0 :type index)) - -(defstruct byte-nlx-info - (stack-slot nil :type (or null index)) - (label (new-assem:gen-label) :type new-assem:label) - (duplicate nil :type (member t nil))) - -(defstruct (byte-block-info - (:include block-annotation) - (:print-function %print-byte-block-info) - (:constructor make-byte-block-info - (block &key produces produces-sset consumes - total-consumes nlx-entries nlx-entry-p))) - (label (new-assem:gen-label) :type new-assem:label) - ;; - ;; A list of the continuations that this block pushes onto the stack. - (produces nil :type list) - ;; - ;; An SSET of the produces for faster set manipulations. - (produces-sset (make-sset) :type sset) - ;; - ;; A list of the continuations that this block pops from the stack. - (consumes nil :type list) - ;; - ;; The transitive closure of what this block and all its successors - ;; consume. After stack-analysis, that is. - (total-consumes (make-sset) :type sset) - ;; - ;; Set to T whenever the consumes lists of a successor changes and the - ;; block is queued for re-analysis so we can easily avoid queueing the same - ;; block several times. - (already-queued nil :type (member t nil)) - ;; - ;; The continuations on the stack (in order) when this block starts. - (start-stack :unknown :type (or (member :unknown) list)) - ;; - ;; The continuations on the stack (in order) when this block ends. - (end-stack nil :type list) - ;; - ;; List of (nlx-infos . extra-stack-cruft) for each entry point in this - ;; block. - (nlx-entries nil :type list) - ;; - ;; T if this is an %nlx-entry point, and we shouldn't just assume we know - ;; what is going to be on the stack. - (nlx-entry-p nil :type (member t nil))) - -(defprinter byte-block-info - block) - -(defstruct (byte-continuation-info - (:include sset-element) - (:print-function %print-byte-continuation-info) - (:constructor make-byte-continuation-info (continuation results))) - (continuation (required-argument) :type continuation) - (results (required-argument) - :type (or (member :fdefinition :eq-test :unknown) unsigned-byte))) - -(defprinter byte-continuation-info - continuation - results) - - - -;;;; Annotate the IR1 - -(defun annotate-continuation (cont results) - ;; For some reason, do-nodes does the same return node multiple times, - ;; which causes annotate-continuation to be called multiple times on the - ;; same continuation. So we can't assert that we haven't done it. - #+nil - (assert (null (continuation-info cont))) - (setf (continuation-info cont) - (make-byte-continuation-info cont results)) - (undefined-value)) - -(defun annotate-set (set) - ;; Annotate the value for one value. - (annotate-continuation (set-value set) 1)) - -(defun annotate-basic-combination-args (call) - (declare (type basic-combination call)) - (etypecase call - (combination - (dolist (arg (combination-args call)) - (when arg - (annotate-continuation arg 1)))) - (mv-combination - ;; Annoate the args. We allow initial args to supply a fixed number of - ;; values, but everything after the first :unknown arg must also be - ;; unknown. This picks off most of the standard uses (i.e. calls to - ;; apply), but still is easy to implement. - (labels - ((allow-fixed (remaining) - (when remaining - (let* ((cont (car remaining)) - (values (nth-value 1 - (values-types - (continuation-derived-type cont))))) - (cond ((eq values :unknown) - (force-to-unknown remaining)) - (t - (annotate-continuation cont values) - (allow-fixed (cdr remaining))))))) - (force-to-unknown (remaining) - (when remaining - (let ((cont (car remaining))) - (when cont - (annotate-continuation cont :unknown))) - (force-to-unknown (cdr remaining))))) - (allow-fixed (mv-combination-args call))))) - (undefined-value)) - -(defun annotate-local-call (call) - (annotate-basic-combination-args call) - (annotate-continuation (basic-combination-fun call) 0)) - -;;; ANNOTATE-FULL-CALL -- Internal -;;; -;;; Annotate the values for any :full combination. This includes inline -;;; functions, multiple value calls & throw. If a real full call, clear any -;;; type-check annotations. -;;; -(defun annotate-full-call (call) - (let* ((fun (basic-combination-fun call)) - (name (continuation-function-name fun)) - (info (find name *inline-functions* - :key #'inline-function-info-function))) - (cond ((and info - (valid-function-use call (inline-function-info-type info))) - (annotate-basic-combination-args call) - (setf (node-tail-p call) nil) - (setf (basic-combination-info call) info) - (annotate-continuation fun 0)) - ((and (mv-combination-p call) (eq name '%throw)) - (let ((args (basic-combination-args call))) - (assert (= (length args) 2)) - (annotate-continuation (first args) 1) - (annotate-continuation (second args) :unknown)) - (setf (node-tail-p call) nil) - (annotate-continuation fun 0)) - (t - (annotate-basic-combination-args call) - (dolist (arg (basic-combination-args call)) - (when (continuation-type-check arg) - (setf (continuation-%type-check arg) :deleted))) - (annotate-continuation - fun - (if (continuation-function-name fun) :fdefinition 1))))) - (undefined-value)) - -(defun annotate-known-call (call) - (annotate-basic-combination-args call) - (setf (node-tail-p call) nil) - (annotate-continuation (basic-combination-fun call) 0) - t) - -(defun annotate-basic-combination (call) - ;; Annotate the function. - (let ((kind (basic-combination-kind call))) - (case kind - (:local - (annotate-local-call call)) - (:full - (annotate-full-call call)) - (:error - (setf (basic-combination-kind call) :full) - (annotate-full-call call)) - (t - (unless (and (function-info-byte-compile kind) - (funcall (or (function-info-byte-annotate kind) - #'annotate-known-call) - call)) - (setf (basic-combination-kind call) :full) - (annotate-full-call call))))) - - ;; If this is (still) a tail-call, then blow away the return. - (when (node-tail-p call) - (node-ends-block call) - (let ((block (node-block call))) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (component-tail (block-component block))))) - (undefined-value)) - -(defun annotate-if (if) - ;; Annotate the test. - (let* ((cont (if-test if)) - (use (continuation-use cont))) - (annotate-continuation - cont - (if (and (combination-p use) - (eq (continuation-function-name (combination-fun use)) 'eq) - (= (length (combination-args use)) 2)) - ;; If the test is a call to EQ, then we can use branch-if-eq - ;; so don't need to actually funcall the test. - :eq-test - ;; Otherwise, funcall the test for 1 value. - 1)))) - -(defun annotate-return (return) - (let ((cont (return-result return))) - (annotate-continuation - cont - (nth-value 1 (values-types (continuation-derived-type cont)))))) - -(defun annotate-exit (exit) - (let ((cont (exit-value exit))) - (when cont - (annotate-continuation cont :unknown)))) - -(defun annotate-block (block) - (do-nodes (node cont block) - (etypecase node - (bind) - (ref) - (cset (annotate-set node)) - (basic-combination (annotate-basic-combination node)) - (cif (annotate-if node)) - (creturn (annotate-return node)) - (entry) - (exit (annotate-exit node)))) - (undefined-value)) - -(defun annotate-ir1 (component) - (do-blocks (block component) - (when (block-interesting block) - (annotate-block block))) - (undefined-value)) - - - -;;;; Stack analysis. - -(defun compute-produces-and-consumes (block) - (let ((stack nil) - (consumes nil) - (total-consumes (make-sset)) - (nlx-entries nil) - (nlx-entry-p nil) - (counter 0)) - (labels ((interesting (cont) - (and cont - (let ((info (continuation-info cont))) - (and info - (not (member (byte-continuation-info-results info) - '(0 :eq-test))))))) - (consume (cont) - (cond ((not (interesting cont))) - (stack - (assert (eq (car stack) cont)) - (pop stack)) - (t - (let ((info (continuation-info cont))) - (unless (byte-continuation-info-number info) - (setf (byte-continuation-info-number info) - (incf counter))) - (sset-adjoin info total-consumes)) - (push cont consumes))))) - (do-nodes (node cont block) - (etypecase node - (bind) - (ref) - (cset - (consume (set-value node))) - (basic-combination - (dolist (arg (reverse (basic-combination-args node))) - (when arg - (consume arg))) - (consume (basic-combination-fun node)) - (when (eq (continuation-function-name - (basic-combination-fun node)) - '%nlx-entry) - (let ((nlx-info (continuation-value - (first (basic-combination-args node))))) - (when (eq (cleanup-kind (nlx-info-cleanup nlx-info)) :block) - (push (nlx-info-continuation nlx-info) stack))) - (setf nlx-entry-p t))) - (cif - (consume (if-test node))) - (creturn - (consume (return-result node))) - (entry - (let ((nlx-info (cleanup-nlx-info (entry-cleanup node)))) - (when nlx-info - (push (list nlx-info stack (reverse consumes)) nlx-entries)))) - (exit - (when (exit-value node) - (consume (exit-value node))))) - (when (and (not (exit-p node)) (interesting cont)) - (push cont stack)))) - (setf (block-info block) - (make-byte-block-info block - :produces stack - :produces-sset - (let ((result (make-sset))) - (dolist (product stack) - (sset-adjoin (continuation-info product) - result)) - result) - :consumes (reverse consumes) - :total-consumes total-consumes - :nlx-entries nlx-entries - :nlx-entry-p nlx-entry-p))) - (undefined-value)) - -(defun walk-successors (block stack) - (let ((tail (component-tail (block-component block)))) - (dolist (succ (block-succ block)) - (unless (or (eq succ tail) - (not (block-interesting succ)) - (byte-block-info-nlx-entry-p (block-info succ))) - (walk-block succ block stack))))) - -(defun walk-nlx-entry (nlx-infos stack produce consume) - (dolist (cont consume) - (assert (eq (car stack) cont)) - (pop stack)) - (setf stack (append produce stack)) - (dolist (nlx-info nlx-infos) - (walk-block (nlx-info-target nlx-info) nil stack))) - -(defun walk-block (block pred stack) - ;; Pop everything off of stack that isn't live. - (let* ((info (block-info block)) - (live (byte-block-info-total-consumes info))) - (collect ((pops)) - (let ((fixed 0)) - (flet ((flush-fixed () - (unless (zerop fixed) - (pops `(%byte-pop-stack ,fixed)) - (setf fixed 0)))) - (loop - (unless stack - (return)) - (let* ((cont (car stack)) - (info (continuation-info cont))) - (when (sset-member info live) - (return)) - (pop stack) - (let ((results (byte-continuation-info-results info))) - (case results - (:unknown - (flush-fixed) - (pops `(%byte-pop-stack 0))) - (:fdefinition - (incf fixed)) - (t - (incf fixed results)))))) - (flush-fixed))) - (when (pops) - (assert pred) - (let ((cleanup-block - (insert-cleanup-code pred block - (continuation-next (block-start block)) - `(progn ,@(pops))))) - (annotate-block cleanup-block)))) - (cond ((eq (byte-block-info-start-stack info) :unknown) - ;; Record what the stack looked like at the start of this block. - (setf (byte-block-info-start-stack info) stack) - ;; Process any nlx entries that build off of our stack. - (dolist (stuff (byte-block-info-nlx-entries info)) - (walk-nlx-entry (first stuff) stack (second stuff) (third stuff))) - ;; Remove whatever we consume. - (dolist (cont (byte-block-info-consumes info)) - (assert (eq (car stack) cont)) - (pop stack)) - ;; Add whatever we produce. - (setf stack (append (byte-block-info-produces info) stack)) - (setf (byte-block-info-end-stack info) stack) - ;; Pass that on to all our successors. - (walk-successors block stack)) - (t - ;; We have already processed the successors of this block. Just - ;; make sure we thing the stack is the same now as before. - (assert (equal (byte-block-info-start-stack info) stack))))) - (undefined-value)) - -(defun byte-stack-analyze (component) - (let ((head nil)) - (do-blocks (block component) - (when (block-interesting block) - (compute-produces-and-consumes block) - (push block head) - (setf (byte-block-info-already-queued (block-info block)) t))) - (let ((tail (last head))) - (labels ((maybe-enqueue (block) - (when (block-interesting block) - (let ((info (block-info block))) - (unless (byte-block-info-already-queued info) - (setf (byte-block-info-already-queued info) t) - (let ((new (list block))) - (if head - (setf (cdr tail) new) - (setf head new)) - (setf tail new)))))) - (maybe-enqueue-predecessors (block) - (dolist (pred (block-pred block)) - (unless (eq pred (component-head (block-component block))) - (maybe-enqueue pred))))) - (loop - (unless head - (return)) - (let* ((block (pop head)) - (info (block-info block)) - (total-consumes (byte-block-info-total-consumes info)) - (did-anything nil)) - (setf (byte-block-info-already-queued info) nil) - (dolist (succ (block-succ block)) - (unless (eq succ (component-tail component)) - (let ((succ-info (block-info succ))) - (when (sset-union-of-difference - total-consumes - (byte-block-info-total-consumes succ-info) - (byte-block-info-produces-sset succ-info)) - (setf did-anything t))))) - (when did-anything - (maybe-enqueue-predecessors block))))))) - (walk-successors (component-head component) nil) - (undefined-value)) - - - -;;;; Actually generate the byte-code - -(defvar *byte-component-info*) - -(defconstant byte-push-local #b00000000) -(defconstant byte-push-arg #b00010000) -(defconstant byte-push-constant #b00100000) -(defconstant byte-push-system-constant #b00110000) -(defconstant byte-push-int #b01000000) -(defconstant byte-push-neg-int #b01010000) -(defconstant byte-pop-local #b01100000) -(defconstant byte-pop-n #b01110000) -(defconstant byte-call #b10000000) -(defconstant byte-tail-call #b10010000) -(defconstant byte-multiple-call #b10100000) -(defconstant byte-named #b00001000) -(defconstant byte-local-call #b10110000) -(defconstant byte-local-tail-call #b10111000) -(defconstant byte-local-multiple-call #b11000000) -(defconstant byte-return #b11001000) -(defconstant byte-branch-always #b11010000) -(defconstant byte-branch-if-true #b11010010) -(defconstant byte-branch-if-false #b11010100) -(defconstant byte-branch-if-eq #b11010110) -(defconstant byte-xop #b11011000) -(defconstant byte-inline-function #b11100000) - - -(defun output-push-int (segment int) - (declare (type new-assem:segment segment) - (type (integer #.(- (ash 1 24)) #.(1- (ash 1 24))))) - (if (minusp int) - (output-byte-with-operand segment byte-push-neg-int (- (1+ int))) - (output-byte-with-operand segment byte-push-int int))) - -(defun output-push-constant-leaf (segment constant) - (declare (type new-assem:segment segment) - (type constant constant)) - (let ((info (constant-info constant))) - (if info - (output-byte-with-operand segment - (ecase (car info) - (:system-constant - byte-push-system-constant) - (:local-constant - byte-push-constant)) - (cdr info)) - (let ((const (constant-value constant))) - (if (and (integerp const) (< (- (ash 1 24)) const (ash 1 24))) - ;; It can be represented as an immediate. - (output-push-int segment const) - ;; We need to store it in the constants pool. - (let* ((posn (gethash const *system-constant-codes*)) - (new-info (if posn - (cons :system-constant posn) - (cons :local-constant - (vector-push-extend - constant - (byte-component-info-constants - *byte-component-info*)))))) - (setf (constant-info constant) new-info) - (output-push-constant-leaf segment constant))))))) - -(defun output-push-constant (segment value) - (if (and (integerp value) - (< (- (ash 1 24)) value (ash 1 24))) - (output-push-int segment value) - (output-push-constant-leaf segment (find-constant value)))) - - -;;; BYTE-LOAD-TIME-CONSTANT-INDEX -- Internal -;;; -;;; Return the offset of a load-time constant in the constant pool, adding -;;; it if absent. -;;; -(defun byte-load-time-constant-index (kind datum) - (let ((constants (byte-component-info-constants *byte-component-info*))) - (or (position-if #'(lambda (x) - (and (consp x) - (eq (car x) kind) - (typecase datum - (cons (equal (cdr x) datum)) - (ctype (type= (cdr x) datum)) - (t - (eq (cdr x) datum))))) - constants) - (vector-push-extend (cons kind datum) constants)))) - - -(defun output-push-load-time-constant (segment kind datum) - (output-byte-with-operand segment byte-push-constant - (byte-load-time-constant-index kind datum)) - (undefined-value)) - -(defun output-do-inline-function (segment function) - ;; Note: we don't annotate this as a call site, because it is used for - ;; internal stuff. Random functions that get inlined have code locations - ;; added byte generate-byte-code-for-full-call below. - (output-byte segment - (logior byte-inline-function - (inline-function-number-or-lose function)))) - -(defun output-do-xop (segment xop) - (let ((index (xop-index-or-lose xop))) - (cond ((< index 7) - (output-byte segment (logior byte-xop index))) - (t - (output-byte segment (logior byte-xop 7)) - (output-byte segment index))))) - -(defun output-ref-lambda-var (segment var env - &optional (indirect-value-cells t)) - (declare (type new-assem:segment segment) - (type lambda-var var) - (type environment env)) - (if (eq (lambda-environment (lambda-var-home var)) env) - (let ((info (leaf-info var))) - (output-byte-with-operand segment - (if (byte-lambda-var-info-argp info) - byte-push-arg - byte-push-local) - (byte-lambda-var-info-offset info))) - (output-byte-with-operand segment - byte-push-arg - (position var (environment-closure env)))) - (when (and indirect-value-cells (lambda-var-indirect var)) - (output-do-inline-function segment 'value-cell-ref))) - -(defun output-ref-nlx-info (segment info env) - (if (eq (node-environment (cleanup-mess-up (nlx-info-cleanup info))) env) - (output-byte-with-operand segment - byte-push-local - (byte-nlx-info-stack-slot - (nlx-info-info info))) - (output-byte-with-operand segment - byte-push-arg - (position info (environment-closure env))))) - -(defun output-set-lambda-var (segment var env &optional make-value-cells) - (declare (type new-assem:segment segment) - (type lambda-var var) - (type environment env)) - (let ((indirect (lambda-var-indirect var))) - (cond ((not (eq (lambda-environment (lambda-var-home var)) env)) - ;; This is not this guys home environment. So we need to get it - ;; the value cell out of the closure, and fill it in. - (assert indirect) - (assert (not make-value-cells)) - (output-byte-with-operand segment byte-push-arg - (position var (environment-closure env))) - (output-do-inline-function segment 'value-cell-setf)) - (t - (let* ((pushp (and indirect (not make-value-cells))) - (byte-code (if pushp byte-push-local byte-pop-local)) - (info (leaf-info var))) - (assert (not (byte-lambda-var-info-argp info))) - (when (and indirect make-value-cells) - ;; Replace the stack top with a value cell holding the - ;; stack top. - (output-do-inline-function segment 'make-value-cell)) - (output-byte-with-operand segment byte-code - (byte-lambda-var-info-offset info)) - (when pushp - (output-do-inline-function segment 'value-cell-setf))))))) - -;;; CANONICALIZE-VALUES -- internal. -;;; -;;; Output whatever noise is necessary to canonicalize the values on the -;;; top of the stack. Desired is the number we want, and supplied is the -;;; number we have. Either push NIL or pop-n to make them balanced. -;;; Note: either desired or supplied can be :unknown, in which case it means -;;; use the ``unknown-values'' convention (which is the stack values followed -;;; by the number of values). -;;; -(defun canonicalize-values (segment desired supplied) - (declare (type new-assem:segment segment) - (type (or (member :unknown) index) desired supplied)) - (cond ((eq desired :unknown) - (unless (eq supplied :unknown) - (output-byte-with-operand segment byte-push-int supplied))) - ((eq supplied :unknown) - (unless (eq desired :unknown) - (output-push-int segment desired) - (output-do-xop segment 'default-unknown-values))) - ((< supplied desired) - (dotimes (i (- desired supplied)) - (output-push-constant segment nil))) - ((> supplied desired) - (output-byte-with-operand segment byte-pop-n (- supplied desired)))) - (undefined-value)) - - -(defparameter *byte-type-weakenings* - (mapcar #'specifier-type - '(fixnum single-float double-float simple-vector simple-bit-vector - bit-vector))) - -;;; BYTE-GENERATE-TYPE-CHECK -- Internal -;;; -;;; Emit byte code to check that the value on TOS is of the specified Type. -;;; Node is used for policy information. We weaken or entirely omit the type -;;; check if speed is more important than safety. -;;; -(defun byte-generate-type-check (segment type node) - (declare (type ctype type) (type node node)) - (unless (or (policy node (zerop safety)) - (csubtypep *universal-type* type)) - (let ((type (if (policy node (> speed safety)) - (dolist (super *byte-type-weakenings* type) - (when (csubtypep type super) (return super))) - type))) - (output-do-xop segment 'type-check) - (output-extended-operand - segment - (byte-load-time-constant-index :type-predicate type))))) - - -;;; CHECKED-CANONICALIZE-VALUES -- Internal -;;; -;;; This function is used when we are generating code which delivers values -;;; to a continuation. If this continuation needs a type check, and has a -;;; single value, then we do a type check. We also CANONICALIZE-VALUES for the -;;; continuation's desired number of values. -;;; -(defun checked-canonicalize-values (segment cont supplied) - (let ((info (continuation-info cont))) - (if info - (let ((desired (byte-continuation-info-results info))) - (flet ((do-check () - (byte-generate-type-check - segment - (single-value-type (continuation-asserted-type cont)) - (continuation-dest cont)))) - (cond - ((member (continuation-type-check cont) '(nil :deleted)) - (canonicalize-values segment desired supplied)) - ((eql supplied 1) - (do-check) - (canonicalize-values segment desired supplied)) - ((eql desired 1) - (canonicalize-values segment desired supplied) - (do-check)) - (t - (canonicalize-values segment desired supplied))))) - (canonicalize-values segment 0 supplied)))) - - -(defun generate-byte-code-for-bind (segment bind cont) - (declare (type new-assem:segment segment) (type bind bind) - (ignore cont)) - (let ((lambda (bind-lambda bind)) - (env (node-environment bind))) - (ecase (lambda-kind lambda) - ((nil :top-level :escape :cleanup :optional) - (let* ((info (lambda-info lambda)) - (frame-size (byte-lambda-info-stack-size info))) - (cond ((< frame-size (* 255 2)) - (output-byte segment (ceiling frame-size 2))) - (t - (output-byte segment 255) - (output-byte segment (ldb (byte 8 16) frame-size)) - (output-byte segment (ldb (byte 8 8) frame-size)) - (output-byte segment (ldb (byte 8 0) frame-size)))) - (loop - for argnum upfrom 0 - for var in (lambda-vars lambda) - for info = (lambda-var-info var) - do (unless (or (null info) (byte-lambda-var-info-argp info)) - (output-byte-with-operand segment byte-push-arg argnum) - (output-set-lambda-var segment var env t))))) - ((:let :mv-let :assignment) - ;; Everything has been taken care of in the combination node. - ))) - (undefined-value)) - - -;;; This hashtable translates from n-ary function names to the two-arg specific -;;; versions which we call to avoid rest-arg consing. -;;; -(defvar *two-arg-functions* (make-hash-table :test #'eq)) - -(dolist (fun '((KERNEL:TWO-ARG-IOR LOGIOR) - (KERNEL:TWO-ARG-* *) - (KERNEL:TWO-ARG-+ +) - (KERNEL:TWO-ARG-/ /) - (KERNEL:TWO-ARG-- -) - (KERNEL:TWO-ARG-> >) - (KERNEL:TWO-ARG-< <) - (KERNEL:TWO-ARG-= =) - (KERNEL:TWO-ARG-LCM LCM) - (KERNEL:TWO-ARG-AND LOGAND) - (KERNEL:TWO-ARG-GCD GCD) - (KERNEL:TWO-ARG-XOR LOGXOR) - - (two-arg-char= char=) - (two-arg-char< char<) - (two-arg-char> char>) - (two-arg-char-equal char-equal) - (two-arg-char-lessp char-lessp) - (two-arg-char-greaterp char-greaterp))) - - (setf (gethash (second fun) *two-arg-functions*) (first fun))) - - -(defun generate-byte-code-for-ref (segment ref cont) - (declare (type new-assem:segment segment) (type ref ref) - (type continuation cont)) - (let ((info (continuation-info cont))) - ;; If there is no info, then nobody wants the result. - (when info - (let ((values (byte-continuation-info-results info)) - (leaf (ref-leaf ref))) - (cond - ((eq values :fdefinition) - (assert (and (global-var-p leaf) - (eq (global-var-kind leaf) - :global-function))) - (let* ((name (global-var-name leaf)) - (found (gethash name *two-arg-functions*))) - (output-push-load-time-constant - segment :fdefinition - (if (and found - (= (length (combination-args (continuation-dest cont))) - 2)) - found - name)))) - ((eql values 0) - ;; Real easy! - nil) - (t - (etypecase leaf - (constant - (output-push-constant-leaf segment leaf)) - (clambda - (let* ((refered-env (lambda-environment leaf)) - (closure (environment-closure refered-env))) - (if (null closure) - (output-push-load-time-constant segment :entry leaf) - (let ((my-env (node-environment ref))) - (output-push-load-time-constant segment :xep leaf) - (dolist (thing closure) - (etypecase thing - (lambda-var - (output-ref-lambda-var segment thing my-env nil)) - (nlx-info - (output-ref-nlx-info segment thing my-env)))) - (output-push-int segment (length closure)) - (output-do-xop segment 'make-closure))))) - (functional - (output-push-load-time-constant segment :entry leaf)) - (lambda-var - (output-ref-lambda-var segment leaf (node-environment ref))) - (global-var - (ecase (global-var-kind leaf) - ((:special :global :constant) - (output-push-constant segment (global-var-name leaf)) - (output-do-inline-function segment 'symbol-value)) - (:global-function - (output-push-load-time-constant segment - :fdefinition - (global-var-name leaf)) - (output-do-xop segment 'fdefn-function-or-lose))))) - (checked-canonicalize-values segment cont 1)))))) - (undefined-value)) - -(defun generate-byte-code-for-set (segment set cont) - (declare (type new-assem:segment segment) (type cset set) - (type continuation cont)) - (let* ((leaf (set-var set)) - (info (continuation-info cont)) - (values (if info - (byte-continuation-info-results info) - 0))) - (unless (eql values 0) - ;; Someone wants the value, so copy it. - (output-do-xop segment 'dup)) - (etypecase leaf - (global-var - (ecase (global-var-kind leaf) - ((:special :global) - (output-push-constant segment (global-var-name leaf)) - (output-do-inline-function segment 'setf-symbol-value)))) - (lambda-var - (output-set-lambda-var segment leaf (node-environment set)))) - (unless (eql values 0) - (checked-canonicalize-values segment cont 1))) - (undefined-value)) - -(defun generate-byte-code-for-local-call (segment call cont num-args) - (let* ((lambda (combination-lambda call)) - (vars (lambda-vars lambda)) - (env (lambda-environment lambda))) - (ecase (functional-kind lambda) - ((:let :assignment) - (dolist (var (reverse vars)) - (when (lambda-var-refs var) - (output-set-lambda-var segment var env t)))) - (:mv-let - (let ((do-check (member (continuation-type-check - (first (basic-combination-args call))) - '(t :error)))) - (dolist (var (reverse vars)) - (when do-check - (byte-generate-type-check segment (leaf-type var) call)) - (output-set-lambda-var segment var env t)))) - ((nil :optional :cleanup) - ;; We got us a local call. - (assert (not (eq num-args :unknown))) - ;; First push closure vars. - (let ((closure (environment-closure env))) - (when closure - (let ((my-env (node-environment call))) - (dolist (thing (reverse closure)) - (etypecase thing - (lambda-var - (output-ref-lambda-var segment thing my-env nil)) - (nlx-info - (output-ref-nlx-info segment thing my-env))))) - (incf num-args (length closure)))) - (let ((results - (let ((info (continuation-info cont))) - (if info - (byte-continuation-info-results info) - 0)))) - ;; Emit the op for whatever flavor of call we are using. - (let ((operand - (cond ((> num-args 6) - (output-push-int segment num-args) - 7) - (t - num-args)))) - ;; ### :call-site - (output-byte segment - (logior (cond ((node-tail-p call) - byte-local-tail-call) - ((member results '(0 1)) - byte-local-call) - (t - byte-local-multiple-call)) - operand))) - ;; Emit a reference to the label. - (output-reference segment - (byte-lambda-info-label (lambda-info lambda))) - ;; ### :unknown-return - ;; Fix up the results. - (unless (node-tail-p call) - (checked-canonicalize-values segment cont - (if (eql results 0) 1 results))))))) - (undefined-value)) - -(defun generate-byte-code-for-full-call (segment call cont num-args) - (let ((info (basic-combination-info call)) - (results - (let ((info (continuation-info cont))) - (if info - (byte-continuation-info-results info) - 0)))) - (cond - (info - ;; It's an inline function. - (assert (not (node-tail-p call))) - (let* ((type (inline-function-info-type info)) - (desired-args (function-type-nargs type)) - (supplied-results - (nth-value 1 - (values-types (function-type-returns type))))) - (canonicalize-values segment desired-args num-args) - ;; ### :call-site - (output-byte segment (logior byte-inline-function - (inline-function-info-number info))) - ;; ### :known-return - (checked-canonicalize-values segment cont supplied-results))) - (t - (let ((operand - (cond ((eq num-args :unknown) - 7) - ((> num-args 6) - (output-push-int segment num-args) - 7) - (t - num-args)))) - (when (eq (byte-continuation-info-results - (continuation-info - (basic-combination-fun call))) - :fdefinition) - (setf operand (logior operand byte-named))) - ;; ### :call-site - (cond - ((node-tail-p call) - (output-byte segment (logior byte-tail-call operand))) - (t - (output-byte segment - (logior - (case results - (:unknown byte-multiple-call) - ((0 1) byte-call) - (t byte-multiple-call)) - operand)) - ;; ### :unknown-return - (checked-canonicalize-values segment cont - (if (eql results 0) 1 results))))))))) - - -(defun generate-byte-code-for-known-call (segment call cont num-args) - (block nil - (catch 'give-up - (funcall (function-info-byte-compile (basic-combination-kind call)) call - (let ((info (continuation-info cont))) - (if info - (byte-continuation-info-results info) - 0)) - num-args segment) - (return)) - (assert (member (byte-continuation-info-results - (continuation-info - (basic-combination-fun call))) - '(1 :fdefinition))) - (generate-byte-code-for-full-call segment call cont num-args)) - (undefined-value)) - -(defun generate-byte-code-for-generic-combination (segment call cont) - (declare (type new-assem:segment segment) (type basic-combination call) - (type continuation cont)) - (let ((num-args - (labels - ((examine (args num-fixed) - (cond - ((null args) - ;; None of the arugments supply :unknown values, so - ;; we know exactly how many there are. - num-fixed) - ((null (car args)) - ;; This arg has been deleted. Ignore it. - (examine (cdr args) num-fixed)) - (t - (let* ((vals - (byte-continuation-info-results - (continuation-info (car args))))) - (cond - ((eq vals :unknown) - (unless (null (cdr args)) - ;; There are (length args) :unknown value blocks on - ;; the top of the stack. We need to combine them. - (output-push-int segment (length args)) - (output-do-xop segment 'merge-unknown-values)) - (unless (zerop num-fixed) - ;; There are num-fixed fixed args above the unknown - ;; values block that want in on the action also. - ;; So add num-fixed to the count. - (output-push-int segment num-fixed) - (output-do-inline-function segment '+)) - :unknown) - (t - (examine (cdr args) (+ num-fixed vals))))))))) - (examine (basic-combination-args call) 0)))) - (case (basic-combination-kind call) - (:local - (generate-byte-code-for-local-call segment call cont num-args)) - (:full - (generate-byte-code-for-full-call segment call cont num-args)) - (t - (generate-byte-code-for-known-call segment call cont num-args))))) - -(defun generate-byte-code-for-basic-combination (segment call cont) - (cond ((and (mv-combination-p call) - (eq (continuation-function-name (basic-combination-fun call)) - '%throw)) - ;; ### :internal-error - (output-do-xop segment 'throw)) - (t - (generate-byte-code-for-generic-combination segment call cont)))) - -(defun generate-byte-code-for-if (segment if cont) - (declare (type new-assem:segment segment) (type cif if) - (ignore cont)) - (let* ((next-info (byte-block-info-next (block-info (node-block if)))) - (consequent-info (block-info (if-consequent if))) - (alternate-info (block-info (if-alternative if)))) - (cond ((eq (byte-continuation-info-results - (continuation-info (if-test if))) - :eq-test) - (output-branch segment - byte-branch-if-eq - (byte-block-info-label consequent-info)) - (unless (eq next-info alternate-info) - (output-branch segment - byte-branch-always - (byte-block-info-label alternate-info)))) - ((eq next-info consequent-info) - (output-branch segment - byte-branch-if-false - (byte-block-info-label alternate-info))) - (t - (output-branch segment - byte-branch-if-true - (byte-block-info-label consequent-info)) - (unless (eq next-info alternate-info) - (output-branch segment - byte-branch-always - (byte-block-info-label alternate-info))))))) - -(defun generate-byte-code-for-return (segment return cont) - (declare (type new-assem:segment segment) (type creturn return) - (ignore cont)) - (let* ((result (return-result return)) - (info (continuation-info result)) - (results (byte-continuation-info-results info))) - (cond ((eq results :unknown) - (setf results 7)) - ((> results 6) - (output-byte-with-operand segment byte-push-int results) - (setf results 7))) - (output-byte segment (logior byte-return results))) - (undefined-value)) - -(defun generate-byte-code-for-entry (segment entry cont) - (declare (type new-assem:segment segment) (type entry entry) - (ignore cont)) - (dolist (exit (entry-exits entry)) - (let ((nlx-info (find-nlx-info entry (node-cont exit)))) - (when nlx-info - (let ((kind (cleanup-kind (nlx-info-cleanup nlx-info)))) - (when (member kind '(:block :tagbody)) - ;; Generate a unique tag. - (output-do-inline-function segment 'cons-unique-tag) - ;; Save it so people can close over it. - (output-do-xop segment 'dup) - (output-byte-with-operand segment - byte-pop-local - (byte-nlx-info-stack-slot - (nlx-info-info nlx-info))) - ;; Now do the actual XOP. - (ecase kind - (:block - (output-do-xop segment 'catch) - (output-reference segment - (byte-nlx-info-label - (nlx-info-info nlx-info)))) - (:tagbody - (output-do-xop segment 'tagbody))) - (return)))))) - (undefined-value)) - -(defun generate-byte-code-for-exit (segment exit cont) - (declare (ignore cont)) - (let ((nlx-info (find-nlx-info (exit-entry exit) (node-cont exit)))) - (output-byte-with-operand segment - byte-push-arg - (position nlx-info - (environment-closure - (node-environment exit)))) - (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) - (:block - ;; ### :internal-error - (output-do-xop segment 'return-from)) - (:tagbody - ;; ### :internal-error - (output-do-xop segment 'go) - (output-reference segment - (byte-nlx-info-label (nlx-info-info nlx-info))))))) - -(defun generate-byte-code (segment component) - (let ((*byte-component-info* (component-info component))) - (do* ((info (byte-block-info-next (block-info (component-head component))) - next) - (block (byte-block-info-block info) (byte-block-info-block info)) - (next (byte-block-info-next info) (byte-block-info-next info))) - ((eq block (component-tail component))) - (when (block-interesting block) - (output-label segment (byte-block-info-label info)) - (do-nodes (node cont block) - (etypecase node - (bind (generate-byte-code-for-bind segment node cont)) - (ref (generate-byte-code-for-ref segment node cont)) - (cset (generate-byte-code-for-set segment node cont)) - (basic-combination - (generate-byte-code-for-basic-combination - segment node cont)) - (cif (generate-byte-code-for-if segment node cont)) - (creturn (generate-byte-code-for-return segment node cont)) - (entry (generate-byte-code-for-entry segment node cont)) - (exit - (when (exit-entry node) - (generate-byte-code-for-exit segment node cont))))) - (let* ((succ (block-succ block)) - (first-succ (car succ))) - (unless (or (cdr succ) - (eq (byte-block-info-block next) first-succ) - (eq (component-tail component) first-succ)) - (output-branch segment - byte-branch-always - (byte-block-info-label - (block-info first-succ)))))))) - (undefined-value)) - - -;;;; Special purpose annotate/compile optimizers. - -(defoptimizer (eq byte-annotate) ((this that) node) - (declare (ignore this that)) - (when (if-p (continuation-dest (node-cont node))) - (annotate-known-call node) - t)) - -(defoptimizer (eq byte-compile) ((this that) call results num-args segment) - (progn segment) ; ignorable. - ;; We don't have to do anything, because everything is handled by the - ;; IF byte-generator. - (assert (eq results :eq-test)) - (assert (eql num-args 2)) - (undefined-value)) - - -(defoptimizer (values byte-compile) - ((&rest values) node results num-args segment) - (canonicalize-values segment results num-args)) - - -(defknown %byte-pop-stack (index) (values)) - -(defoptimizer (%byte-pop-stack byte-annotate) ((count) node) - (assert (constant-continuation-p count)) - (annotate-continuation count 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%byte-pop-stack byte-compile) - ((count) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) - (output-byte-with-operand segment byte-pop-n (continuation-value count))) - -(defoptimizer (%special-bind byte-annotate) ((var value) node) - (annotate-continuation var 0) - (annotate-continuation value 1) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%special-bind byte-compile) - ((var value) node results num-args segment) - (assert (and (eql num-args 1) (zerop results))) - (output-push-constant segment (leaf-name (continuation-value var))) - (output-do-inline-function segment '%byte-special-bind)) - -(defoptimizer (%special-unbind byte-annotate) ((var) node) - (annotate-continuation var 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%special-unbind byte-compile) - ((var) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) - (output-do-inline-function segment '%byte-special-unbind)) - -(defoptimizer (%catch byte-annotate) ((nlx-info tag) node) - (annotate-continuation nlx-info 0) - (annotate-continuation tag 1) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%catch byte-compile) - ((nlx-info tag) node results num-args segment) - (progn node) ; ignore - (assert (and (= num-args 1) (zerop results))) - (output-do-xop segment 'catch) - (let ((info (nlx-info-info (continuation-value nlx-info)))) - (output-reference segment (byte-nlx-info-label info)))) - -(defoptimizer (%cleanup-point byte-compile) (() node results num-args segment) - (progn node segment) ; ignore - (assert (and (zerop num-args) (zerop results)))) - - -(defoptimizer (%catch-breakup byte-compile) (() node results num-args segment) - (progn node) ; ignore - (assert (and (zerop num-args) (zerop results))) - (output-do-xop segment 'breakup)) - - -(defoptimizer (%lexical-exit-breakup byte-annotate) ((nlx-info) node) - (annotate-continuation nlx-info 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%lexical-exit-breakup byte-compile) - ((nlx-info) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) - (let ((nlx-info (continuation-value nlx-info))) - (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) - (:catch t) - (:block - ;; We only want to do this for the fall-though case. - (not (eq (car (block-pred (node-block node))) - (nlx-info-target nlx-info)))) - (:tagbody - ;; Only want to do it once per tagbody. - (not (byte-nlx-info-duplicate (nlx-info-info nlx-info))))) - (output-do-xop segment 'breakup)))) - - -(defoptimizer (%nlx-entry byte-annotate) ((nlx-info) node) - (annotate-continuation nlx-info 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%nlx-entry byte-compile) - ((nlx-info) node results num-args segment) - (progn node results) ; ignore - (assert (eql num-args 0)) - (let* ((info (continuation-value nlx-info)) - (byte-info (nlx-info-info info))) - (output-label segment (byte-nlx-info-label byte-info)) - ;; ### :non-local-entry - (ecase (cleanup-kind (nlx-info-cleanup info)) - ((:catch :block) - (checked-canonicalize-values segment - (nlx-info-continuation info) - :unknown)) - ((:tagbody :unwind-protect))))) - - -(defoptimizer (%unwind-protect byte-annotate) - ((nlx-info cleanup-fun) node) - (annotate-continuation nlx-info 0) - (annotate-continuation cleanup-fun 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%unwind-protect byte-compile) - ((nlx-info cleanup-fun) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) - (output-do-xop segment 'unwind-protect) - (output-reference segment - (byte-nlx-info-label - (nlx-info-info - (continuation-value nlx-info))))) - -(defoptimizer (%unwind-protect-breakup byte-compile) - (() node results num-args segment) - (progn node) ; ignore - (assert (and (zerop num-args) (zerop results))) - (output-do-xop segment 'breakup)) - -(defoptimizer (%continue-unwind byte-annotate) ((a b c) node) - (annotate-continuation a 0) - (annotate-continuation b 0) - (annotate-continuation c 0) - (annotate-continuation (basic-combination-fun node) 0) - (setf (node-tail-p node) nil) - t) - -(defoptimizer (%continue-unwind byte-compile) - ((a b c) node results num-args segment) - (progn node) ; ignore - (assert (member results '(0 nil))) - (assert (eql num-args 0)) - (output-do-xop segment 'breakup)) - - -;;;; XEP descriptions. - -(defstruct (byte-xep - (:print-function %print-byte-xep)) - ;; - ;; The component that this XEP is an entry point into. NIL until - ;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in. We also allow - ;; cons so that the dumper can stick in a unique cons cell to - ;; identify what component it is trying to dump. What a hack. - (component nil :type (or null kernel:code-component cons)) - ;; - ;; The minimum and maximum number of args, ignoring &rest and &key. - (min-args 0 :type (integer 0 #.call-arguments-limit)) - (max-args 0 :type (integer 0 #.call-arguments-limit)) - ;; - ;; List of the entry points for min-args, min-args+1, ... max-args. - (entry-points nil :type list) - ;; - ;; The entry point to use when there are more than max-args. Only filled - ;; in where okay. In other words, only when &rest or &key is specified. - (more-args-entry-point nil :type (or null (unsigned-byte 24))) - ;; - ;; The number of ``more-arg'' args. - (num-more-args 0 :type (integer 0 #.call-arguments-limit)) - ;; - ;; True if there is a rest-arg. - (rest-arg-p nil :type (member t nil)) - ;; - ;; True if there are keywords. Note: keywords might still be NIL because - ;; having &key with no keywords is valid and should result in - ;; allow-other-keys processing. If :allow-others, then allow other keys. - (keywords-p nil :type (member t nil :allow-others)) - ;; - ;; List of keyword arguments. Each element is a list of: - ;; key, default, supplied-p. - (keywords nil :type list)) - -(defprinter byte-xep) - - -;;; MAKE-XEP-FOR -- internal -;;; -;;; Make a byte-xep for LAMBDA. -;;; -(defun make-xep-for (lambda) - (flet ((entry-point-for (entry) - (let ((info (lambda-info entry))) - (assert (byte-lambda-info-interesting info)) - (new-assem:label-position (byte-lambda-info-label info))))) - (let ((entry (lambda-entry-function lambda))) - (etypecase entry - (optional-dispatch - (let ((rest-arg-p nil)) - (collect ((keywords)) - (dolist (var (nthcdr (optional-dispatch-max-args entry) - (optional-dispatch-arglist entry))) - (let ((arg-info (lambda-var-arg-info var))) - (assert arg-info) - (ecase (arg-info-kind arg-info) - (:rest - (assert (not rest-arg-p)) - (setf rest-arg-p t)) - (:keyword - (keywords (list (arg-info-keyword arg-info) - (arg-info-default arg-info) - (if (arg-info-supplied-p arg-info) t))))))) - (make-byte-xep - :min-args (optional-dispatch-min-args entry) - :max-args (optional-dispatch-max-args entry) - :entry-points - ;; ### Some of these entry points are :Deleted. This needs to - ;; be fixed somehow. - (mapcar #'entry-point-for (optional-dispatch-entry-points entry)) - :more-args-entry-point - (entry-point-for (optional-dispatch-main-entry entry)) - :rest-arg-p rest-arg-p - :keywords-p - (if (optional-dispatch-keyp entry) - (if (optional-dispatch-allowp entry) - :allow-others t)) - :keywords (keywords))))) - (clambda - (let ((args (length (lambda-vars entry)))) - (make-byte-xep - :min-args args - :max-args args - :entry-points (list (entry-point-for entry))))))))) - -(defun generate-xeps (component) - (let ((xeps nil)) - (dolist (lambda (component-lambdas component)) - (when (member (lambda-kind lambda) '(:external :top-level)) - (push (cons lambda (make-xep-for lambda)) xeps))) - xeps)) - - - -;;;; Noise to actually do the compile. - -(defun assign-locals (component) - ;; - ;; Process all of the lambdas in component, and assign stack frame - ;; locations for all the locals. - (dolist (lambda (component-lambdas component)) - ;; We don't generate any code for :external lambdas, so we don't need - ;; to allocate stack space. Also, we don't use the ``more'' entry, - ;; so we don't need code for it. - (cond - ((or (eq (lambda-kind lambda) :external) - (and (eq (lambda-kind lambda) :optional) - (eq (optional-dispatch-more-entry - (lambda-optional-dispatch lambda)) - lambda))) - (setf (lambda-info lambda) - (make-byte-lambda-info :interesting nil))) - (t - (let ((num-locals 0)) - (let* ((vars (lambda-vars lambda)) - (arg-num (+ (length vars) - (length (environment-closure - (lambda-environment lambda)))))) - (dolist (var vars) - (decf arg-num) - (cond ((or (lambda-var-sets var) (lambda-var-indirect var)) - (setf (leaf-info var) - (make-byte-lambda-var-info :offset num-locals)) - (incf num-locals)) - ((leaf-refs var) - (setf (leaf-info var) - (make-byte-lambda-var-info :argp t - :offset arg-num)))))) - (dolist (let (lambda-lets lambda)) - (dolist (var (lambda-vars let)) - (setf (leaf-info var) - (make-byte-lambda-var-info :offset num-locals)) - (incf num-locals))) - (let ((entry-nodes-already-done nil)) - (dolist (nlx-info (environment-nlx-info (lambda-environment lambda))) - (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) - (:block - (setf (nlx-info-info nlx-info) - (make-byte-nlx-info :stack-slot num-locals)) - (incf num-locals)) - (:tagbody - (let* ((entry (cleanup-mess-up (nlx-info-cleanup nlx-info))) - (cruft (assoc entry entry-nodes-already-done))) - (cond (cruft - (setf (nlx-info-info nlx-info) - (make-byte-nlx-info :stack-slot (cdr cruft) - :duplicate t))) - (t - (push (cons entry num-locals) entry-nodes-already-done) - (setf (nlx-info-info nlx-info) - (make-byte-nlx-info :stack-slot num-locals)) - (incf num-locals))))) - ((:catch :unwind-protect) - (setf (nlx-info-info nlx-info) (make-byte-nlx-info)))))) - (setf (lambda-info lambda) - (make-byte-lambda-info :stack-size num-locals)))))) - - (undefined-value)) - - -;;; BYTE-COMPILE-COMPONENT -- internal interface. -;;; -(defun byte-compile-component (component) - (setf (component-info component) (make-byte-component-info)) - - ;; Assign offsets for all the locals, and figure out which args can - ;; stay in the argument area and which need to be moved into locals. - (assign-locals component) - - ;; Annotate every continuation with information about how we want the - ;; values. - (annotate-ir1 component) - - ;; Determine what stack values are dead, and emit cleanup code to pop - ;; them. - (byte-stack-analyze component) - - ;; Assign an ordering of the blocks. - (control-analyze component #'make-byte-block-info) - - ;; Find the start labels for the lambdas. - (dolist (lambda (component-lambdas component)) - (let ((info (lambda-info lambda))) - (when (byte-lambda-info-interesting info) - (setf (byte-lambda-info-label info) - (byte-block-info-label - (block-info (node-block (lambda-bind lambda)))))))) - - ;; Delete any blocks that we are not going to emit from the emit order. - (do-blocks (block component) - (unless (block-interesting block) - (let* ((info (block-info block)) - (prev (byte-block-info-prev info)) - (next (byte-block-info-next info))) - (setf (byte-block-info-next prev) next) - (setf (byte-block-info-prev next) prev)))) - - (let ((segment nil)) - (unwind-protect - (progn - (setf segment (new-assem:make-segment :name "Byte Output")) - (generate-byte-code segment component) - (let ((xeps (generate-xeps component)) - (constants (byte-component-info-constants - (component-info component)))) - (when *compiler-trace-output* - (describe-component component *compiler-trace-output*)) - (etypecase *compile-object* - (fasl-file - (maybe-mumble "FASL") - (fasl-dump-byte-component segment constants xeps - *compile-object*)) - (core-object - (maybe-mumble "Core") - (make-core-byte-component segment constants xeps - *compile-object*)) - (null)))) - (when segment - (new-assem:release-segment segment)))) - (undefined-value)) - - - -;;;; Extra stuff for debugging. - -(defun dump-stack-info (component) - (do-blocks (block component) - (when (block-interesting block) - (print-nodes block) - (let ((info (block-info block))) - (cond - (info - (format t - "start-stack ~S~%consume ~S~%produce ~S~%end-stack ~S~%~ - total-consume ~S~%~@[nlx-entries ~S~%~]~@[nlx-entry-p ~S~%~]" - (byte-block-info-start-stack info) - (byte-block-info-consumes info) - (byte-block-info-produces info) - (byte-block-info-end-stack info) - (byte-block-info-total-consumes info) - (byte-block-info-nlx-entries info) - (byte-block-info-nlx-entry-p info))) - (t - (format t "no info~%"))))))) - - - -;;;; Hacks until we want to recompile everything. - -#+nil -(defun block-label (block) - (declare (type cblock block)) - (let ((info (block-info block))) - (etypecase info - (ir2-block - (or (ir2-block-%label info) - (setf (ir2-block-%label info) (gen-label)))) - (byte-block-info - (byte-block-info-label info))))) diff --git a/compiler/c.log b/compiler/c.log deleted file mode 100644 index a304fda24db21e7d8e32f82ca11663309c3bfe99..0000000000000000000000000000000000000000 --- a/compiler/c.log +++ /dev/null @@ -1,2048 +0,0 @@ -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp -05-Feb-90 20:45:20, Edit by Ram. - Fixed MAKE-INTERPRETED-FUNCTION to specify the LAMBDA slot when creating the - function so that it is avaliable to INTERPRETED-FUNCTION-LAMBDA-EXPRESSION. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/sset.lisp -05-Feb-90 12:07:12, Edit by Ram. - Fixed a problem in SSET-UNION-OF-DIFFERENCE. It was using (>= num2 num3) in - two places where it should have been using <=. Probably due to incorrect - modification of the original SSET-DIFFERENCE code into this function. The - original function had the inner loop over the second arg, rather than the - first. This effectively resulted in the difference aspect usually not - happening, so the KILL set in constraint propagation never took effect, - resulting in some over-zealous type propagation. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -04-Feb-90 10:11:51, Edit by Ram. - Oops... Fixed * transform so that multiplication by 8 doesn't really - multiply by 256, etc. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -04-Feb-90 09:48:09, Edit by Ram. - Wrote CLOSE-SOURCE-INFO, and made COMPILE-FILE, ADVANCE-SOURCE-FILE and - COMPILE-FROM-STREAM call it. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp -04-Feb-90 08:09:06, Edit by Ram. - Added definition for %SP-STRING-COMPARE. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp -04-Feb-90 08:01:21, Edit by Ram. - Fixed STRING<>=-BODY a bit. In addition to some query replace lossage, there - was also a genuine ancestral bug in computation of the result in the = case - of = ops. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ctype.lisp -03-Feb-90 20:44:39, Edit by Ram. - Made VALID-FUNCTION-USE and VALID-APPROXIMATE-TYPE return NIL, NIL when - uncertainty is encountered, rather than T, NIL. Everybody was expecting this - to be a conservative test (and only looking at the first value.) This caused - spurious transforms to happen. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -02-Feb-90 14:08:09, Edit by Ram. - Added NTH, NTHCDR transforms for the constant index case. Added * transform - for the power-of-2 case. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp -02-Feb-90 13:00:15, Edit by Ram. - Added string transforms, derived from CLC sources. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -02-Feb-90 13:25:40, Edit by Ram. - Added FORMAT transform derived from CLC sources. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp -02-Feb-90 11:23:26, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -02-Feb-90 11:23:15, Edit by Ram. - Defined TYPE/= and made the "anything changed" tests use it instead of TYPE= - so as to be conservative in the presence of hairy types. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -02-Feb-90 10:29:54, Edit by Ram. - Changed REOPTIMIZE-CONTINUATION to set BLOCK-TYPE-CHECK in the use blocks so - that new derived-type information will also cause type checking to be redone. - This mainly handles the case where new type information causes us to want to - negate a check that was previously simple. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -02-Feb-90 10:12:24, Edit by Ram. - Fixed CONTINUATION-%DERIVED-TYPE to call CONTINUATION-%TYPE-CHECK instead of - CONTINUATION-TYPE-CHECK so that it won't recurse indefinitely. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp -01-Feb-90 14:46:13, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -01-Feb-90 14:43:26, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/knownfun.lisp -01-Feb-90 14:40:22, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -01-Feb-90 14:42:19, Edit by Ram. - Flushed *FUNCTION-INFO* in favor of (INFO FUNCTION INFO ...). Added - FUNCTION-INFO-PREDICATE-TYPE slot. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -01-Feb-90 14:09:42, Edit by Ram. - Changed ASSERT-CONTINUATION-TYPE to set BLOCK-TYPE-ASSERTED in the use - blocks. Also, moved fixed the setting of BLOCK-TYPE-CHECK to be on the use - blocks rather than the CONTINUATION-BLOCK, since type check generation uses - DO-NODES, and thus ignores the BLOCK-START. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp -01-Feb-90 13:37:14, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp -01-Feb-90 13:41:46, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -01-Feb-90 13:41:48, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -01-Feb-90 13:42:05, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -01-Feb-90 13:42:29, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -01-Feb-90 13:43:07, Edit by Ram. - Renamed the CONTINUATION TYPE-CHECK slot to %TYPE-CHECK, which is filtered by - the new CONTINUATION-TYPE-CHECK function to make sure that it has been - computed recently. Changed setters of TYPE-CHECK to %TYPE-CHECK, and flushed - the now unnecessary calls to CONTINUATION-DERIVED-TYPE (which explicitly did - the recomputation.) - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -01-Feb-90 12:56:50, Edit by Ram. - Changed %CONTINUATION-DERIVED-TYPE to not set TYPE-CHECK when the assertion - is T or there is no DEST. In the first case, this just avoids waste motion. - In the second case, this prevents constraint analysis from being tricked into - believing such a check will be done, when in fact no checks are done on - unused values. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -01-Feb-90 12:51:41, Edit by Ram. - Made DELETE-CONTINUATION, FLUSH-DEST, NODE-ENDS-BLOCK and UNLINK-NODE set the - BLOCK-TYPE-ASSERTED and BLOCK-TEST-CHANGED flags. At least for the former, - this has to be done in more places than I thought, and also must be done for - correctness, rather than just to ensure new assertions are seen. This is - because if a block is split, or code needing an assertion is deleted, then we - must recompute the block's set of constraints or it will contain incorrect - constraints. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/sset.lisp -01-Feb-90 11:33:28, Edit by Ram. - Fixed SSET-INTERSECTION to blow away any extra elements in SET1 that are - larger than the greatest element in SET2. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp -01-Feb-90 10:34:17, Edit by Ram. - Changed initial values for TYPE-ASSERTED and TEST-MODIFIED to be T rather - than NIL. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vop.lisp -30-Jan-90 16:10:06, Edit by Ram. - Added IR2-ENVIRONMENT-KEEP-AROUND-TNS and IR2-COMPONENT-PRE-PACKED-SAVE-TNS - so that we won't have to recompile to add these features later on. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp -30-Jan-90 14:54:58, Edit by Ram. - Added the MAKE-INTERPRETED-FUNCTION interface which allows lazy conversion of - functions and features bounded IR1 memory usage through a LRU cache that is - partially flushed on GC. Added INTERPRETED-FUNCTION-NAME, - INTERPRETED-FUNCTION-ARGLIST and setf functions. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -30-Jan-90 10:08:19, Edit by Ram. - Now that %DEFMACRO is passed #'(lambda ... for benefit for the interpreter, - we don't want to unquote the definition using EVAL. Use SECOND instead. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -29-Jan-90 14:17:06, Edit by Ram. - Changed FIND-COMPONENT-NAME to bind *PRINT-LEVEL* and *PRINT-PRETTY* so as to - prevent huge component names. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp -29-Jan-90 13:43:23, Edit by Ram. - Fixed CONFLICT-ANALYZE-BLOCK in the dead read case to do FROB-MORE-TNS on - NOTE-CONFLICTS as well as the addition to the live set. This was the fix to - the long-procrastinated-about :MORE TN bug (first noticed in fall 88.) Also, - changed FROB-MORE-TNS to return whether it did anything, rather than sleazily - hacking on the loop variable to get the loop to exit. I must have been - having a Pascal flashback when I wrote that code... - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp -29-Jan-90 13:24:23, Edit by Ram. - Fixed LEAF-VALUE to use FDEFINITION rather than SYMBOL-FUNCTION when the name - isn't a symbol. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -29-Jan-90 10:46:23, Edit by Ram. - Changed COMPILE-FIX-FUNCTION-NAME to substitute for old uses of the name so - that recursive calls get converted. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -29-Jan-90 10:13:18, Edit by Ram. - But for the want of a single character... So that's why no functions were - being inline expanded! In %DEFUN the ir1 translator, I was looking at the - INLINEP value for the NAME in the same LET that was eval'ing the name to - unquote it. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug-dump.lisp -27-Jan-90 18:05:15, Edit by Ram. - Made DEBUG-SOURCE-FOR-INFO handle the incremental compilation cases. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -27-Jan-90 17:46:09, Edit by Ram. - Wrote COMPILE and UNCOMPILE. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp -27-Jan-90 17:07:17, Edit by Ram. - Added the interfaces INTERPRETED-FUNCTION-LAMBDA-EXPRESSION and - INTERPRETED-FUNCTION-CLOSURE. These use the new FIND-IF-IN-CLOSURE operation - pick apart the closure that is an interpreted function. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -26-Jan-90 16:35:51, Edit by Ram. - Moved a bunch of stuff from COMPILE-FILE to SUB-COMPILE-FILE. Wrote - MAKE-LISP-SOURCE-INFO and MAKE-STREAM-SOURCE-INFO. Wrote - COMPILE-FROM-STREAM, and added appropriate uses of the in-core compilation - interface to various functions. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp -26-Jan-90 16:09:30, Edit by Ram. - Made the CACHE-NAME slot be duplicated in both kinds of environment rather - than inherited from INFO-ENV so that the inline type checks for the slot - access will win, allowing bootstrapping to work. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp -26-Jan-90 13:12:09, Edit by Ram. - Changed COMPILE-FOR-EVAL to call the new MAKE-LISP-SOURCE-INFO, rather than - rolling its own. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp -26-Jan-90 11:59:58, Edit by Ram. - Added code to cache the last name looked up, since we commonly consecutively - look up several types of info for the same name. [Maybe even some types more - than once!] - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -26-Jan-90 09:30:59, Edit by Ram. - Fixed PROCESS-TYPE-PROCLAMATION to not try to call TYPES-INTERSECT on - function types so that we don't flame out. This was probably what I was - really trying to fix in the last change to PROCESS-TYPE-DECLARATION. Really - both were broken. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -25-Jan-90 10:58:43, Edit by Ram. - Added transform for ARRAY-DIMENSION that converts to LENGTH when possible. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/typetran.lisp -25-Jan-90 10:46:00, Edit by Ram. - Moved array typep code here from vm-type-tran, since it turned out not to be - VM dependent after all. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/typetran.lisp -23-Jan-90 15:31:32, Edit by Ram. - Transformed array type tests to %ARRAY-TYPEP so that clever - implementation-dependent things can be done. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -23-Jan-90 18:45:14, Edit by Ram. - Fixed up some messed up backquote stuff in DO-MACROLET-STUFF where it was - trying to coerce the lambda to a function. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/envanal.lisp -23-Jan-90 13:06:41, Edit by Ram. - Don't annotate as TAIL-P nodes whose DERIVED-TYPE is NIL, so that we don't - tail-call functions such as ERROR. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -23-Jan-90 12:44:28, Edit by Ram. - Fixed %DEFUN translator to record an inline expansion when the INLINEP value - is :MAYBE-INLINE as well as :INLINE. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -23-Jan-90 08:49:50, Edit by Ram. - Changed PUSH-IN and DELETEF-IN to only call FOO-GET-SETF-METHOD when - CLC::*IN-THE-COMPILER* is true, so that we can still use these macros in the - old compiler. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp -22-Jan-90 16:11:28, Edit by Ram. - Added a transform for MEMBER where the list is a constant argument (primarily - to help MEMBER type tests.) - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp -22-Jan-90 15:20:27, Edit by Ram. - Replaced all uses of COMBINATION- accessors with BASIC-COMBINATION- accessors - so that MV combinations will work. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp -22-Jan-90 15:08:07, Edit by Ram. - Put a couple of macros in EVAL-WHEN (COMPILE LOAD EVAL) so that they are - avaliable to SETF in the bootstrap environment. Also, changed %SP-[UN]BIND - to the appropriate %PRIMITIVE calls. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp -20-Jan-90 20:21:34, Edit by Ram. - Fixed up FBOUNDP & stuff to correspond to the FUNCTION-NAME cleanup. Now - FBOUNDP can take a list as well as a symbol. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -20-Jan-90 09:56:43, Edit by Ram. - In #+NEW-COMPILER, made DO-MACROLET-STUFF coerce the lambda expression to a - function. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp -20-Jan-90 09:52:20, Edit by Ram. - Added bind of *FENV* to () in COMPILE-FOR-EVAL. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -20-Jan-90 09:50:59, Edit by Ram. - And made IR1-TOP-LEVEL *not* bind *FENV* to () so that top-level MACROLETs - will be recognized... - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -20-Jan-90 09:47:19, Edit by Ram. - Added binding of *FENV* to () in SUB-COMPILE-FILE so that MACROLET processing - won't flame out. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp -19-Jan-90 22:25:15, Edit by Ram. - Made WITH-IR1-ENVIRONMENT bind a bunch more variables. *fenv*, etc. Wrote - WITH-IR1-NAMESPACE, which allocates the gloabal namespace hashtables. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp -19-Jan-90 22:35:44, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -19-Jan-90 22:34:20, Edit by Ram. - Flushed IR1-TOP-LEVEL-FOR-EVAL and changed IR1-TOP-LEVEL to take a FOR-VALUE - flag so that it can do the same thing. Added use of WITH-IR1-NAMESPACE. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -19-Jan-90 21:43:20, Edit by Ram. - Made SUB-COMPILE-FILE bind *CURRENT-COOKIE* so that people can randomly call - (POLICY NIL ...) to get at the current policy, and will never see any - leftover local policy from a dynamically enclosing IR1 conversion. - ### Maybe this should really be bound somewhere else, like COMPILE-COMPONENT. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -19-Jan-90 22:00:35, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp -19-Jan-90 22:01:47, Edit by Ram. - Added a keyword constructor for CBLOCK, and changed all MAKE-BLOCK calls - outside of IR1 conversion to use this new constructor, specifying all the - values that would otherwise be defaulted from specials. This is necessary to - make stuff properly reentrant. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -19-Jan-90 17:26:17, Edit by Ram. - In FIND-FREE-VARIABLE, flushed the assertion that non-constant variables - never have constant values. This isn't really right, but it is better. - ### Really, the implementation of "constant but value unknown" variables - should be either flushed or redone. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp -19-Jan-90 15:31:33, Edit by Ram. - New file from Chiles. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp -19-Jan-90 15:30:03, Edit by Ram. - New file from chiles. Changed MY-EVAL to INTERNAL-EVAL and made it frob - *ALREADY-EVALED-THIS*. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -19-Jan-90 14:53:28, Edit by Ram. - Made IR1 conversion reentrant by having IR1-TOP-LEVEL bind all of the state - variables. Removed DEFVAR initial values for variables that should never be - referenced outside of IR1 conversion. Rather than always making four new - hashtables every time, I kept around the global values, allowing them to be - used on the outermost call. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -19-Jan-90 11:06:50, Edit by Ram. - Changed PROPAGATE-TO-REFS to do nothing when the variable type is a function - type so that we don't lose specific function type information, and also so - that TYPE-INTERSECTION doesn't gag. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -19-Jan-90 11:24:07, Edit by Ram. - Changed PROCESS-TYPE-DECLARATION to quietly set the var type when either the - old or new type is a function type, rather than losing trying to do - TYPE-INTERSECTION. - ### Someday when we have a incompatible-redefinition detection capability, we - might want to hook it in here. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -18-Jan-90 16:45:20, Edit by Ram. - In %DEFMACRO IR1 convert, when #+NEW-COMPILER, coerce the expander to a - function before sticking it in the MACRO-FUNCTION. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -18-Jan-90 14:11:44, Edit by Ram. - Changed %DEFUN translator to dump an inline expanion when appropriate. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp -18-Jan-90 12:33:17, Edit by Ram. - Added %STANDARD-CHAR-P and %STRING-CHAR-P to the imports list. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp -18-Jan-90 12:24:34, Edit by Ram. - In #+NEW-COMPILER, added info type defaults that get information from the - environment. This only affected functions and constant values, since - everything else is already stored in the global database. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -18-Jan-90 11:51:45, Edit by Ram. - In COMPILE-FILE, fixed FROB to always pathnamify the thing so that - OPEN-FASL-FILE won't choke. Also, this way any syntax error always happens - in COMPILE-FILE. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp -18-Jan-90 10:44:11, Edit by Ram. - And also in NOTE-CONFLICTS, fixed the declaration for Live-List to be - (OR TN NULL) rather than TN. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp -18-Jan-90 10:39:41, Edit by Ram. - In NOTE-CONFLICTS, fixed the type for Live-Bits to be LOCAL-TN-BIT-VECTOR, - not SC-BIT-VECTOR. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -17-Jan-90 20:47:37, Edit by Ram. - Fixed IR2-CONVERT-NORMAL-LOCAL-CALL to set up the argument pointer. It - seems this was only happening in tail calls, so stack arguments did not in - general work in local calls. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -17-Jan-90 16:20:28, Edit by Ram. - Changed FIND-TEMPLATE to guard the unsafe policy "trusting" result test by a - check for any non-null value of TYPE-CHECK, rather than just T or :ERROR. - This since the value might have also been :NO-CHECK, this was usually - preventing us from believing the assertion. - - This was resulting in the rather baffling efficiency note that output type - assertions can't be trusted in a safe policy, when the policy wasn't safe... - I added an assertion that the policy really is safe when we emit that note. - Although it should always be the case, lossage in either VALID-FUNCTION-USE - or template selection could cause us to end up in that branch. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp -16-Jan-90 21:25:42, Edit by Ram. - Renamed the types ENTRY-INFO and ENTRIES-INDEX to be COMPACT-INFO-ENTRY and - COMPACT-INFO-ENTRIES-INDEX. We already had a structure called ENTRY-INFO. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/proclaim.lisp -16-Jan-90 11:23:51, Edit by Ram. - Set the symbol-function of PROCLAIM to the definition of %PROCLAIM. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -16-Jan-90 11:15:56, Edit by Ram. - Fixed DEFMACRO ir1 convert to unquote the original arglist before setting the - FUNCTIONAL-ARG-DOCUMENTATION. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/codegen.lisp -15-Jan-90 13:04:59, Edit by Ram. - Oops... I seem to have broken codegen when I changed to it give each block a - label, sometimes emitting a label more than once. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -13-Jan-90 13:09:05, Edit by Ram. - Changed DELETEF-IN and PUSH-IN to use FOO-GET-SETF-METHOD rather than - GET-SETF-METHOD so that they will expand correctly in the bootstrapping - environment. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -13-Jan-90 12:27:12, Edit by Ram. - Fixed a CDR circularity detection in FIND-SOURCE-PATHS a bit. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp -13-Jan-90 11:49:48, Edit by Ram. - In addition to initializing *INFO-CLASSES* in GLOBALDB-INIT for benefit of - bootstrapping, we must also init *TYPE-COUNTER* and *TYPE-NUMBERS*. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp -12-Jan-90 16:15:25, Edit by Ram. - Changed to use a special FIND-TYPE-INFO function instead of FIND, since the - slot accessor TYPE-INFO-NAME isn't avaliable for use as a funarg before - top-level forms run. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp -11-Jan-90 11:14:44, Edit by Ram. - I'm sooo embarrassed... I got the rehashing algorithm wrong in compact - environments. The second hash could be 0, resulting in infinite looping. - [b.t.w., this is a new largely rewritten version of globaldb that uses - special hashtables instead of standard hashtables. There are two kinds of - environments: volatile and compact. Volatile environments can be modified, - but are not especially compact (comparable to the old hashtable - implementation, but faster.) Compact environments are not modifiable, but - reduce memory usage by at least half.] - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -10-Jan-90 12:04:33, Edit by Ram. - Rather than asserting that (INFO FUNCTION WHERE-FROM <name>) is :ASSUMED - whenever the LEAF-WHERE-FROM is assumed, we just quietly skip the unknown - function warning code when the name no longer names an assumed function. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -10-Jan-90 11:27:03, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -10-Jan-90 11:24:07, Edit by Ram. - Added special-case top-level form processing of EVAL-WHEN, PROGN and MACROLET - so that we don't get huge compilations when these forms enclose lots of code - at top-level. To do this, I split off the environment manipulation code in - EVAL-WHEN and MACROLET. - ### Probably should expand macros to see if they turn into a magic form - ### before just compiling the thing. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -09-Jan-90 13:23:41, Edit by Ram. - Wrote a version of PROGV. This IR1 translator is in IR2tran because it goes - directly from syntax to shallow-binding primitives. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -08-Jan-90 14:39:46, Edit by Ram. - Made FIND-SOURCE-PATHS hack circular source code. CAR circularities are - detected by noticing that the cons is already in the source paths hashtable. - CDR circularities are detected using the two-phase trailing pointer hack. - This support is necessary as long as circular constants are allowed (which is - strongly implied by the presence of the #=/## read syntax.) Of course if - there is circular evaluated code, bad things will still happen... - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -08-Jan-90 13:36:03, Edit by Ram. - Made PRINT-SUMMARY print information about compilation units that were - aborted, and inhibited printing of unknown function warnings when the warning - compilation unit is unwound. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -08-Jan-90 10:58:02, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -08-Jan-90 10:49:04, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp -08-Jan-90 10:28:23, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp -08-Jan-90 10:40:20, Edit by Ram. - Changed *UNKNOWN-FUNCTIONS* a bit. Now it is a list of UNKNOWN-FUNCTION - structures. This was done primarily to allow the number of warnings to be - limited in IR1-CONVERT-OK-COMBINATION-FER-SHER rather than in PRINT-SUMMARY. - It turns out that recording hundreds of error locations for tents of - functions can suck down a large amount of memory. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -05-Jan-90 16:24:40, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -05-Jan-90 15:58:34, Edit by Ram. - Changed *UNKNOWN-FUNCTIONS* to be an alist with one entry for each name, with - the value being a list of all the error contexts for the calls. Made - PRINT-SUMMARY print the undefined function warnings sorted by name, limiting - the number of warnings per function to *UNKNOWN-FUNCTION-WARNING-LIMIT*. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -05-Jan-90 15:51:31, Edit by Ram. - Changed PRINT-SUMMARY to print a warning for each unknown function. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -05-Jan-90 15:46:02, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp -05-Jan-90 15:45:49, Edit by Ram. - Moved detection of unknown function calls to - IR1-CONVERT-OK-COMBINATION-FER-SHER so that we can conveniently note the - error context each time around. *UNKNOWN-FUNCTIONS* is now a list of conses - (Name . Compiler-Error-Context), with entries for each call to an unknown - function. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -05-Jan-90 15:22:04, Edit by Ram. - Split off error context determination from error printing by introducing the - COMPILER-ERROR-CONTEXT structure. The current error context can now be saved - for future use by calling FIND-ERROR-CONTEXT. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug-dump.lisp -04-Jan-90 10:56:42, Edit by Ram. - New file. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -04-Jan-90 10:39:31, Edit by Ram. - Put in hooks for dumping debug info. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/entry.lisp -03-Jan-90 15:04:07, Edit by Ram. - Added code to dump the arg documentation. For now, we do pretty much what - the old compiler did, i.e. printing it to a string. - ### Eventually, we may want to put in code to flush package qualifiers on the - variable names and omit complex default forms. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp -03-Jan-90 14:44:54, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -03-Jan-90 14:50:15, Edit by Ram. - Added FUNCTIONAL-ARG-DOCUMENTATION slot and made IR1 conversion set it. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp -03-Jan-90 14:34:44, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -03-Jan-90 14:34:27, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug.lisp -03-Jan-90 14:40:06, Edit by Ram. - Added LAMBDA-OPTIONAL-DISPATCH and made IR1 conversion set it in :OPTIONAL - lambdas. Made consistency checker allow this. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -03-Jan-90 14:07:30, Edit by Ram. - In DELETE-OPTIONAL-DISPATCH, don't clear the ENTRY-FUNCTION in the :OPTIONAL - lambdas. This info is now kept in the LAMBDA-OPTIONAL-DISPATCH slot, and is - not cleared when the lambda stops being an entry point. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp -03-Jan-90 10:35:50, Edit by Ram. - But we still want to compute the component name in such components... - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp -03-Jan-90 09:27:51, Edit by Ram. - Changed FIND-INITIAL-DFO to move all components containing a top-level lambda - to the end of the compilation order, even if there are XEPs. This does a - better job of ensuring that environment analysis is done before we compile - the top-level component which does cross-component references. - ### This probably still loses in some pathological case. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -02-Jan-90 17:01:46, Edit by Ram. - Fixed CLEAR-IR2-INFO to check whether there is a tail set before attempting - to clear its INFO. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -02-Jan-90 14:51:46, Edit by Ram. - Changed IR2-CONVERT-CLOSURE to not use the IR2-ENVIRONMENT-ENVIRONMENT, since - this is now blown away after the component is compiled. Instead we use the - ENVIRONMENT-CLOSURE, which is just as good. Actually, this should only - happen with references in XEPs, since that is the only kind of function that - can reference functions across component boundaries. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -17-Dec-89 15:30:10, Edit by Ram. - Wrote CLEAR-IR2-INFO and made COMPILE-TOP-LEVEL call it after it was done - with the IR2 for each component. This should allow the IR2 data structures - to be reclaimed after each component is compiled, even in a multi-component - compilation. - - ### Eventually it should be possible for the IR1 to be reclaimed after the - component is compiled, but there currently cross-component links that inhibit - this. It would also cause problems with IR1 consistency checking, since we - currently need to check all components together. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -15-Dec-89 13:33:44, Edit by Ram. - In IR1-CONVERT-VARIABLE, when we find a CT-A-VAL, we convert an ALIEN-VALUE - form rather than referencing the CT-A-VAL as a leaf. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp -13-Dec-89 13:38:51, Edit by Ram. - In NOTE-FAILED-OPTIMIZATION, also inhibit any attempt to give a note if the - combination is no longer a known call. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/gtn.lisp -12-Dec-89 12:25:57, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -12-Dec-89 12:36:38, Edit by Ram. - To avoid having to fix this right right now, changed all passing locations to - be *ANY-PRIMITIVE-TYPE* and added code to do necessary coercions to/from the - actual variable representation. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp -12-Dec-89 10:21:15, Edit by Ram. - Fixed a bunch of declarations that were calling things TYPEs instead of - CTYPEs. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -11-Dec-89 10:11:31, Edit by Ram. - Changed default fasl file extension from "fasl" to "nfasl", at least for now. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp -11-Dec-89 08:15:47, Edit by Ram. - Changed most uses of the FUNCTION type to CALLABLE, now that FUNCTION doesn't - encompass SYMBOL but we can still call them. Also fixed some lossage where - someone believed that the SUBSTITUTE/NSUBSTITUTE family of functions had the - same arguments as the DELETE/REMOVE family. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -10-Dec-89 20:33:05, Edit by Ram. - Oops... (fifth x) /==> (nth 5 x), is really (nth 4 x). So that's why - PACKAGE-INIT was losing... - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp -10-Dec-89 09:23:47, Edit by Ram. - Fixed DO-NODES-BACKWARDS to work when the current node is deleted now that - UNLINK-NODE blasts the PREV. Also fixed two bugs in this macro that seem not - to have affected the sole use in FLUSH-DEAD-CODE. One was that it randomly - referenced the variable CONT in one place, rather than commaing in the - appropriate argument. The other was that it did an extra iteration binding - CONT to the block start and NODE to whatever its USE was (often NIL.) - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -09-Dec-89 13:31:24, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp -09-Dec-89 13:30:52, Edit by Ram. - Wrote NODE-DELETED and made NOTE-FAILED-OPTIMIZATION call it so that we won't - gag trying to look at deleted code. This also prevents bogus efficiency - notes about code that was actually optimized away. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -09-Dec-89 13:22:39, Edit by Ram. - Made UNLINK-NODE set the NODE-PREV of the deleted node to NIL so that we can - recognize deleted nodes. Also, fixed the degenerate exit branch to add a use - by EXIT rather than NODE. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp -08-Dec-89 11:28:54, Edit by Ram. - Changed CONVERT-TYPE-CHECK to call LOCAL-CALL-ANALYZE now that this is not - being done in COMPILE-COMPONENT. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -08-Dec-89 11:24:13, Edit by Ram. - Fixed PROPAGATE-FUNCTION-CHANGE to call MAYBE-LET-CONVERT in addition to - COMVERT-CALL-IF-POSSIBLE so that IR1 optimize will let convert calls that it - discovers can be local. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vop.lisp -08-Dec-89 10:58:23, Edit by Ram. - Looks like when I made OLD-CONT and RETURN-PC environment TNs (and requiring - the IR2-ENVIRONMENT-SLOTS to be initialized after the environment was - created), I modified the wrong slots to allow NIL. Only detected now because - I was running with safe defstruct accessors. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug.lisp -08-Dec-89 09:58:33, Edit by Ram. - IR1 invariants now a bit different: :DELETED continuations can only be - received by blocks with DELETE-P set, and blocks with DELETE-P set can have - no successors. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp -08-Dec-89 09:51:24, Edit by Ram. - Don't attempt to let-convert when the REF is in a block with DELETE-P set - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -08-Dec-89 09:50:13, Edit by Ram. - Don't attempt to do IR1 optimizations when the block has DELETE-P set, just - delete it instead. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -08-Dec-89 09:46:20, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp -08-Dec-89 09:51:26, Edit by Ram. - Added BLOCK-DELETE-P and made DELETE-CONTINUATION set it in the DEST block - and its predecessors. Changed most uses of DELETE-CONTINUATION to assert - that there isn't a DEST. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -07-Dec-89 22:08:35, Edit by Ram. - In IR1-OPTIMIZE-IF, set COMPONENT-REANALYZE before UNLINK-NODE so that there - is still a component in the block. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -07-Dec-89 21:17:43, Edit by Ram. - In IR1-CONVERT-OK-COMBINATION-FER-SHER, set the CONTINUATION-%DERIVED-TYPE - and CONTINUATION-TYPE-CHECK of the fun cont in addition to setting - CONTINUATION-REOPTIMIZE. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -07-Dec-89 21:08:09, Edit by Ram. - Moved definitions of the arithmetic & logic functions %LDB et al. here from - eval.lisp, since we need them in the bootstrapping environment. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -07-Dec-89 19:17:48, Edit by Ram. - Changed USE-CONTINUATION not to set the CONTINUATION-%DERIVED-TYPE, as this - inhibits CONTINUATION-DERIVED-TYPE from seeing whether the assertion needs to - be intersected, etc. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -07-Dec-89 18:55:32, Edit by Ram. - Changed IR1-OPTIMIZE to more explicitly ignore a block when it is directly - deleted due to :DELETED kind or no predecessors. The old code should have - realized not to optimize a deleted block, but in a rather obscure way. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -07-Dec-89 13:25:38, Edit by Ram. - Changed IR1-OPTIMIZE-UNTIL-DONE to count the number of iterations that didn't - introduce any new code (set COMPONENT-REANALYZE) rather than just the total - number of iterations. Reduced MAX-OPTIMIZE-ITERATIONS to 3, since we now - don't have to worry so much about the results of transforms being adequately - optimized. Changed IR1-PHASES to call GENERATE-TYPE-CHECKS where it was - calling CHECK-TYPES. Flushed old call to GENERATE-TYPE-CHECKS in - COMPILE-COMPONENT. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -07-Dec-89 13:24:20, Edit by Ram. - Changed IR1-OPTIMIZE-IF to set COMPONENT-REANALYZE if it does anything. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp -07-Dec-89 12:56:18, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -07-Dec-89 12:28:19, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -07-Dec-89 13:01:31, Edit by Ram. - Changed type checking around a bunch, fixing some bugs and inefficiencies. - The old CHECK-TYPES phase is gone. The determination of - CONTINUATION-TYPE-CHECK is now done on the fly by CONTINUATION-DERIVED-TYPE. - The compile-time type error detection has been moved into type check - generation. Type check generation is now driven by BLOCK-TYPE-CHECK, so it - doesn't have to look at everything on repeat iterations. Made - ASSERT-CONTINUATION-TYPE set BLOCK-TYPE-CHECK when there is a new assertion. - - There are two new values of TYPE-CHECK: :ERROR and :NO-CHECK. These are used - by check generation to comminicate with itself and the back end. :ERROR - indicates a compile-time type error, which always causes a type check to be - emitted, regardless of policy. :NO-CHECK indicates that a check is needed, - but expected not to be generated due to policy or a safe implementation. - This inhibits LTN from choosing an unsafe implementation based on results of - new type information from the post-type-check optimization pass. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp -07-Dec-89 10:01:23, Edit by Ram. - Yep, that combined with a bug in how I hooked CTYPEP into TYPES-INTERSECT. - That function should return (VALUES T NIL) in the uncertain case, not - (VALUES NIL NIL). - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp -07-Dec-89 09:54:44, Edit by Ram. - Fixed CTYPEP to return the second value T when it calls TYPEP. Is this what - is causing all hell to break loose? It shouldn't, since it should just - result in increased type uncertainty. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/proclaim.lisp -06-Dec-89 21:24:00, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp -06-Dec-89 21:26:24, Edit by Ram. - Added support for the DEBUG-INFO optimization quality (DEBUG for short). - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp -06-Dec-89 11:25:36, Edit by Ram. - Made CTYPEP return a second value indicating whether it was able to determine - the relationship. Made all callers look at the second value and propagate - the uncertainty. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/proclaim.lisp -06-Dec-89 11:11:06, Edit by Ram. - Moved the actual establishing of the type definition to %%COMPILER-DEFSTRUCT - from %DEFSTRUCT. Part of this was actually duplicated both places. Now it - is only here. Hopefully this won't cause any initialization problems. Also, - made structure redefinition preserve the INCLUDED-BY list so that existing - structures won't suddenly be broken when the supertype is compiled. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -06-Dec-89 10:43:21, Edit by Ram. - Changed PROCESS-TYPE-PROCLAMATION to call SINGLE-VALUE-TYPE so that we don't - try to call TYPE-INTERSECTION on a hairy function type (or make the type of a - variable, for all that matter.) - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -05-Dec-89 13:42:19, Edit by Ram. - Made NCOMPILE-FILE frob *DEFAULT-COOKIE* so as to make optimize proclamations - affect only the file that they appear in (and any compilations dynamically - enclosed in that file.) - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -04-Dec-89 09:38:18, Edit by Ram. - Flushed :SEMI-INLINE and :ALWAYS-INLINE values for INLINEP. Added - :MAYBE-INLINE, which is interpreted in a more advisory manner. Changed - IR1-CONVERT-GLOBAL-INLINE so that it does something like the old - :SEMI-INLINE case for all inline calls so that recursive functions can be - INLINE. - - Fixed this code so that you really can have recursive inline functions. This - was supposedly supported for :SEMI-INLINE functions, but did not in fact - work. We do a hack similar to LABELS: we enter a dummy FUNCTIONAL in the - *FREE-FUNCTIONS* to prevent repeated attempts to convert the expansion. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -03-Dec-89 15:03:48, Edit by Ram. - Defined SAME-LEAF-REF-P and made transforms for EQ, EQL, < and > use it to - see if both args are references to the same variable or functional or - whatever. Also use the EQ transform for CHAR= and EQUAL. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -02-Dec-89 09:26:12, Edit by Ram. - Made MAX-OPTIMIZE-ITERATIONS be a ceiling on the number of times that - IR1-OPTIMIZE-UNTIL-DONE will iterate. If exceeded, we clear a bunch of - REOPTIMIZE flags and punt. This was made necessary by the addition of type - inference on set variables, which may take arbitrarily long to converge. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -01-Dec-89 14:05:10, Edit by Ram. - Added code to compute the type of set LET variables as the union of the types - of the initial value and the set values. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp -01-Dec-89 12:11:57, Edit by Ram. - Added code to check to see if it is cheaper to check against the difference - between the proven type and the assertion. If so, emit a check against the - negation of this difference. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -01-Dec-89 09:04:37, Edit by Ram. - Wrote IR1 transforms for < and > that attempt to statically determine the - relationship using type information. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp -01-Dec-89 10:06:56, Edit by Ram. - Wrote TYPE-DIFFERENCE. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -30-Nov-89 12:04:24, Edit by Ram. - Marked the error signalling funny functions as not returning by using - TRULY-THE NIL. Formerly this was subverting type inference, since the - primitive was considered to return *. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -30-Nov-89 11:52:27, Edit by Ram. - Made SUBSTITUTE-CONTINUATION-USES do a REOPTIMIZE-CONTINUATION on the New - continuation so that we realize we need to recompute its type, etc. This was - seriously crippling type inference. It probably came unglued in let - conversion when we changed over to using the general substitute function. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -30-Nov-89 11:31:00, Edit by Ram. - Changed FIND-FREE-VARIABLE to find the type of constants having values with - CTYPE-OF, rather than using INFO VARIABLE TYPE. This way we find a good type - for all constants, without interacting with the vagaries of environment query. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -30-Nov-89 10:50:37, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp -29-Nov-89 13:14:40, Edit by Ram. - Moved merging of tail sets from CONVERT-CALL to IR1-OPTIMIZE-RETURN. The old - code wasn't working because IR1 optimizations (such as deleting local EXITs) - could cause a local call to be tail-recursive yet the function would never - get added to the tail set because it had already been converted. - - Inaccurate computation of the tail sets resulted in bad code problems, since - functions were returning in ways not expected by their callers. - - ### This code still isn't quite right, since IR1 optimization is supposed to - be optional. One possible fix would be to do tail annotation in IR1 - optimization, but then you would have to run IR1 optimize to get proper tail - recursion. This might not be much of an issue, since we will probably always - want to do at least some IR1 optimization. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -27-Nov-89 12:35:17, Edit by Ram. - Fixed a braino in mask computation in the %DPB, %MASK-FIELD and - %DEPOSIT-FIELD transforms. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp -26-Nov-89 15:28:27, Edit by Ram. - Fixed MACRO-FUNCTION def to specify a result type of (OR FUNCTION NULL), - rather than just FUNCTION. This was disabling the use of this function as a - predicate to test whether a symbol names a macro. Also fixed the argument - order to REPLACE. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -25-Nov-89 22:44:32, Edit by Ram. - Fixed RPLACx transforms to return the right value. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp -22-Nov-89 19:27:58, Edit by Ram. - Fixed the definition of STRING-CHAR so that it wouldn't seem to be a subtype - of STANDARD-CHAR. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp -22-Nov-89 14:31:40, Edit by Ram. - In MAPPER-TRANSFORM, I seem to have inverted the sense of the exit test when - converting from CONSP to ENDP. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -21-Nov-89 16:51:31, Edit by Ram. - Moved GTN before control analysis so that the IR2-Environment is allocated by - the time that control analysis runs. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/control.lisp -21-Nov-89 16:38:24, Edit by Ram. - Moved to ADD-TO-EMIT-ORDER the adding of IR2-Blocks to the - IR2-ENVIRONMENT-BLOCKS. This way, overflow blocks created by conflict - analysis will appear in this list. TNs only live in overflow blocks were - being considered not to conflict with :ENVIRONMENT TNs. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/stack.lisp -21-Nov-89 16:34:05, Edit by Ram. - Made DISCARD-UNUSED-VALUES make an IR2 block for the cleanup block and call - ADD-TO-EMIT-ORDER on it. I think that if this code ever ran, it would have - died. This code was tested at one point, so it was probably broken by the - move of control analysis to before all the other IR2 pre-passes. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/tn.lisp -21-Nov-89 14:43:29, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/gtn.lisp -21-Nov-89 14:51:36, Edit by Ram. - Wrote MAKE-WIRED-ENVIRONMENT-TN so that the save TNs for old-cont and - return-pc could be made environment-live. Made ASSIGN-IR2-ENVIRONMENT pass - the environment to MAKE-xxx-SAVE-TN so that they could make environment-live - TNs. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/assembler.lisp -20-Nov-89 08:58:31, Edit by Ram. - In NEW-LOGIOR-ARGUMENT, added code to check that the SB for :REGISTER - operands is really REGISTERS. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -20-Nov-89 08:29:42, Edit by Ram. - In EMIT-MOVE, added code to emit a type error when moving between - incompatible TNs. It seems that this can happen with functions (especially - funny functions) that don't return. This seems like a good fix until we can - figure out how to hack the flow graph when there is a non-returning function. - [Incompatible moves may also happen if there is a compile-time type error and - the check is deleted due to unsafe policy, etc.] - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp -17-Nov-89 15:06:51, Edit by Ram. - Changed %PUT's IR1 attributes from (FLUSHABLE) to (UNSAFE). - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -17-Nov-89 10:12:48, Edit by Ram. - Fixed some missing commas in SOURCE-TRANSFORM-TRANSITIVE that only affected - LOGEQV. Good thing nobody uses it... - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vmdef.lisp -16-Nov-89 09:42:37, Edit by Ram. - Fixed previous fix to work when there is a more result. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vmdef.lisp -15-Nov-89 13:57:36, Edit by Ram. - In TEMPLATE-TYPE-SPECIFIER, if we use a values type for the result, make it - &REST T to represent the vagueness of values count matching. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -15-Nov-89 09:57:48, Edit by Ram. - Added missing source transform for LOGEQV, which was missed in the previous - pass. This required changing SOURCE-TRANSFORM-TRANSTIVE, since that was - already a source transform for LOGEQV. It's a good thing I left in *both* - checks for broken interpreter stubs. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -14-Nov-89 10:41:51, Edit by Ram. - Added source transforms for zillions of trivial logic operations that were - missing. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -14-Nov-89 10:43:24, Edit by Ram. - In %DEFUN, added the presence of an IR2-CONVERT methods to the list of things - that inhibits substitution of the actual definition for existing references. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp -13-Nov-89 12:21:52, Edit by Ram. - Added source transforms for RPLACA, RPLACD. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -13-Nov-89 12:17:32, Edit by Ram. - Moved the test of NODE-REOPTIMIZE out of FIND-RESULT-TYPE and into - IR1-OPTIMIZE-RETURN. This fixes a bug that was introduced when the clearing - of NODE-REOPTIMIZE was moved to the start of the loop in IR1-OPTIMIZE-BLOCK. - We were never recomputing the RETURN-RESULT-TYPE, since REOPTIMIZE was never - set when we got to IR1-OPTIMIZE-RETURN. With this fix, the previous change - should detect broken interpreter stubs. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp -12-Nov-89 13:05:49, Edit by Ram. - Made CHECK-FREE-FUNCTION give a note when it sees a function that doesn't - return (return type is NIL.) I thought that this would detect broken - interpreter stubs. It turns out not to, but still seems like a useful - feature. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -13-Nov-89 11:47:30, Edit by Ram. - Made LTN-ANALYZE-KNOWN-CALL give a warning when we are unable to find a - template for a known call where there call is to the current function. This - should tell result in a warning when we compile an interpreter stub for a - function that the code sources assume is implemented primitively, but the - compiler doesn't recognize. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -12-Nov-89 10:54:25, Edit by Ram. - Oops... When doing unsafe global function references, use - FAST-SYMBOL-FUNCTION, not FAST-SYMBOL-VALUE. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp -10-Nov-89 13:37:15, Edit by Ram. - Oops... Have to dump package frobbing forms specially for cold load. This - might want to be on a switch someday. Instead of actually compiling them, we - dump them as lists so that Genesis can eval them. The normal top-level form - compilation must be suppressed, since the package system isn't initialized at - the time that top-level forms run. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp -05-Nov-89 13:45:11, Edit by Ram. - Changed FIND-INITIAL-DFO to return top-level components at the end of the - list so that in a block compilation all the functions will be compiled before - we compile any of the top-level references to them. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/envanal.lisp -01-Nov-89 11:57:58, Edit by Ram. - Changed Find-Non-Local-Exits back to a loop over all the blocks in the - component, rather than trying to find the exits from the Lambda-Entries. - Unfortunately, the latter is not possible, since the exit continuation may - become deleted if it isn't used. A possible way to avoid this search would - be to make the Entry node have a list of all the Exit nodes, rather than the - continuations. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vop.lisp -31-Oct-89 12:45:20, Edit by Ram. - Allow (SETF xxx) for the Entry-Info-Name, in addition to strings and symbols. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -31-Oct-89 12:53:37, Edit by Ram. - In Find-Source-Context, only take the car of list first args to DEFxxx forms - when the form name is in a special list. This list initially only contains - DEFSTRUCT. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -31-Oct-89 12:23:57, Edit by Ram. - In Convert-More-Entry, made the temporaries for the keyword and value - ignorable so that we don't get "defined but never read" warnings when there - aren't any keywords specified. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -31-Oct-89 12:11:24, Edit by Ram. - Fixed Process-Declarations to correctly deal with pervasive special - declarations. Previously, a warning would be given if the varible was only - locally declared, and not globally known. Also an assertion failure would - have resulted (rather than a Compiler-Error) when a constant was declared - pervasively special. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -31-Oct-89 11:39:54, Edit by Ram. - Changed Reference-Constant so that it doesn't call Reference-Leaf anymore, - and made the source be an explicit argument. Changed Reference-Leaf to just - use the Leaf-Name as source, rather than (sometime incorrectly) inferring the - source for constants. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -20-Oct-89 15:56:56, Edit by Ram. - In the :UNKNOWN and :UNUSED cases of CONTINUATION-RESULT-TNS, always return - TNs of the specified result types, rather than sometimes returing T TNs. - This is some sort of compensation for our new belief that VOPS returining - non-T results need not be prepared to accept T TNs. How many other places - does this need to be fixed? - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/stack.lisp -17-Oct-89 12:36:38, Edit by Ram. - In FIND-PUSHED-CONTINUATIONS, fix the check for pushes coming before pops. - You can compare nodes and continuations all day without finding any that are - EQ. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp -17-Oct-89 11:44:40, Edit by Ram. - Flushed the code in DEFTRANSFORM that was creating a THE out of the CONT's - asserted type. This should be unnecessary, and was made incorrect by the - continuation representation change. If the node was the last in a block and - the value wasn't used, then the value would be asserted to be of the NIL - type, resulting in a warning. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -17-Oct-89 10:51:27, Edit by Ram. - Changed Compiler-Mumble to tell whether an error message precedes from - *last-format-string*, rather than *last-source-context*, since the last - message might not have had a source context. Made *compiler-error-output* be - globally bound to a synonym stream for *error-output* so that calls to - Compiler-Error outside of the compiler will more or less work. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp -16-Oct-89 15:23:13, Edit by Ram. - In Convert-Type-Check, set the start & end cleanups of the new block to the - *start* cleanup of the Dest's block, and not the end cleanup. Not sure this - is really more correct, but it fixes one case. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/pack.lisp -12-Oct-89 14:05:43, Edit by Ram. - Added a before-GC hook that flushes the per-SB conflict data structure - whenever they aren't being used. This should prevent megabyte-plus conflicts - information from persisting after it is needed, and also reduce the cost of - Init-SB-Vectors, since the vectors will stay smaller. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -11-Oct-89 11:37:16, Edit by Ram. - Made Propagate-Function-Change ignore references that are :Notinline. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -10-Oct-89 23:28:33, Edit by Ram. - In Print-Error-Message, use the *Current-Form* as the source form whenever if - is non-NIL, even if there is a node in *Compiler-Error-Context*. This way, - messages during IR1 conversion of a transform will be more useful. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -10-Oct-89 22:47:56, Edit by Ram. - Now Delete-Optional-Dispatch must be prepared for the main entry to be a let - rather than just being deleted or a normal function, since let conversion is - being triggered here. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp -09-Oct-89 17:56:35, Edit by Ram. - Fixed Convert-Call to change the combination kind before changing the ref - leaf so that the call will appear local at that time. This allows let - conversion to happen when we replace a optional dispatch with one of its EPs. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -09-Oct-89 17:34:42, Edit by Ram. - Fixed Delete-Optional-Dispatch to call Maybe-Let-Convert if we notice that a - former EP lambda has exactly one reference. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -04-Oct-89 19:05:16, Edit by Ram. - In IR1-Optimize-Combination, we must be prepared for the derive-type method - to return NIL. This will happen if the arglist is incompatible with the - call (and if the optimizer explicitly returns NIL.) - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp -04-Oct-89 19:22:17, Edit by Ram. - Check-Transform-Keys and Check-Keywords-Constant were checking the second - (value) part of the key/value pair, so optimizers would never run if any - keywords were supplied. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -04-Oct-89 15:39:27, Edit by Ram. - When I changed Propagate-Local-Call-Args to clear the Continuation-Reoptimize - flags, I forgot that a local call continuation can be NIL (for an unused - argument.) - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -04-Oct-89 11:05:48, Edit by Ram. - Oops... In Propagate-Function-Change, we have to use - Continuation-Derived-Type rather than Continuation-Type now that the latter - changes function types to FUNCTION. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp -27-Sep-89 14:24:04, Edit by Ram. - Exported basic interface (but not environment vars, pending some abstract - interface to environment manipulation.) Changed class and type names to be - represented as strings at run time to avoid package lossage. Changed names - to be arbitrary equal objects (to allow setf functions). - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -21-Sep-89 10:12:38, Edit by Ram. - Changed OK-Result-TN to indicate need for a coercion if the result is unboxed - and the TN is boxed. This prevents load-TN packing from getting confused due - to there being no intersection between the SC restriction and the types - allowed by the SC. This would happen when the result was restricted to a - non-descriptor SC. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -21-Sep-89 10:39:04, Edit by Ram. - Changed Restrict-Descriptor-Args to restrict the argument only when a - coercion was required. This allows immediate objects to be passed to - templates in unboxed registers. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -30-Aug-89 14:37:36, Edit by Ram. - Changed Change-Leaf-Ref (and hence Substitute-Leaf) to use Derive-Node-Type - on the Ref with the Leaf-Type so that substituting a variable causes the new - type to be noticed. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -30-Aug-89 14:30:44, Edit by Ram. - Changed IR1-Optimize-Block and all the combination optimization code to clear - optimize flags *before* optimizing rather than after, so that a node will be - reoptimized if necessary. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vmdef.lisp -29-Aug-89 09:20:18, Edit by Ram. - Made Template-Type-Specifier hack *'s in operand type restrictions. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -24-Aug-89 13:55:04, Edit by Ram. - In LTN-Analyze-MV-Call, have to annotate the continuations in reverse order, - now that the IR2-Block-Popped isn't built in reverse order. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -24-Aug-89 13:25:14, Edit by Ram. - In LTN-Analyze, eliminated assertion that the block containing the use of a - unknown-values continuation is not already in the - IR2-Component-Values-Generators. It is possible for a single block to - contain uses of several MV continuations that have their DEST in a different - block. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp -22-Aug-89 12:12:49, Edit by Ram. - Made Find-Initial-DFO-Aux call Walk-Home-Call-Graph on each block before - walking the successors. Walk-Home-Call-Graph is a new function that looks at - the current block's home lambda's bind block to see if it is in a different - component. We need to do this to ensure that all code in a given environment - ends up in the same component, since any successor might be a non-local exit - (into a different environment.) - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -18-Aug-89 15:46:51, Edit by Ram. - Flushed the (locally (declare (optimize (safety 0))) ...) around the body of - Unwind-Protect's expansion. I think that this was trying to suppress some - type checking of the MV-Bind, but it was also causing unsafe compilation of - the protected form. If we really need this, it must be but back some other - way. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -18-Aug-89 15:11:13, Edit by Ram. - Oops... We can't use Label-Offset in the generators for Make-Catch-Block, - &c. Instead, we use a :Label load-time constant. The target argument to the - VOPs is now a normal integer argument, rather than a label in the - codegen-info. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -18-Aug-89 14:13:51, Edit by Ram. - In LTN-Analyze-Return, don't annotate NLX continuations as :Unused so that - the NLX entry code doesn't have to worry about this case. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -18-Aug-89 13:45:19, Edit by Ram. - In Reoptimize-Continuation, don't do anything if the continuation is deleted. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp -17-Aug-89 11:17:13, Edit by Ram. - Oops... In Node-Ends-Block, have to set the Block-Start-Uses, now that it is - always supposed to hold the uses of block starts. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -10-Aug-89 10:49:01, Edit by Ram. - Changed Find-Template to intersect the Node-Derived-Type with the - Continuation-Asserted-Type rather than using the Continuation-Derived-Type in - the case where we are allowed to use the result type assertion. This works - better when the continuation has multiple uses. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/typetran.lisp -24-Jul-89 14:25:09, Edit by Ram. - Fixed Source-Transform-Union-Typep to check that there really is a MEMBER - type in the union, instead of assuming there is whenever LIST is a subtype. - This was losing on (OR SYMBOL CONS). - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/assembler.lisp -19-Jul-89 14:36:10, Edit by Ram. - Made Init-Assembler nil out the Info slots in all the fixups so that the - fixup freelist doesn't hold onto the entire IR. More storage allocation - lossage has been caused by the explicit freelists in the assembler than - anything else. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp -12-Jul-89 15:34:09, Edit by Ram. - Changed defining macros to stick the actual function object into the - Function-Info &c to be compatible with the new definition of the Function - type. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -12-Jul-89 12:57:24, Edit by Ram. - Fixed goof in IR2-Convert-Local-Unknown call, where it was converting the - result TN list to TN-refs twice. For some reason, this was dying with a - highly mysterious error in Reference-TN-List. Perhaps this file was last - compiled with an unsafe policy? - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp -11-Jul-89 19:29:05, Edit by Ram. - In Propagate-Live-TNs, when we convert a :Read-Only conflict to :Live, we - null the entry in the local TNs to represent the elimination of local - conflict information. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -11-Jul-89 18:46:17, Edit by Ram. - Changed %Defun to only substitute the functional when it isn't notinline and - isn't known to have any templates or transforms. The latter constraint fixes - big problems with interpreter stubs. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp -05-Jul-89 22:11:10, Edit by Ram. - In Return-From, put back code that made Cont start a block so that Cont will - have a block assigned before IR1-Convert. So that's why that was there. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -05-Jul-89 18:07:48, Edit by Ram. - In Annotate-Unknown-Values-Continuation, make a safety note when we delete a - check and the policy is safe. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp -05-Jul-89 17:43:18, Edit by Ram. - In IR1-Optimize-Exit, don't propagate Cont's type to the Value, since this - moves checking of the assertion to the Exit, which is a bad place. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -05-Jul-89 15:10:34, Edit by Ram. - In Emit-Return-For-Locs, changed the test for when to use known return - convention from External-Entry-Point-P to *not* External-Entry-Point-P. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp -05-Jul-89 14:41:55, Edit by Ram. - Oops... We need a UWP-Entry VOP for Unwind-Protect entries to force random - live TNs onto the stack. It doesn't actually do anything, but specifies the - passing locations as results so that they aren't forced to the stack. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp -03-Jul-89 16:46:09, Edit by Ram. -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/stack.lisp -03-Jul-89 16:39:53, Edit by Ram. - Changed unknown values hackery to ignore non-local exits. We don't record - NLX uses of unknown-values continuations as generators, and we stop - our graph walk when we hit the component root. These changes were - necessitated by the decision to make %NLX-Entry no longer use the values - continuation. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/pack.lisp -03-Jul-89 11:31:36, Edit by Ram. - Fixed one-off error in Pack-Wired-TN's determination of when we have to grow - the SB, and fixed it to handle SC-Element-Size /= 1 while I was at it. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp -29-Jun-89 12:02:16, Edit by Ram. - In Local-Call-Analyze-1, moved the test for the reference being by the - Basic-Combination-Fun to around the entire branch that attempts to convert, - rather than immediately around the call to Convert-Call-If-Possible. Before, - a closure arg to a local function wouldn't get an XEP. - - Also, changed Reference-Entry-Point to ignore references to :Cleanup and - :Escape functions. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/envanal.lisp -28-Jun-89 16:57:12, Edit by Ram. - In Emit-Cleanups, if we find there is no cleanup code, then do nothing, - instead of inserting a cleanup block holding NIL. This was causing blocks - with no non-local uses to inhibit tail-recursion. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp -28-Jun-89 14:03:45, Edit by Ram. - It finally happened. A paren error that resulted in mysterious lossage. In - this case, the body of the loop in Make-Type-Check-Form was moved out of the - loop, and always executed once. The meant that only one value would ever be - checked or propagated on to the original receiver. - -/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/pack.lisp -28-Jun-89 13:20:59, Edit by Ram. - Oops... I introduced a bug in the previously correct argument case of - Load-TN-Conflicts-In-SB. We terminate the loop when we reach the first - reference, not the first argument. This caused conflicts with temporaries - with lives beginning at :Load to be ignored. - -/usr1/lisp/compiler/pack.lisp, 23-Jun-89 15:54:32, Edit by Ram. - Fixed logic in Load-TN-Conflicts-In-SB. We weren't recognizing conflicts - with other argument/result TNs that had already been packed. This bug would - only show up with multiple result load TNs. The argument case was actually - correct, but was asymmetrical with the result case, and only worked becase - argument load TNs were packed in evaluation order. - -/usr1/lisp/compiler/locall.lisp, 20-Jun-89 14:53:51, Edit by Ram. - In Merge-Tail-Sets, quietly do nothing if the called function has no tail set - (doesn't return), rather than dying. - -/usr1/lisp/compiler/globaldb.lisp, 14-Jun-89 10:14:04, Edit by Ram. - Flushed Top-Level-P attribute. - -/usr1/lisp/compiler/macros.lisp, 14-Jun-89 10:14:03, Edit by Ram. - Allow a doc string in Def-IR1-Translator (made the FUNCTION documentation). - Removed support for Top-Level-P attribute. - -/usr1/lisp/compiler/ir1opt.lisp, 22-May-89 15:30:59, Edit by Ram. -/usr1/lisp/compiler/ir1util.lisp, 22-May-89 15:22:17, Edit by Ram. - Undid last change to Node-Ends-Block and Join-Blocks. This was fucking up - big time, since it messed with the continuation even when it was a block - start. - -/usr1/lisp/compiler/locall.lisp, 22-May-89 13:24:48, Edit by Ram. - Changed Local-Call-Analyze to maintain the Component-New-Functions exactly up - to date, only popping a function off exactly as it analyzes it. This way, a - lambda is always referenced either in the Lambdas or New-Functions (except - during a brief window), so we can do consistency checking during local call - analysis. - -/usr1/lisp/compiler/ir1util.lisp, 19-May-89 10:05:28, Edit by Ram. -/usr1/lisp/compiler/ir1opt.lisp, 19-May-89 10:05:27, Edit by Ram. - In Flush-Dest and Reoptimize-Continuation, take care not to assume that the - Continuation-Block is an undeleted block. Instead, we pick up the component - to reoptimize from the uses or Dest. - -/usr1/lisp/compiler/ir2tran.lisp, 17-May-89 12:48:35, Edit by Ram. - In Move-Results-Coerced and Move-Results-Checked, subtract Nsrc from Ndest, - rather than the other way around. - -/usr1/lisp/compiler/control.lisp, 15-May-89 11:53:36, Edit by Ram. - Made Control-Analyze walk XEPs first to eliminate the idiocy of never getting - the drop-through in components with only one EP. - -/usr1/lisp/compiler/ir1util.lisp, 13-May-89 15:23:28, Edit by Ram. - And similarly, in Node-Ends-Block, move the last continuation to the new - block when its block is the old block. - -/usr1/lisp/compiler/ir1opt.lisp, 13-May-89 15:02:31, Edit by Ram. - In Join-Blocks, move the Cont of the Last to Block1 when it's block is - currently Block2. This way, the continuation isn't left pointing at some - random deleted block. - -/usr1/lisp/compiler/ir1util.lisp, 14-Mar-89 10:12:04, Edit by Ram. - Also, in Delete-Block, when we delete a bind, call Delete-Lambda, rather - than trying to roll our own. - -/usr1/lisp/compiler/ir1util.lisp, 14-Mar-89 10:07:01, Edit by Ram. - In Delete-Lambda, we must remove a let from its home's lets. - -/usr1/lisp/compiler/ir1util.lisp, 14-Mar-89 09:34:54, Edit by Ram. - In Unlink-Node, the assertion that the start and end cleanups are the same - must use Find-Enclosing-Cleanup, rather than just comparing the values - directly. - -/usr1/lisp/compiler/ir2tran.lisp, 14-Mar-89 08:26:04, Edit by Ram. - Wrote Flush-Tail-Transfer and made people who do TR stuff use it. This - function deletes the link between the blocks for a TR node and the block - containing the return node. We have to do this so that lifetime analysis - doesn't get confused when there are TNs live at the return node, but some - predecessors of the return don't write the TNs because the return some other - way. - -/usr1/lisp/compiler/srctran.lisp, 10-Mar-89 19:11:51, Edit by Ram. - Made the transforms into %typep always pass until we do type predicates for - real. - -/usr1/lisp/compiler/assembler.lisp, 10-Mar-89 18:56:45, Edit by Ram. - Fixed Macrolet of Emit-Label in Def-Branch to have a paren in the right - place. As written, it expanded into its argument, and didn't enclose any - code anyway. But I think this would only affect instructions that both were - a branch and had a load-time fixup. - -/usr1/lisp/compiler/assembler.lisp, 10-Mar-89 18:47:50, Edit by Ram. - Added code to Def-Branch in the choose function that calls - Undefined-Label-Error when the the label isn't defined. This function uses - the *assembler-nodes* source info and the branch instruction location to - print the source node responsible for generating the bogus branch. - -/usr1/lisp/compiler/assembler.lisp, 10-Mar-89 17:59:51, Edit by Ram. - Made Gen-Label initalize the Elsewhere-P slot to :Undecided. Also made - Merge-Code-Vectors ignore labels whose Elsewhere-P is undecided. The theory - is that it should be o.k. to make labels that aren't emitted as long as you - don't reference them. Of course, I will probably find that the losing labels - are referenced. Renamed the Location slot in Label to %Location, and defined - Label-Location to filter out undefined labels. - -/usr1/lisp/compiler/ltn.lisp, 10-Mar-89 17:43:39, Edit by Ram. - In LTN-Analyze-Return, we must check for the Return-Info-Count being :Unknown - rather than null when we want to know if a fixed number of values are - returned. - -/usr1/lisp/compiler/ir2tran.lisp, 07-Mar-89 18:13:12, Edit by Ram. - In the Values-List IR2 convert method, we must also handle :Unused - continuations, only punting when the continuation is :Fixed. When called - with a TR result continuation, we have to emit the unknown-values return - ourself. Otherwise, there isn't any way to write the Values-List function. - -/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 21:25:12, Edit by Ram. - Make-Closure takes the number of closure vars and the function-entry, rather - than the other way around. - -/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 20:48:29, Edit by Ram. - And always pass 1 as the number of symbols to Unbind, rather than 0. - -/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 20:43:47, Edit by Ram. - Args to the Bind miscop are (Value, Symbol), and not the other way around. - -/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 19:09:16, Edit by Ram. - In IR2-Convert-IF, we have to negate the sense of the test when using an EQ - NIL check. Made IR2-Convert-Conditional take an additional not-p argument. - -/usr1/lisp/compiler/ctype.lisp, 06-Mar-89 17:22:40, Edit by Ram. - In Definition-Type, when we make the Function-Type, include the list of - keyword info that we have built. - -/usr1/lisp/compiler/ir2tran.lisp, 02-Mar-89 18:16:40, Edit by Ram. - In Init-XEP-Environment, when we are checking for whether there is a more - arg, look at the entry-function rather than the XEP. - -/usr1/lisp/compiler/main.lisp, 01-Mar-89 15:58:32, Edit by Ram. - Made Clear-Stuff clear the Finite-SB-Live-TNs in all SBs. Maybe this will - nuke some garbage. - -/usr1/lisp/compiler/pack.lisp, 01-Mar-89 15:50:41, Edit by Ram. - In Grow-SC, fill the Finite-SB-Live-TNs vector with NILs before we lose it so - that if it is statically allocated, it won't hold onto garbage. But this - shouldn't make any difference, since we never use the Live-TNs in unbounded - SBs. - -/usr1/lisp/compiler/locall.lisp, 01-Mar-89 01:15:22, Edit by Ram. - In Make-XEP-Lambda, in the lambda case, we now include an ignore declaration - for the nargs var when policy suppresses the argument count check. - -/usr1/lisp/compiler/ir1util.lisp, 28-Feb-89 19:39:56, Edit by Ram. - Also clear :Optional kind for the Main-Entry in Delete-Optional-Dispatch. - -/usr1/lisp/compiler/locall.lisp, 28-Feb-89 19:31:07, Edit by Ram. - Changed Local-Call-Analyze so that it pushes new lambdas on the - Component-Lambdas before it does any call analysis or let conversion. This - gets the normal consistency maintenance code to handle removal of deleted - and let lambdas. Before, there was a local list of new lambdas that could - become inconsistent. - -/usr1/lisp/compiler/ir1tran.lisp, 28-Feb-89 18:12:15, Edit by Ram. - Instead of trying to set the :Optional kind everywhere that hairy lambda - conversion creates a lambda, we wait until we are done and set the kind only - the lambdas that are actually e-ps. This was causing internal lambdas that - weren't e-ps to be marked as optional. The fix is also clearer, and causes - less complication in the already-hairy code. - -/usr1/lisp/compiler/ir1tran.lisp, 24-Feb-89 15:26:29, Edit by Ram. - Changed Optional-Dispatch stuff to set the Functional-Entry-Function of the - :Optional lambdas to the result Optional-Dispatch structure. - -/usr1/lisp/compiler/ir1opt.lisp, 24-Feb-89 14:46:57, Edit by Ram. - In IR1-Optimize, changed test for being in a deleted lambda to just look at - the block-lambda, rather than at it's home. The result should be the same. - -/usr1/lisp/compiler/entry.lisp, 24-Feb-89 14:30:37, Edit by Ram. - Changed Compute-Entry-Info to use the XEP's environment to determine whether - the function is a closure. The result should be the same, but is more easily - obtained. - -/usr1/lisp/compiler/ir1util.lisp, 24-Feb-89 14:26:58, Edit by Ram. - Deleted definition of Find-XEP-Call, since this doesn't make sense anymore. - -/usr1/lisp/compiler/debug.lisp, 24-Feb-89 14:21:09, Edit by Ram. - Flushed permission of random wired live TNs at the start of an XEP. - -/usr1/lisp/compiler/debug.lisp, 24-Feb-89 14:18:01, Edit by Ram. - In Check-Block-Successors, flushed permission of random successor count in - XEPs. - -/usr1/lisp/compiler/ir2tran.lisp, 24-Feb-89 14:14:12, Edit by Ram. - Flushed check for being the bind block for an XEP that inhibited emission of - a block-finishing branch in Finish-IR2-Block. Control flow is now normal in - XEPs, so we don't want to randomly flush branches. - -/usr1/lisp/compiler/ir1opt.lisp, 24-Feb-89 14:07:52, Edit by Ram. - Flushed check for being in an XEP in Join-Successor-If-Possible. Now that - argument count dispatching is done explicitly, there is no need to force the - call to a block boundry (for easy location). Also, we are getting more - complex code in the XEP, making block merging a desirable optimization. - -/usr1/lisp/compiler/ir1util.lisp, 24-Feb-89 14:03:35, Edit by Ram. - Fixed code in Delete-Lambda that was trying to notice when we are deleting - the the XEP for an optional dispatch. The test was right, but the action was - wrong: it was setting the Functional-Entry-Function for all the e-p's to NIL, - yet they were already NIL. Instead, we call Delete-Optional-Dispatch, which - deletes the unreferenced e-p's. - -/usr1/lisp/compiler/ir1tran.lisp, 23-Feb-89 20:17:21, Edit by Ram. - Wrapped a (locally (declare (optimize (safety 0))) ...) around the body of - the loop created in Convert-More-Entry so that no type checking is done on - the fixnum arithmetic. - -/usr1/lisp/compiler/ir2tran.lisp, 23-Feb-89 14:34:49, Edit by Ram. - Flushed most of the hair associated with the %Function-Entry funny function. - What remains is now in Init-XEP-Environment, which is called by - IR2-Convert-Bind when the lambda is an XEP. - -/usr1/lisp/compiler/gtn.lisp, 23-Feb-89 14:24:20, Edit by Ram. - Flushed some special-casing of XEPs that is no longer needed now that XEP's - have args. Also, allocation of argument passing locations in XEPs is now - more similar to the non-XEP case: we don't allocate passing locations for - unused arguments. - -/usr1/lisp/compiler/locall.lisp, 22-Feb-89 15:26:50, Edit by Ram. - Change handling of XEPs. Most of the action in XEPs is now represented by - explicit IR1 in the XEP: argument dispatching is done by a COND, etc. - Instead of using funny functions such as %XEP-ARG to access the passed - arguments, NARGS and all the positional arguments are passed as arguments to - the XEP (with garbage defaults for unsupplied args). The code in the XEP - just references these variables. - - This simplifies creation of the XEP, since we can just cons up a lambda form - and convert it, instead of creating each XEP call by hand. It also moves - complexity out of IR2 conversion, since argument dispatching has already been - implemented. - -/usr1/lisp/compiler/ir2tran.lisp, 16-Feb-89 15:12:17, Edit by Ram. - Fixed %XEP-Arg to use Move-Argument rather than just Move. - -/usr1/lisp/compiler/node.lisp, 15-Feb-89 00:36:30, Edit by Ram. - Made Functional specify :Defined and Function as the defaults for the - Where-From and Type slots so that we know defined functions are in fact - functions. - -/usr1/lisp/compiler/ir1tran.lisp, 14-Feb-89 23:48:37, Edit by Ram. - In %Defun translator, fixed the test for being at top level (and thus o.k. to - substitute). The sense was negated, but it was also broken so that it was - always false, so the normal top-level thing happened anyway. - -/usr1/lisp/compiler/ir1tran.lisp, 14-Feb-89 15:02:14, Edit by Ram. - Wrote Leaf-Inlinep and changed uses to (cdr (assoc leaf *inlines*)) with the - new function. This means that global declarations will now affect function - references. - -/usr1/lisp/compiler/main.lisp, 13-Feb-89 12:19:39, Edit by Ram. - Call Init-Assembler *before* Entry-Analyze so that we don't emit labels when - the assembler isn't initialized. - -/usr1/lisp/compiler/ltn.lisp, 02-Feb-89 15:41:40, Edit by Ram. - Changed Annotate-Function-Continuation not to clear Type-Check unless the - policy is unsafe. Changed LTN-Default-Call to take a policy argument and - pass it through. - -/usr1/lisp/compiler/ir1tran.lisp, 02-Feb-89 15:16:32, Edit by Ram. - Changed IR1-Convert-Combination-Args and the translator for - Multiple-Value-Call to assert that the function continuation yeilds a value - of type Function. - -/usr1/lisp/compiler/assembler.lisp, 31-Jan-89 14:13:54, Edit by Ram. -/usr1/lisp/compiler/codegen.lisp, 31-Jan-89 14:13:53, Edit by Ram. - Added a function version of Emit-Label that can be called outside of - Assemble. Used this in Generate-Code so that we don't have to worry about - faking the current node for Assemble, when we aren't emitting any code - anyway. - -/usr1/lisp/compiler/assembler.lisp, 31-Jan-89 13:56:08, Edit by Ram. - In Init-Assembler, Null out the Assembler-Node-Names in *Assembler-Nodes* so - that we don't hold onto old garbage. Also zero the code vectors so that - unitialized bytes always come up zero. - -/usr1/lisp/compiler/ir2tran.lisp, 31-Jan-89 12:37:21, Edit by Ram. - Fixed IR2-Convert-Local-Unknown-Call to use Standard-Value-TNs to get the - result TNs, rather than calling incorrectly calling Make-Standard-Value-TNs - on a continuation. - -/usr1/lisp/compiler/ir1opt.lisp, 30-Jan-89 23:28:08, Edit by Ram. - Changed Check-Types to not set Type-Check when the asserted type is T and the - derived type is *. - -/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 19:36:09, Edit by Ram. - Changed Delete-Ref not to call Delete-Lambda or Delete-Optional-Dispatch when - the functional is already deleted. - -/usr1/lisp/compiler/locall.lisp, 30-Jan-89 19:23:26, Edit by Ram. - Convert-MV-Call must add the ep to the Lambda-Calls for the home lambda (as - in Convert-Call) so that DFO can detect the control transfer implicit in - local call. - -/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 18:30:27, Edit by Ram. - Changed Delete-Optional-Dispatch to call Delete-Lambda on all entry points - with no references. - -/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 17:04:33, Edit by Ram. - Changed Delete-Lambda to mark the Lambda's lets as :Deleted as well, - guaranteeing that all code in the environment of a deleted lambda is deleted - (without having to do flow analysis). - -/usr1/lisp/compiler/locall.lisp, 30-Jan-89 16:37:31, Edit by Ram. - Changed Convert-MV-Call not to call Let-Convert, since the last entry may - have spurious references due to optional defaulting code that hasn't been - deleted yet. Changed Maybe-Let-Convert to set the Functional-Kind of the - lambda to :Let or :MV-Let, depending on the combination type. - -/usr1/lisp/compiler/locall.lisp, 30-Jan-89 15:35:52, Edit by Ram. - Changed Merge-Cleanups-And-Lets to use Find-Enclosing-Cleanup to determine - whether there is any cleanup in effect at the call site, rather than directly - using the Block-End-Cleanup. - -/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 15:12:51, Edit by Ram. - Changed Node-Ends-Block to set the start and end cleanups of the *new* block - (not the old) to the ending cleanup of the old block. This is clearly more - right, but may not be totally right. - -/usr1/lisp/compiler/life.lisp, 27-Jan-89 17:09:01, Edit by Ram. - Make Clear-Lifetime-Info always set the TN-Local slot for local TNs, using - some other referencing block when there there are global conflicts. - -/usr1/lisp/compiler/pack.lisp, 10-Jan-89 15:27:21, Edit by Ram. - Fixed Select-Location not to infinite loop when Finite-Sb-Last-Offset is 0. - -/usr0/ram/compiler/ir2tran.lisp, 30-Jun-88 13:57:12, Edit by Ram. - Fixed IR2-Convert-Bind to ignore vars with no Refs. - -/usr0/ram/compiler/gtn.lisp, 30-Jun-88 13:54:51, Edit by Ram. - Fixed Assign-Lambda-Var-TNs and Assign-IR2-Environment to ignore vars with no - Refs. - -/usr0/ram/compiler/life.lisp, 02-Mar-88 17:06:18, Edit by Ram. - Aaaargh! When clearing the Packed-TN-Local in Clear-Lifetime-Info, iterate - up to Local-TN-Limit, not SC-Number-Limit. - -/usr0/ram/compiler/ir1util.lisp, 20-Feb-88 22:00:37, Edit by Ram. - Made Substitute-Leaf and Change-Ref-Leaf do an Up-Tick-Node on the changed - Refs. - -/usr0/ram/compiler/ltn.lisp, 20-Feb-88 16:25:11, Edit by Ram. - Changed Find-Template to deal with output assertions correctly once again. - Instead of assuming that the Node-Derived-Type is true, we look at the - Type-Check flag in the continuation. If the continuation type is being - checked, then we only use a template when it doesn't have an output - restriction. - - In Find-Template-For-Policy, use safe templates as a last resort, even when - policy is :Small or :Fast. A safe template is surely faster and smaller than - a full call. - - In Ltn-Analyze, clear the Type-Check flags on all continuations when our - policy is unsafe. - -/usr0/ram/compiler/debug.lisp, 18-Feb-88 17:17:19, Edit by Ram. - And fixed Check-VOP-Refs to ensure that the temporary write comes before - (which is after in the reversed VOP-Refs) the read, rather than vice-versa... - -/usr0/ram/compiler/vmdef.lisp, 18-Feb-88 17:10:35, Edit by Ram. - Fixed Compute-Reference-Order to begin temporary lifetimes with the write - rather than the read. - -/usr0/ram/compiler/gtn.lisp, 18-Feb-88 16:06:41, Edit by Ram. - Have to fetch the Equated-Returns inside the loop in Find-Equivalence - classes, since Equate-Return-Info will change the returns for the current - environment. This used to work, since Equate-Return-Info used to be - destructive. - -/usr0/ram/compiler/ir1opt.lisp, 14-Feb-88 14:30:47, Edit by Ram. - Oops. Fixed the test in Propagate-From-Calls for being a call to the - function concerned. Now that this optimization can actually happen, who - knows? - -/usr0/ram/compiler/ltn.lisp, 11-Feb-88 18:01:38, Edit by Ram. - Made Annotate-1-Value-Continuation delay global function references to - functions that aren't notinline. Made LTN-Default-Call, - LTN-Analyze-Full-Call and LTN-Analyze-MV-Call annotate their function - continuation. - -/usr0/ram/compiler/flowsimp.lisp, 11-Feb-88 16:44:48, Edit by Ram. - Now that returns aren't being picked off in flow-graph-simplify, we have to - fix join-block-if-possible not to attempt to join the XEP return to the - component tail... - -/usr0/ram/compiler/ir1util.lisp, 11-Feb-88 16:14:52, Edit by Ram. - Made Delete-Ref call Maybe-Let-Convert when deleting the second-to-last - reference to a lambda. - -/usr0/ram/compiler/flowsimp.lisp, 10-Feb-88 16:46:56, Edit by Ram. -/usr0/ram/compiler/locall.lisp, 11-Feb-88 13:24:04, Edit by Ram. - Moved let-conversion to locall from flowsimp, and made it be triggered by - Maybe-Let-Convert. This is called on each new lambda after local call - analysis, and can also be called whenever there is some reason to believe - that a lambda might be eligible for let-conversion. We clear any :Optional - function kinds since the entry functions can be treated as normal functions - after local call analysis. - - This change was made to solve problems with lambdas not being let-converted - when the return node was deleted due to being unreachable. This is important - now that being a let has major environment significance. Originally let - conversion was regarded as a way to delete a return, and thus made some kind - of sense to have it be a flow graph optimization. Now that a let can have - only one reference, we can trigger let conversion by noticing when references - are deleted. - -/usr0/ram/compiler/node.lisp, 11-Feb-88 13:12:38, Edit by Ram. -/usr0/ram/compiler/ir1tran.lisp, 11-Feb-88 13:12:47, Edit by Ram. - Added :Optional Functional-Kind that is initially specified for the - entry-point lambdas in optional-dispatches so that we know there may be - references to the function through the optional dispatch. - -/usr0/ram/compiler/ir1util.lisp, 11-Feb-88 12:23:11, Edit by Ram. - Changed assertion in Control-Equate to allow an existing value-equate to the - same continuation. - -/usr0/ram/compiler/ir1tran.lisp, 25-Jan-88 19:27:57, Edit by Ram. - Changed the default policy to be all 1's, and modified calls to Policy in all - files so that they do "the right thing" when compared qualities are equal. - The default action should be chosen so as to minimize mystification and - annoyance to non-wizards. In general, the default should be chosen according - to the ordering: safety > brevity > speed > space > cspeed. Checks for 0 and - 3 meaning "totally unimportant" and "ultimately important" are also o.k. - -/usr0/ram/compiler/gtn.lisp, 24-Jan-88 11:20:37, Edit by Ram. - Changed Equate-Return-Info so that it effectively ignores the Count and Types - in :Unused continuations, yet still combines the Entry-P and Tail-P values. - -/usr0/ram/compiler/locall.lisp, 23-Jan-88 21:41:28, Edit by Ram. - Make Convert-XEP-Call set the Return-Point too... - -/usr0/ram/compiler/ir1util.lisp, 22-Jan-88 16:17:38, Edit by Ram. - Made Immediately-Used-P special-case local calls by using - Basic-Combination-Return-Point. - -/usr0/ram/compiler/locall.lisp, 22-Jan-88 16:13:32, Edit by Ram. -/usr0/ram/compiler/node.lisp, 22-Jan-88 16:12:03, Edit by Ram. - Added a Basic-Combination-Return-Point slot so that local calls can rebember - where they are supposed to return to. - -/usr0/ram/compiler/gtn.lisp, 22-Jan-88 10:03:37, Edit by Ram. - Fixed Assign-Lambda-Vars to set the TN-Leaf. - -/usr0/ram/compiler/flowsimp.lisp, 22-Jan-88 10:22:53, Edit by Ram. - Made Convert-To-Let do an Intersect-Continuation-Asserted-Type on the actual - continuation with the dummy's assertion when the let call is the only use of - the actual continuation. - -/usr0/ram/compiler/ir1tran.lisp, 22-Jan-88 09:42:49, Edit by Ram. - Tack NIL on the end of the forms that we convert so that no top-level form is - in a for-value context. - -/usr0/ram/compiler/ir1opt.lisp, 21-Jan-88 17:50:52, Edit by Ram. - Made Check-Types intersect the new type with the Node-Derived-Type for all - the continuation uses so that IR1Opt doesn't go and change the type right - back. - -/usr0/ram/compiler/main.lisp, 21-Jan-88 17:31:57, Edit by Ram. -/usr0/ram/compiler/ir1opt.lisp, 21-Jan-88 17:30:31, Edit by Ram. - Type checking was being done wrong. We need to check types even if IR1Opt - doesn't do anything, and we need to give IR1Opt a second chance if type check - does anything. Made Check-Types return whether it did anything. - -/usr0/ram/compiler/ir1tran.lisp, 21-Jan-88 17:14:13, Edit by Ram. - Fixed IR1 translator for THE to use Find-Uses to find whether the - continuation is used, rather than incorrectly doing it itself (using an old - interpretation of Continuation-Use). - -/usr0/ram/compiler/ir1tran.lisp, 16-Nov-87 15:58:39, Edit by Ram. - Made %proclaim (and hence proclaim) return (undefined-value) rather than - arbitrary randomness. - -/usr1/ram/compiler/flowsimp.lisp, 23-Aug-87 22:00:39, Edit by Ram - Changed Flow-Graph-Simplify not to merge blocks unless the cleanups for the - two blocks are identical. The is a sub-optimal (but conservative) way to - ensure that cleanups are only done on block boundaries. - -/usr1/ram/compiler/ir1opt.lisp, 23-Aug-87 21:26:53, Edit by Ram - Just look for the :Let functional kind in Top-Down-Optimize, instead of - figuring out from first principles. - -/usr1/ram/compiler/ir1util.lisp, 20-Aug-87 22:12:45, Edit by Ram - The only worthwhile use for the functional nesting was in Delete-Ref, where - it would walk all the inferiors, marking them as deleted as well. But I - think that just marking the outer function as deleted will eventually cause - all the inner functions to be deleted. As it stands, Delete-Ref is a lot - simpler. If there are problems with deleted-but-somehow-undeletable - references holding onto functions, we may want to look at all references in - Delete-Ref and see if some enclosing function is deleted. - -/usr1/ram/compiler/ir1tran.lisp, 22-Aug-87 15:38:50, Edit by Ram - Changed stuff to use the new Functional and Cleanup structures. Mostly - involves flushing stuff. - -/usr1/ram/compiler/locall.lisp, 21-Aug-87 14:24:32, Edit by Ram -/usr1/ram/compiler/ir1opt.lisp, 20-Aug-87 22:05:33, Edit by Ram - Changed Local-Call-Analyze to just take a component and analyze the - New-Functions. This simplifies (and optimizes) the late uses in IR1 - optimize. Also changed convert-call-if-possible to know to try to convert - the call to the real function rather than the XEP. - -/usr1/ram/compiler/node.lisp, 23-Aug-87 20:12:58, Edit by Ram - Flushed bogus hierarchical information in the Functional, Environment and - Cleanup structures. Now that I've taken a stab at implementing the IR2 - conversion passes, it is obvious that this information is useless and - difficult to maintain. - - We do need a way to iterate over all the functions in a component, but doing - a tree walk is bogus. Instead, we have a list of all the lambdas in each - component. When functions are initially converted, they are placed on the - component New-Functions list. Local call analysis moves analyzed lambdas - into the Lambdas list. We don't bother to remove lambdas from this list when - they are deleted. - - A change needed in the cleanup stuff to make it work is to have continuations - with no immediately enclosing cleanup point have their lambda as the cleanup. - Then when we convert the lambda to a let, we set the Cleanup slot in the - lambda to any cleanup enclosing the call so that we realize stuff needs to be - cleaned up. - -/usr1/ram/compiler/flowsimp.lisp, 23-Aug-87 20:49:36, Edit by Ram - Changed Find-Initial-DFO to build the Lambdas lists for the components. At - the same time, we also use XEP references to (correctly) merge components - with potential environment inter-dependencies, rather than attempting to use - the lambda nesting. Changed Join-Components to combine the Lambdas and - New-Functions lists. - - Changed Delete-Return to convert to a let only when there is a single call, - and also to mark the lambda with the :Let functional kind. This makes - let-calls exactly correspond to the functions that IR1 optimize can - substitute for. This also solves problems with cleanups, since it is - trivially true that all calls are in the same dynamic environment. - -/usr1/ram/compiler/ir1tran.lisp, 18-Aug-87 15:25:18, Edit by Ram - In IR1-Convert, if the function is not a symbol, but doesn't look even - vaguely like a lambda, then complain about an illegal function call, - rather than having IR1-Convert-Lambda say it is an illegal lambda. - -/usr1/ram/compiler/numacs.lisp, 16-Aug-87 13:48:11, Edit by Ram - Added a Defvar that doesn't use OR (and create a LET and freak out IR1 - conversion.) - -/usr1/ram/compiler/ir1util.lisp, 16-Aug-87 18:14:10, Edit by Ram -/usr1/ram/compiler/debug.lisp, 16-Aug-87 15:19:47, Edit by Ram -/usr1/ram/compiler/flowsimp.lisp, 16-Aug-87 15:19:13, Edit by Ram -/usr1/ram/compiler/ir1opt.lisp, 16-Aug-87 15:18:47, Edit by Ram -/usr1/ram/compiler/node.lisp, 16-Aug-87 19:58:30, Edit by Ram -/usr1/ram/compiler/ir1tran.lisp, 16-Aug-87 20:29:36, Edit by Ram -/usr1/ram/compiler/locall.lisp, 16-Aug-87 20:22:28, Edit by Ram - Changed stuff for new explicit external entry point concept. The external - entry point is now a real function containing local calls to the entry - points. This represents reality better, making lots of things previously - special-cased automatically happen in our favor. We really needed this for - environment analysis and IR2 conversion to work. - - Functional-Entry-Kind is replaced by Functional-Kind and - Functional-Entry-Function. The Kind is kind of like the old Entry-Kind. The - Entry-Function is the XEP (or a back-pointer in an XEP). Uses of Entry-Kind - were replaced with Kind or Entry-Function or flushed, as appropriate. - - Note-Entry-Point has been flushed. %Defun doesn't need to do anything to - cause the function to be an entry point. The top-level lambda is no longer - a real entry-point: instead we just directly link it to the component head - and tail. - - The more-arg XEP creates a more-arg cleanup. The local-call case still needs - to be fixed. - -/usr1/ram/compiler/fndb.lisp, 16-Aug-87 20:37:28, Edit by Ram - Added some definitions for %mumble magic compiler functions. - -/usr1/ram/compiler/ir1tran.lisp, 16-Aug-87 20:29:36, Edit by Ram - Changed uses of the two-arg Arg for more-arg hackery into %More-Arg, since - this isn't the user-level functionality we will ultimately want for - more-args. - -/usr1/ram/compiler/main.lisp, 16-Aug-87 18:35:29, Edit by Ram - Changed Compile-Component not to do any IR1 passes on the top-level component - except for Type-Check. These optimizations are unlikely to have any useful - effect on top-level code, and they might want to inject illegal stuff into - the top-level component. - -/usr1/ram/compiler/macros.lisp, 16-Aug-87 18:26:19, Edit by Ram - Changed With-IR1-Environment to bind *Converting-Top-Level*. Currently you'd - better not use this on top-level code unless you are sure you won't emit - anything that can't go in top-level, since IR1-Convert-Lambda will bogue out - because there is no *Initial-Component* to switch to. - -/usr1/ram/compiler/macros.lisp, 13-Aug-87 20:16:47, Edit by Ram -/usr1/ram/compiler/node.lisp, 13-Aug-87 22:24:30, Edit by Ram -/usr1/ram/compiler/main.lisp, 13-Aug-87 22:35:11, Edit by Ram -/usr1/ram/compiler/globaldb.lisp, 13-Aug-87 20:21:12, Edit by Ram -/usr1/ram/compiler/locall.lisp, 13-Aug-87 22:57:54, Edit by Ram -/usr1/ram/compiler/flowsimp.lisp, 13-Aug-87 22:52:01, Edit by Ram -/usr1/ram/compiler/ir1opt.lisp, 13-Aug-87 22:59:11, Edit by Ram -/usr1/ram/compiler/ir1tran.lisp, 13-Aug-87 23:06:03, Edit by Ram - Changed stuff to support having separate top-level and initial components. - Whenver we see a lambda or anything hairy, we switch over to the initial - component. Hairyness of special-forms is determined by the :Top-Level-P - keyword to Def-IR1-Translator. - - We make appropriate special forms hairy to guarantee that the top-level - component doesn't contain any stuff that would make life hard for IR2 - conversion. In particular, it contains no variables, no functions other than - the top-level lambda and no non-local exit targets. - - Local call analysis refuses to convert calls appearing in the top-level - component. In other files, stuff related to Functional-Top-Level-P was - ripped out. - -/usr1/ram/compiler/ir1opt.lisp, 13-Aug-87 17:58:37, Edit by Ram - Changed propagate-from-calls to punt if any use is a mv-combination. Changed - Top-Down-Optimize not to Substitute-Let-Vars unless the only use is not a - MV-Combination. Un-commented-out the substituion of functionals for non-set - let vars. - -/usr1/ram/compiler/locall.lisp, 13-Aug-87 18:31:24, Edit by Ram - Frobbed Find-Top-Level-Code to recognize DEFUNs with no calls as - non-top-level. The entire concept is probably wrong, though. - -/usr1/ram/compiler/ir1tran.lisp, 13-Aug-87 19:07:22, Edit by Ram - Changed IR1-Convert-OK-Combination to look at the leaf-type of the leaf - rather than the derived type for the function continuation. This allows - known calls to be recognized again (I'm sure that worked at one point. - Perhaps before they were becoming known later on somehow?). This is all not - really right anyway, given the broken interpretation of function types - currently used in IR1. - -/usr/ram/compiler/ir1tran.slisp, 12-Jan-87 11:48:32, Edit by Ram - Fixed Find-Source-Paths to use a DO with ATOM test rather than a dolist, so - that it won't blow up on dotted lists. - -/usr/ram/compiler/ir1util.slisp, 12-Jan-87 10:28:07, Edit by Ram - Fixed Delete-Block to null out the DEST for the continuations belonging to - each node as we delete the node, so we don't try to deliver a result to a - node that doesn't exist anymore. diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp deleted file mode 100644 index 4c8bf836c70e8ec2436d99d038dcb02b64230cb1..0000000000000000000000000000000000000000 --- a/compiler/checkgen.lisp +++ /dev/null @@ -1,533 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/checkgen.lisp,v 1.22 1992/09/07 15:34:20 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file implements type check generation. This is a phase that runs -;;; at the very end of IR1. If a type check is too complex for the back end to -;;; directly emit in-line, then we transform the check into an explicit -;;; conditional using TYPEP. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") - - -;;;; Cost estimation: - - -;;; Function-Cost -- Internal -;;; -;;; Return some sort of guess about the cost of a call to a function. If -;;; the function has some templates, we return the cost of the cheapest one, -;;; otherwise we return the cost of CALL-NAMED. Calling this with functions -;;; that have transforms can result in relatively meaningless results -;;; (exaggerated costs.) -;;; -;;; We randomly special-case NULL, since it does have a source tranform and is -;;; interesting to us. -;;; -(defun function-cost (name) - (declare (symbol name)) - (let ((info (info function info name)) - (call-cost (template-cost (template-or-lose 'call-named *backend*)))) - (if info - (let ((templates (function-info-templates info))) - (if templates - (template-cost (first templates)) - (case name - (null (template-cost (template-or-lose 'if-eq *backend*))) - (t call-cost)))) - call-cost))) - - -;;; Type-Test-Cost -- Internal -;;; -;;; Return some sort of guess for the cost of doing a test against TYPE. -;;; The result need not be precise as long as it isn't way out in space. The -;;; units are based on the costs specified for various templates in the VM -;;; definition. -;;; -(defun type-test-cost (type) - (declare (type ctype type)) - (or (let ((check (type-check-template type))) - (if check - (template-cost check) - (let ((found (cdr (assoc type (backend-type-predicates *backend*) - :test #'type=)))) - (if found - (+ (function-cost found) (function-cost 'eq)) - nil)))) - (typecase type - (union-type - (collect ((res 0 +)) - (dolist (mem (union-type-types type)) - (res (type-test-cost mem))) - (res))) - (member-type - (* (length (member-type-members type)) - (function-cost 'eq))) - (numeric-type - (* (if (numeric-type-complexp type) 2 1) - (function-cost - (if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp)) - (+ 1 - (if (numeric-type-low type) 1 0) - (if (numeric-type-high type) 1 0)))) - (t - (function-cost 'typep))))) - - -;;;; Checking strategy determination: - - -;;; MAYBE-WEAKEN-CHECK -- Internal -;;; -;;; Return the type we should test for when we really want to check for -;;; Type. If speed, space or compilation speed is more important than safety, -;;; then we return a weaker type if it is easier to check. First we try the -;;; defined type weakenings, then look for any predicate that is cheaper. -;;; -;;; If the supertype is equal in cost to the type, we prefer the supertype. -;;; This produces a closer approximation of the right thing in the presence of -;;; poor cost info. -;;; -(defun maybe-weaken-check (type cont) - (declare (type ctype type) (type continuation cont)) - (cond ((policy (continuation-dest cont) - (<= speed safety) (<= space safety) (<= cspeed safety)) - type) - (t - (let ((min-cost (type-test-cost type)) - (min-type type) - (found-super nil)) - (dolist (x (backend-type-predicates *backend*)) - (let ((stype (car x))) - (when (and (csubtypep type stype) - (not (union-type-p stype))) ;Not #!% COMMON type. - (let ((stype-cost (type-test-cost stype))) - (when (or (< stype-cost min-cost) - (type= stype type)) - (setq found-super t) - (setq min-type stype min-cost stype-cost)))))) - (if found-super - min-type - *universal-type*))))) - - -;;; NO-FUNCTION-VALUES-TYPES -- Internal -;;; -;;; Like VALUES-TYPES, only mash any complex function types to FUNCTION. -;;; -(defun no-function-values-types (type) - (declare (type ctype type)) - (multiple-value-bind (res count) - (values-types type) - (values (mapcar #'(lambda (type) - (if (function-type-p type) - (specifier-type 'function) - type)) - res) - count))) - - -;;; Switch to disable check complementing, for evaluation. -;;; -(defvar *complement-type-checks* t) - -;;; MAYBE-NEGATE-CHECK -- Internal -;;; -;;; Cont is a continuation we are doing a type check on and Types is a list -;;; of types that we are checking its values against. If we have proven -;;; that Cont generates a fixed number of values, then for each value, we check -;;; whether it is cheaper to then difference between the the proven type and -;;; the corresponding type in Types. If so, we opt for a :HAIRY check with -;;; that test negated. Otherwise, we try to do a simple test, and if that is -;;; impossible, we do a hairy test with non-negated types. If true, -;;; Force-Hairy forces a hairy type check. -;;; -;;; When doing a non-negated check, we call MAYBE-WEAKEN-CHECK to weaken the -;;; test to a convenient supertype (conditional on policy.) If debug-info is -;;; not particularly important (debug <= 1) or speed is 3, then we allow -;;; weakened checks to be simple, resulting in less informative error messages, -;;; but saving space and possibly time. -;;; -(defun maybe-negate-check (cont types force-hairy) - (declare (type continuation cont) (list types)) - (multiple-value-bind - (ptypes count) - (no-function-values-types (continuation-proven-type cont)) - (if (eq count :unknown) - (if (and (every #'type-check-template types) (not force-hairy)) - (values :simple types) - (values :hairy - (mapcar #'(lambda (x) - (list nil (maybe-weaken-check x cont) x)) - types))) - (let ((res (mapcar #'(lambda (p c) - (let ((diff (type-difference p c)) - (weak (maybe-weaken-check c cont))) - (if (and diff - (< (type-test-cost diff) - (type-test-cost weak)) - *complement-type-checks*) - (list t diff c) - (list nil weak c)))) - ptypes types))) - (cond ((or force-hairy (find-if #'first res)) - (values :hairy res)) - ((every #'type-check-template types) - (values :simple types)) - ((policy (continuation-dest cont) - (or (<= debug 1) (and (= speed 3) (/= debug 3)))) - (let ((weakened (mapcar #'second res))) - (if (every #'type-check-template weakened) - (values :simple weakened) - (values :hairy res)))) - (t - (values :hairy res))))))) - - -;;; CONTINUATION-CHECK-TYPES -- Interface -;;; -;;; Determines whether Cont's assertion is: -;;; -- Checkable by the back end (:SIMPLE), or -;;; -- Not checkable by the back end, but checkable via an explicit test in -;;; type check conversion (:HAIRY), or -;;; -- not reasonably checkable at all (:TOO-HAIRY). -;;; -;;; A type is checkable if it either represents a fixed number of values (as -;;; determined by VALUES-TYPES), or it is the assertion for an MV-Bind. A type -;;; is simply checkable if all the type assertions have a TYPE-CHECK-TEMPLATE. -;;; In this :SIMPLE case, the second value is a list of the type restrictions -;;; specified for the leading positional values. -;;; -;;; We force a check to be hairy even when there are fixed values if we are in -;;; a context where we may be forced to use the unknown values convention -;;; anyway. This is because IR2tran can't generate type checks for unknown -;;; values continuations but people could still be depending on the check being -;;; done. We only care about EXIT and RETURN (not MV-COMBINATION) since these -;;; are the only contexts where the ultimate values receiver -;;; -;;; In the :HAIRY case, the second value is a list of triples of the form: -;;; (Not-P Type Original-Type) -;;; -;;; If true, the Not-P flag indicates a test that the corresponding value is -;;; *not* of the specified Type. Original-Type is the type asserted on this -;;; value in the continuation, for use in error messages. When Not-P is true, -;;; this will be different from Type. -;;; -;;; This allows us to take what has been proven about Cont's type into -;;; consideration. If it is cheaper to test for the difference between the -;;; derived type and the asserted type, then we check for the negation of this -;;; type instead. -;;; -(defun continuation-check-types (cont) - (declare (type continuation cont)) - (let ((type (continuation-asserted-type cont)) - (dest (continuation-dest cont))) - (assert (not (eq type *wild-type*))) - (multiple-value-bind (types count) - (no-function-values-types type) - (cond ((not (eq count :unknown)) - (if (or (exit-p dest) - (and (return-p dest) - (multiple-value-bind - (ignore count) - (values-types (return-result-type dest)) - (declare (ignore ignore)) - (eq count :unknown)))) - (maybe-negate-check cont types t) - (maybe-negate-check cont types nil))) - ((and (mv-combination-p dest) - (eq (basic-combination-kind dest) :local)) - (assert (values-type-p type)) - (maybe-negate-check cont (args-type-optional type) nil)) - (t - (values :too-hairy nil)))))) - - -;;; Probable-Type-Check-P -- Internal -;;; -;;; Return true if Cont is a continuation whose type the back end is likely -;;; to want to check. Since we don't know what template the back end is going -;;; to choose to implement the continuation's DEST, we use a heuristic. We -;;; always return T unless: -;;; -- Nobody uses the value, or -;;; -- Safety is totally unimportant, or -;;; -- the continuation is an argument to an unknown function, or -;;; -- the continuation is an argument to a known function that has no -;;; IR2-Convert method or :fast-safe templates that are compatible with the -;;; call's type. -;;; -;;; We must only return nil when it is *certain* that a check will not be done, -;;; since if we pass up this chance to do the check, it will be too late. The -;;; penalty for being too conservative is duplicated type checks. -;;; -;;; If there is a compile-time type error, then we always return true unless -;;; the DEST is a full call. With a full call, the theory is that the type -;;; error is probably from a declaration in (or on) the callee, so the callee -;;; should be able to do the check. We want to let the callee do the check, -;;; because it is possible that the error is really in the callee, not the -;;; caller. We don't want to make people recompile all calls to a function -;;; when they were originally compiled with a bad declaration (or an old type -;;; assertion derived from a definition appearing after the call.) -;;; -(defun probable-type-check-p (cont) - (declare (type continuation cont)) - (let ((dest (continuation-dest cont))) - (cond ((eq (continuation-type-check cont) :error) - (if (and (combination-p dest) (eq (combination-kind dest) :error)) - nil - t)) - ((or (not dest) - (policy dest (zerop safety))) - nil) - ((basic-combination-p dest) - (let ((kind (basic-combination-kind dest))) - (cond ((eq cont (basic-combination-fun dest)) t) - ((eq kind :local) t) - ((member kind '(:full :error)) nil) - ((function-info-ir2-convert kind) t) - (t - (dolist (template (function-info-templates kind) nil) - (when (eq (template-policy template) :fast-safe) - (multiple-value-bind - (val win) - (valid-function-use dest (template-type template)) - (when (or val (not win)) (return t))))))))) - (t t)))) - - -;;; Make-Type-Check-Form -- Internal -;;; -;;; Return a form that we can convert to do a hairy type check of the -;;; specified Types. Types is a list of the format returned by -;;; Continuation-Check-Types in the :HAIRY case. In place of the actual -;;; value(s) we are to check, we use 'Dummy. This constant reference is later -;;; replaced with the actual values continuation. -;;; -;;; Note that we don't attempt to check for required values being unsupplied. -;;; Such checking is impossible to efficiently do at the source level because -;;; our fixed-values conventions are optimized for the common MV-Bind case. -;;; -;;; We can always use Multiple-Value-Bind, since the macro is clever about -;;; binding a single variable. -;;; -(defun make-type-check-form (types) - (collect ((temps)) - (dotimes (i (length types)) - (temps (gensym))) - - `(multiple-value-bind ,(temps) - 'dummy - ,@(mapcar #'(lambda (temp type) - (let* ((spec - (let ((*unparse-function-type-simplify* t)) - (type-specifier (second type)))) - (test (if (first type) `(not ,spec) spec))) - `(unless (typep ,temp ',test) - (%type-check-error - ,temp - ',(type-specifier (third type)))))) - (temps) types) - (values ,@(temps))))) - - -;;; Convert-Type-Check -- Internal -;;; -;;; Splice in explicit type check code immediately before the node that its -;;; Cont's Dest. This code receives the value(s) that were being passed to -;;; Cont, checks the type(s) of the value(s), then passes them on to Cont. -;;; We: -;;; -- Ensure that Cont starts a block, so that we can freely manipulate its -;;; uses. -;;; -- Make a new continuation and move Cont's uses to it. Set type set -;;; Type-Check in Cont to :DELETED to indicate that the check has been -;;; done. -;;; -- Make the Dest node start its block so that we can splice in the type -;;; check code. -;;; -- Splice in a new block before the Dest block, giving it all the Dest's -;;; predecessors. -;;; -- Convert the check form, using the new block start as Start and a dummy -;;; continuation as Cont. -;;; -- Set the new block's start and end cleanups to the *start* cleanup of -;;; Prev's block. This overrides the incorrect default from -;;; With-IR1-Environment. -;;; -- Finish off the dummy continuation's block, and change the use to a use -;;; of Cont. (we need to use the dummy continuation to get the control -;;; transfer right, since we want to go to Prev's block, not Cont's.) -;;; Link the new block to Prev's block. -;;; -- Substitute the new continuation for the dummy placeholder argument. -;;; Since no let conversion has been done yet, we can find the placeholder. -;;; The [mv-]combination node from the mv-bind in the check form will be -;;; the Use of the new check continuation. We substitute for the first -;;; argument of this node. -;;; -- Invoke local call analysis to convert the call to a let. -;;; -(defun convert-type-check (cont types) - (declare (type continuation cont) (list types)) - (with-ir1-environment (continuation-dest cont) - (ensure-block-start cont) - (let* ((new-start (make-continuation)) - (dest (continuation-dest cont)) - (prev (node-prev dest))) - (continuation-starts-block new-start) - (substitute-continuation-uses new-start cont) - (setf (continuation-%type-check cont) :deleted) - - (when (continuation-use prev) - (node-ends-block (continuation-use prev))) - - (let* ((prev-block (continuation-block prev)) - (new-block (continuation-block new-start)) - (dummy (make-continuation))) - (dolist (block (block-pred prev-block)) - (change-block-successor block prev-block new-block)) - (ir1-convert new-start dummy (make-type-check-form types)) - (assert (eq (continuation-block dummy) new-block)) - - (let ((node (continuation-use dummy))) - (setf (block-last new-block) node) - (delete-continuation-use node) - (add-continuation-use node cont)) - (link-blocks new-block prev-block)) - - (let* ((node (continuation-use cont)) - (args (basic-combination-args node)) - (victim (first args))) - (assert (and (= (length args) 1) - (eq (constant-value - (ref-leaf - (continuation-use victim))) - 'dummy))) - (substitute-continuation new-start victim))) - - (local-call-analyze *current-component*)) - - (undefined-value)) - - -;;; DO-TYPE-WARNING -- Internal -;;; -;;; Emit a type warning for Node. If the value of node is being used for a -;;; variable binding, we figure out which one for source context. If the value -;;; is a constant, we print it specially. We ignore nodes whose type is NIL, -;;; since they are supposed to never return. -;;; -(defun do-type-warning (node) - (declare (type node node)) - (let* ((*compiler-error-context* node) - (cont (node-cont node)) - (atype-spec (type-specifier (continuation-asserted-type cont))) - (dtype (node-derived-type node)) - (dest (continuation-dest cont)) - (what (when (and (combination-p dest) - (eq (combination-kind dest) :local)) - (let ((lambda (combination-lambda dest)) - (pos (position cont (combination-args dest)))) - (format nil "~:[A possible~;The~] binding of ~S" - (and (continuation-use cont) - (eq (functional-kind lambda) :let)) - (leaf-name (elt (lambda-vars lambda) pos))))))) - (cond ((eq dtype *empty-type*)) - ((and (ref-p node) (constant-p (ref-leaf node))) - (compiler-warning "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S" - what atype-spec (constant-value (ref-leaf node)))) - (t - (compiler-warning - "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>" - what (type-specifier dtype) atype-spec)))) - (undefined-value)) - - -;;; MARK-ERROR-CONTINUATION -- Internal -;;; -;;; Mark Cont as being a continuation with a manifest type error. We set -;;; the kind to :ERROR, and clear any FUNCTION-INFO if the continuation is an -;;; argument to a known call. The last is done so that the back end doesn't -;;; have to worry about type errors in arguments to known functions. This -;;; clearing is inhibited for things with IR2-CONVERT methods, since we can't -;;; do a full call to funny functions. -;;; -(defun mark-error-continuation (cont) - (declare (type continuation cont)) - (setf (continuation-%type-check cont) :error) - (let ((dest (continuation-dest cont))) - (when (and (combination-p dest) - (let ((kind (basic-combination-kind dest))) - (or (eq kind :full) - (and (function-info-p kind) - (not (function-info-ir2-convert kind)))))) - (setf (basic-combination-kind dest) :error))) - (undefined-value)) - - -;;; Generate-Type-Checks -- Interface -;;; -;;; Loop over all blocks in Component that have TYPE-CHECK set, looking for -;;; continuations with TYPE-CHECK T. We do two mostly unrelated things: detect -;;; compile-time type errors and determine if and how to do run-time type -;;; checks. -;;; -;;; If there is a compile-time type error, then we mark the continuation and -;;; emit a warning if appropriate. This part loops over all the uses of the -;;; continuation, since after we convert the check, the :DELETED kind will -;;; inhibit warnings about the types of other uses. -;;; -;;; If a continuation is too complex to be checked by the back end, or is -;;; better checked with explicit code, then convert to an explicit test. -;;; Assertions that can checked by the back end are passed through. Assertions -;;; that can't be tested are flamed about and marked as not needing to be -;;; checked. -;;; -;;; If we determine that a type check won't be done, then we set TYPE-CHECK -;;; to :NO-CHECK. In the non-hairy cases, this is just to prevent us from -;;; wasting time coming to the same conclusion again on a later iteration. In -;;; the hairy case, we must indicate to LTN that it must choose a safe -;;; implementation, since IR2 conversion will choke on the check. -;;; -(defun generate-type-checks (component) - (do-blocks (block component) - (when (block-type-check block) - (do-nodes (node cont block) - (let ((type-check (continuation-type-check cont))) - (unless (member type-check '(nil :error :deleted)) - (let ((atype (continuation-asserted-type cont))) - (do-uses (use cont) - (unless (values-types-intersect (node-derived-type use) - atype) - (mark-error-continuation cont) - (unless (policy node (= brevity 3)) - (do-type-warning use)))))) - - (when (and (eq type-check t) - (not *byte-compiling*)) - (if (probable-type-check-p cont) - (multiple-value-bind (check types) - (continuation-check-types cont) - (ecase check - (:simple) - (:hairy - (convert-type-check cont types)) - (:too-hairy - (let* ((context (continuation-dest cont)) - (*compiler-error-context* context)) - (when (policy context (>= safety brevity)) - (compiler-note - "Type assertion too complex to check:~% ~S." - (type-specifier (continuation-asserted-type cont))))) - (setf (continuation-%type-check cont) :deleted)))) - (setf (continuation-%type-check cont) :no-check))))) - - (setf (block-type-check block) nil))) - - (undefined-value)) diff --git a/compiler/codegen.lisp b/compiler/codegen.lisp deleted file mode 100644 index f18eb36e31d81c93cf5ccb85aa64dfbc7eac27dc..0000000000000000000000000000000000000000 --- a/compiler/codegen.lisp +++ /dev/null @@ -1,289 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/codegen.lisp,v 1.18 1992/08/03 12:36:01 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; The implementation-independent parts of the code generator. We use -;;; functions and information provided by the VM definition to convert IR2 into -;;; assembly code. After emitting code, we finish the assembly and then do the -;;; post-assembly phase. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package :c) - -(in-package :new-assem) -(import '(label gen-label emit-label label-position) :c) - -(in-package :c) -(export '(component-header-length sb-allocated-size current-nfp-tn - callee-nfp-tn callee-return-pc-tn *code-segment* *elsewhere* - trace-table-entry pack-trace-table note-fixup - fixup fixup-p make-fixup fixup-name fixup-flavor fixup-offset)) - - -;;;; Utilities used during code generation. - -;;; Component-Header-Length -- Interface -;;; -(defun component-header-length (&optional (component *compile-component*)) - "Returns the number of bytes used by the code object header." - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp)) - (num-consts (length constants))) - (ash (logandc2 (1+ num-consts) 1) vm:word-shift))) - -;;; SB-Allocated-Size -- Interface -;;; -(defun sb-allocated-size (name) - "The size of the Name'd SB in the currently compiled component. Useful - mainly for finding the size for allocating stack frames." - (finite-sb-current-size (sb-or-lose name *backend*))) - - -;;; Current-NFP-TN -- Interface -;;; -(defun current-nfp-tn (vop) - "Return the TN that is used to hold the number stack frame-pointer in VOP's - function. Returns NIL if no number stack frame was allocated." - (unless (zerop (sb-allocated-size 'non-descriptor-stack)) - (let ((block (ir2-block-block (vop-block vop)))) - (when (ir2-environment-number-stack-p - (environment-info - (block-environment block))) - (ir2-component-nfp (component-info (block-component block))))))) - -;;; CALLEE-NFP-TN -- Interface -;;; -(defun callee-nfp-tn (2env) - "Return the TN that is used to hold the number stack frame-pointer in the - function designated by 2env. Returns NIL if no number stack frame was - allocated." - (unless (zerop (sb-allocated-size 'non-descriptor-stack)) - (when (ir2-environment-number-stack-p 2env) - (ir2-component-nfp (component-info *compile-component*))))) - - -;;; CALLEE-RETURN-PC-TN -- Interface -;;; -(defun callee-return-pc-tn (2env) - "Return the TN used for passing the return PC in a local call to the function - designated by 2env." - (ir2-environment-return-pc-pass 2env)) - - - -;;;; Fixups - -;;; FIXUP -- A fixup of some kind. -;;; -(defstruct (fixup - (:constructor make-fixup (name flavor &optional offset))) - ;; The name and flavor of the fixup. The assembler makes no assumptions - ;; about the contents of these fields; their semantics are imposed by the - ;; dumper. - name - flavor - ;; An optional offset from whatever external label this fixup refers to. - offset) - -(defun %print-fixup (fixup stream depth) - (declare (ignore depth)) - (format stream "#<~S fixup ~S~@[ offset=~S~]>" - (fixup-flavor fixup) - (fixup-name fixup) - (fixup-offset fixup))) - -(defvar *fixups*) - -;;; NOTE-FIXUP -- interface. -;;; -;;; This function is called by the (new-assembler) instruction emitters that -;;; find themselves trying to deal with a fixup. -;;; -(defun note-fixup (segment kind fixup) - (new-assem:emit-back-patch - segment 0 - #'(lambda (segment posn) - (declare (ignore segment)) - (push (list kind fixup posn) *fixups*))) - (undefined-value)) - - - -;;;; Specials used during code generation. - -(defvar *trace-table-info*) -(defvar *code-segment* nil) -(defvar *elsewhere* nil) -(defvar *elsewhere-label* nil) - -(defvar *assembly-optimize* nil - "Set to NIL to inhibit assembly-level optimization. For compiler debugging, - rather than policy control.") - - -;;;; Noise to emit an instruction trace. - -(defvar *prev-segment*) -(defvar *prev-vop*) - -(defun trace-instruction (segment vop inst args) - (let ((*standard-output* *compiler-trace-output*)) - (unless (eq *prev-segment* segment) - (format t "In the ~A segment:~%" (new-assem:segment-name segment)) - (setf *prev-segment* segment)) - (unless (eq *prev-vop* vop) - (when vop - (format t "~%VOP ") - (if (vop-p vop) - (print-vop vop) - (format *compiler-trace-output* "~S~%" vop))) - (terpri) - (setf *prev-vop* vop)) - (case inst - (:label - (format t "~A:~%" args)) - (:align - (format t "~0,8T.align~0,8T~A~%" args)) - (t - (format t "~0,8T~A~@[~0,8T~{~A~^, ~}~]~%" inst args)))) - (undefined-value)) - - - -;;;; Generate-code and support routines. - -(defun make-segment (&optional name) - (new-assem:make-segment - :name name - :run-scheduler - (and *assembly-optimize* - (policy (lambda-bind - (block-home-lambda - (block-next (component-head *compile-component*)))) - (or (>= speed cspeed) (>= space cspeed)))) - :inst-hook (if *compiler-trace-output* #'trace-instruction))) - -;;; Init-Assembler -- Interface -;;; -(defun init-assembler () - (setf *code-segment* (make-segment "Regular")) - (setf *elsewhere* (make-segment "Elsewhere")) - (undefined-value)) - -;;; Generate-Code -- Interface -;;; -(defun generate-code (component) - (when *compiler-trace-output* - (format *compiler-trace-output* - "~|~%Assembly code for ~S~2%" - component)) - (let ((prev-env nil) - (*trace-table-info* nil) - (*prev-segment* nil) - (*prev-vop* nil) - (*fixups* nil)) - (let ((label (new-assem:gen-label))) - (setf *elsewhere-label* label) - (new-assem:assemble (*elsewhere*) - (new-assem:emit-label label))) - (do-ir2-blocks (block component) - (let ((1block (ir2-block-block block))) - (when (and (eq (block-info 1block) block) - (block-start 1block)) - (new-assem:assemble (*code-segment*) - (new-assem:emit-label (block-label 1block))) - (let ((env (block-environment 1block))) - (unless (eq env prev-env) - (let ((lab (gen-label))) - (setf (ir2-environment-elsewhere-start (environment-info env)) - lab) - (emit-label-elsewhere lab)) - (setq prev-env env))))) - - (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop)) - (let ((gen (vop-info-generator-function (vop-info vop)))) - (if gen - (funcall gen vop) - (format t "Missing generator for ~S.~%" - (template-name (vop-info vop))))))) - - (new-assem:append-segment *code-segment* *elsewhere*) - (setf *elsewhere* nil) - (values (new-assem:finalize-segment *code-segment*) - (nreverse *trace-table-info*) - *fixups*))) - -(defun emit-label-elsewhere (label) - (new-assem:assemble (*elsewhere*) - (new-assem:emit-label label))) - -(defun label-elsewhere-p (label-or-posn) - (<= (label-position *elsewhere-label*) - (etypecase label-or-posn - (label - (label-position label-or-posn)) - (index - label-or-posn)))) - -(defun trace-table-entry (state) - (let ((label (gen-label))) - (emit-label label) - (push (cons label state) *trace-table-info*)) - (undefined-value)) - -;;; COMPUTE-TRACE-TABLE -- interface. -;;; -;;; Convert the list of (label . state) entries into an ivector. -;;; -(eval-when (compile load eval) - (defconstant bits-per-state 3) - (defconstant bits-per-entry 16) - (defconstant bits-per-offset (- bits-per-entry bits-per-state)) - (defconstant max-offset (ash 1 bits-per-offset))) -;;; -(defun pack-trace-table (table) - (declare (list table)) - #+nil - (let ((last-posn 0) - (last-state 0) - (result (make-array (length table) - :element-type '(unsigned-byte #.bits-per-entry))) - (index 0)) - (dolist (entry table) - (let* ((posn (label-position (car entry))) - (state (cdr entry))) - (flet ((push-entry (offset state) - (when (>= index (length result)) - (setf result - (replace (make-array - (truncate (* (length result) 5) 4) - :element-type - '(unsigned-byte #.bits-per-entry)) - result))) - (setf (aref result index) - (logior (ash offset bits-per-state) - state)) - (incf index))) - (do ((offset (- posn last-posn) (- offset max-offset))) - ((< offset max-offset) - (push-entry offset state)) - (push-entry 0 last-state))) - (setf last-posn posn) - (setf last-state state))) - (if (eql (length result) index) - result - (subseq result 0 index))) - ;; ### Hack 'cause this stuff doesn't work. - (declare (ignore table)) - (make-array 0 :element-type '(unsigned-byte #.bits-per-entry))) diff --git a/compiler/constraint.lisp b/compiler/constraint.lisp deleted file mode 100644 index ace86bad1bd07aa410ef87d0860bf5055496251e..0000000000000000000000000000000000000000 --- a/compiler/constraint.lisp +++ /dev/null @@ -1,518 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/constraint.lisp,v 1.13 1992/06/03 20:03:37 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file implements the constraint propagation phase of the compiler, -;;; which uses global flow analysis to obtain dynamic type information. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(defstruct (constraint - (:include sset-element) - (:constructor make-constraint (number kind x y not-p))) - ;; - ;; The kind of constraint we have: - ;; - ;; TYPEP - ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is constrained to - ;; be of type Y. - ;; - ;; >, < - ;; X is a lambda-var and Y is a CTYPE. The relation holds between X and - ;; some object of type Y. - ;; - ;; EQL - ;; X is a LAMBDA-VAR Y is a LAMBDA-VAR or a CONSTANT. The relation is - ;; asserted to hold. - ;; - (kind nil :type (member typep < > eql)) - ;; - ;; The operands to the relation. - (x nil :type lambda-var) - (y nil :type (or ctype lambda-var constant)) - ;; - ;; If true, negates the sense of the constraint. The relation is does *not* - ;; hold. - (not-p nil :type boolean)) - - -(defvar *constraint-number*) - -;;; FIND-CONSTRAINT -- Interface -;;; -;;; Return a constraint for the specified arguments. We only create a new -;;; constraint if there isn't already an equivalent old one, guaranteeing that -;;; all equivalent constraints are EQ. This shouldn't be called on lambda-vars -;;; with no CONSTRAINTS set. -;;; -(defun find-constraint (kind x y not-p) - (declare (type lambda-var x) (type (or constant lambda-var ctype) y) - (type boolean not-p)) - (or (etypecase y - (ctype - (do-elements (con (lambda-var-constraints x) nil) - (when (and (eq (constraint-kind con) kind) - (eq (constraint-not-p con) not-p) - (type= (constraint-y con) y)) - (return con)))) - (constant - (do-elements (con (lambda-var-constraints x) nil) - (when (and (eq (constraint-kind con) kind) - (eq (constraint-not-p con) not-p) - (eq (constraint-y con) y)) - (return con)))) - (lambda-var - (do-elements (con (lambda-var-constraints x) nil) - (when (and (eq (constraint-kind con) kind) - (eq (constraint-not-p con) not-p) - (let ((cx (constraint-x con))) - (eq (if (eq cx x) - (constraint-y con) - cx) - y))) - (return con))))) - (let ((new (make-constraint (incf *constraint-number*) kind x y not-p))) - (sset-adjoin new (lambda-var-constraints x)) - (when (lambda-var-p y) - (sset-adjoin new (lambda-var-constraints y))) - new))) - - -;;; OK-REF-LAMBDA-VAR -- Internal -;;; -;;; If Ref is to a Lambda-Var with Constraints (i.e. we can do flow analysis -;;; on it), then return the Lambda-Var, otherwise NIL. -;;; -(proclaim '(inline ok-ref-lambda-var)) -(defun ok-ref-lambda-var (ref) - (declare (type ref ref)) - (let ((leaf (ref-leaf ref))) - (when (and (lambda-var-p leaf) - (lambda-var-constraints leaf)) - leaf))) - - -;;; OK-CONT-LAMBDA-VAR -- Internal -;;; -;;; If Cont's Use is a Ref, then return OK-REF-LAMBDA-VAR of the Use, -;;; otherwise NIL. -;;; -(proclaim '(inline ok-cont-lambda-var)) -(defun ok-cont-lambda-var (cont) - (declare (type continuation cont)) - (let ((use (continuation-use cont))) - (when (ref-p use) - (ok-ref-lambda-var use)))) - - -;;; ADD-TEST-CONSTRAINT -- Internal -;;; -;;; Add the indicated test constraint to Block, marking the block as having -;;; a new assertion when the constriant was not already present. We don't add -;;; the constraint if the block has multiple predecessors, since it only holds -;;; on this particular path. -;;; -(defun add-test-constraint (block fun x y not-p) - (unless (rest (block-pred block)) - (let ((con (find-constraint fun x y not-p)) - (old (or (block-test-constraint block) - (setf (block-test-constraint block) (make-sset))))) - (when (sset-adjoin con old) - (setf (block-type-asserted block) t)))) - (undefined-value)) - - -;;; ADD-COMPLEMENT-CONSTRAINTS -- Internal -;;; -;;; Add complementary constraints to the consequent and alternative blocks -;;; of If. We do nothing if X is NIL. -;;; -(proclaim '(inline add-complement-constraints)) -(defun add-complement-constraints (if fun x y not-p) - (when x - (add-test-constraint (if-consequent if) fun x y not-p) - (add-test-constraint (if-alternative if) fun x y (not not-p))) - (undefined-value)) - - -;;; ADD-TEST-CONSTRAINTS -- Internal -;;; -;;; Add test constraints to the consequent and alternative blocks of the -;;; test represented by Use. -;;; -(defun add-test-constraints (use if) - (declare (type node use) (type cif if)) - (typecase use - (ref - (add-complement-constraints if 'typep (ok-ref-lambda-var use) - *null-type* t)) - (combination - (let ((name (continuation-function-name - (basic-combination-fun use))) - (args (basic-combination-args use))) - (case name - (%typep - (let ((type (second args))) - (when (constant-continuation-p type) - (let ((val (continuation-value type))) - (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) - (if (ctype-p val) - val - (specifier-type val)) - nil))))) - ((eq eql) - (let* ((var1 (ok-cont-lambda-var (first args))) - (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) - (cond ((not var1)) - (var2 - (add-complement-constraints if 'eql var1 var2 nil)) - ((constant-continuation-p arg2) - (add-complement-constraints if 'eql var1 - (ref-leaf - (continuation-use arg2)) - nil))))) - ((< >) - (let* ((arg1 (first args)) - (var1 (ok-cont-lambda-var arg1)) - (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) - (when var1 - (add-complement-constraints if name var1 (continuation-type arg2) - nil)) - (when var2 - (add-complement-constraints if (if (eq name '<) '> '<) - var2 (continuation-type arg1) - nil)))) - (t - (let ((ptype (gethash name (backend-predicate-types *backend*)))) - (when ptype - (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) - ptype nil)))))))) - (undefined-value)) - - - -;;; FIND-TEST-CONSTRAINTS -- Internal -;;; -;;; Set the Test-Constraint in the successors of Block according to the -;;; condition it tests. -;;; -(defun find-test-constraints (block) - (declare (type cblock block)) - (let ((last (block-last block))) - (when (if-p last) - (let ((use (continuation-use (if-test last)))) - (when use - (add-test-constraints use last))))) - - (setf (block-test-modified block) nil) - (undefined-value)) - - -;;; FIND-BLOCK-TYPE-CONSTRAINTS -- Internal -;;; -;;; Compute the initial flow analysis sets for Block: -;;; -- For any lambda-var ref with a type check, add that constraint. -;;; -- For any lambda-var set, delete all constraints on that var, and add -;;; those constraints to the set nuked by this block. -;;; -(defun find-block-type-constraints (block) - (declare (type cblock block)) - (let ((gen (make-sset))) - (collect ((kill nil adjoin)) - - (let ((test (block-test-constraint block))) - (when test - (sset-union gen test))) - - (do-nodes (node cont block) - (typecase node - (ref - (when (continuation-type-check cont) - (let ((var (ok-ref-lambda-var node))) - (when var - (let* ((atype (continuation-derived-type cont)) - (con (find-constraint 'typep var atype nil))) - (sset-adjoin con gen)))))) - (cset - (let ((var (set-var node))) - (when (lambda-var-p var) - (kill var) - (let ((cons (lambda-var-constraints var))) - (when cons - (sset-difference gen cons)))))))) - - (setf (block-in block) nil) - (setf (block-gen block) gen) - (setf (block-kill block) (kill)) - (setf (block-out block) (copy-sset gen)) - (setf (block-type-asserted block) nil) - (undefined-value)))) - - -;;; INTEGER-TYPE-P -- Internal -;;; -;;; Return true if X is an integer NUMERIC-TYPE. -;;; -(defun integer-type-p (x) - (declare (type ctype x)) - (and (numeric-type-p x) - (eq (numeric-type-class x) 'integer) - (eq (numeric-type-complexp x) :real))) - - -;;; CONSTRAIN-INTEGER-TYPE -- Internal -;;; -;;; Given that an inequality holds on values of type X any Y, return a new -;;; type for X. If Greater is true, then X was greater than Y, otherwise less. -;;; If Or-Equal is true, then the inequality was inclusive, i.e. >=. -;;; -;;; If Greater (or not), then we max (or min) in Y's lower (or upper) bound -;;; into X and return that result. If not Or-Equal, we can go one greater -;;; (less) than Y's bound. -;;; -(defun constrain-integer-type (x y greater or-equal) - (declare (type numeric-type x y)) - (flet ((exclude (x) - (cond ((not x) nil) - (or-equal x) - (greater (1+ x)) - (t (1- x)))) - (bound (x) - (if greater (numeric-type-low x) (numeric-type-high x)))) - (let* ((x-bound (bound x)) - (y-bound (exclude (bound y))) - (new-bound (cond ((not x-bound) y-bound) - ((not y-bound) x-bound) - (greater (max x-bound y-bound)) - (t (min x-bound y-bound)))) - (res (copy-numeric-type x))) - (if greater - (setf (numeric-type-low res) new-bound) - (setf (numeric-type-high res) new-bound)) - res))) - - -;;; CONSTRAIN-REF-TYPE -- Internal -;;; -;;; Given the set of Constraints for a variable and the current set of -;;; restrictions from flow analysis In, set the type for Ref accordingly. -;;; -(defun constrain-ref-type (ref constraints in) - (declare (type ref ref) (type sset constraints in)) - (let ((var-cons (copy-sset constraints))) - (sset-intersection var-cons in) - (let ((res (single-value-type (node-derived-type ref))) - (not-res *empty-type*) - (leaf (ref-leaf ref))) - (do-elements (con var-cons) - (let* ((x (constraint-x con)) - (y (constraint-y con)) - (not-p (constraint-not-p con)) - (other (if (eq x leaf) y x)) - (kind (constraint-kind con))) - (case kind - (typep - (if not-p - (setq not-res (type-union not-res other)) - (setq res (type-intersection res other)))) - (eql - (let ((other-type (leaf-type other))) - (if not-p - (when (and (constant-p other) - (member-type-p other-type)) - (setq not-res (type-union not-res other-type))) - (let ((leaf-type (leaf-type leaf))) - (when (or (constant-p other) - (and (csubtypep other-type leaf-type) - (not (type= other-type leaf-type)))) - (change-ref-leaf ref other) - (when (constant-p other) (return))))))) - ((< >) - (when (and (integer-type-p res) (integer-type-p y)) - (let ((greater (eq kind '>))) - (let ((greater (if not-p (not greater) greater))) - (setq res - (constrain-integer-type res y greater not-p))))))))) - - (let* ((cont (node-cont ref)) - (dest (continuation-dest cont))) - (cond ((and (if-p dest) - (csubtypep *null-type* not-res) - (eq (continuation-asserted-type cont) *wild-type*)) - (setf (node-derived-type ref) *wild-type*) - (change-ref-leaf ref (find-constant 't))) - (t - (derive-node-type ref (or (type-difference res not-res) - res))))))) - - (undefined-value)) - - -;;; USE-RESULT-CONSTRAINTS -- Internal -;;; -;;; Deliver the results of constraint propagation to REFs in Block. During -;;; this pass, we also do local constraint propagation by adding in constraints -;;; as we seem them during the pass through the block. -;;; -(defun use-result-constraints (block) - (declare (type cblock block)) - (let ((in (block-in block))) - - (let ((test (block-test-constraint block))) - (when test - (sset-union in test))) - - (do-nodes (node cont block) - (typecase node - (ref - (let ((var (ref-leaf node))) - (when (lambda-var-p var) - (let ((con (lambda-var-constraints var))) - (when con - (constrain-ref-type node con in) - (when (continuation-type-check cont) - (sset-adjoin - (find-constraint 'typep var - (continuation-asserted-type cont) - nil) - in))))))) - (cset - (let ((var (set-var node))) - (when (lambda-var-p var) - (let ((cons (lambda-var-constraints var))) - (when cons - (sset-difference in cons)))))))))) - - -;;; CLOSURE-VAR-P -- Internal -;;; -;;; Return true if Var would have to be closed over if environment analysis -;;; ran now (i.e. if there are any uses that have a different home lambda than -;;; the var's home.) -;;; -(defun closure-var-p (var) - (declare (type lambda-var var)) - (let ((home (lambda-home (lambda-var-home var)))) - (flet ((frob (l) - (dolist (node l nil) - (unless (eq (node-home-lambda node) home) - (return t))))) - (or (frob (leaf-refs var)) - (frob (basic-var-sets var)))))) - - -;;; INIT-VAR-CONSTRAINTS -- Internal -;;; -;;; Give an empty constraints set to any var that doesn't have one and isn't -;;; a set closure var. Since a var that we previously rejected looks identical -;;; to one that is new, so we optimistically keep hoping that vars stop being -;;; closed over or lose their sets. -;;; -(defun init-var-constraints (component) - (declare (type component component)) - (dolist (fun (component-lambdas component)) - (flet ((frob (x) - (dolist (var (lambda-vars x)) - (unless (lambda-var-constraints var) - (when (or (null (lambda-var-sets var)) - (not (closure-var-p var))) - (setf (lambda-var-constraints var) (make-sset))))))) - (frob fun) - (dolist (let (lambda-lets fun)) - (frob let))))) - - -;;; FLOW-PROPAGATE-CONSTRAINTS -- Internal -;;; -;;; BLOCK-IN becomes the intersection of the OUT of the prececessors. Our -;;; OUT is: -;;; out U (in - kill) -;;; -;;; BLOCK-KILL is just a list of the lambda-vars killed, so we must compute -;;; the kill set when there are any vars killed. We bum this a bit by -;;; special-casing when only one var is killed, and just using that var's -;;; constraints as the kill set. This set could possibly be precomputed, but -;;; it would have to be invalidated whenever any constraint is added, which -;;; would be a pain. -;;; -(defun flow-propagate-constraints (block) - (let* ((pred (block-pred block)) - (in (cond (pred - (let ((res (copy-sset (block-out (first pred))))) - (dolist (b (rest pred)) - (sset-intersection res (block-out b))) - res)) - (t - (when *check-consistency* - (let ((*compiler-error-context* (block-last block))) - (compiler-warning - "*** Unreachable code in constraint ~ - propagation... Bug?"))) - (make-sset)))) - (kill (block-kill block)) - (out (block-out block))) - - (setf (block-in block) in) - (cond ((null kill) - (sset-union (block-out block) in)) - ((null (rest kill)) - (let ((con (lambda-var-constraints (first kill)))) - (if con - (sset-union-of-difference out in con) - (sset-union out in)))) - (t - (let ((kill-set (make-sset))) - (dolist (var kill) - (let ((con (lambda-var-constraints var))) - (when con - (sset-union kill-set con)))) - (sset-union-of-difference (block-out block) in kill-set)))))) - - -;;; CONSTRAINT-PROPAGATE -- Interface -;;; -(defun constraint-propagate (component) - (declare (type component component)) - (init-var-constraints component) - - (do-blocks (block component) - (when (block-test-modified block) - (find-test-constraints block))) - - (do-blocks (block component) - (cond ((block-type-asserted block) - (find-block-type-constraints block)) - (t - (setf (block-in block) nil) - (setf (block-out block) (copy-sset (block-gen block)))))) - - (setf (block-out (component-head component)) (make-sset)) - - (let ((did-something nil)) - (loop - (do-blocks (block component) - (when (flow-propagate-constraints block) - (setq did-something t))) - - (unless did-something (return)) - (setq did-something nil))) - - (do-blocks (block component) - (use-result-constraints block)) - - (undefined-value)) diff --git a/compiler/control.lisp b/compiler/control.lisp deleted file mode 100644 index e6023f15fcff5f6c7099762a8ceb3fa6a806ebf8..0000000000000000000000000000000000000000 --- a/compiler/control.lisp +++ /dev/null @@ -1,228 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/control.lisp,v 1.11 1992/04/21 04:16:55 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; The control analysis pass in the compiler. This pass determines the -;;; order in which the IR2 blocks are to be emitted, attempting to minimize the -;;; associated branching costs. -;;; -;;; At this point, we commit to generating IR2 (and ultimately assembler) -;;; for reachable blocks. Before this phase there might be blocks that are -;;; unreachable but still appear in the DFO, due in inadequate optimization, -;;; etc. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; Add-To-Emit-Order -- Interface -;;; -;;; Insert Block in the emission order after the block After. -;;; -(defun add-to-emit-order (block after) - (declare (type block-annotation block after)) - (let ((next (block-annotation-next after))) - (setf (block-annotation-next after) block) - (setf (block-annotation-prev block) after) - (setf (block-annotation-next block) next) - (setf (block-annotation-prev next) block)) - (undefined-value)) - - -;;; FIND-ROTATED-LOOP-HEAD -- Internal -;;; -;;; If Block looks like the head of a loop, then attempt to rotate it. A -;;; block looks like a loop head if the number of some predecessor is less than -;;; the block's number. Since blocks are numbered in reverse DFN, this will -;;; identify loop heads in a reducible flow graph. -;;; -;;; When we find a suspected loop head, we scan back from the tail to find -;;; an alternate loop head. This substitution preserves the correctness of the -;;; walk, since the old head can be reached from the new head. We determine -;;; the new head by scanning as far back as we can find increasing block -;;; numbers. Beats me if this is in general optimal, but it works in simple -;;; cases. -;;; -;;; This optimization is inhibited in functions with NLX EPs, since it is hard -;;; to do this without possibly messing up the special-case walking from NLX -;;; EPs described in CONTROL-ANALYZE-1-FUN. We also suppress rotation of loop -;;; heads which are the start of a function (i.e. tail calls), as the debugger -;;; wants functions to start at the start. -;;; -(defun find-rotated-loop-head (block) - (declare (type cblock block)) - (let* ((num (block-number block)) - (env (block-environment block)) - (pred (dolist (pred (block-pred block) nil) - (when (and (not (block-flag pred)) - (eq (block-environment pred) env) - (< (block-number pred) num)) - (return pred))))) - (cond - ((and pred - (not (environment-nlx-info env)) - (not (eq (node-block (lambda-bind (block-home-lambda block))) - block))) - (let ((current pred) - (current-num (block-number pred))) - (block DONE - (loop - (dolist (pred (block-pred current) (return-from DONE)) - (when (eq pred block) - (return-from DONE)) - (when (and (not (block-flag pred)) - (eq (block-environment pred) env) - (> (block-number pred) current-num)) - (setq current pred current-num (block-number pred)) - (return))))) - (assert (not (block-flag current))) - current)) - (t - block)))) - - -;;; Control-Analyze-Block -- Internal -;;; -;;; Do a graph walk linking blocks into the emit order as we go. We call -;;; FIND-ROTATED-LOOP-HEAD to do while-loop optimization. -;;; -;;; We treat blocks ending in tail local calls to other environments -;;; specially. We can't walked the called function immediately, since it is in -;;; a different function and we must keep the code for a function contiguous. -;;; Instead, we return the function that we want to call so that it can be -;;; walked as soon as possible, which is hopefully immediately. -;;; -;;; If any of the recursive calls ends in a tail local call, then we return -;;; the last such function, since it is the only one we can possibly drop -;;; through to. (But it doesn't have to be from the last block walked, since -;;; that call might not have added anything.) -;;; -;;; We defer walking successors whose successor is the component tail (end -;;; in an error, NLX or tail full call.) This is to discourage making error -;;; code the drop-through. -;;; -(defun control-analyze-block (block tail block-info-constructor) - (declare (type cblock block) (type block-annotation tail)) - (unless (block-flag block) - (let ((block (find-rotated-loop-head block))) - (setf (block-flag block) t) - (assert (and (block-component block) (not (block-delete-p block)))) - (add-to-emit-order (or (block-info block) - (setf (block-info block) - (funcall block-info-constructor block))) - (block-annotation-prev tail)) - - (let ((last (block-last block))) - (cond ((and (combination-p last) (node-tail-p last) - (eq (basic-combination-kind last) :local) - (not (eq (node-environment last) - (lambda-environment (combination-lambda last))))) - (combination-lambda last)) - (t - (let ((component-tail (component-tail (block-component block))) - (block-succ (block-succ block)) - (fun nil)) - (dolist (succ block-succ) - (unless (eq (first (block-succ succ)) component-tail) - (let ((res (control-analyze-block - succ tail block-info-constructor))) - (when res (setq fun res))))) - (dolist (succ block-succ) - (control-analyze-block succ tail block-info-constructor)) - fun))))))) - - -;;; CONTROL-ANALYZE-1-FUN -- Internal -;;; -;;; Analyze all of the NLX EPs first to ensure that code reachable only from -;;; a NLX is emitted contiguously with the code reachable from the Bind. Code -;;; reachable from the Bind is inserted *before* the NLX code so that the Bind -;;; marks the beginning of the code for the function. If the walks from NLX -;;; EPs reach the bind block, then we just move it to the beginning. -;;; -;;; If the walk from the bind node encountered a tail local call, then we -;;; start over again there to help the call drop through. Of course, it will -;;; never get a drop-through if either function has NLX code. -;;; -(defun control-analyze-1-fun (fun component block-info-constructor) - (declare (type clambda fun) (type component component)) - (let* ((tail-block (block-info (component-tail component))) - (prev-block (block-annotation-prev tail-block)) - (bind-block (node-block (lambda-bind fun)))) - (unless (block-flag bind-block) - (dolist (nlx (environment-nlx-info (lambda-environment fun))) - (control-analyze-block (nlx-info-target nlx) tail-block - block-info-constructor)) - (cond - ((block-flag bind-block) - (let* ((block-note (block-info bind-block)) - (prev (block-annotation-prev block-note)) - (next (block-annotation-next block-note))) - (setf (block-annotation-prev next) prev) - (setf (block-annotation-next prev) next) - (add-to-emit-order block-note prev-block))) - (t - (let ((new-fun (control-analyze-block bind-block - (block-annotation-next - prev-block) - block-info-constructor))) - (when new-fun - (control-analyze-1-fun new-fun component - block-info-constructor))))))) - (undefined-value)) - - -;;; Control-Analyze -- Interface -;;; -;;; Do control analysis on Component, finding the emit order. Our only -;;; cleverness here is that we walk XEP's first to increase the probability -;;; that the tail call will be a drop-through. -;;; -;;; When we are done, we delete blocks that weren't reached by the walk. -;;; Some return blocks are made unreachable by LTN without setting -;;; COMPONENT-REANALYZE. We remove all deleted blocks from the IR2-COMPONENT -;;; VALUES-RECEIVERS to keep stack analysis from getting confused. -;;; -(defun control-analyze (component block-info-constructor) - (declare (type component component) - (type function block-info-constructor)) - (let* ((head (component-head component)) - (head-block (funcall block-info-constructor head)) - (tail (component-tail component)) - (tail-block (funcall block-info-constructor tail))) - (setf (block-info head) head-block) - (setf (block-info tail) tail-block) - (setf (block-annotation-prev tail-block) head-block) - (setf (block-annotation-next head-block) tail-block) - - (clear-flags component) - - (dolist (fun (component-lambdas component)) - (when (external-entry-point-p fun) - (control-analyze-1-fun fun component block-info-constructor))) - - (dolist (fun (component-lambdas component)) - (control-analyze-1-fun fun component block-info-constructor)) - - (do-blocks (block component) - (unless (block-flag block) - (delete-block block)))) - - (let ((2comp (component-info component))) - (when (ir2-component-p 2comp) - ;; If it's not an ir2-component, don't worry about it. - (setf (ir2-component-values-receivers 2comp) - (delete-if-not #'block-component - (ir2-component-values-receivers 2comp))))) - - (undefined-value)) diff --git a/compiler/copyprop.lisp b/compiler/copyprop.lisp deleted file mode 100644 index fa7d2705540ae5105766e8a40f1426a858f793e7..0000000000000000000000000000000000000000 --- a/compiler/copyprop.lisp +++ /dev/null @@ -1,269 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/copyprop.lisp,v 1.6 1991/02/20 14:56:55 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file implements the copy propagation phase of the compiler, -;;; which uses global flow analysis to eliminate unnecessary copying of -;;; variables. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;; In copy propagation, we manipulate sets of TNs. We only consider TNs whose -;;; sole write is by a MOVE VOP. This allows us to use a degenerate version of -;;; reaching definitions: since each such TN has only one definition, the TN -;;; can stand for the definition. We can get away with this simplification, -;;; since the TNs that would be subject to copy propagation are nearly always -;;; single-writer (mostly temps allocated to ensure evaluation order is -;;; perserved). Only TNs written by MOVEs are interesting, since all we do -;;; with this information is delete spurious MOVEs. -;;; -;;; There are additional semantic constraints on whether a TN can be considered -;;; to be a copy. See TN-IS-A-COPY-OF. -;;; -;;; If a TN is in the IN set for a block, that TN is a copy of a TN which still -;;; has the same value it had at the time the move was done. Any reference -;;; to a TN in the IN set can be replaced with a reference to the TN moved -;;; from. When we delete all reads of such a TN, we can delete the MOVE VOP. -;;; IN is computed as the intersection of OUT for all the predecessor blocks. -;;; -;;; In this flow analysis scheme, the KILL set is the set of all interesting -;;; TNs where the copied TN is modified by the block (in any way.) -;;; -;;; GEN is the set of all interesting TNs that are copied in the block (whose -;;; write appears in the block.) -;;; -;;; OUT is (union (difference IN KILL) GEN) -;;; - - -;;; TN-IS-COPY-OF -- Internal -;;; -;;; If TN is subject to copy propagation, then return the TN it is a copy -;;; of, otherwise NIL. -;;; -;;; We also only consider TNs where neither the TN nor the copied TN are wired -;;; or restricted. If we extended the life of a wired or restricted TN, -;;; register allocation might fail, and we can't substitute arbitrary things -;;; for references to wired or restricted TNs, since the reader may be -;;; expencting the argument to be in a particular place (as in a passing -;;; location.) -;;; -;;; The TN must be a :NORMAL TN. Other TNs might have hidden references or be -;;; otherwise bizzare. -;;; -;;; A TN is also inelegible if it has interned name, policy is such that we -;;; would dump it in the debug vars, and speed is not 3. -;;; -;;; The SCs of the TN's primitive types is a subset of the SCs of the copied -;;; TN. Moves between TNs of different primitive type SCs may need to be -;;; changed into coercions, so we can't squeeze them out. The reason for -;;; testing for subset of the SCs instead of the same primitive type is -;;; that this test lets T be substituted for LIST, POSITIVE-FIXNUM for FIXNUM, -;;; etc. Note that more SCs implies fewer possible values, or a subtype -;;; relationship, since more SCs implies more possible representations. -;;; -(defun tn-is-copy-of (tn) - (declare (type tn tn) (inline subsetp)) - (let ((writes (tn-writes tn))) - (and (eq (tn-kind tn) :normal) - (not (tn-sc tn)) ; Not wired or restricted. - (and writes (null (tn-ref-next writes))) - (let ((vop (tn-ref-vop writes))) - (and (eq (vop-info-name (vop-info vop)) 'move) - (let ((arg-tn (tn-ref-tn (vop-args vop)))) - (and (or (not (tn-sc arg-tn)) - (eq (tn-kind arg-tn) :constant)) - (subsetp (primitive-type-scs - (tn-primitive-type tn)) - (primitive-type-scs - (tn-primitive-type arg-tn))) - (let ((leaf (tn-leaf tn))) - (or (not leaf) - (not (symbol-package (leaf-name leaf))) - (policy (vop-node vop) - (or (= speed 3) (< debug 2))))) - arg-tn))))))) - - -;;; INIT-COPY-SETS -- Internal -;;; -;;; Init the sets in Block for copy propagation. To find Gen, we just look -;;; for MOVE vops, and then see if the result is a eligible copy TN. To find -;;; Kill, we must look at all VOP results, seeing if any of the reads of the -;;; written TN are copies for eligible TNs. -;;; -(defun init-copy-sets (block) - (declare (type cblock block)) - (let ((kill (make-sset)) - (gen (make-sset))) - (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop))) - ((null vop)) - (unless (and (eq (vop-info-name (vop-info vop)) 'move) - (let ((y (tn-ref-tn (vop-results vop)))) - (when (tn-is-copy-of y) - (sset-adjoin y gen) - t))) - (do ((res (vop-results vop) (tn-ref-across res))) - ((null res)) - (let ((res-tn (tn-ref-tn res))) - (do ((read (tn-reads res-tn) (tn-ref-next read))) - ((null read)) - (let ((read-vop (tn-ref-vop read))) - (when (eq (vop-info-name (vop-info read-vop)) 'move) - (let ((y (tn-ref-tn (vop-results read-vop)))) - (when (tn-is-copy-of y) - (sset-delete y gen) - (sset-adjoin y kill)))))))))) - - (setf (block-out block) (copy-sset gen)) - (setf (block-kill block) kill) - (setf (block-gen block) gen)) - (undefined-value)) - - -;;; COPY-FLOW-ANALYSIS -- Internal -;;; -;;; Do the flow analysis step for copy propagation on Block. We rely on OUT -;;; being initilized to GEN, and use SSET-UNION-OF-DIFFERENCE to incrementally -;;; build the union in OUT, rather than replacing OUT each time. -;;; -(defun copy-flow-analysis (block) - (declare (type cblock block)) - (let* ((pred (block-pred block)) - (in (copy-sset (block-out (first pred))))) - (dolist (pred-block (rest pred)) - (sset-intersection in (block-out pred-block))) - (setf (block-in block) in) - (sset-union-of-difference (block-out block) in (block-kill block)))) - - -(defevent copy-deleted-move "Copy propagation deleted a move.") - -;;; OK-COPY-REF -- Internal -;;; -;;; Return true if Arg is a reference to a TN that we can copy propagate to. -;;; In addition to dealing with copy chains (as discussed below), we also throw -;;; out references that are arguments to a local call, since IR2tran introduces -;;; tempes in that context to preserve parallel assignment semantics. -;;; -(defun ok-copy-ref (vop arg in original-copy-of) - (declare (type vop vop) (type tn arg) (type sset in) - (type hash-table original-copy-of)) - (and (sset-member arg in) - (do ((original (gethash arg original-copy-of) - (gethash original original-copy-of))) - ((not original) t) - (unless (sset-member original in) - (return nil))) - (let ((info (vop-info vop))) - (not (and (eq (vop-info-move-args info) :local-call) - (>= (or (position-in #'tn-ref-across arg (vop-args vop) - :key #'tn-ref-tn) - (error "Couldn't find REF?")) - (length (template-arg-types info)))))))) - - -;;; PROPAGATE-COPIES -- Internal -;;; -;;; Make use of the result of flow analysis to eliminate copies. We scan -;;; the VOPs in block, propagating copies and keeping our IN set in sync. -;;; -;;; Original-Copy-Of is an EQ hash table that we use to keep track of -;;; renamings when there are copy chains, i.e. copies of copies. When we see -;;; copy of a copy, we enter the first copy in the table with the second copy -;;; as a key. When we see a reference to a TN in a copy chain, we can only -;;; substitute the first copied TN for the reference when all intervening -;;; copies in the copy chain are also avaliable. Otherwise, we just leave the -;;; reference alone. It is possible that we might have been able to reference -;;; one of the intermediate copies instead, but that copy might have already -;;; been deleted, since we delete the move immediately when the references go -;;; to zero. -;;; -;;; To understand why we always can to the substitution when the copy chain -;;; recorded in the Original-Copy-Of table hits NIL, note that we make an entry -;;; in the table iff we change the arg of a copy. If an entry is not in the -;;; table, it must be that we hit a move which *originally* referenced our -;;; Copy-Of TN. If all the intervening copies reach our reference, then -;;; Copy-Of must reach the reference. -;;; -;;; Note that due to our restricting copies to single-writer TNs, it will -;;; always be the case that when the first copy in a chain reaches the -;;; reference, all intervening copies reach also reach the reference. We -;;; don't exploit this, since we have to work backward from the last copy. -;;; -;;; In this discussion, we are really only playing with the tail of the true -;;; copy chain for which all of the copies have already had PROPAGATE-COPIES -;;; done on them. But, because we do this pass in DFO, it is virtually always -;;; the case that we will process earlier copies before later ones. In -;;; perverse cases (non-reducible flow graphs), we just miss some optimization -;;; opportinities. -;;; -(defun propagate-copies (block original-copy-of) - (declare (type cblock block) (type hash-table original-copy-of)) - (let ((in (block-in block))) - (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop))) - ((null vop)) - (let ((this-copy (and (eq (vop-info-name (vop-info vop)) 'move) - (let ((y (tn-ref-tn (vop-results vop)))) - (when (tn-is-copy-of y) y))))) - ;; - ;; Substitute copied TN for copy when we find a reference to a copy. - ;; If the copy is left with no reads, delete the move to the copy. - (do ((arg-ref (vop-args vop) (tn-ref-across arg-ref))) - ((null arg-ref)) - (let* ((arg (tn-ref-tn arg-ref)) - (copy-of (tn-is-copy-of arg))) - (when (and copy-of (ok-copy-ref vop arg in original-copy-of)) - (when this-copy - (setf (gethash this-copy original-copy-of) arg)) - (change-tn-ref-tn arg-ref copy-of) - (when (null (tn-reads arg)) - (event copy-deleted-move) - (delete-vop (tn-ref-vop (tn-writes arg))))))) - ;; - ;; Kill any elements in IN that are copies of a TN we are clobbering. - (do ((res-ref (vop-results vop) (tn-ref-across res-ref))) - ((null res-ref)) - (do-elements (tn in) - (when (eq (tn-is-copy-of tn) (tn-ref-tn res-ref)) - (sset-delete tn in)))) - ;; - ;; If this VOP is a copy, add the copy TN to IN. - (when this-copy (sset-adjoin this-copy in))))) - - (undefined-value)) - - -;;; COPY-PROPAGATE -- Interface -;;; -;;; Do copy propgation on Component by initilizing the flow analysis sets, -;;; doing flow analysis, and then propagating copies using the results. -;;; -(defun copy-propagate (component) - (setf (block-out (component-head component)) (make-sset)) - (do-blocks (block component) - (init-copy-sets block)) - - (loop - (let ((did-something nil)) - (do-blocks (block component) - (when (copy-flow-analysis block) - (setq did-something t))) - (unless did-something (return)))) - - (let ((original-copies (make-hash-table :test #'eq))) - (do-blocks (block component) - (propagate-copies block original-copies))) - - (undefined-value)) diff --git a/compiler/ctype.lisp b/compiler/ctype.lisp deleted file mode 100644 index 31d94e24eb53d555aed07ad4ce7c94cabd81306d..0000000000000000000000000000000000000000 --- a/compiler/ctype.lisp +++ /dev/null @@ -1,782 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/ctype.lisp,v 1.25 1991/12/11 23:49:53 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains code which knows about both the type representation -;;; and the compiler IR1 representation. This stuff is used for doing type -;;; checking. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;; These are the functions that are to be called when a problem is detected. -;;; They are passed format arguments. If null, we don't do anything. The -;;; error function is called when something is definitely incorrect. The -;;; warning function is called when it is somehow impossible to tell if the -;;; call is correct. -;;; -(defvar *error-function*) -(defvar *warning-function*) - -;;; The function that we use for type checking. The derived type is the first -;;; argument and the type we are testing against is the second argument. The -;;; function should return values like Csubtypep. -;;; -(defvar *test-function*) - -(proclaim '(type (or function null) *error-function* *warning-function - *test-function*)) - -;;; *lossage-detected* is set if a definite incompatibility is detected. -;;; *slime-detected* is set if we can't tell whether the call is compatible or -;;; not. -;;; -(defvar *lossage-detected*) -(defvar *slime-detected*) - - -;;; Note-Lossage, Note-Slime -- Internal -;;; -;;; Signal a warning if appropriate and set the *lossage-detected* flag. -;;; -(proclaim '(ftype (function (string &rest t) void) note-lossage note-slime)) -(defun note-lossage (format-string &rest format-args) - (setq *lossage-detected* t) - (when *error-function* - (apply *error-function* format-string format-args))) -;;; -(defun note-slime (format-string &rest format-args) - (setq *slime-detected* t) - (when *warning-function* - (apply *warning-function* format-string format-args))) - - -(proclaim '(special *compiler-error-context*)) - - -;;;; Stuff for checking a call against a function type. - -;;; ALWAYS-SUBTYPEP -- Interface -;;; -;;; A dummy version of SUBTYPEP useful when we want a functional like -;;; subtypep that always returns true. -;;; -(defun always-subtypep (type1 type2) - (declare (ignore type1 type2)) - (values t t)) - - -;;; Valid-Function-Use -- Interface -;;; -;;; Determine whether a use of a function is consistent with its type. -;;; These values are returned: -;;; T, T: the call is definitely valid. -;;; NIL, T: the call is definitely invalid. -;;; NIL, NIL: unable to determine if the call is valid. -;;; -;;; The Argument-Test function is used to determine whether an argument type -;;; matches the type we are checking against. Similarly, the Result-Test is -;;; used to determine whether the result type matches the specified result. -;;; -;;; Unlike the argument test, the result test may be called on values or -;;; function types. If Strict-Result is true and safety is non-zero, then the -;;; Node-Derived-Type is always used. Otherwise, if Cont's Type-Check is true, -;;; then the Node-Derived-Type is intersected with the Cont's Asserted-Type. -;;; -;;; The error and warning functions are functions that are called to explain -;;; the result. We bind *compiler-error-context* to the combination node so -;;; that Compiler-Warning and related functions will do the right thing if -;;; they are supplied. -;;; -(defun valid-function-use (call type &key - ((:argument-test *test-function*) #'csubtypep) - (result-test #'values-subtypep) - (strict-result nil) - ((:error-function *error-function*)) - ((:warning-function *warning-function*))) - (declare (type function result-test) (type combination call) - (type function-type type)) - (let* ((*lossage-detected* nil) - (*slime-detected* nil) - (*compiler-error-context* call) - (args (combination-args call)) - (nargs (length args)) - (required (function-type-required type)) - (min-args (length required)) - (optional (function-type-optional type)) - (max-args (+ min-args (length optional))) - (rest (function-type-rest type)) - (keyp (function-type-keyp type))) - - (cond - ((function-type-wild-args type) - (do ((i 1 (1+ i)) - (arg args (cdr arg))) - ((null arg)) - (check-arg-type (car arg) *wild-type* i))) - ((not (or optional keyp rest)) - (if (/= nargs min-args) - (note-lossage - "Function called with ~R argument~:P, but wants exactly ~R." - nargs min-args) - (check-fixed-and-rest args required nil))) - ((< nargs min-args) - (note-lossage - "Function called with ~R argument~:P, but wants at least ~R." - nargs min-args)) - ((<= nargs max-args) - (check-fixed-and-rest args (append required optional) rest)) - ((not (or keyp rest)) - (note-lossage - "Function called with ~R argument~:P, but wants at most ~R." - nargs max-args)) - ((and keyp (oddp (- nargs max-args))) - (note-lossage - "Function has an odd number of arguments in the keyword portion.")) - (t - (check-fixed-and-rest args (append required optional) rest) - (when keyp - (check-keywords args max-args type)))) - - (let* ((dtype (node-derived-type call)) - (return-type (function-type-returns type)) - (cont (node-cont call)) - (out-type - (if (or (not (continuation-type-check cont)) - (and strict-result (policy call (/= safety 0)))) - dtype - (values-type-intersection (continuation-asserted-type cont) - dtype)))) - (multiple-value-bind (int win) - (funcall result-test out-type return-type) - (cond ((not win) - (note-slime "Can't tell whether the result is a ~S." - (type-specifier return-type))) - ((not int) - (note-lossage "The result is a ~S, not a ~S." - (type-specifier out-type) - (type-specifier return-type)))))) - - (cond (*lossage-detected* (values nil t)) - (*slime-detected* (values nil nil)) - (t (values t t))))) - - -;;; Check-Arg-Type -- Internal -;;; -;;; Check that the derived type of the continuation Cont is compatible with -;;; Type. N is the arg number, for error message purposes. We return true if -;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then we check -;;; for the argument being a constant value of the specified type. If there is -;;; a manfest type error (DERIVED-TYPE = NIL), then we flame about the asserted -;;; type even when our type is satisfied under the test. -;;; -(defun check-arg-type (cont type n) - (declare (type continuation cont) (type ctype type) (type index n)) - (cond - ((not (constant-type-p type)) - (let ((ctype (continuation-type cont))) - (multiple-value-bind (int win) - (funcall *test-function* ctype type) - (cond ((not win) - (note-slime "Can't tell whether the ~:R argument is a ~S." n - (type-specifier type)) - nil) - ((not int) - (note-lossage "The ~:R argument is a ~S, not a ~S." n - (type-specifier ctype) - (type-specifier type)) - nil) - ((eq ctype *empty-type*) - (note-slime "The ~:R argument never returns a value." n) - nil) - (t t))))) - ((not (constant-continuation-p cont)) - (note-slime "The ~:R argument is not a constant." n) - nil) - (t - (let ((val (continuation-value cont)) - (type (constant-type-type type))) - (multiple-value-bind (res win) - (ctypep val type) - (cond ((not win) - (note-slime "Can't tell whether the ~:R argument is a ~ - constant ~S:~% ~S" - n (type-specifier type) val) - nil) - ((not res) - (note-lossage "The ~:R argument is not a constant ~S:~% ~S" - n (type-specifier type) val) - nil) - (t t))))))) - - -;;; Check-Fixed-And-Rest -- Internal -;;; -;;; Check that each of the type of each supplied argument intersects with -;;; the type specified for that argument. If we can't tell, then we complain -;;; about the slime. -;;; -(proclaim '(function check-fixed-and-rest (list list (or ctype null)) void)) -(defun check-fixed-and-rest (args types rest) - (do ((arg args (cdr arg)) - (type types (cdr type)) - (n 1 (1+ n))) - ((or (null type) (null arg)) - (when rest - (dolist (arg arg) - (check-arg-type arg rest n) - (incf n)))) - (declare (fixnum n)) - (check-arg-type (car arg) (car type) n))) - - -;;; Check-Keywords -- Internal -;;; -;;; Check that the keyword args are of the correct type. Each keyword -;;; should be known and the corresponding argument should be of the correct -;;; type. If the keyword isn't a constant, then we can't tell, so we note -;;; slime. -;;; -(proclaim '(function check-keywords (list fixnum function-type) void)) -(defun check-keywords (args pre-key type) - (do ((key (nthcdr pre-key args) (cddr key)) - (n (1+ pre-key) (+ n 2))) - ((null key)) - (declare (fixnum n)) - (let ((k (car key))) - (cond - ((not (check-arg-type k (specifier-type 'symbol) n))) - ((not (constant-continuation-p k)) - (note-slime "The ~:R argument (in keyword position) is not a constant." - n)) - (t - (let* ((name (continuation-value k)) - (info (find name (function-type-keywords type) - :key #'key-info-name))) - (cond ((not info) - (unless (function-type-allowp type) - (note-lossage "~S is not a known argument keyword." - name))) - (t - (check-arg-type (second key) (key-info-type info) - (1+ n)))))))))) - - -;;; Definition-Type -- Interface -;;; -;;; Construct a function type from a definition. -;;; -;;; Due to the lack of a (list x) type specifier, we can't reconstruct the -;;; &rest type. -;;; -(proclaim '(function definition-type (functional) function-type)) -(defun definition-type (functional) - (if (lambda-p functional) - (make-function-type - :required (mapcar #'leaf-type (lambda-vars functional)) - :returns (tail-set-type (lambda-tail-set functional))) - (let ((rest nil)) - (collect ((req) - (opt) - (keys)) - (dolist (arg (optional-dispatch-arglist functional)) - (let ((info (lambda-var-arg-info arg)) - (type (leaf-type arg))) - (if info - (ecase (arg-info-kind info) - (:required (req type)) - (:optional (opt type)) - (:keyword - (keys (make-key-info :name (arg-info-keyword info) - :type type))) - (:rest - (setq rest *universal-type*))) - (req type)))) - - (make-function-type - :required (req) :optional (opt) :rest rest :keywords (keys) - :keyp (optional-dispatch-keyp functional) - :allowp (optional-dispatch-allowp functional) - :returns (tail-set-type - (lambda-tail-set - (optional-dispatch-main-entry functional)))))))) - - - -;;;; Approximate function types: -;;; -;;; Approximate function types provide a condensed representation of all the -;;; different ways that a function has been used. If we have no declared or -;;; defined type for a function, then we build an approximate function type -;;; by examining each use of the function. When we encounter a definition or -;;; proclamation, we can check the actual type for compatibity with the -;;; previous uses. - - -(defstruct (approximate-function-type) - ;; - ;; The smallest and largest numbers of arguments that this function has been - ;; called with. - (min-args call-arguments-limit :type fixnum) - (max-args 0 :type fixnum) - ;; - ;; A list of lists of the all the types that have been used in each argument - ;; position. - (types () :type list) - ;; - ;; A list of the Approximate-Key-Info structures describing all the things - ;; that looked like keyword arguments. There are distinct structures - ;; describing each argument position in which the keyword appeared. - (keys () :type list)) - - -(defstruct (approximate-key-info) - ;; - ;; The keyword name of this argument. Although keyword names don't have to - ;; be keywords, we only match on keywords when figuring an approximate type. - (name (required-argument) :type keyword) - ;; - ;; The position at which this keyword appeared. 0 if it appeared as the - ;; first argument, etc. - (position (required-argument) :type fixnum) - ;; - ;; A list of all the argument types that have been used with this keyword. - (types nil :type list) - ;; - ;; True if this keyword has appeared only in calls with an obvious - ;; :allow-other-keys. - (allowp nil :type (member t nil))) - - -;;; Note-Function-Use -- Interface -;;; -;;; Return an Approximate-Function-Type representing the context of Call. -;;; If Type is supplied and not null, then we merge the information into the -;;; information already accumulated in Type. -;;; -(proclaim '(function note-function-use - (combination &optional (or approximate-function-type null)) - approximate-function-type)) -(defun note-function-use (call &optional type) - (let* ((type (or type (make-approximate-function-type))) - (types (approximate-function-type-types type)) - (args (combination-args call)) - (nargs (length args)) - (allowp (some #'(lambda (x) - (and (constant-continuation-p x) - (eq (continuation-value x) :allow-other-keys))) - args))) - - (setf (approximate-function-type-min-args type) - (min (approximate-function-type-min-args type) nargs)) - (setf (approximate-function-type-max-args type) - (max (approximate-function-type-max-args type) nargs)) - - (do ((old types (cdr old)) - (arg args (cdr arg))) - ((null old) - (setf (approximate-function-type-types type) - (nconc types - (mapcar #'(lambda (x) - (list (continuation-type x))) - arg)))) - (when (null arg) (return)) - (pushnew (continuation-type (car arg)) - (car old) - :test #'type=)) - - (collect ((keys (approximate-function-type-keys type) cons)) - (do ((arg args (cdr arg)) - (pos 0 (1+ pos))) - ((or (null arg) (null (cdr arg))) - (setf (approximate-function-type-keys type) (keys))) - (let ((key (first arg)) - (val (second arg))) - (when (constant-continuation-p key) - (let ((name (continuation-value key))) - (when (keywordp name) - (let ((old (find-if - #'(lambda (x) - (and (eq (approximate-key-info-name x) name) - (= (approximate-key-info-position x) - pos))) - (keys))) - (val-type (continuation-type val))) - (cond (old - (pushnew val-type - (approximate-key-info-types old) - :test #'type=) - (unless allowp - (setf (approximate-key-info-allowp old) nil))) - (t - (keys (make-approximate-key-info - :name name :position pos :allowp allowp - :types (list val-type)))))))))))) - type)) - - -;;; Valid-Approximate-Type -- Interface -;;; -;;; Similar to Valid-Function-Use, but checks an Approximate-Function-Type -;;; against a real function type. -;;; -(proclaim '(function valid-approximate-type - (approximate-function-type function-type &optional - function function function) - (values boolean boolean))) -(defun valid-approximate-type (call-type type &optional - (*test-function* #'types-intersect) - (*error-function* #'compiler-warning) - (*warning-function* #'compiler-note)) - (let* ((*lossage-detected* nil) - (*slime-detected* nil) - (required (function-type-required type)) - (min-args (length required)) - (optional (function-type-optional type)) - (max-args (+ min-args (length optional))) - (rest (function-type-rest type)) - (keyp (function-type-keyp type))) - - (when (function-type-wild-args type) - (return-from valid-approximate-type (values t t))) - - (let ((call-min (approximate-function-type-min-args call-type))) - (when (< call-min min-args) - (note-lossage - "Function previously called with ~R argument~:P, but wants at least ~R." - call-min min-args))) - - (let ((call-max (approximate-function-type-max-args call-type))) - (cond ((<= call-max max-args)) - ((not (or keyp rest)) - (note-lossage - "Function previously called with ~R argument~:P, but wants at most ~R." - call-max max-args)) - ((and keyp (oddp (- call-max max-args))) - (note-lossage - "Function previously called with an odd number of arguments in ~ - the keyword portion."))) - - (when (and keyp (> call-max max-args)) - (check-approximate-keywords call-type max-args type))) - - (check-approximate-fixed-and-rest call-type (append required optional) - rest) - - (cond (*lossage-detected* (values nil t)) - (*slime-detected* (values nil nil)) - (t (values t t))))) - - -;;; Check-Approximate-Fixed-And-Rest -- Internal -;;; -;;; Check that each of the types used at each arg position is compatible -;;; with the actual type. -;;; -(proclaim '(function check-approximate-fixed-and-rest - (approximate-function-type list (or ctype null)) - void)) -(defun check-approximate-fixed-and-rest (call-type fixed rest) - (do ((types (approximate-function-type-types call-type) (cdr types)) - (n 1 (1+ n)) - (arg fixed (cdr arg))) - ((null types)) - (let ((decl-type (or (car arg) rest))) - (unless decl-type (return)) - (check-approximate-arg-type (car types) decl-type "~:R" n)))) - - -;;; Check-Approximate-Arg-Type -- Internal -;;; -;;; Check that each of the call-types is compatible with Decl-Type, -;;; complaining if not or if we can't tell. -;;; -(proclaim '(function check-approximate-arg-type - (list ctype string &rest t) - void)) -(defun check-approximate-arg-type (call-types decl-type context &rest args) - (let ((losers *empty-type*)) - (dolist (ctype call-types) - (multiple-value-bind (int win) - (funcall *test-function* ctype decl-type) - (cond - ((not win) - (note-slime "Can't tell whether previous ~? argument type ~S is a ~S." - context args (type-specifier ctype) (type-specifier decl-type))) - ((not int) - (setq losers (type-union ctype losers)))))) - - (unless (eq losers *empty-type*) - (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call." - context args (type-specifier decl-type) (type-specifier losers))))) - - -;;; Check-Approximate-Keywords -- Internal -;;; -;;; Check the types of each manifest keyword that appears in a keyword -;;; argument position. Check the validity of all keys that appeared in valid -;;; keyword positions. -;;; -;;; ### We could check the Approximate-Function-Type-Types to make sure that -;;; all arguments in keyword positions were manifest keywords. -;;; -(defun check-approximate-keywords (call-type max-args type) - (let ((call-keys (approximate-function-type-keys call-type)) - (keys (function-type-keywords type))) - (dolist (key keys) - (let ((name (key-info-name key))) - (collect ((types nil append)) - (dolist (call-key call-keys) - (let ((pos (approximate-key-info-position call-key))) - (when (and (eq (approximate-key-info-name call-key) name) - (> pos max-args) (evenp (- pos max-args))) - (types (approximate-key-info-types call-key))))) - (check-approximate-arg-type (types) (key-info-type key) "~S" name)))) - - (unless (function-type-allowp type) - (collect ((names () adjoin)) - (dolist (call-key call-keys) - (let ((pos (approximate-key-info-position call-key))) - (when (and (> pos max-args) (evenp (- pos max-args)) - (not (approximate-key-info-allowp call-key))) - (names (approximate-key-info-name call-key))))) - - (dolist (name (names)) - (unless (find name keys :key #'key-info-name) - (note-lossage "Function previously called with unknown argument keyword ~S." - name))))))) - - -;;;; ASSERT-DEFINITION-TYPE - -;;; TRY-TYPE-INTERSECTIONS -- Internal -;;; -;;; Intersect Lambda's var types with Types, giving a warning if there is a -;;; mismatch. If all intersections are non-null, we return lists of the -;;; variables and intersections, otherwise we return NIL, NIL. -;;; -(defun try-type-intersections (vars types where) - (declare (list vars types) (string where)) - (collect ((res)) - (mapc #'(lambda (var type) - (let* ((vtype (leaf-type var)) - (int (type-intersection vtype type))) - (cond - ((eq int *empty-type*) - (note-lossage - "Definition's declared type for variable ~A:~% ~S~@ - conflicts with this type from ~A:~% ~S" - (leaf-name var) (type-specifier vtype) - where (type-specifier type)) - (return-from try-type-intersections (values nil nil))) - (t - (res int))))) - vars types) - (values vars (res)))) - - -;;; FIND-OPTIONAL-DISPATCH-TYPES -- Internal -;;; -;;; Check that the optional-dispatch OD conforms to Type. We return the -;;; values of TRY-TYPE-INTERSECTIONS if there are no syntax problems, otherwise -;;; NIL, NIL. -;;; -;;; Note that the variables in the returned list are the actual original -;;; variables (extracted from the optional dispatch arglist), rather than the -;;; variables that are arguments to the main entry. This difference is -;;; significant only for keyword args with hairy defaults. Returning the -;;; actual vars allows us to use the right variable name in warnings. -;;; -;;; A slightly subtle point: with keywords and optionals, the type in the -;;; function type is only an assertion on calls --- it doesn't constrain the -;;; type of default values. So we have to union in the type of the default. -;;; With optionals, we can't do any assertion unless the default is constant. -;;; -;;; With keywords, we exploit our knowledge about how hairy keyword -;;; defaulting is done when computing the type assertion to put on the -;;; main-entry argument. In the case of hairy keywords, the default has been -;;; clobbered with NIL, which is the value of the main-entry arg in the -;;; unsupplied case, whatever the actual default value is. So we can just -;;; assume the default is constant, effectively unioning in NULL, and not -;;; totally blow off doing any type assertion. -;;; -(defun find-optional-dispatch-types (od type where) - (declare (type optional-dispatch od) (type function-type type) - (string where)) - (let* ((min (optional-dispatch-min-args od)) - (req (function-type-required type)) - (opt (function-type-optional type))) - (flet ((frob (x y what) - (unless (= x y) - (note-lossage - "Definition has ~R ~A arg~P, but ~A has ~R." - x what x where y)))) - (frob min (length req) "fixed") - (frob (- (optional-dispatch-max-args od) min) (length opt) "optional")) - (flet ((frob (x y what) - (unless (eq x y) - (note-lossage - "Definition ~:[doesn't have~;has~] ~A, but ~ - ~A ~:[doesn't~;does~]." - x what where y)))) - (frob (optional-dispatch-keyp od) (function-type-keyp type) - "keyword args") - (unless (optional-dispatch-keyp od) - (frob (not (null (optional-dispatch-more-entry od))) - (not (null (function-type-rest type))) - "rest args")) - (frob (optional-dispatch-allowp od) (function-type-allowp type) - "&allow-other-keys")) - - (when *lossage-detected* - (return-from find-optional-dispatch-types (values nil nil))) - - (collect ((res) - (vars)) - (let ((keys (function-type-keywords type)) - (arglist (optional-dispatch-arglist od))) - (dolist (arg arglist) - (cond - ((lambda-var-arg-info arg) - (let* ((info (lambda-var-arg-info arg)) - (default (arg-info-default info)) - (def-type (when (constantp default) - (ctype-of (eval default))))) - (ecase (arg-info-kind info) - (:keyword - (let* ((key (arg-info-keyword info)) - (kinfo (find key keys :key #'key-info-name))) - (cond - (kinfo - (res (type-union (key-info-type kinfo) def-type))) - (t - (note-lossage - "Defining a ~S keyword not present in ~A." - key where) - (res *universal-type*))))) - (:required (res (pop req))) - (:optional - (res (type-union (pop opt) - (or def-type *universal-type*)))) - (:rest - (when (function-type-rest type) - (res (specifier-type 'list))))) - (vars arg) - (when (arg-info-supplied-p info) - (res *universal-type*) - (vars (arg-info-supplied-p info))))) - (t - (res (pop req)) - (vars arg)))) - - (dolist (key keys) - (unless (find (key-info-name key) arglist - :key #'(lambda (x) - (let ((info (lambda-var-arg-info x))) - (when info - (arg-info-keyword info))))) - (note-lossage - "Definition lacks the ~S keyword present in ~A." - (key-info-name key) where)))) - - (try-type-intersections (vars) (res) where)))) - - -;;; FIND-LAMBDA-TYPES -- Internal -;;; -;;; Check that Type doesn't specify any funny args, and do the intersection. -;;; -(defun find-lambda-types (lambda type where) - (declare (type clambda lambda) (type function-type type) (string where)) - (flet ((frob (x what) - (when x - (note-lossage - "Definition has no ~A, but the ~A did." - what where)))) - (frob (function-type-optional type) "optional args") - (frob (function-type-keyp type) "keyword args") - (frob (function-type-rest type) "rest arg")) - (let* ((vars (lambda-vars lambda)) - (nvars (length vars)) - (req (function-type-required type)) - (nreq (length req))) - (unless (= nvars nreq) - (note-lossage "Definition has ~R arg~:P, but the ~A has ~R." - nvars where nreq)) - (if *lossage-detected* - (values nil nil) - (try-type-intersections vars req where)))) - - -;;; ASSERT-DEFINITION-TYPE -- Interface -;;; -;;; Check for syntactic and type conformance between the definition -;;; Functional and the specified Function-Type. If they are compatible and -;;; Really-Assert is T, then add type assertions to the defintion from the -;;; Function-Type. -;;; -;;; If there is a syntactic or type problem, then we call Error-Function -;;; with an error message using Where as context describing where Function-Type -;;; came from. -;;; -;;; If there is no problem, we return T (even if Really-Assert was false). -;;; If there was a problem, we return NIL. -;;; -(defun assert-definition-type - (functional type &key (really-assert t) - ((:error-function *error-function*) #'compiler-warning) - warning-function - (where "previous declaration")) - (declare (type functional functional) (type function *error-function*) - (string where)) - (let ((*lossage-detected* nil)) - (multiple-value-bind - (vars types) - (if (function-type-wild-args type) - (values nil nil) - (etypecase functional - (optional-dispatch - (find-optional-dispatch-types functional type where)) - (clambda - (find-lambda-types functional type where)))) - (let* ((type-returns (function-type-returns type)) - (return (lambda-return (main-entry functional))) - (atype (when return - (continuation-asserted-type (return-result return))))) - (cond - ((and atype (not (values-types-intersect atype type-returns))) - (note-lossage - "The result type from ~A:~% ~S~@ - conflicts with the definition's result type assertion:~% ~S" - where (type-specifier type-returns) (type-specifier atype)) - nil) - (*lossage-detected* nil) - ((not really-assert) t) - (t - (when atype - (assert-continuation-type (return-result return) atype)) - (loop for var in vars and type in types do - (cond ((basic-var-sets var) - (when (and warning-function - (not (csubtypep (leaf-type var) type))) - (funcall warning-function - "Assignment to argument: ~S~% ~ - prevents use of assertion from function ~ - type ~A:~% ~S~%" - (leaf-name var) where (type-specifier type)))) - (t - (setf (leaf-type var) type) - (dolist (ref (leaf-refs var)) - (derive-node-type ref type))))) - t)))))) diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp deleted file mode 100644 index 3049a8d1bbf556945d309668acfc6f6e51d5f7af..0000000000000000000000000000000000000000 --- a/compiler/debug-dump.lisp +++ /dev/null @@ -1,774 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/debug-dump.lisp,v 1.31 1992/08/03 19:03:35 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains stuff that creates debugger information from the -;;; compiler's internal data structures. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package :c) - -(defvar *byte-buffer*) -(declaim (type (vector (unsigned-byte 8)) *byte-buffer*)) - - -;;;; Debug blocks: - -(deftype location-kind () - '(member :unknown-return :known-return :internal-error :non-local-exit - :block-start :call-site :single-value-return :non-local-entry)) - - -;;; The Location-Info structure holds the information what we need about -;;; locations which code generation decided were "interesting". -;;; -(defstruct (location-info - (:constructor make-location-info (kind label vop))) - ;; - ;; The kind of location noted. - (kind nil :type location-kind) - ;; - ;; The label pointing to the interesting code location. - (label nil :type (or label index null)) - ;; - ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.) - (vop nil :type vop)) - -;;; NOTE-DEBUG-LOCATION -- Interface -;;; -;;; Called during code generation in places where there is an "interesting" -;;; location: some place where we are likely to end up in the debugger, and -;;; thus want debug info. -;;; -(defun note-debug-location (vop label kind) - (declare (type vop vop) (type (or label null) label) - (type location-kind kind)) - (let ((location (make-location-info kind label vop))) - (setf (ir2-block-locations (vop-block vop)) - (nconc (ir2-block-locations (vop-block vop)) - (list location))) - location)) - - -;;; IR2-BLOCK-ENVIRONMENT -- Interface -;;; -(proclaim '(inline ir2-block-environment)) -(defun ir2-block-environment (2block) - (declare (type ir2-block 2block)) - (block-environment (ir2-block-block 2block))) - - -;;; COMPUTE-LIVE-VARS -- Internal -;;; -;;; Given a local conflicts vector and an IR2 block to represent the set of -;;; live TNs, and the Var-Locs hash-table representing the variables dumped, -;;; compute a bit-vector representing the set of live variables. If the TN is -;;; environment-live, we only mark it as live when it is in scope at Node. -;;; -(defun compute-live-vars (live node block var-locs vop) - (declare (type ir2-block block) (type local-tn-bit-vector live) - (type hash-table var-locs) (type node node) - (type (or vop null) vop)) - (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7) - :element-type 'bit - :initial-element 0)) - (spilled (gethash vop - (ir2-component-spilled-vops - (component-info *compile-component*))))) - (do-live-tns (tn live block) - (let ((leaf (tn-leaf tn))) - (when (and (lambda-var-p leaf) - (or (not (member (tn-kind tn) - '(:environment :debug-environment))) - (rassoc leaf (lexenv-variables (node-lexenv node)))) - (or (null spilled) - (not (member tn spilled)))) - (let ((num (gethash leaf var-locs))) - (when num - (setf (sbit res num) 1)))))) - res)) - - -;;; The PC for the location most recently dumped. -;;; -(defvar *previous-location*) -(proclaim '(type index *previous-location*)) - -;;; DUMP-1-LOCATION -- Internal -;;; -;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the -;;; code/source map and live info. If true, VOP is the VOP associated with -;;; this location, for use in determining whether TNs are spilled. -;;; -(defun dump-1-location (node block kind tlf-num label live var-locs vop) - (declare (type node node) (type ir2-block block) - (type local-tn-bit-vector live) - (type (or label index) label) - (type location-kind kind) (type (or index null) tlf-num) - (type hash-table var-locs) (type (or vop null) vop)) - - (vector-push-extend - (dpb (position kind compiled-code-location-kinds) - compiled-code-location-kind-byte - 0) - *byte-buffer*) - - (let ((loc (if (fixnump label) label (label-position label)))) - (write-var-integer (- loc *previous-location*) *byte-buffer*) - (setq *previous-location* loc)) - - (let ((path (node-source-path node))) - (unless tlf-num - (write-var-integer (source-path-tlf-number path) *byte-buffer*)) - (write-var-integer (source-path-form-number path) *byte-buffer*)) - - (write-packed-bit-vector (compute-live-vars live node block var-locs vop) - *byte-buffer*) - - (undefined-value)) - - -;;; DUMP-LOCATION-FROM-INFO -- Internal -;;; -;;; Extract context info from a Location-Info structure and use it to dump a -;;; compiled code-location. -;;; -(defun dump-location-from-info (loc tlf-num var-locs) - (declare (type location-info loc) (type (or index null) tlf-num) - (type hash-table var-locs)) - (let ((vop (location-info-vop loc))) - (dump-1-location (vop-node vop) - (vop-block vop) - (location-info-kind loc) - tlf-num - (location-info-label loc) - (vop-save-set vop) - var-locs - vop)) - (undefined-value)) - - -;;; FIND-TLF-AND-BLOCK-NUMBERS -- Internal -;;; -;;; Scan all the blocks, caching the block numbering in the BLOCK-FLAG and -;;; determining if all locations are in the same TLF. -;;; -(defun find-tlf-and-block-numbers (fun) - (declare (type clambda fun)) - (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))) - (num 0)) - (declare (type index num) (type (or index null) res)) - (do-environment-ir2-blocks (2block (lambda-environment fun)) - (let ((block (ir2-block-block 2block))) - (when (eq (block-info block) 2block) - (setf (block-flag block) num) - (incf num) - (unless (eql (source-path-tlf-number - (node-source-path - (continuation-next - (block-start block)))) - res) - (setq res nil))) - - (dolist (loc (ir2-block-locations 2block)) - (unless (eql (source-path-tlf-number - (node-source-path - (vop-node (location-info-vop loc)))) - res) - (setq res nil))))) - res)) - - -;;; DUMP-BLOCK-LOCATIONS -- Internal -;;; -;;; Dump out the number of locations and the locations for Block. -;;; -(defun dump-block-locations (block locations tlf-num var-locs) - (declare (type cblock block) (list locations)) - (if (and locations - (eq (location-info-kind (first locations)) - :non-local-entry)) - (write-var-integer (length locations) *byte-buffer*) - (let ((2block (block-info block))) - (write-var-integer (+ (length locations) 1) *byte-buffer*) - (dump-1-location (continuation-next (block-start block)) - 2block :block-start tlf-num - (ir2-block-%label 2block) - (ir2-block-live-out 2block) - var-locs - nil))) - (dolist (loc locations) - (dump-location-from-info loc tlf-num var-locs)) - (undefined-value)) - - -;;; DUMP-BLOCK-SUCCESSORS -- Internal -;;; -;;; Dump the successors of Block, being careful not to fly into space on -;;; weird successors. -;;; -(defun dump-block-successors (block env) - (declare (type cblock block) (type environment env)) - (let* ((tail (component-tail (block-component block))) - (succ (block-succ block)) - (valid-succ - (if (and succ - (or (eq (car succ) tail) - (not (eq (block-environment (car succ)) env)))) - () - succ))) - (vector-push-extend - (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0) - *byte-buffer*) - (dolist (b valid-succ) - (write-var-integer (block-flag b) *byte-buffer*))) - (undefined-value)) - - -;;; COMPUTE-DEBUG-BLOCKS -- Internal -;;; -;;; Return a vector and an integer (or null) suitable for use as the BLOCKS -;;; and TLF-NUMBER in Fun's debug-function. This requires three passes to -;;; compute: -;;; -- Scan all blocks, dumping the header and successors followed by all the -;;; non-elsewhere locations. -;;; -- Dump the elsewhere block header and all the elsewhere locations (if -;;; any.) -;;; -(defun compute-debug-blocks (fun var-locs) - (declare (type clambda fun) (type hash-table var-locs)) - (setf (fill-pointer *byte-buffer*) 0) - (let ((*previous-location* 0) - (tlf-num (find-tlf-and-block-numbers fun)) - (env (lambda-environment fun)) - (prev-locs nil) - (prev-block nil)) - (collect ((elsewhere)) - (do-environment-ir2-blocks (2block env) - (let ((block (ir2-block-block 2block))) - (when (eq (block-info block) 2block) - (when prev-block - (dump-block-locations prev-block prev-locs tlf-num var-locs)) - (setq prev-block block prev-locs ()) - (dump-block-successors block env))) - - (collect ((here prev-locs)) - (dolist (loc (ir2-block-locations 2block)) - (if (label-elsewhere-p (location-info-label loc)) - (elsewhere loc) - (here loc))) - (setq prev-locs (here)))) - - (dump-block-locations prev-block prev-locs tlf-num var-locs) - - (when (elsewhere) - (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*) - (write-var-integer (length (elsewhere)) *byte-buffer*) - (dolist (loc (elsewhere)) - (dump-location-from-info loc tlf-num var-locs)))) - - (values (copy-seq *byte-buffer*) tlf-num))) - - -;;; DEBUG-SOURCE-FOR-INFO -- Interface -;;; -;;; Return a list of DEBUG-SOURCE structures containing information derived -;;; from Info. We always dump the Start-Positions, since it is too hard -;;; figure out whether we need them or not. -;;; -(defun debug-source-for-info (info) - (declare (type source-info info)) - (assert (not (source-info-current-file info))) - (mapcar #'(lambda (x) - (let ((name (file-info-name x)) - (res (make-debug-source - :from :file - :comment (file-info-comment x) - :created (file-info-write-date x) - :compiled (source-info-start-time info) - :source-root (file-info-source-root x) - :start-positions - (coerce-to-smallest-eltype - (file-info-positions x))))) - (cond ((simple-string-p name) - (setf (debug-source-name res) name)) - (t - (setf (debug-source-from res) name) - (setf (debug-source-name res) - (coerce (file-info-forms x) 'simple-vector)))) - res)) - (source-info-files info))) - - -;;; COERCE-TO-SMALLEST-ELTYPE -- Internal -;;; -;;; Given an arbirtary sequence, coerce it to an unsigned vector if -;;; possible. -;;; -(defun coerce-to-smallest-eltype (seq) - (declare (type sequence seq)) - (let ((max 0)) - (declare (type (or index null) max)) - (macrolet ((frob () - '(if (and (typep val 'index) max) - (when (> val max) - (setq max val)) - (setq max nil)))) - (if (listp seq) - (dolist (val seq) - (frob)) - (dotimes (i (length seq)) - (let ((val (aref seq i))) - (frob))))) - - (if max - (coerce seq `(simple-array (integer 0 ,max))) - (coerce seq 'simple-vector)))) - - -;;;; Variables: - -;;; TN-SC-OFFSET -- Internal -;;; -;;; Return a SC-OFFSET describing TN's location. -;;; -(defun tn-sc-offset (tn) - (declare (type tn tn)) - (make-sc-offset (sc-number (tn-sc tn)) - (tn-offset tn))) - - -;;; DUMP-1-VARIABLE -- Internal -;;; -;;; Dump info to represent Var's location being TN. ID is an integer that -;;; makes Var's name unique in the function. Buffer is the vector we stick the -;;; result in. If Minimal is true, we suppress name dumping, and set the -;;; minimal flag. -;;; -;;; The debug-variable is only marked as always-live if the TN is -;;; environment live and is an argument. If a :debug-environment TN, then we -;;; also exclude set variables, since the variable is not guranteed to be live -;;; everywhere in that case. -;;; -(defun dump-1-variable (fun var tn id minimal buffer) - (declare (type lambda-var var) (type (or tn null) tn) (type index id) - (type clambda fun)) - (let* ((name (leaf-name var)) - (package (symbol-package name)) - (package-p (and package (not (eq package *package*)))) - (save-tn (and tn (tn-save-tn tn))) - (kind (and tn (tn-kind tn))) - (flags 0)) - (declare (type index flags)) - (cond (minimal - (setq flags (logior flags compiled-debug-variable-minimal-p)) - (unless tn - (setq flags (logior flags compiled-debug-variable-deleted-p)))) - (t - (unless package - (setq flags (logior flags compiled-debug-variable-uninterned))) - (when package-p - (setq flags (logior flags compiled-debug-variable-packaged))))) - (when (and (or (eq kind :environment) - (and (eq kind :debug-environment) - (null (basic-var-sets var)))) - (not (gethash tn (ir2-component-spilled-tns - (component-info *compile-component*)))) - (eq (lambda-var-home var) fun)) - (setq flags (logior flags compiled-debug-variable-environment-live))) - (when save-tn - (setq flags (logior flags compiled-debug-variable-save-loc-p))) - (unless (or (zerop id) minimal) - (setq flags (logior flags compiled-debug-variable-id-p))) - (vector-push-extend flags buffer) - (unless minimal - (write-var-string (symbol-name name) buffer) - (when package-p - (write-var-string (package-name package) buffer)) - (unless (zerop id) - (write-var-integer id buffer))) - (if tn - (write-var-integer (tn-sc-offset tn) buffer) - (assert minimal)) - (when save-tn - (write-var-integer (tn-sc-offset save-tn) buffer))) - (undefined-value)) - - -;;; COMPUTE-VARIABLES -- Internal -;;; -;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun. -;;; Level is the current DEBUG-INFO quality. Var-Locs is a hashtable in which -;;; we enter the translation from LAMBDA-VARS to the relative position of that -;;; variable's location in the resulting vector. -;;; -(defun compute-variables (fun level var-locs) - (declare (type clambda fun) (type hash-table var-locs)) - (collect ((vars)) - (labels ((frob-leaf (leaf tn gensym-p) - (let ((name (leaf-name leaf))) - (when (and name (leaf-refs leaf) (tn-offset tn) - (or gensym-p (symbol-package name))) - (vars (cons leaf tn))))) - (frob-lambda (x gensym-p) - (dolist (leaf (lambda-vars x)) - (frob-leaf leaf (leaf-info leaf) gensym-p)))) - (frob-lambda fun t) - (when (>= level 2) - (dolist (x (ir2-environment-environment - (environment-info (lambda-environment fun)))) - (let ((thing (car x))) - (when (lambda-var-p thing) - (frob-leaf thing (cdr x) (= level 3))))) - - (dolist (let (lambda-lets fun)) - (frob-lambda let (= level 3))))) - - (setf (fill-pointer *byte-buffer*) 0) - (let ((sorted (sort (vars) #'string< - :key #'(lambda (x) - (symbol-name (leaf-name (car x)))))) - (prev-name nil) - (id 0) - (i 0)) - (declare (type (or simple-string null) prev-name) - (type index id i)) - (dolist (x sorted) - (let* ((var (car x)) - (name (symbol-name (leaf-name var)))) - (cond ((and prev-name (string= prev-name name)) - (incf id)) - (t - (setq id 0 prev-name name))) - (dump-1-variable fun var (cdr x) id nil *byte-buffer*) - (setf (gethash var var-locs) i)) - (incf i))) - - (copy-seq *byte-buffer*))) - - -;;; COMPUTE-MINIMAL-VARIABLES -- Internal -;;; -;;; Dump out the arguments to Fun in the minimal variable format. -;;; -(defun compute-minimal-variables (fun) - (declare (type clambda fun)) - (setf (fill-pointer *byte-buffer*) 0) - (dolist (var (lambda-vars fun)) - (dump-1-variable fun var (leaf-info var) 0 t *byte-buffer*)) - (copy-seq *byte-buffer*)) - - -;;; DEBUG-LOCATION-FOR -- Internal -;;; -;;; Return Var's relative position in the function's variables (determined -;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED. -;;; -(defun debug-location-for (var var-locs) - (declare (type lambda-var var) (type hash-table var-locs)) - (let ((res (gethash var var-locs))) - (cond (res) - (t - (assert (or (null (leaf-refs var)) - (not (tn-offset (leaf-info var))))) - 'deleted)))) - - -;;;; Arguments/returns: - -;;; COMPUTE-ARGUMENTS -- Internal -;;; -;;; Return a vector to be used as the COMPILED-DEBUG-FUNCTION-ARGUMENTS for -;;; Fun. If fun is the MAIN-ENTRY for an optional dispatch, then look at the -;;; ARGLIST to determine the syntax, otherwise pretend all arguments are fixed. -;;; -;;; ### This assumption breaks down in EPs other than the main-entry, since -;;; they may or may not have supplied-p vars, etc. -;;; -(defun compute-arguments (fun var-locs) - (declare (type clambda fun) (type hash-table var-locs)) - (collect ((res)) - (let ((od (lambda-optional-dispatch fun))) - (if (and od (eq (optional-dispatch-main-entry od) fun)) - (let ((actual-vars (lambda-vars fun)) - (saw-optional nil)) - (dolist (arg (optional-dispatch-arglist od)) - (let ((info (lambda-var-arg-info arg)) - (actual (pop actual-vars))) - (cond (info - (case (arg-info-kind info) - (:keyword - (res (arg-info-keyword info))) - (:rest - (res 'rest-arg)) - (:optional - (unless saw-optional - (res 'optional-args) - (setq saw-optional t)))) - (res (debug-location-for actual var-locs)) - (when (arg-info-supplied-p info) - (res 'supplied-p) - (res (debug-location-for (pop actual-vars) var-locs)))) - (t - (res (debug-location-for actual var-locs))))))) - (dolist (var (lambda-vars fun)) - (res (debug-location-for var var-locs))))) - - (coerce-to-smallest-eltype (res)))) - - -;;; COMPUTE-DEBUG-RETURNS -- Internal -;;; -;;; Return a vector of SC offsets describing Fun's return locations. (Must -;;; be known values return...) -;;; -(defun compute-debug-returns (fun) - (coerce-to-smallest-eltype - (mapcar #'(lambda (loc) - (tn-sc-offset loc)) - (return-info-locations (tail-set-info (lambda-tail-set fun)))))) - - -;;;; Debug functions: - -;;; DFUN-FROM-FUN -- Internal -;;; -;;; Return a C-D-F structure with all the mandatory slots filled in. -;;; -(defun dfun-from-fun (fun) - (declare (type clambda fun)) - (let* ((2env (environment-info (lambda-environment fun))) - (dispatch (lambda-optional-dispatch fun)) - (main-p (and dispatch - (eq fun (optional-dispatch-main-entry dispatch))))) - (make-compiled-debug-function - :name (cond ((leaf-name fun)) - ((let ((ef (functional-entry-function - fun))) - (and ef (leaf-name ef)))) - ((and main-p (leaf-name dispatch))) - (t - (component-name - (block-component (node-block (lambda-bind fun)))))) - :kind (if main-p nil (functional-kind fun)) - :return-pc (tn-sc-offset (ir2-environment-return-pc 2env)) - :old-fp (tn-sc-offset (ir2-environment-old-fp 2env)) - :start-pc (label-position (ir2-environment-environment-start 2env)) - :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env))))) - - -;;; COMPUTE-1-DEBUG-FUNCTION -- Internal -;;; -;;; Return a complete C-D-F structure for Fun. This involves determining -;;; the DEBUG-INFO level and filling in optional slots as appropriate. -;;; -(defun compute-1-debug-function (fun var-locs) - (declare (type clambda fun) (type hash-table var-locs)) - (let* ((dfun (dfun-from-fun fun)) - (level (cookie-debug - (lexenv-cookie (node-lexenv (lambda-bind fun)))))) - - (cond ((zerop level)) - ((and (<= level 1) - (let ((od (lambda-optional-dispatch fun))) - (or (not od) - (not (eq (optional-dispatch-main-entry od) fun))))) - (setf (compiled-debug-function-variables dfun) - (compute-minimal-variables fun)) - (setf (compiled-debug-function-arguments dfun) :minimal)) - (t - (setf (compiled-debug-function-variables dfun) - (compute-variables fun level var-locs)) - (setf (compiled-debug-function-arguments dfun) - (compute-arguments fun var-locs)))) - - (when (>= level 2) - (multiple-value-bind (blocks tlf-num) - (compute-debug-blocks fun var-locs) - (setf (compiled-debug-function-tlf-number dfun) tlf-num) - (setf (compiled-debug-function-blocks dfun) blocks))) - - (if (external-entry-point-p fun) - (setf (compiled-debug-function-returns dfun) :standard) - (let ((info (tail-set-info (lambda-tail-set fun)))) - (when info - (cond ((eq (return-info-kind info) :unknown) - (setf (compiled-debug-function-returns dfun) - :standard)) - ((/= level 0) - (setf (compiled-debug-function-returns dfun) - (compute-debug-returns fun))))))) - dfun)) - - -;;;; Minimal debug functions: - -;;; DEBUG-FUNCTION-MINIMAL-P -- Internal -;;; -;;; Return true if Dfun can be represented as a minimal debug function. -;;; Dfun is a cons (<start offset> . C-D-F). -;;; -(defun debug-function-minimal-p (dfun) - (declare (type cons dfun)) - (let ((dfun (cdr dfun))) - (and (member (compiled-debug-function-arguments dfun) '(:minimal nil)) - (null (compiled-debug-function-blocks dfun))))) - - -;;; DUMP-1-MINIMAL-DFUN -- Internal -;;; -;;; Dump a packed binary representation of a Dfun into *byte-buffer*. -;;; Prev-Start and Start are the byte offsets in the code where the previous -;;; function started and where this one starts. Prev-Elsewhere is the previous -;;; function's elsewhere PC. -;;; -(defun dump-1-minimal-dfun (dfun prev-start start prev-elsewhere) - (declare (type compiled-debug-function dfun) - (type index prev-start start prev-elsewhere)) - (let* ((name (compiled-debug-function-name dfun)) - (setf-p (and (consp name) (eq (car name) 'setf) - (consp (cdr name)) (symbolp (cadr name)))) - (base-name (if setf-p (cadr name) name)) - (pkg (when (symbolp base-name) - (symbol-package base-name))) - (name-rep - (cond ((stringp base-name) - minimal-debug-function-name-component) - ((not pkg) - minimal-debug-function-name-uninterned) - ((eq pkg *package*) - minimal-debug-function-name-symbol) - (t - minimal-debug-function-name-packaged)))) - (assert (or (atom name) setf-p)) - (let ((options 0)) - (setf (ldb minimal-debug-function-name-style-byte options) name-rep) - (setf (ldb minimal-debug-function-kind-byte options) - (position (compiled-debug-function-kind dfun) - minimal-debug-function-kinds)) - (setf (ldb minimal-debug-function-returns-byte options) - (etypecase (compiled-debug-function-returns dfun) - ((member :standard) minimal-debug-function-returns-standard) - ((member :fixed) minimal-debug-function-returns-fixed) - (vector minimal-debug-function-returns-specified))) - (vector-push-extend options *byte-buffer*)) - - (let ((flags 0)) - (when setf-p - (setq flags (logior flags minimal-debug-function-setf-bit))) - (when (compiled-debug-function-nfp dfun) - (setq flags (logior flags minimal-debug-function-nfp-bit))) - (when (compiled-debug-function-variables dfun) - (setq flags (logior flags minimal-debug-function-variables-bit))) - (vector-push-extend flags *byte-buffer*)) - - (when (eql name-rep minimal-debug-function-name-packaged) - (write-var-string (package-name pkg) *byte-buffer*)) - (unless (stringp base-name) - (write-var-string (symbol-name base-name) *byte-buffer*)) - - (let ((vars (compiled-debug-function-variables dfun))) - (when vars - (let ((len (length vars))) - (write-var-integer len *byte-buffer*) - (dotimes (i len) - (vector-push-extend (aref vars i) *byte-buffer*))))) - - (let ((returns (compiled-debug-function-returns dfun))) - (when (vectorp returns) - (let ((len (length returns))) - (write-var-integer len *byte-buffer*) - (dotimes (i len) - (write-var-integer (aref returns i) *byte-buffer*))))) - - (write-var-integer (compiled-debug-function-return-pc dfun) - *byte-buffer*) - (write-var-integer (compiled-debug-function-old-fp dfun) - *byte-buffer*) - (when (compiled-debug-function-nfp dfun) - (write-var-integer (compiled-debug-function-nfp dfun) - *byte-buffer*)) - (write-var-integer (- start prev-start) *byte-buffer*) - (write-var-integer (- (compiled-debug-function-start-pc dfun) start) - *byte-buffer*) - (write-var-integer (- (compiled-debug-function-elsewhere-pc dfun) - prev-elsewhere) - *byte-buffer*))) - - -;;; COMPUTE-MINIMAL-DEBUG-FUNCTIONS -- Internal -;;; -;;; Return a byte-vector holding all the debug functions for a component in -;;; the packed binary minimal-debug-function format. -;;; -(defun compute-minimal-debug-functions (dfuns) - (declare (list dfuns)) - (setf (fill-pointer *byte-buffer*) 0) - (let ((prev-start 0) - (prev-elsewhere 0)) - (dolist (dfun dfuns) - (let ((start (car dfun)) - (elsewhere (compiled-debug-function-elsewhere-pc (cdr dfun)))) - (dump-1-minimal-dfun (cdr dfun) prev-start start prev-elsewhere) - (setq prev-start start prev-elsewhere elsewhere)))) - (copy-seq *byte-buffer*)) - - -;;;; Full component dumping: - -;;; COMPUTE-DEBUG-FUNCTION-MAP -- Internal -;;; -;;; Compute the full form (simple-vector) function map. -;;; -(defun compute-debug-function-map (sorted) - (declare (list sorted)) - (let* ((len (1- (* (length sorted) 2))) - (funs-vec (make-array len))) - (do ((i -1 (+ i 2)) - (sorted sorted (cdr sorted))) - ((= i len)) - (declare (fixnum i)) - (let ((dfun (car sorted))) - (unless (minusp i) - (setf (svref funs-vec i) (car dfun))) - (setf (svref funs-vec (1+ i)) (cdr dfun)))) - funs-vec)) - - -;;; DEBUG-INFO-FOR-COMPONENT -- Interface -;;; -;;; Return a debug-info structure describing component. This has to be -;;; called after assembly so that source map information is available. -;;; -(defun debug-info-for-component (component) - (declare (type component component)) - (let ((res (make-compiled-debug-info :name (component-name component) - :package (package-name *package*)))) - (collect ((dfuns)) - (let ((var-locs (make-hash-table :test #'eq)) - (*byte-buffer* - (make-array 10 :element-type '(unsigned-byte 8) - :fill-pointer 0 :adjustable t))) - (dolist (fun (component-lambdas component)) - (clrhash var-locs) - (dfuns (cons (label-position - (block-label (node-block (lambda-bind fun)))) - (compute-1-debug-function fun var-locs)))) - - (let ((sorted (sort (dfuns) #'< :key #'car))) - (setf (compiled-debug-info-function-map res) - (if (every #'debug-function-minimal-p sorted) - (compute-minimal-debug-functions sorted) - (compute-debug-function-map sorted)))))) - - res)) diff --git a/compiler/debug.lisp b/compiler/debug.lisp deleted file mode 100644 index d7ca48a6e4d2ecf6627fdeecdf36e2977ace909c..0000000000000000000000000000000000000000 --- a/compiler/debug.lisp +++ /dev/null @@ -1,1362 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/debug.lisp,v 1.23 1992/07/21 17:38:54 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Utilities for debugging the compiler. Currently contains only stuff for -;;; checking the consistency of the IR1. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") - -(export '(label-id)) - - -(defvar *args* () - "This variable is bound to the format arguments when an error is signalled - by Barf or Burp.") - -(defvar *ignored-errors* (make-hash-table :test #'equal)) - -;;; Barf -- Interface -;;; -;;; A definite inconsistency has been detected. Signal an error with -;;; *args* bound to the list of the format args. -;;; -(proclaim '(function barf (string &rest t) void)) -(defun barf (string &rest *args*) - (unless (gethash string *ignored-errors*) - (restart-case - (apply #'error string *args*) - (continue () - :report "Ignore this error.") - (ignore-all () - :report "Ignore this and all future occurrences of this error." - (setf (gethash string *ignored-errors*) t))))) - -(defvar *burp-action* :warn - "Action taken by the Burp function when a possible compiler bug is detected. - One of :Warn, :Error or :None.") - -(proclaim '(type (member :warn :error :none) *burp-action*)) - -;;; Burp -- Interface -;;; -;;; Called when something funny but possibly correct is noticed. Otherwise -;;; similar to Barf. -;;; -(proclaim '(function burp (string &rest t) void)) -(defun burp (string &rest *args*) - (ecase *burp-action* - (:warn (apply #'warn string *args*)) - (:error (apply #'cerror "press on anyway." string *args*)) - (:none))) - - -;;; *Seen-Blocks* is a hashtable with true values for all blocks which appear -;;; in the DFO for one of the specified components. -;;; -(defvar *seen-blocks* (make-hash-table :test #'eq)) - -;;; *Seen-Functions* is similar, but records all the lambdas we reached by -;;; recursing on top-level functions. -;;; -(defvar *seen-functions* (make-hash-table :test #'eq)) - - -;;; Check-Node-Reached -- Internal -;;; -;;; Barf if Node is in a block which wasn't reached during the graph -;;; walk. -;;; -(proclaim '(function check-node-reached (node) void)) -(defun check-node-reached (node) - (unless (gethash (continuation-block (node-prev node)) *seen-blocks*) - (barf "~S was not reached." node))) - - -;;; Check-IR1-Consistency -- Interface -;;; -;;; Check everything that we can think of for consistency. When a definite -;;; inconsistency is detected, we Barf. Possible problems just cause us to -;;; Burp. Our argument is a list of components, but we also look at the -;;; *free-variables*, *free-functions* and *constants*. -;;; -;;; First we do a pre-pass which finds all the blocks and lambdas, testing -;;; that they are linked together properly and entering them in hashtables. -;;; Next, we iterate over the blocks again, looking at the actual code and -;;; control flow. Finally, we scan the global leaf hashtables, looking for -;;; lossage. -;;; -(proclaim '(function check-ir1-consistency (list) void)) -(defun check-ir1-consistency (components) - (clrhash *seen-blocks*) - (clrhash *seen-functions*) - (dolist (c components) - (let* ((head (component-head c)) - (tail (component-tail c))) - (unless (and (null (block-pred head)) (null (block-succ tail))) - (barf "~S malformed." c)) - - (do ((prev nil block) - (block head (block-next block))) - ((null block) - (unless (eq prev tail) - (barf "Wrong Tail for DFO, ~S in ~S." prev c))) - (setf (gethash block *seen-blocks*) t) - (unless (eq (block-prev block) prev) - (barf "Bad Prev for ~S, should be ~S." block prev)) - (unless (or (eq block tail) - (eq (block-component block) c)) - (barf "~S is not in ~S." block c))) -#| - (when (or (loop-blocks c) (loop-inferiors c)) - (do-blocks (block c :both) - (setf (block-flag block) nil)) - (check-loop-consistency c nil) - (do-blocks (block c :both) - (unless (block-flag block) - (barf "~S was not in any loop." block)))) -|# - )) - - (check-function-consistency components) - - (dolist (c components) - (do ((block (block-next (component-head c)) (block-next block))) - ((null (block-next block))) - (check-block-consistency block))) - - - (maphash #'(lambda (k v) - (declare (ignore k)) - (unless (or (constant-p v) - (and (global-var-p v) - (member (global-var-kind v) - '(:global :special :constant)))) - (barf "Strange *free-variables* entry: ~S." v)) - (dolist (n (leaf-refs v)) - (check-node-reached n)) - (when (basic-var-p v) - (dolist (n (basic-var-sets v)) - (check-node-reached n)))) - *free-variables*) - - (maphash #'(lambda (k v) - (declare (ignore k)) - (unless (constant-p v) - (barf "Strange *constants* entry: ~S." v)) - (dolist (n (leaf-refs v)) - (check-node-reached n))) - *constants*) - - (maphash #'(lambda (k v) - (declare (ignore k)) - (unless (or (functional-p v) - (and (global-var-p v) - (eq (global-var-kind v) :global-function))) - (barf "Strange *free-functions* entry: ~S." v)) - (dolist (n (leaf-refs v)) - (check-node-reached n))) - *free-functions*) - (clrhash *seen-functions*) - (clrhash *seen-blocks*) - (values)) - - -;;;; Function consistency checking: - -;;; Observe-Functional -- Internal -;;; -(defun observe-functional (x) - (declare (type functional x)) - (when (gethash x *seen-functions*) - (barf "~S seen more than once." x)) - (unless (eq (functional-kind x) :deleted) - (setf (gethash x *seen-functions*) t))) - - -;;; Check-Function-Reached -- Internal -;;; -;;; Check that the specified function has been seen. -;;; -(defun check-function-reached (fun where) - (declare (type functional fun)) - (unless (gethash fun *seen-functions*) - (barf "Unseen function ~S in ~S." fun where))) - - -;;; Check-Function-Stuff -- Internal -;;; -;;; In a lambda, check that the associated nodes are in seen blocks. In an -;;; optional dispatch, check that the entry points were seen. If the function -;;; is deleted, ignore it. -;;; -(defun check-function-stuff (functional) - (ecase (functional-kind functional) - (:external - (let ((fun (functional-entry-function functional))) - (check-function-reached fun functional) - (when (functional-kind fun) - (barf "Function for XEP ~S has kind." functional)) - (unless (eq (functional-entry-function fun) functional) - (barf "Bad back-pointer in function for XEP ~S." functional)))) - ((:let :mv-let :assignment) - (check-function-reached (lambda-home functional) functional) - (when (functional-entry-function functional) - (barf "Let ~S has entry function." functional)) - (unless (member functional (lambda-lets (lambda-home functional))) - (barf "Let ~S not in Lets for Home." functional)) - (unless (eq (functional-kind functional) :assignment) - (when (rest (leaf-refs functional)) - (barf "Let ~S has multiple refernces." functional))) - (when (lambda-lets functional) - (barf "Lets in a Let: ~S." functional))) - (:optional - (when (functional-entry-function functional) - (barf ":Optional ~S has an ENTRY-FUNCTION." functional)) - (let ((ef (lambda-optional-dispatch functional))) - (check-function-reached ef functional) - (unless (or (member functional (optional-dispatch-entry-points ef)) - (eq functional (optional-dispatch-more-entry ef)) - (eq functional (optional-dispatch-main-entry ef))) - (barf ":Optional ~S not an e-p for its OPTIONAL-DISPATCH ~S." - functional ef)))) - (:top-level - (unless (eq (functional-entry-function functional) functional) - (barf "Entry-Function is ~S isn't a self-pointer." functional))) - ((nil :escape :cleanup) - (let ((ef (functional-entry-function functional))) - (when ef - (check-function-reached ef functional) - (unless (eq (functional-kind ef) :external) - (barf "Entry-Function in ~S isn't an XEP: ~S." functional ef))))) - (:deleted - (return-from check-function-stuff))) - - (case (functional-kind functional) - ((nil :optional :external :top-level :escape :cleanup) - (when (lambda-p functional) - (dolist (fun (lambda-lets functional)) - (unless (eq (lambda-home fun) functional) - (barf "Home in ~S not ~S." fun functional)) - (check-function-reached fun functional)) - (unless (eq (lambda-home functional) functional) - (barf "Home not self-pointer in ~S." functional))))) - - (etypecase functional - (clambda - (when (lambda-bind functional) - (check-node-reached (lambda-bind functional))) - (when (lambda-return functional) - (check-node-reached (lambda-return functional))) - - (dolist (var (lambda-vars functional)) - (dolist (ref (leaf-refs var)) - (check-node-reached ref)) - (dolist (set (basic-var-sets var)) - (check-node-reached set)) - (unless (eq (lambda-var-home var) functional) - (barf "HOME in ~S should be ~S." var functional)))) - (optional-dispatch - (dolist (ep (optional-dispatch-entry-points functional)) - (check-function-reached ep functional)) - (let ((more (optional-dispatch-more-entry functional))) - (when more (check-function-reached more functional))) - (check-function-reached (optional-dispatch-main-entry functional) - functional)))) - - -;;; Check-Function-Consistency -- Internal -;;; -(defun check-function-consistency (components) - (dolist (c components) - (dolist (fun (component-new-functions c)) - (observe-functional fun)) - (dolist (fun (component-lambdas c)) - (when (eq (functional-kind fun) :external) - (let ((ef (functional-entry-function fun))) - (when (optional-dispatch-p ef) - (observe-functional ef)))) - (observe-functional fun) - (dolist (let (lambda-lets fun)) - (observe-functional let)))) - - (dolist (c components) - (dolist (fun (component-new-functions c)) - (check-function-stuff fun)) - (dolist (fun (component-lambdas c)) - (when (eq (functional-kind fun) :deleted) - (barf "Deleted lambda ~S in Lambdas for ~S." fun c)) - (check-function-stuff fun) - (dolist (let (lambda-lets fun)) - (check-function-stuff let))))) - - -;;;; Loop consistency checking: - -#| -;;; Check-Loop-Consistency -- Internal -;;; -;;; Descend through the loop nesting and check that the tree is well-formed -;;; and that all blocks in the loops are known blocks. We also mark each block -;;; that we see so that we can do a check later to detect blocks that weren't -;;; in any loop. -;;; -(proclaim '(function check-loop-consistency (loop (or loop null)) void)) -(defun check-loop-consistency (loop superior) - (unless (eq (loop-superior loop) superior) - (barf "Wrong superior in ~S, should be ~S." loop superior)) - (when (and superior - (/= (loop-depth loop) (1+ (loop-depth superior)))) - (barf "Wrong depth in ~S." loop)) - - (dolist (tail (loop-tail loop)) - (check-loop-block tail loop)) - (dolist (exit (loop-exits loop)) - (check-loop-block exit loop)) - (check-loop-block (loop-head loop) loop) - (unless (eq (block-loop (loop-head loop)) loop) - (barf "Head of ~S is not directly in the loop." loop)) - - (do ((block (loop-blocks loop) (block-loop-next block))) - ((null block)) - (setf (block-flag block) t) - (unless (gethash block *seen-blocks*) - (barf "Unseen block ~S in Blocks for ~S." block loop)) - (unless (eq (block-loop block) loop) - (barf "Wrong Loop in ~S, should be ~S." block loop))) - - (dolist (inferior (loop-inferiors loop)) - (check-loop-consistency inferior loop))) - - -;;; Check-Loop-Block -- Internal -;;; -;;; Check that Block is either in Loop or an inferior. -;;; -(proclaim '(function check-loop-block (block loop) void)) -(defun check-loop-block (block loop) - (unless (gethash block *seen-blocks*) - (barf "Unseen block ~S in loop info for ~S." block loop)) - (labels ((walk (l) - (if (eq (block-loop block) l) - t - (dolist (inferior (loop-inferiors l) nil) - (when (walk inferior) (return t)))))) - (unless (walk loop) - (barf "~S in loop info for ~S but not in the loop." block loop)))) - -|# - - -;;; Check-Block-Consistency -- Internal -;;; -;;; Check a block for consistency at the general flow-graph level, and call -;;; Check-Node-Consistency on each node to locally check for semantic -;;; consistency. -;;; -(proclaim '(function check-block-consistency (cblock) void)) -(defun check-block-consistency (block) - - (dolist (pred (block-pred block)) - (unless (gethash pred *seen-blocks*) - (barf "Unseen predecessor ~S in ~S." pred block)) - (unless (member block (block-succ pred)) - (barf "Bad predecessor link ~S in ~S." pred block))) - - (let* ((fun (block-home-lambda block)) - (fun-deleted (eq (functional-kind fun) :deleted)) - (this-cont (block-start block)) - (last (block-last block))) - (unless fun-deleted - (check-function-reached fun block)) - (when (not this-cont) - (barf "~S has no START." block)) - (when (not last) - (barf "~S has no LAST." block)) - (unless (eq (continuation-kind this-cont) :block-start) - (barf "Start of ~S has wrong kind." block)) - - (let ((use (continuation-use this-cont)) - (uses (block-start-uses block))) - (when (and (null use) (= (length uses) 1)) - (barf "~S has unique use, but no USE." this-cont)) - (dolist (node uses) - (unless (eq (node-cont node) this-cont) - (barf "Use ~S for START in ~S has wrong CONT." node block)) - (check-node-reached node))) - - (let* ((last-cont (node-cont last)) - (cont-block (continuation-block last-cont)) - (dest (continuation-dest last-cont))) - (ecase (continuation-kind last-cont) - (:deleted) - (:deleted-block-start - (let ((dest (continuation-dest last-cont))) - (when dest - (check-node-reached dest))) - (unless (member last (block-start-uses cont-block)) - (barf "Last in ~S is missing from uses of it's Cont." block))) - (:block-start - (check-node-reached (continuation-next last-cont)) - (unless (member last (block-start-uses cont-block)) - (barf "Last in ~S is missing from uses of it's Cont." block))) - (:inside-block - (unless (eq cont-block block) - (barf "Cont of Last in ~S is in a different block." block)) - (unless (eq (continuation-use last-cont) last) - (barf "Use is not Last in Cont of Last in ~S." block)) - (when (continuation-next last-cont) - (barf "Cont of Last has a Next in ~S." block)))) - - (when dest - (check-node-reached dest))) - - (loop - (unless (eq (continuation-block this-cont) block) - (barf "BLOCK in ~S should be ~S." this-cont block)) - - (let ((dest (continuation-dest this-cont))) - (when dest - (check-node-reached dest))) - - (let ((node (continuation-next this-cont))) - (unless (node-p node) - (barf "~S has strange next." this-cont)) - (unless (eq (node-prev node) this-cont) - (barf "PREV in ~S should be ~S." node this-cont)) - - (unless fun-deleted - (check-node-consistency node)) - - (let ((cont (node-cont node))) - (when (not cont) - (barf "~S has no CONT." node)) - (when (eq node last) (return)) - (unless (eq (continuation-kind cont) :inside-block) - (barf "Interior continuation ~S in ~S has wrong kind." cont block)) - (unless (continuation-next cont) - (barf "~S has no NEXT." cont)) - (unless (eq (continuation-use cont) node) - (barf "USE in ~S should be ~S." cont node)) - (setq this-cont cont)))) - - (check-block-successors block))) - - -;;; Check-Block-Successors -- Internal -;;; -;;; Check that Block is properly terminated. Each successor must be -;;; accounted for by the type of the last node. -;;; -(proclaim '(function check-block-successors (cblock) void)) -(defun check-block-successors (block) - (let ((last (block-last block)) - (succ (block-succ block))) - - (let* ((comp (block-component block)) - (tail (component-tail comp))) - (dolist (b succ) - (unless (gethash b *seen-blocks*) - (barf "Unseen successor ~S in ~S." b block)) - (unless (member block (block-pred b)) - (barf "Bad successor link ~S in ~S." b block)) - (unless (eq (block-component b) comp) - (barf "Successor ~S in ~S is in a different component." b block)) - (unless (or (not (eq b tail)) - (typep last '(or creturn exit)) - (and (basic-combination-p last) - (or (node-tail-p last) - (eq (node-derived-type last) *empty-type*) - (eq (continuation-asserted-type (node-cont last)) - *empty-type*)))) - (barf "Component tail is successor of ~S when it shouldn't be." - block)))) - - (typecase last - (cif - (unless (<= 1 (length succ) 2) - (barf "~S ends in an IF, but doesn't have one or two succesors." - block)) - (unless (member (if-consequent last) succ) - (barf "CONSEQUENT for ~S isn't in SUCC for ~S." last block)) - (unless (member (if-alternative last) succ) - (barf "ALTERNATIVE for ~S isn't in SUCC for ~S." last block))) - (creturn - (unless (if (eq (functional-kind (return-lambda last)) :deleted) - (null succ) - (and (= (length succ) 1) - (eq (first succ) - (component-tail (block-component block))))) - (barf "Strange successors for RETURN in ~S." block))) - (exit - (unless (<= (length succ) 1) - (barf "EXIT node has strange number of successors: ~S." last))) - (t - (unless (or (= (length succ) 1) (node-tail-p last) - (and (block-delete-p block) (null succ))) - (barf "~S ends in normal node, but doesn't have one successor." - block)))))) - - -;;;; Node consistency checking: - -;;; Check-Dest -- Internal -;;; -;;; Check that the Dest for Cont is the specified Node. We also mark the -;;; block Cont is in as Seen. -;;; -(proclaim '(function check-dest (continuation node) void)) -(defun check-dest (cont node) - (let ((kind (continuation-kind cont))) - (ecase kind - (:deleted - (unless (block-delete-p (node-block node)) - (barf "DEST ~S of deleted continuation ~S is not DELETE-P." - cont node))) - (:deleted-block-start - (unless (eq (continuation-dest cont) node) - (barf "DEST for ~S should be ~S." cont node))) - ((:inside-block :block-start) - (unless (gethash (continuation-block cont) *seen-blocks*) - (barf "~S receives ~S, which is in an unknown block." node cont)) - (unless (eq (continuation-dest cont) node) - (barf "DEST for ~S should be ~S." cont node)))))) - - -;;; Check-Node-Consistency -- Internal -;;; -;;; This function deals with checking for consistency the type-dependent -;;; information in a node. -;;; -(defun check-node-consistency (node) - (declare (type node node)) - (etypecase node - (ref - (let ((leaf (ref-leaf node))) - (when (functional-p leaf) - (if (eq (functional-kind leaf) :top-level-xep) - (unless (eq (component-kind (block-component (node-block node))) - :top-level) - (barf ":TOP-LEVEL-XEP ref in non-top-level component: ~S." - node)) - (check-function-reached leaf node))))) - (basic-combination - (check-dest (basic-combination-fun node) node) - (dolist (arg (basic-combination-args node)) - (cond - (arg (check-dest arg node)) - ((not (and (eq (basic-combination-kind node) :local) - (combination-p node))) - (barf "Flushed arg not in local call: ~S." node)) - (t - (let ((fun (ref-leaf (continuation-use - (basic-combination-fun node))))) - (when (leaf-refs (elt (lambda-vars fun) - (position arg (basic-combination-args node)))) - (barf "Flushed arg for referenced var in ~S." node)))))) - - (let ((dest (continuation-dest (node-cont node)))) - (when (and (return-p dest) - (eq (basic-combination-kind node) :local) - (not (eq (lambda-tail-set (combination-lambda node)) - (lambda-tail-set (return-lambda dest))))) - (barf "Tail local call to function with different tail set:~% ~S" - node)))) - (cif - (check-dest (if-test node) node) - (unless (eq (block-last (node-block node)) node) - (barf "IF not at block end: ~S" node))) - (cset - (check-dest (set-value node) node)) - (bind - (check-function-reached (bind-lambda node) node)) - (creturn - (check-function-reached (return-lambda node) node) - (check-dest (return-result node) node) - (unless (eq (block-last (node-block node)) node) - (barf "RETURN not at block end: ~S" node))) - (entry - (unless (member node (lambda-entries (node-home-lambda node))) - (barf "~S not in Entries for its home lambda." node)) - (dolist (exit (entry-exits node)) - (unless (node-deleted exit) - (check-node-reached node)))) - (exit - (let ((entry (exit-entry node)) - (value (exit-value node))) - (cond (entry - (check-node-reached entry) - (unless (member node (entry-exits entry)) - (barf "~S not in its ENTRY's EXITS." node)) - (when value - (check-dest value node))) - (t - (when value - (barf "~S has VALUE but no ENTRY." node))))))) - - (undefined-value)) - - -;;;; IR2 consistency checking: - - -;;; Check-TN-Refs -- Internal -;;; -;;; Check for some kind of consistency in some Refs linked together by -;;; TN-Ref-Across. VOP is the VOP that the references are in. Write-P is the -;;; value of Write-P that should be present. Count is the minimum number of -;;; operands expected. If More-P is true, then any larger number will also be -;;; accepted. What is a string describing the kind of operand in error -;;; messages. -;;; -(defun check-tn-refs (refs vop write-p count more-p what) - (let ((vop-refs (vop-refs vop))) - (do ((ref refs (tn-ref-across ref)) - (num 0 (1+ num))) - ((null ref) - (when (< num count) - (barf "Should be at least ~D ~A in ~S, but are only ~D." - count what vop num)) - (when (and (not more-p) (> num count)) - (barf "Should be ~D ~A in ~S, but are ~D." - count what vop num))) - (unless (eq (tn-ref-vop ref) vop) - (barf "VOP is ~S isn't ~S." ref vop)) - (unless (eq (tn-ref-write-p ref) write-p) - (barf "Write-P in ~S isn't ~S." vop write-p)) - (unless (find-in #'tn-ref-next-ref ref vop-refs) - (barf "~S not found in Refs for ~S." ref vop)) - (unless (find-in #'tn-ref-next ref - (if (tn-ref-write-p ref) - (tn-writes (tn-ref-tn ref)) - (tn-reads (tn-ref-tn ref)))) - (barf "~S not found in reads/writes for its TN." ref)) - - (let ((target (tn-ref-target ref))) - (when target - (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref))) - (barf "Target for ~S isn't complementary write-p." ref)) - (unless (find-in #'tn-ref-next-ref target vop-refs) - (barf "Target for ~S isn't in Refs for ~S." ref vop))))))) - - -;;; Check-VOP-Refs -- Internal -;;; -;;; Verify the sanity of the VOP-Refs slot in VOP. This involves checking -;;; that each referenced TN appears as an argument, result or temp, and also -;;; basic checks for the plausibility of the specified ordering of the refs. -;;; -(defun check-vop-refs (vop) - (declare (type vop vop)) - (do ((ref (vop-refs vop) (tn-ref-next-ref ref))) - ((null ref)) - (cond - ((find-in #'tn-ref-across ref (vop-args vop))) - ((find-in #'tn-ref-across ref (vop-results vop))) - ((not (eq (tn-ref-vop ref) vop)) - (barf "VOP in ~S isn't ~S." ref vop)) - ((find-in #'tn-ref-across ref (vop-temps vop))) - ((tn-ref-write-p ref) - (barf "Stray ref that isn't a read: ~S." ref)) - (t - (let* ((tn (tn-ref-tn ref)) - (temp (find-in #'tn-ref-across tn (vop-temps vop) - :key #'tn-ref-tn))) - (unless temp - (barf "Stray ref with no corresponding temp write: ~S." ref)) - (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref)) - (barf "Read is after write for temp ~S in refs of ~S." - tn vop)))))) - (undefined-value)) - - -;;; Check-IR2-Block-Consistency -- Internal -;;; -;;; Check the basic sanity of the VOP linkage, then call some other -;;; functions to check on the TN-Refs. We grab some info out of the VOP-Info -;;; to tell us what to expect. -;;; [### Check that operand type restrictions are met?] -;;; -(defun check-ir2-block-consistency (2block) - (declare (type ir2-block 2block)) - (do ((vop (ir2-block-start-vop 2block) - (vop-next vop)) - (prev nil vop)) - ((null vop) - (unless (eq prev (ir2-block-last-vop 2block)) - (barf "Last VOP in ~S shoule be ~S." 2block prev))) - (unless (eq (vop-prev vop) prev) - (barf "Prev in ~S should be ~S." vop prev)) - - (unless (eq (vop-block vop) 2block) - (barf "Block in ~S should be ~S." vop 2block)) - - (check-vop-refs vop) - - (let* ((info (vop-info vop)) - (atypes (template-arg-types info)) - (rtypes (template-result-types info))) - (check-tn-refs (vop-args vop) vop nil - (count-if-not #'(lambda (x) - (and (consp x) - (eq (car x) :constant))) - atypes) - (template-more-args-type info) "args") - (check-tn-refs (vop-results vop) vop t - (if (eq rtypes :conditional) 0 (length rtypes)) - (template-more-results-type info) "results") - (check-tn-refs (vop-temps vop) vop t 0 t "temps") - (unless (= (length (vop-codegen-info vop)) - (template-info-arg-count info)) - (barf "Wrong number of codegen info args in ~S." vop)))) - (undefined-value)) - - -;;; Check-IR2-Consistency -- Interface -;;; -;;; Check stuff about the IR2 representation of Component. This assumes the -;;; sanity of the basic flow graph. -;;; -;;; [### Also grovel global TN data structures? Assume pack not -;;; done yet? Have separate check-tn-consistency for pre-pack and -;;; check-pack-consistency for post-pack?] -;;; -(defun check-ir2-consistency (component) - (declare (type component component)) - (do-ir2-blocks (block component) - (check-ir2-block-consistency block)) - (undefined-value)) - - -;;;; Lifetime analysis checking: - -;;; Pre-Pack-TN-Stats -- Interface -;;; -;;; Dump some info about how many TNs there, and what the conflicts data -;;; structures are like. -;;; -(defun pre-pack-tn-stats (component &optional (stream *compiler-error-output*)) - (declare (type component component)) - (let ((wired 0) - (global 0) - (local 0) - (confs 0) - (unused 0) - (const 0) - (temps 0) - (environment 0) - (comp 0)) - (do-packed-tns (tn component) - (let ((reads (tn-reads tn)) - (writes (tn-writes tn))) - (when (and reads writes - (not (tn-ref-next reads)) (not (tn-ref-next writes)) - (eq (tn-ref-vop reads) (tn-ref-vop writes))) - (incf temps))) - (when (tn-offset tn) - (incf wired)) - (unless (or (tn-reads tn) (tn-writes tn)) - (incf unused)) - (cond ((eq (tn-kind tn) :component) - (incf comp)) - ((tn-global-conflicts tn) - (case (tn-kind tn) - ((:environment :debug-environment) (incf environment)) - (t (incf global))) - (do ((conf (tn-global-conflicts tn) - (global-conflicts-tn-next conf))) - ((null conf)) - (incf confs))) - (t - (incf local)))) - - (do ((tn (ir2-component-constant-tns (component-info component)) - (tn-next tn))) - ((null tn)) - (incf const)) - - (format stream - "~%TNs: ~D local, ~D temps, ~D constant, ~D env, ~D comp, ~D global.~@ - Wired: ~D, Unused: ~D. ~D block~:P, ~D global conflict~:P.~%" - local temps const environment comp global wired unused - (ir2-block-count component) - confs)) - (undefined-value)) - - -;;; Check-More-TN-Entry -- Internal -;;; -;;; If the entry in Local-TNs for TN in Block is :More, then do some checks -;;; for the validity of the usage. -;;; -(defun check-more-tn-entry (tn block) - (let* ((vop (ir2-block-start-vop block)) - (info (vop-info vop))) - (macrolet ((frob (more-p ops) - `(and (,more-p info) - (find-in #'tn-ref-across tn (,ops vop) - :key #'tn-ref-tn)))) - (unless (and (eq vop (ir2-block-last-vop block)) - (or (frob template-more-args-type vop-args) - (frob template-more-results-type vop-results))) - (barf "Strange :More LTN entry for ~S in ~S." tn block)))) - (undefined-value)) - - -;;; Check-TN-Conflicts -- Internal -;;; -(defun check-tn-conflicts (component) - (do-packed-tns (tn component) - (unless (or (not (eq (tn-kind tn) :normal)) - (tn-reads tn) - (tn-writes tn)) - (barf "No references to ~S." tn)) - - (unless (tn-sc tn) (barf "~S has no SC." tn)) - - (let ((conf (tn-global-conflicts tn)) - (kind (tn-kind tn))) - (cond - ((eq kind :component) - (unless (member tn (ir2-component-component-tns - (component-info component))) - (barf "~S not in Component-TNs for ~S." tn component))) - (conf - (do ((conf conf (global-conflicts-tn-next conf)) - (prev nil conf)) - ((null conf)) - (unless (eq (global-conflicts-tn conf) tn) - (barf "TN in ~S should be ~S." conf tn)) - - (unless (eq (global-conflicts-kind conf) :live) - (let* ((block (global-conflicts-block conf)) - (ltn (svref (ir2-block-local-tns block) - (global-conflicts-number conf)))) - (cond ((eq ltn tn)) - ((eq ltn :more) (check-more-tn-entry tn block)) - (t - (barf "~S wrong in LTN map for ~S." conf tn))))) - - (when prev - (unless (> (ir2-block-number (global-conflicts-block conf)) - (ir2-block-number (global-conflicts-block prev))) - (barf "~S and ~S out of order." prev conf))))) - ((member (tn-kind tn) '(:constant :specified-save))) - (t - (let ((local (tn-local tn))) - (unless local - (barf "~S has no global conflicts, but isn't local either." tn)) - (unless (eq (svref (ir2-block-local-tns local) - (tn-local-number tn)) - tn) - (barf "~S wrong in LTN map." tn)) - (do ((ref (tn-reads tn) (tn-ref-next ref))) - ((null ref)) - (unless (eq (vop-block (tn-ref-vop ref)) local) - (barf "~S has references in blocks other than its Local block." - tn))) - (do ((ref (tn-writes tn) (tn-ref-next ref))) - ((null ref)) - (unless (eq (vop-block (tn-ref-vop ref)) local) - (barf "~S has references in blocks other than its Local block." - tn)))))))) - (undefined-value)) - - -;;; Check-Block-Conflicts -- Internal -;;; -(defun check-block-conflicts (component) - (do-ir2-blocks (block component) - (do ((conf (ir2-block-global-tns block) - (global-conflicts-next conf)) - (prev nil conf)) - ((null conf)) - (when prev - (unless (> (tn-number (global-conflicts-tn conf)) - (tn-number (global-conflicts-tn prev))) - (barf "~S and ~S out of order in ~S." prev conf block))) - - (unless (find-in #'global-conflicts-tn-next - conf - (tn-global-conflicts - (global-conflicts-tn conf))) - (barf "~S missing from global conflicts of its TN." conf))) - - (let ((map (ir2-block-local-tns block))) - (dotimes (i (ir2-block-local-tn-count block)) - (let ((tn (svref map i))) - (unless (or (eq tn :more) - (null tn) - (tn-global-conflicts tn) - (eq (tn-local tn) block)) - (barf "Strange TN ~S in LTN map for ~S." tn block))))))) - - -;;; Check-Environment-Lifetimes -- Internal -;;; -;;; All TNs live at the beginning of an environment must be passing -;;; locations associated with that environment. We make an exception for wired -;;; TNs in XEP functions, since we randomly reference wired TNs to access the -;;; full call passing locations. -;;; -(defun check-environment-lifetimes (component) - (dolist (fun (component-lambdas component)) - (let* ((env (lambda-environment fun)) - (2env (environment-info env)) - (vars (lambda-vars fun)) - (closure (ir2-environment-environment 2env)) - (pc (ir2-environment-return-pc-pass 2env)) - (fp (ir2-environment-old-fp 2env)) - (2block (block-info - (node-block - (lambda-bind - (environment-function env)))))) - (do ((conf (ir2-block-global-tns 2block) - (global-conflicts-next conf))) - ((null conf)) - (let ((tn (global-conflicts-tn conf))) - (unless (or (eq (global-conflicts-kind conf) :write) - (eq tn pc) - (eq tn fp) - (and (external-entry-point-p fun) - (tn-offset tn)) - (member (tn-kind tn) '(:environment :debug-environment)) - (member tn vars :key #'leaf-info) - (member tn closure :key #'cdr)) - (barf "Strange TN live at head of ~S: ~S." env tn)))))) - (undefined-value)) - - -;;; Check-Life-Consistency -- Interface -;;; -;;; Check for some basic sanity in the TN conflict data structures, and also -;;; check that no TNs are unexpectedly live at environment entry. -;;; -(defun check-life-consistency (component) - (check-tn-conflicts component) - (check-block-conflicts component) - (check-environment-lifetimes component)) - - -;;;; Pack consistency checking: - -;;; CHECK-PACK-CONSISTENCY -- Interface -;;; -(defun check-pack-consistency (component) - (flet ((check (scs ops) - (do ((scs scs (cdr scs)) - (op ops (tn-ref-across op))) - ((null scs)) - (let ((load-tn (tn-ref-load-tn op))) - (unless (eq (svref (car scs) - (sc-number - (tn-sc - (or load-tn (tn-ref-tn op))))) - t) - (barf "Operand restriction not satisfied: ~S." op)))))) - (do-ir2-blocks (block component) - (do ((vop (ir2-block-last-vop block) (vop-prev vop))) - ((null vop)) - (let ((info (vop-info vop))) - (check (vop-info-result-load-scs info) (vop-results vop)) - (check (vop-info-arg-load-scs info) (vop-args vop)))))) - (undefined-value)) - - -;;;; Data structure dumping routines: - -;;; Continuation-Number, Number-Continuation, ID-TN, TN-ID -- Interface -;;; -;;; When we print Continuations and TNs, we assign them small numeric IDs so -;;; that we can get a handle on anonymous objects given a printout. -;;; -(macrolet ((frob (counter vto vfrom fto ffrom) - `(progn - (defvar ,vto (make-hash-table :test #'eq)) - (defvar ,vfrom (make-hash-table :test #'eql)) - (proclaim '(hash-table ,vto ,vfrom)) - (defvar ,counter 0) - (proclaim '(fixnum ,counter)) - - (defun ,fto (x) - (or (gethash x ,vto) - (let ((num (incf ,counter))) - (setf (gethash num ,vfrom) x) - (setf (gethash x ,vto) num)))) - - (defun ,ffrom (num) - (values (gethash num ,vfrom)))))) - (frob *continuation-number* - *continuation-numbers* *number-continuations* - cont-num num-cont) - (frob *tn-id* - *tn-ids* *id-tns* - tn-id id-tn) - (frob *label-id* - *id-labels* *label-ids* - label-id id-label)) - -;;; Print-Leaf -- Internal -;;; -;;; Print out a terse one-line description of a leaf. -;;; -(defun print-leaf (leaf &optional (stream *standard-output*)) - (declare (type leaf leaf) (type stream stream)) - (etypecase leaf - (lambda-var (prin1 (leaf-name leaf) stream)) - (constant (format stream "'~S" (constant-value leaf))) - (global-var - (format stream "~S {~A}" (leaf-name leaf) (global-var-kind leaf))) - (clambda - (format stream "lambda ~S ~S" (leaf-name leaf) - (mapcar #'leaf-name (lambda-vars leaf)))) - (optional-dispatch - (format stream "optional-dispatch ~S" (leaf-name leaf))) - (functional - (assert (eq (functional-kind leaf) :top-level-xep)) - (format stream "TL-XEP ~S" - (let ((info (leaf-info leaf))) - (etypecase info - (entry-info (entry-info-name info)) - (byte-lambda-info :byte-compiled-entry))))))) - -;;; Block-Or-Lose -- Interface -;;; -;;; Attempt to find a block given some thing that has to do with it. -;;; -(proclaim '(function block-or-lose (t) cblock)) -(defun block-or-lose (thing) - (ctypecase thing - (cblock thing) - (ir2-block (ir2-block-block thing)) - (vop (block-or-lose (vop-block thing))) - (tn-ref (block-or-lose (tn-ref-vop thing))) - (continuation (continuation-block thing)) - (node (node-block thing)) - (component (component-head thing)) -#| (cloop (loop-head thing))|# - (integer (continuation-block (num-cont thing))) - (functional (node-block (lambda-bind (main-entry thing)))) - (null (error "Bad thing: ~S." thing)) - (symbol (block-or-lose (gethash thing *free-functions*))))) - - -;;; Print-Continuation -- Internal -;;; -;;; Print cN. -;;; -(defun print-continuation (cont) - (declare (type continuation cont)) - (format t " c~D" (cont-num cont)) - (undefined-value)) - - -;;; Print-Nodes -- Interface -;;; -;;; Print out the nodes in Block in a format oriented toward representing -;;; what the code does. -;;; -(defun print-nodes (block) - (setq block (block-or-lose block)) - (format t "~%block start c~D" (cont-num (block-start block))) - - (let ((last (block-last block))) - (terpri) - (do ((cont (block-start block) (node-cont (continuation-next cont)))) - (()) - (let ((node (continuation-next cont))) - (format t "~3D: " (cont-num (node-cont node))) - (etypecase node - (ref (print-leaf (ref-leaf node))) - (basic-combination - (let ((kind (basic-combination-kind node))) - (format t "~(~A ~A~) c~D" - (if (function-info-p kind) "known" kind) - (type-of node) - (cont-num (basic-combination-fun node))) - (dolist (arg (basic-combination-args node)) - (if arg - (print-continuation arg) - (format t " <none>"))))) - (cset - (write-string "set ") - (print-leaf (set-var node)) - (print-continuation (set-value node))) - (cif - (format t "if c~D" (cont-num (if-test node))) - (print-continuation (block-start (if-consequent node))) - (print-continuation (block-start (if-alternative node)))) - (bind - (write-string "bind ") - (print-leaf (bind-lambda node))) - (creturn - (format t "return c~D " (cont-num (return-result node))) - (print-leaf (return-lambda node))) - (entry - (format t "entry ~S" (entry-exits node))) - (exit - (let ((value (exit-value node))) - (cond (value - (format t "exit c~D" (cont-num value))) - ((exit-entry node) - (format t "exit <no value>")) - (t - (format t "exit <degenerate>")))))) - (terpri) - (when (eq node last) (return))))) - - (let ((succ (block-succ block))) - (format t "successors~{ c~D~}~%" - (mapcar #'(lambda (x) (cont-num (block-start x))) succ))) - (values)) - - -;;; Print-TN -- Internal -;;; -;;; Print a useful representation of a TN. If the TN has a leaf, then do a -;;; Print-Leaf on that, otherwise print a generated ID. -;;; -(defun print-tn (tn &optional (stream *standard-output*)) - (declare (type tn tn)) - (let ((leaf (tn-leaf tn))) - (cond (leaf - (print-leaf leaf stream) - (format stream "!~D" (tn-id tn))) - (t - (format stream "t~D" (tn-id tn)))) - (when (and (tn-sc tn) (tn-offset tn)) - (format stream "[~A]" (location-print-name tn))))) - - -;;; Print-Operands -- Internal -;;; -;;; Print the TN-Refs representing some operands to a VOP, linked by -;;; TN-Ref-Across. -;;; -(defun print-operands (refs) - (declare (type (or tn-ref null) refs)) - (pprint-logical-block (*standard-output* nil) - (do ((ref refs (tn-ref-across ref))) - ((null ref)) - (let ((tn (tn-ref-tn ref)) - (ltn (tn-ref-load-tn ref))) - (cond ((not ltn) - (print-tn tn)) - (t - (print-tn tn) - (princ (if (tn-ref-write-p ref) #\< #\>)) - (print-tn ltn))) - (princ #\space) - (pprint-newline :fill))))) - - -;;; Print-Vop -- internal -;;; -;;; Print the vop, putting args, info and results on separate lines, if -;;; necessary. -;;; -(defun print-vop (vop) - (pprint-logical-block (*standard-output* nil) - (princ (vop-info-name (vop-info vop))) - (princ #\space) - (pprint-indent :current 0) - (print-operands (vop-args vop)) - (pprint-newline :linear) - (when (vop-codegen-info vop) - (princ (with-output-to-string (stream) - (let ((*print-level* 1) - (*print-length* 3)) - (format stream "{~{~S~^ ~}} " (vop-codegen-info vop))))) - (pprint-newline :linear)) - (when (vop-results vop) - (princ "=> ") - (print-operands (vop-results vop)))) - (terpri)) - -;;; Print-IR2-Block -- Internal -;;; -;;; Print the VOPs in the specified IR2 block. -;;; -(defun print-ir2-block (block) - (declare (type ir2-block block)) - (cond - ((eq (block-info (ir2-block-block block)) block) - (format t "~%IR2 block start c~D~%" - (cont-num (block-start (ir2-block-block block)))) - (let ((label (ir2-block-%label block))) - (when label - (format t "L~D:~%" (label-id label))))) - (t - (format t "<overflow>~%"))) - - (do ((vop (ir2-block-start-vop block) - (vop-next vop)) - (number 0 (1+ number))) - ((null vop)) - (format t "~D: " number) - (print-vop vop))) - - -;;; Print-VOPs -- Interface -;;; -;;; Like Print-Nodes, but dumps the IR2 representation of the code in Block. -;;; -(defun print-vops (block) - (setq block (block-or-lose block)) - (let ((2block (block-info block))) - (print-ir2-block 2block) - (do ((b (ir2-block-next 2block) (ir2-block-next b))) - ((not (eq (ir2-block-block b) block))) - (print-ir2-block b))) - (values)) - - -;;; Print-IR2-Blocks -- Interface -;;; -;;; Scan the IR2 blocks in emission order. -;;; -(defun print-ir2-blocks (thing) - (do-ir2-blocks (block (block-component (block-or-lose thing))) - (print-ir2-block block)) - (values)) - - -;;; Print-Blocks -- Interface -;;; -;;; Do a Print-Nodes on Block and all blocks reachable from it by successor -;;; links. -;;; -(defun print-blocks (block) - (setq block (block-or-lose block)) - (do-blocks (block (block-component block) :both) - (setf (block-flag block) nil)) - (labels ((walk (block) - (unless (block-flag block) - (setf (block-flag block) t) - (when (block-start block) - (print-nodes block)) - (dolist (block (block-succ block)) - (walk block))))) - (walk block)) - (values)) - - -;;; Print-All-Blocks -- Interface -;;; -;;; Print all blocks in Block's component in DFO. -;;; -(defun print-all-blocks (thing) - (do-blocks (block (block-component (block-or-lose thing))) - (handler-case (print-nodes block) - (error (condition) - (format t "~&~A...~%" condition)))) - (values)) - - -(defvar *list-conflicts-table* (make-hash-table :test #'eq)) - -;;; Add-Always-Live-TNs -- Internal -;;; -;;; Add all Always-Live TNs in Block to the conflicts. TN is ignored when -;;; it appears in the global conflicts. -;;; -(defun add-always-live-tns (block tn) - (declare (type ir2-block block) (type tn tn)) - (do ((conf (ir2-block-global-tns block) - (global-conflicts-next conf))) - ((null conf)) - (when (eq (global-conflicts-kind conf) :live) - (let ((btn (global-conflicts-tn conf))) - (unless (eq btn tn) - (setf (gethash btn *list-conflicts-table*) t))))) - (undefined-value)) - - -;;; Add-All-Local-TNs -- Internal -;;; -;;; Add all local TNs in block to the conflicts. -;;; -(defun add-all-local-tns (block) - (declare (type ir2-block block)) - (let ((ltns (ir2-block-local-tns block))) - (dotimes (i (ir2-block-local-tn-count block)) - (setf (gethash (svref ltns i) *list-conflicts-table*) t))) - (undefined-value)) - - -;;; Listify-Conflicts-Table -- Internal -;;; -;;; Make a list out of all of the recorded conflicts. -;;; -(defun listify-conflicts-table () - (collect ((res)) - (maphash #'(lambda (k v) - (declare (ignore v)) - (when k - (res k))) - *list-conflicts-table*) - (clrhash *list-conflicts-table*) - (res))) - - -;;; List-Conflicts -- Interface -;;; -(defun list-conflicts (tn) - "Return a list of a the TNs that conflict with TN. Sort of, kind of. For - debugging use only. Probably doesn't work on :COMPONENT TNs." - (assert (member (tn-kind tn) '(:normal :environment :debug-environment))) - (let ((confs (tn-global-conflicts tn))) - (cond (confs - (clrhash *list-conflicts-table*) - (do ((conf confs (global-conflicts-tn-next conf))) - ((null conf)) - (let ((block (global-conflicts-block conf))) - (add-always-live-tns block tn) - (if (eq (global-conflicts-kind conf) :live) - (add-all-local-tns block) - (let ((bconf (global-conflicts-conflicts conf)) - (ltns (ir2-block-local-tns block))) - (dotimes (i (ir2-block-local-tn-count block)) - (when (/= (sbit bconf i) 0) - (setf (gethash (svref ltns i) *list-conflicts-table*) - t))))))) - (listify-conflicts-table)) - (t - (let* ((block (tn-local tn)) - (ltns (ir2-block-local-tns block)) - (confs (tn-local-conflicts tn))) - (collect ((res)) - (dotimes (i (ir2-block-local-tn-count block)) - (when (/= (sbit confs i) 0) - (let ((tn (svref ltns i))) - (when (and tn (not (eq tn :more)) - (not (tn-global-conflicts tn))) - (res tn))))) - (do ((gtn (ir2-block-global-tns block) - (global-conflicts-next gtn))) - ((null gtn)) - (when (or (eq (global-conflicts-kind gtn) :live) - (/= (sbit confs (global-conflicts-number gtn)) 0)) - (res (global-conflicts-tn gtn)))) - (res))))))) - - -;;; Nth-VOP -- Interface -;;; -(defun nth-vop (thing n) - "Return the Nth VOP in the IR2-Block pointed to by Thing." - (let ((block (block-info (block-or-lose thing)))) - (do ((i 0 (1+ i)) - (vop (ir2-block-start-vop block) (vop-next vop))) - ((= i n) vop)))) diff --git a/compiler/dfo.lisp b/compiler/dfo.lisp deleted file mode 100644 index c9668b0a4e151501c4e705dbd3b982ba690340d8..0000000000000000000000000000000000000000 --- a/compiler/dfo.lisp +++ /dev/null @@ -1,490 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/dfo.lisp,v 1.24 1992/09/29 17:58:48 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the code that finds the initial components and DFO, -;;; and recomputes the DFO if it is invalidated. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") - - -;;; Find-DFO -- Interface -;;; -;;; Find the DFO for a component, deleting any unreached blocks and merging -;;; any other components we reach. We repeatedly iterate over the entry -;;; points, since new ones may show up during the walk. -;;; -(proclaim '(function find-dfo (component) void)) -(defun find-dfo (component) - (clear-flags component) - (setf (component-reanalyze component) nil) - (let ((head (component-head component))) - (do () - ((dolist (ep (block-succ head) t) - (unless (block-flag ep) - (find-dfo-aux ep head component) - (return nil)))))) - - (let ((num 0)) - (declare (fixnum num)) - (do-blocks-backwards (block component :both) - (if (block-flag block) - (setf (block-number block) (incf num)) - (setf (block-delete-p block) t))) - (do-blocks (block component) - (unless (block-flag block) - (delete-block block))))) - - -;;; Join-Components -- Interface -;;; -;;; Move all the code and entry points from Old to New. The code in Old is -;;; inserted at the head of New. This is also called during let conversion -;;; when we are about in insert the body of a let in a different component. [A -;;; local call can be to a different component before FIND-INITIAL-DFO runs.] -;;; -(proclaim '(function join-components (component component) void)) -(defun join-components (new old) - (assert (eq (component-kind new) (component-kind old))) - (let ((old-head (component-head old)) - (old-tail (component-tail old)) - (head (component-head new)) - (tail (component-tail new))) - - (do-blocks (block old) - (setf (block-flag block) nil) - (setf (block-component block) new)) - - (let ((old-next (block-next old-head)) - (old-last (block-prev old-tail)) - (next (block-next head))) - (unless (eq old-next old-tail) - (setf (block-next head) old-next) - (setf (block-prev old-next) head) - - (setf (block-prev next) old-last) - (setf (block-next old-last) next)) - - (setf (block-next old-head) old-tail) - (setf (block-prev old-tail) old-head)) - - (setf (component-lambdas new) - (nconc (component-lambdas old) (component-lambdas new))) - (setf (component-lambdas old) ()) - (setf (component-new-functions new) - (nconc (component-new-functions old) (component-new-functions new))) - (setf (component-new-functions old) ()) - - (dolist (xp (block-pred old-tail)) - (unlink-blocks xp old-tail) - (link-blocks xp tail)) - (dolist (ep (block-succ old-head)) - (unlink-blocks old-head ep) - (link-blocks head ep)))) - - -;;; Find-DFO-Aux -- Internal -;;; -;;; Do a depth-first walk from Block, inserting ourself in the DFO after -;;; Head. If we somehow find ourselves in another component, then we join that -;;; component to our component. -;;; -(proclaim '(function find-dfo-aux (cblock cblock component) void)) -(defun find-dfo-aux (block head component) - (unless (eq (block-component block) component) - (join-components component (block-component block))) - - (unless (block-flag block) - (setf (block-flag block) t) - (dolist (succ (block-succ block)) - (find-dfo-aux succ head component)) - - (remove-from-dfo block) - (add-to-dfo block head))) - - -;;; Walk-Home-Call-Graph -- Internal -;;; -;;; This function is called on each block by Find-Initial-DFO-Aux before it -;;; walks the successors. It looks at the home lambda's bind block to see if -;;; that block is in some other component: -;;; -- If the block is in the initial component, then do DFO-Walk-Call-Graph on -;;; the home function to move it into component. -;;; -- If the block is in some other component, join Component into it and -;;; return that component. -;;; -- If the home function is deleted, do nothing. Block must eventually be -;;; discovered to be unreachable as well. This can happen when we have a -;;; NLX into a function with no references. The escape function still has -;;; refs (in the deleted function). -;;; -;;; This ensures that all the blocks in a given environment will be in the same -;;; component, even when they might not seem reachable from the environment -;;; entry. Consider the case of code that is only reachable from a non-local -;;; exit. -;;; -(defun walk-home-call-graph (block component) - (declare (type cblock block) (type component component)) - (let ((home (block-home-lambda block))) - (if (eq (functional-kind home) :deleted) - component - (let* ((bind-block (node-block (lambda-bind home))) - (home-component (block-component bind-block))) - (cond ((eq (component-kind home-component) :initial) - (dfo-walk-call-graph home component)) - ((eq home-component component) - component) - (t - (join-components home-component component) - home-component)))))) - - -;;; Find-Initial-DFO-Aux -- Internal -;;; -;;; Somewhat similar to Find-DFO-Aux, except that it merges the current -;;; component with any strange component, rather than the other way around. -;;; This is more efficient in the common case where the current component -;;; doesn't have much stuff in it. -;;; -;;; We return the current component as a result, allowing the caller to -;;; detect when the old current component has been merged with another. -;;; -;;; We walk blocks in initial components as though they were already in the -;;; current component, moving them to the current component in the process. -;;; The blocks are inserted at the head of the current component. -;;; -(defun find-initial-dfo-aux (block component) - (declare (type cblock block) (type component component)) - (let ((this (block-component block))) - (cond - ((not (or (eq this component) - (eq (component-kind this) :initial))) - (join-components this component) - this) - ((block-flag block) component) - (t - (setf (block-flag block) t) - (let ((current (walk-home-call-graph block component))) - (dolist (succ (block-succ block)) - (setq current (find-initial-dfo-aux succ current))) - - (remove-from-dfo block) - (add-to-dfo block (component-head current)) - current))))) - - -;;; Find-Reference-Functions -- Internal -;;; -;;; Return a list of all the home lambdas that reference Fun (may contain -;;; duplications). -;;; -;;; References to functions which local call analysis could not (or were -;;; chosen not) to local call convert will appear as references to XEP lambdas. -;;; We can ignore references to XEPs that appear in :TOP-LEVEL components, -;;; since environment analysis goes to special effort to allow closing over of -;;; values from a separate top-level component. All other references must -;;; cause components to be joined. -;;; -;;; References in deleted functions are also ignored, since this code will be -;;; deleted eventually. -;;; -(defun find-reference-functions (fun) - (collect ((res)) - (dolist (ref (leaf-refs fun)) - (let* ((home (node-home-lambda ref)) - (home-kind (functional-kind home))) - (unless (or (and (eq home-kind :top-level) - (eq (functional-kind fun) :external)) - (eq home-kind :deleted)) - (res home)))) - (res))) - - -;;; DFO-Walk-Call-Graph -- Internal -;;; -;;; Move the code for Fun and all functions called by it into Component. If -;;; Fun is already in Component, then we just return that component. -;;; -;;; If the function is in an initial component, then we move its head and -;;; tail to Component and add it to Component's lambdas. It is harmless to -;;; move the tail (even though the return might be unreachable) because if the -;;; return is unreachable it (and its successor link) will be deleted in the -;;; post-deletion pass. -;;; -;;; We then do a Find-DFO-Aux starting at the head of Fun. If this -;;; flow-graph walk encounters another component (which can only happen due to -;;; a non-local exit), then we move code into that component instead. We then -;;; recurse on all functions called from Fun, moving code into whichever -;;; component the preceding call returned. -;;; -;;; If Fun is in the initial component, but the Block-Flag is set in the -;;; bind block, then we just return Component, since we must have already -;;; reached this function in the current walk (or the component would have been -;;; changed). -;;; -;;; If the function is an XEP, then we also walk all functions that contain -;;; references to the XEP. This is done so that environment analysis doesn't -;;; need to cross component boundries. This also ensures that conversion of a -;;; full call to a local call won't result in a need to join components, since -;;; the components will already be one. -;;; -(defun dfo-walk-call-graph (fun component) - (declare (type clambda fun) (type component component)) - (let* ((bind-block (node-block (lambda-bind fun))) - (this (block-component bind-block)) - (return (lambda-return fun))) - (cond - ((eq this component) component) - ((not (eq (component-kind this) :initial)) - (join-components this component) - this) - ((block-flag bind-block) - component) - (t - (push fun (component-lambdas component)) - (setf (component-lambdas this) - (delete fun (component-lambdas this))) - (link-blocks (component-head component) bind-block) - (unlink-blocks (component-head this) bind-block) - (when return - (let ((return-block (node-block return))) - (link-blocks return-block (component-tail component)) - (unlink-blocks return-block (component-tail this)))) - (let ((calls (if (eq (functional-kind fun) :external) - (append (find-reference-functions fun) - (lambda-calls fun)) - (lambda-calls fun)))) - (do ((res (find-initial-dfo-aux bind-block component) - (dfo-walk-call-graph (first funs) res)) - (funs calls (rest funs))) - ((null funs) res) - (declare (type component res)))))))) - - -;;; HAS-XEP-OR-NLX -- Internal -;;; -;;; Return true if Fun is either an XEP or has EXITS to some of its ENTRIES. -;;; -(defun has-xep-or-nlx (fun) - (declare (type clambda fun)) - (or (eq (functional-kind fun) :external) - (let ((entries (lambda-entries fun))) - (and entries - (find-if #'entry-exits entries))))) - - -;;; FIND-TOP-LEVEL-COMPONENTS -- Internal -;;; -;;; Compute the result of FIND-INITIAL-DFO given the list of all resulting -;;; components. Components with a :TOP-LEVEL lambda, but no normal XEPs or -;;; potential non-local exits are marked as :TOP-LEVEL. If there is a -;;; :TOP-LEVEL lambda, and also a normal XEP, then we treat the component as -;;; normal, but also return such components in a list as the third value. -;;; Components with no entry of any sort are deleted. -;;; -(defun find-top-level-components (components) - (declare (list components)) - (collect ((real) - (top) - (real-top)) - (dolist (com components) - (unless (eq (block-next (component-head com)) (component-tail com)) - (let* ((funs (component-lambdas com)) - (has-top (find :top-level funs :key #'functional-kind))) - (cond ((or (find-if #'has-xep-or-nlx funs) - (and has-top (rest funs))) - (setf (component-name com) (find-component-name com)) - (real com) - (when has-top - (setf (component-kind com) :complex-top-level) - (real-top com))) - (has-top - (setf (component-kind com) :top-level) - (setf (component-name com) "Top-Level Form") - (top com)) - (t - (delete-component com)))))) - - (values (real) (top) (real-top)))) - - -;;; Find-Initial-DFO -- Interface -;;; -;;; Given a list of top-level lambdas, return three lists of components -;;; representing the actual component division: -;;; 1] the non-top-level components, -;;; 2] and the second is the top-level components, and -;;; 3] Components in [1] that also have a top-level lambda. -;;; -;;; We assign the DFO for each component, and delete any unreachable blocks. -;;; We assume that the Flags have already been cleared. -;;; -;;; We iterate over the lambdas in each initial component, trying to put -;;; each function in its own component, but joining it to an existing component -;;; if we find that there are references between them. Any code that is left -;;; in an initial component must be unreachable, so we can delete it. Stray -;;; links to the initial component tail (due NIL function terminated blocks) -;;; are moved to the appropriate newc component tail. -;;; -;;; When we are done, we assign DFNs and call FIND-TOP-LEVEL-COMPONENTS to -;;; pull out top-level code. -;;; -(defun find-initial-dfo (lambdas) - (declare (list lambdas)) - (collect ((components)) - (let ((new (make-empty-component))) - (dolist (tll lambdas) - (let ((component (block-component (node-block (lambda-bind tll))))) - (dolist (fun (component-lambdas component)) - (assert (member (functional-kind fun) - '(:optional :external :top-level nil :escape - :cleanup))) - (let ((res (dfo-walk-call-graph fun new))) - (when (eq res new) - (components new) - (setq new (make-empty-component))))) - (when (eq (component-kind component) :initial) - (assert (null (component-lambdas component))) - (let ((tail (component-tail component))) - (dolist (pred (block-pred tail)) - (let ((pred-component (block-component pred))) - (unless (eq pred-component component) - (unlink-blocks pred tail) - (link-blocks pred (component-tail pred-component)))))) - (delete-component component))))) - - (dolist (com (components)) - (let ((num 0)) - (declare (fixnum num)) - (do-blocks-backwards (block com :both) - (setf (block-number block) (incf num))))) - - (find-top-level-components (components)))) - - -;;; MERGE-1-TL-LAMBDA -- Internal -;;; -;;; Insert the code in LAMBDA at the end of RESULT-LAMBDA. -;;; -(defun merge-1-tl-lambda (result-lambda lambda) - (declare (type clambda result-lambda lambda)) - ;; - ;; Delete the lambda, and combine the lets and entries. - (setf (functional-kind lambda) :deleted) - (dolist (let (lambda-lets lambda)) - (setf (lambda-home let) result-lambda) - (setf (lambda-environment let) (lambda-environment result-lambda)) - (push let (lambda-lets result-lambda))) - (setf (lambda-entries result-lambda) - (nconc (lambda-entries result-lambda) - (lambda-entries lambda))) - - (let* ((bind (lambda-bind lambda)) - (bind-block (node-block bind)) - (component (block-component bind-block)) - (result-component - (block-component (node-block (lambda-bind result-lambda)))) - (result-return-block (node-block (lambda-return result-lambda)))) - ;; - ;; Move blocks into the new component, and move any nodes directly in - ;; the old lambda into the new one (lets implicitly moved by changing - ;; their home.) - (do-blocks (block component) - (do-nodes (node cont block) - (let ((lexenv (node-lexenv node))) - (when (eq (lexenv-lambda lexenv) lambda) - (setf (lexenv-lambda lexenv) result-lambda)))) - (setf (block-component block) result-component)) - ;; - ;; Splice the blocks into the new DFO, and unlink them from the old - ;; component head and tail. Non-return blocks that jump to the tail - ;; (NIL returning calls) are switched to go to the new tail. - (let* ((head (component-head component)) - (first (block-next head)) - (tail (component-tail component)) - (last (block-prev tail)) - (prev (block-prev result-return-block))) - (setf (block-next prev) first) - (setf (block-prev first) prev) - (setf (block-next last) result-return-block) - (setf (block-prev result-return-block) last) - (dolist (succ (block-succ head)) - (unlink-blocks head succ)) - (dolist (pred (block-pred tail)) - (unlink-blocks pred tail) - (let ((last (block-last pred))) - (unless (return-p last) - (assert (basic-combination-p last)) - (link-blocks pred (component-tail result-component)))))) - - (let ((lambdas (component-lambdas component))) - (assert (and (null (rest lambdas)) - (eq (first lambdas) lambda)))) - ;; - ;; Switch the end of the code from the return block to the start of - ;; the next chunk. - (dolist (pred (block-pred result-return-block)) - (unlink-blocks pred result-return-block) - (link-blocks pred bind-block)) - (unlink-node bind) - ;; - ;; If there is a return, then delete it (making the preceding node the - ;; last node) and link the block to the result return. There is always a - ;; preceding REF NIL node in top-level lambdas. - (let ((return (lambda-return lambda))) - (when return - (let ((return-block (node-block return)) - (result (return-result return))) - (setf (block-last return-block) (continuation-use result)) - (flush-dest result) - (delete-continuation result) - (link-blocks return-block result-return-block)))))) - - -;;; MERGE-TOP-LEVEL-LAMBDAS -- Interface -;;; -;;; Given a non-empty list of top-level lambdas, smash them into a top-level -;;; lambda and component, returning these as values. We use the first lambda -;;; and its component, putting the other code in that component and deleting -;;; the other lambdas. -;;; -(defun merge-top-level-lambdas (lambdas) - (declare (cons lambdas)) - (let* ((result-lambda (first lambdas)) - (result-return (lambda-return result-lambda))) - (cond - (result-return - ;; - ;; Make sure the result's return node starts a block so that we can - ;; splice code in before it. - (let ((prev (node-prev - (continuation-use - (return-result result-return))))) - (when (continuation-use prev) - (node-ends-block (continuation-use prev))) - (do-uses (use prev) - (let ((new (make-continuation))) - (delete-continuation-use use) - (add-continuation-use use new)))) - - (dolist (lambda (rest lambdas)) - (merge-1-tl-lambda result-lambda lambda))) - (t - (dolist (lambda (rest lambdas)) - (setf (functional-entry-function lambda) nil) - (delete-component - (block-component - (node-block (lambda-bind lambda))))))) - - (values (block-component (node-block (lambda-bind result-lambda))) - result-lambda))) diff --git a/compiler/disassem.lisp b/compiler/disassem.lisp deleted file mode 100644 index a5650711e829edf188c756dd096712bd70b85237..0000000000000000000000000000000000000000 --- a/compiler/disassem.lisp +++ /dev/null @@ -1,3724 +0,0 @@ -;;; -*- Package: DISASSEM -*- -;;; -;;; ********************************************************************** -;;; This code was written for the use 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/disassem.lisp,v 1.19 1992/12/17 11:24:37 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Machine independent disassembler for CMU Common Lisp -;;; -;;; Written by Miles Bader <miles@cogsci.ed.ac.uk> -;;; - -(in-package :disassem) - -(use-package :extensions) - -(export '(;; for defining the instruction set - set-disassem-params - define-argument-type - define-instruction-format - install-inst-flavors - - ;; macroexpanders - gen-preamble-form gen-clear-info-form - gen-arg-type-def-form gen-format-def-form - gen-printer-def-forms-def-form - - ;; main user entry-points - disassemble - disassemble-memory - disassemble-function - disassemble-code-component - disassemble-assem-segment - - ;; some variables to set - *opcode-column-width* - *note-column* - - ;; slightly lower level entry-points - make-dstate - get-function-segments get-code-segments - label-segments disassemble-segments disassemble-segment - map-segment-instructions - segment-overflow - set-location-printing-range - add-offs-hook add-offs-note-hook add-offs-comment-hook - *default-dstate-hooks* - make-segment make-code-segment make-vector-segment make-memory-segment - make-offs-hook - - ;; segment type - segment seg-sap-maker seg-length seg-virtual-location - - ;; decoding a bit-pattern - sap-ref-dchunk - get-inst-space - find-inst - make-decoded-inst - - ;; getting at the dstate (usually from mach-dep code) - disassem-state dstate-cur-offs dstate-next-offs - dstate-segment dstate-segment-sap - dstate-get-prop - dstate-cur-addr dstate-next-addr - - ;; random types - dchunk params instruction - - ;; - read-suffix read-signed-suffix - sign-extend - - ;; useful for printers - princ16 - - ;; making handy margin notes - note - note-code-constant - maybe-note-nil-indexed-symbol-slot-ref - maybe-note-nil-indexed-object - maybe-note-assembler-routine - maybe-note-single-storage-ref - maybe-note-associated-storage-ref - handle-break-args - - ;; taking over and printing... - print-notes-and-newline - print-current-address - print-bytes print-words - prin1-short - prin1-quoted-short - )) - -;;; ---------------------------------------------------------------- - -(defvar *opcode-column-width* nil - "The width of the column in which instruction-names are printed. - NIL means use the default. A value of zero gives the effect of not - aligning the arguments at all.") -(defvar *note-column* 45 - "The column in which end-of-line comments for notes are started.") - -(defconstant default-opcode-column-width 6) -(defconstant default-location-column-width 8) -(defconstant label-column-width 7) - -(deftype address () '(unsigned-byte 32)) -(deftype alignment () '(integer 0 64)) -(deftype offset () '(signed-byte 24)) -(deftype length () '(unsigned-byte 24)) - -(deftype column () '(integer 0 1000)) -(deftype text-width () '(integer 0 1000)) - -(defconstant max-filtered-value-index 32) -(deftype filtered-value-index () - `(integer 0 ,max-filtered-value-index)) -(deftype filtered-value-vector () - `(simple-array t (,max-filtered-value-index))) - -;;; ---------------------------------------------------------------- - -(defmacro set-disassem-params (&rest args) - "Specify global disassembler params for C:*TARGET-BACKEND*. - Keyword arguments include: - - :INSTRUCTION-ALIGNMENT number - Minimum alignment of instructions, in bits. - - :ADDRESS-SIZE number - Size of a machine address, in bits. - - :OPCODE-COLUMN-WIDTH - Width of the column used for printing the opcode portion of the - instruction, or NIL to use the default." - (gen-preamble-form args)) - -(defmacro define-argument-type (name &rest args) - "DEFINE-ARGUMENT-TYPE Name {Key Value}* - Define a disassembler argument type NAME (which can then be referenced in - another argument definition using the :TYPE keyword argument). Keyword - arguments are: - - :SIGN-EXTEND boolean - If non-NIL, the raw value of this argument is sign-extended. - - :TYPE arg-type-name - Inherit any properties of given argument-type. - - :PREFILTER function - A function which is called (along with all other prefilters, in the - order that their arguments appear in the instruction- format) before - any printing is done, to filter the raw value. Any uses of READ-SUFFIX - must be done inside a prefilter. - - :PRINTER function-string-or-vector - A function, string, or vector which is used to print an argument of - this type. - - :USE-LABEL - If non-NIL, the value of an argument of this type is used as an - address, and if that address occurs inside the disassembled code, it is - replaced by a label. If this is a function, it is called to filter the - value." - (gen-arg-type-def-form name args)) - -(defmacro define-instruction-format (header &rest fields) - "DEFINE-INSTRUCTION-FORMAT (Name Length {Format-Key Value}*) Arg-Def* - Define an instruction format NAME for the disassembler's use. LENGTH is - the length of the format in bits. - Possible FORMAT-KEYs: - - :INCLUDE other-format-name - Inherit all arguments and properties of the given format. Any - arguments defined in the current format definition will either modify - the copy of an existing argument (keeping in the same order with - respect to when pre-filter's are called), if it has the same name as - one, or be added to the end. - :DEFAULT-PRINTER printer-list - Use the given PRINTER-LIST as a format to print any instructions of - this format when they don't specify something else. - - Each ARG-DEF defines one argument in the format, and is of the form - (Arg-Name {Arg-Key Value}*) - - Possible ARG-KEYs (the values are evaulated unless otherwise specified): - - :FIELDS byte-spec-list - The argument takes values from these fields in the instruction. If - the list is of length one, then the corresponding value is supplied by - itself; otherwise it is a list of the values. The list may be NIL. - :FIELD byte-spec - The same as :FIELDS (list byte-spec). - - :VALUE value - If the argument only has one field, this is the value it should have, - otherwise it's a list of the values of the individual fields. This can - be overridden in an instruction-definition or a format definition - including this one by specifying another, or NIL to indicate that it's - variable. - - :SIGN-EXTEND boolean - If non-NIL, the raw value of this argument is sign-extended, - immediately after being extracted from the instruction (before any - prefilters are run, for instance). If the argument has multiple - fields, they are all sign-extended. - - :TYPE arg-type-name - Inherit any properties of the given argument-type. - - :PREFILTER function - A function which is called (along with all other prefilters, in the - order that their arguments appear in the instruction-format) before - any printing is done, to filter the raw value. Any uses of READ-SUFFIX - must be done inside a prefilter. - - :PRINTER function-string-or-vector - A function, string, or vector which is used to print this argument. - - :USE-LABEL - If non-NIL, the value of this argument is used as an address, and if - that address occurs inside the disassembled code, it is replaced by a - label. If this is a function, it is called to filter the value." - (gen-format-def-form header fields)) - -;;; ---------------------------------------------------------------- - -(declaim (inline bytes-to-bits) - (maybe-inline sign-extend aligned-p align tab tab0)) - -(defun bytes-to-bits (bytes) - (declare (type length bytes)) - (* bytes vm:byte-bits)) - -(defun bits-to-bytes (bits) - (declare (type length bits)) - (multiple-value-bind (bytes rbits) - (truncate bits vm:byte-bits) - (when (not (zerop rbits)) - (error "~d bits is not a byte-multiple" bits)) - bytes)) - -(defun sign-extend (int size) - (declare (type integer int) - (type (integer 0 128) size)) - (if (logbitp (1- size) int) - (dpb int (byte size 0) -1) - int)) - -(defun aligned-p (address size) - "Returns non-NIL if ADDRESS is aligned on a SIZE byte boundary." - (declare (type address address) - (type alignment size)) - (zerop (logand (1- size) address))) - -(defun align (address size) - "Return ADDRESS aligned *upward* to a SIZE byte boundary." - (declare (type address address) - (type alignment size)) - (logandc1 (1- size) (+ (1- size) address))) - -(defun tab (column stream) - (funcall (formatter "~v,1t") stream column) - nil) -(defun tab0 (column stream) - (funcall (formatter "~v,0t") stream column) - nil) - -(defun princ16 (value stream) - (write value :stream stream :radix t :base 16 :escape nil)) - -;;; ---------------------------------------------------------------- - -(defun self-evaluating-p (x) - (typecase x - (null t) - (keyword t) - (symbol (eq x t)) - (cons nil) - (t t))) - -;;; ---------------------------------------------------------------- -;;; Some simple functions that help avoid consing when we're just -;;; recursively filtering things that usually don't change. - -(defun sharing-cons (old-cons car cdr) - "If CAR is eq to the car of OLD-CONS and CDR is eq to the CDR, return - OLD-CONS, otherwise return (cons CAR CDR)." - (if (and (eq car (car old-cons)) (eq cdr (cdr old-cons))) - old-cons - (cons car cdr))) - -(defun sharing-mapcar (fun list) - "A simple (one list arg) mapcar that avoids consing up a new list - as long as the results of calling FUN on the elements of LIST are - eq to the original." - (and list - (sharing-cons list - (funcall fun (car list)) - (sharing-mapcar fun (cdr list))))) - -;;; ---------------------------------------------------------------- -;;; A Dchunk contains the bits we look at to decode an -;;; instruction. -;;; I tried to keep this abstract so that if using integers > the machine -;;; word size conses too much, it can be changed to use bit-vectors or -;;; something. - -(declaim (inline dchunk-or dchunk-and dchunk-clear dchunk-not - dchunk-make-mask dchunk-make-field - sap-ref-dchunk - dchunk-extract - dchunk= - dchunk-count-bits)) - -(defconstant dchunk-bits 32) - -(deftype dchunk () - `(unsigned-byte ,dchunk-bits)) -(deftype dchunk-index () - `(integer 0 ,dchunk-bits)) - -(defconstant dchunk-zero 0) -(defconstant dchunk-one #xFFFFFFFF) - -(defmacro dchunk-copy (x) - `(the dchunk ,x)) - -(defun dchunk-or (to from) - (declare (type dchunk to from)) - (the dchunk (logior to from))) -(defun dchunk-and (to from) - (declare (type dchunk to from)) - (the dchunk (logand to from))) -(defun dchunk-clear (to from) - (declare (type dchunk to from)) - (the dchunk (logandc2 to from))) -(defun dchunk-not (from) - (declare (type dchunk from)) - (the dchunk (logand dchunk-one (lognot from)))) - -(defmacro dchunk-andf (to from) - `(setf ,to (dchunk-and ,to ,from))) -(defmacro dchunk-orf (to from) - `(setf ,to (dchunk-or ,to ,from))) -(defmacro dchunk-clearf (to from) - `(setf ,to (dchunk-clear ,to ,from))) - -(defun dchunk-make-mask (pos) - (the dchunk (mask-field pos -1))) -(defun dchunk-make-field (pos value) - (the dchunk (dpb value pos 0))) - -(defmacro make-dchunk (value) - `(the dchunk ,value)) - -(defun sap-ref-dchunk (sap byte-offset byte-order) - (declare (type system:system-area-pointer sap) - (type offset byte-offset) - (optimize (speed 3) (safety 0))) - (the dchunk - (if (eq byte-order :big-endian) - (+ (ash (system:sap-ref-8 sap byte-offset) 24) - (ash (system:sap-ref-8 sap (+ 1 byte-offset)) 16) - (ash (system:sap-ref-8 sap (+ 2 byte-offset)) 8) - (system:sap-ref-8 sap (+ 3 byte-offset))) - (+ (system:sap-ref-8 sap byte-offset) - (ash (system:sap-ref-8 sap (+ 1 byte-offset)) 8) - (ash (system:sap-ref-8 sap (+ 2 byte-offset)) 16) - (ash (system:sap-ref-8 sap (+ 3 byte-offset)) 24))))) - -(defun correct-dchunk-bytespec-for-endianness (bs unit-bits byte-order) - (if (eq byte-order :big-endian) - (byte (byte-size bs) (+ (byte-position bs) (- dchunk-bits unit-bits))) - bs)) - -(defun dchunk-extract (from pos) - (declare (type dchunk from)) - (the dchunk (ldb pos (the dchunk from)))) - -(defun dchunk-corrected-extract (from pos unit-bits byte-order) - (declare (type dchunk from)) - (if (eq byte-order :big-endian) - (ldb (byte (byte-size pos) - (+ (byte-position pos) (- dchunk-bits unit-bits))) - (the dchunk from)) - (ldb pos (the dchunk from)))) - -(defmacro dchunk-insertf (place pos value) - `(setf ,place (the dchunk (dpb ,value ,pos (the dchunk,place))))) - -(defun dchunk= (x y) - (declare (type dchunk x y)) - (= x y)) -(defmacro dchunk-zerop (x) - `(dchunk= ,x dchunk-zero)) - -(defun dchunk-strict-superset-p (sup sub) - (and (zerop (logandc2 sub sup)) - (not (zerop (logandc2 sup sub))))) - -(defun dchunk-count-bits (x) - (declare (type dchunk x)) - (logcount x)) - -;;; ---------------------------------------------------------------- - -(defstruct (params (:print-function %print-params)) - (instructions (make-hash-table :test #'eq) :type hash-table) - (inst-space nil :type (or null inst-space)) - (instruction-alignment vm:word-bytes :type alignment) - (location-column-width default-location-column-width :type text-width) - (opcode-column-width default-opcode-column-width :type (or null text-width)) - (backend (required-argument) :type c::backend) ; for convenience - ) - -(defun %print-params (params stream level) - (declare (ignore level)) - (print-unreadable-object (params stream :type t) - (when (params-backend params) - (prin1 (c:backend-name (params-backend params)) stream)))) - -;;; ---------------------------------------------------------------- -;;; Only used during compilation of the instructions for a backend - -(defstruct (argument (:conc-name arg-)) - (name nil :type symbol) - (fields nil :type list) - - (value nil :type (or list integer)) - (sign-extend-p nil :type (member t nil)) - - ;; position in a vector of prefiltered values - (position 0 :type fixnum) - - ;; functions to use - (printer nil) - (prefilter nil) - (use-label nil) - ) - -(defstruct (instruction-format (:conc-name format-)) - (name nil) - (args nil :type list) - - (length 0 :type length) ; in bytes - - (default-printer nil :type list) - ) - -;;; ---------------------------------------------------------------- -;;; - -(defstruct (instruction (:conc-name inst-) - (:print-function %print-instruction) - (:constructor - make-instruction (name - format-name - print-name - length - mask id - printer - labeller prefilter control))) - (name nil :type (or symbol string)) - (format-name nil :type (or symbol string)) - - (mask dchunk-zero :type dchunk) ; bits in the inst that are constant - (id dchunk-zero :type dchunk) ; value of those constant bits - - (length 0 :type length) ; in bytes - - (print-name nil :type symbol) - - ;; disassembly functions - (prefilter nil :type (or null function)) - (labeller nil :type (or null function)) - (printer (required-argument) :type (or null function)) - (control nil :type (or null function)) - - ;; instructions that are the same as this instruction but with more - ;; constraints - (specializers nil :type list) - ) - -(defun %print-instruction (inst stream depth) - (declare (ignore depth)) - (print-unreadable-object (inst stream :type t :identity t) - (format stream "~a(~a)" (inst-name inst) (inst-format-name inst)))) - -;;; ---------------------------------------------------------------- -;;; provide more meaningful error messages during compilation - -(defvar *current-instruction-flavor* nil) - -(defun pd-error (fmt &rest args) - (if *current-instruction-flavor* - (error "~@<In printer-definition for ~s(~s): ~3i~:_~?~:>" - (car *current-instruction-flavor*) - (cdr *current-instruction-flavor*) - fmt args) - (apply #'error fmt args))) - -;;; ---------------------------------------------------------------- -;;; Since we can't include some values in compiled output as they are -;;; (notably functions), we sometimes use a valsrc structure to keep track of -;;; the source from which they were derived. - -(defstruct (valsrc (:constructor %make-valsrc)) - (value nil) - (source nil)) - -;;; Returns a version of THING suitable for including in an evaluable -;;; position in some form. -(defun source-form (thing) - (cond ((valsrc-p thing) - (valsrc-source thing)) - ((functionp thing) - (pd-error - "Can't dump functions, so function ref form must be quoted: ~s" - thing)) - ((self-evaluating-p thing) - thing) - ((eq (car thing) 'function) - thing) - (t - `',thing))) - -;;; Returns anything but a valsrc structure. -(defun value-or-source (thing) - (if (valsrc-p thing) - (valsrc-value thing) - thing)) - -(defun make-valsrc (value source) - (cond ((equal value source) - source) - ((and (listp value) (eq (car value) 'function)) - value) - (t - (%make-valsrc :value value :source source)))) - -;;; ---------------------------------------------------------------- -;;; A funstate holds the state of any arguments used in a disassembly -;;; function. - -(defstruct (funstate (:conc-name funstate-) (:constructor %make-funstate)) - (args nil :type list) - (arg-temps nil :type list) ; see below - ) - -(defun make-funstate (args) - ;; give the args a position - (let ((i 0)) - (dolist (arg args) - (setf (arg-position arg) i) - (incf i))) - (%make-funstate :args args)) - -(defun arg-or-lose (name funstate) - (let ((arg (find name (funstate-args funstate) :key #'arg-name))) - (when (null arg) - (pd-error "Unknown argument ~s" name)) - arg)) - -(defun get-arg-temp (arg kind funstate) - (let ((this-arg-temps (assoc arg (funstate-arg-temps funstate)))) - (if this-arg-temps - (let ((this-kind-temps - (assoc (canonicalize-arg-form-kind kind) - (cdr this-arg-temps)))) - (values (cadr this-kind-temps) (cddr this-kind-temps))) - (values nil nil)))) - -(defun make-arg-temp-bindings (funstate) - ;; Everything is in reverse order, so we just use push, which results in - ;; everything being in the right order at the end. - (let ((bindings nil)) - (dolist (ats (funstate-arg-temps funstate)) - (dolist (atk (cdr ats)) - (cond ((null (cadr atk))) - ((atom (cadr atk)) - (push `(,(cadr atk) ,(cddr atk)) bindings)) - (t - (mapc #'(lambda (var form) - (push `(,var ,form) bindings)) - (cadr atk) - (cddr atk)))))) - bindings)) - -(defun set-arg-temps (vars forms arg kind funstate) - (let ((this-arg-temps - (or (assoc arg (funstate-arg-temps funstate)) - (car (push (cons arg nil) (funstate-arg-temps funstate))))) - (kind (canonicalize-arg-form-kind kind))) - (let ((this-kind-temps - (or (assoc kind (cdr this-arg-temps)) - (car (push (cons kind nil) (cdr this-arg-temps)))))) - (setf (cdr this-kind-temps) (cons vars forms))))) - -(defun gen-arg-forms (arg kind funstate) - (multiple-value-bind (vars forms) - (get-arg-temp arg kind funstate) - (when (null forms) - (multiple-value-bind (new-forms single-value-p) - (funcall (find-arg-form-producer kind) arg funstate) - (setq forms new-forms) - (cond ((or single-value-p (atom forms)) - (unless (symbolp forms) - (setq vars (gensym)))) - ((every #'symbolp forms) - ;; just use the same as the forms - (setq vars nil)) - (t - (setq vars nil) - (dotimes (i (length forms)) - (push (gensym) vars)))) - (set-arg-temps vars forms arg kind funstate))) - (or vars forms))) - -(defun funstate-compatible-p (funstate args) - (every #'(lambda (this-arg-temps) - (let* ((old-arg (car this-arg-temps)) - (new-arg (find (arg-name old-arg) args :key #'arg-name))) - (and new-arg - (every #'(lambda (this-kind-temps) - (funcall (find-arg-form-checker - (car this-kind-temps)) - new-arg - old-arg)) - (cdr this-arg-temps))))) - (funstate-arg-temps funstate))) - -(defun maybe-listify (forms) - (cond ((atom forms) - forms) - ((/= (length forms) 1) - `(list ,@forms)) - (t - (car forms)))) - -(defun arg-value-form (arg funstate - &optional - (kind :final) - (allow-multiple-p (not (eq kind :numeric)))) - (let ((forms (gen-arg-forms arg kind funstate))) - (when (and (not allow-multiple-p) - (listp forms) - (/= (length forms) 1)) - (pd-error "~s must not have multiple values" arg)) - (maybe-listify forms))) - -;;; ---------------------------------------------------------------- -;;; These are the kind of values we can compute for an argument, and -;;; how to compute them. The :checker functions make sure that a given -;;; argument is compatible with another argument for a given use. - -(defvar *arg-form-kinds* nil) - -(defstruct arg-form-kind - (names nil :type list) - (producer (required-argument) :type function) - (checker (required-argument) :type function) - ) - -(defun arg-form-kind-or-lose (kind) - (or (getf *arg-form-kinds* kind) - (pd-error "Unknown arg-form kind ~s" kind))) - -(defun find-arg-form-producer (kind) - (arg-form-kind-producer (arg-form-kind-or-lose kind))) -(defun find-arg-form-checker (kind) - (arg-form-kind-checker (arg-form-kind-or-lose kind))) - -(defun canonicalize-arg-form-kind (kind) - (car (arg-form-kind-names (arg-form-kind-or-lose kind)))) - -(defmacro def-arg-form-kind ((&rest names) &rest inits) - `(let ((kind (make-arg-form-kind :names ',names ,@inits))) - ,@(mapcar #'(lambda (name) - `(setf (getf *arg-form-kinds* ',name) kind)) - names))) - -(def-arg-form-kind (:raw) - :producer #'(lambda (arg funstate) - (declare (ignore funstate)) - (mapcar #'(lambda (bytespec) - `(the (unsigned-byte ,(byte-size bytespec)) - (local-extract ',bytespec))) - (arg-fields arg))) - :checker #'(lambda (new-arg old-arg) - (equal (arg-fields new-arg) - (arg-fields old-arg)))) - -(def-arg-form-kind (:sign-extended :unfiltered) - :producer #'(lambda (arg funstate) - (let ((raw-forms (gen-arg-forms arg :raw funstate))) - (if (and (arg-sign-extend-p arg) (listp raw-forms)) - (mapcar #'(lambda (form field) - `(the (signed-byte ,(byte-size field)) - (sign-extend ,form - ,(byte-size field)))) - raw-forms - (arg-fields arg)) - raw-forms))) - :checker #'(lambda (new-arg old-arg) - (equal (arg-sign-extend-p new-arg) - (arg-sign-extend-p old-arg)))) - -(defun valsrc-equal (f1 f2) - (if (null f1) - (null f2) - (equal (value-or-source f1) - (value-or-source f2)))) - -(def-arg-form-kind (:filtering) - :producer #'(lambda (arg funstate) - (let ((sign-extended-forms - (gen-arg-forms arg :sign-extended funstate)) - (pf (arg-prefilter arg))) - (if pf - (values - `(local-filter ,(maybe-listify sign-extended-forms) - ,(source-form pf)) - t) - (values sign-extended-forms nil)))) - :checker #'(lambda (new-arg old-arg) - (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg)))) - -(def-arg-form-kind (:filtered :unadjusted) - :producer #'(lambda (arg funstate) - (let ((pf (arg-prefilter arg))) - (if pf - (values `(local-filtered-value ,(arg-position arg)) t) - (gen-arg-forms arg :sign-extended funstate)))) - :checker #'(lambda (new-arg old-arg) - (let ((pf1 (arg-prefilter new-arg)) - (pf2 (arg-prefilter old-arg))) - (if (null pf1) - (null pf2) - (= (arg-position new-arg) - (arg-position old-arg)))))) - -(def-arg-form-kind (:adjusted :numeric :unlabelled) - :producer #'(lambda (arg funstate) - (let ((filtered-forms (gen-arg-forms arg :filtered funstate)) - (use-label (arg-use-label arg))) - (if (and use-label (not (eq use-label t))) - (list - `(adjust-label ,(maybe-listify filtered-forms) - ,(source-form use-label))) - filtered-forms))) - :checker #'(lambda (new-arg old-arg) - (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg)))) - -(def-arg-form-kind (:labelled :final) - :producer #'(lambda (arg funstate) - (let ((adjusted-forms - (gen-arg-forms arg :adjusted funstate)) - (use-label (arg-use-label arg))) - (if use-label - (let ((form (maybe-listify adjusted-forms))) - (if (and (not (eq use-label t)) - (not (atom adjusted-forms)) - (/= (Length adjusted-forms) 1)) - (pd-error - "Cannot label a multiple-field argument ~ - unless using a function: ~s" arg) - `((lookup-label ,form)))) - adjusted-forms))) - :checker #'(lambda (new-arg old-arg) - (let ((lf1 (arg-use-label new-arg)) - (lf2 (arg-use-label old-arg))) - (if (null lf1) (null lf2) t)))) - -;;; This is a bogus kind that's just used to ensure that printers are -;;; compatible... -(def-arg-form-kind (:printed) - :producer #'(lambda (&rest noise) - (declare (ignore noise)) - (pd-error "Bogus! Can't use the :printed value of an arg!")) - :checker #'(lambda (new-arg old-arg) - (valsrc-equal (arg-printer new-arg) (arg-printer old-arg)))) - -(defun remember-printer-use (arg funstate) - (set-arg-temps nil nil arg :printed funstate)) - -;;; ---------------------------------------------------------------- - -(defun compare-fields-form (val-form-1 val-form-2) - (flet ((listify-fields (fields) - (cond ((symbolp fields) fields) - ((every #'constantp fields) `',fields) - (t `(list ,@fields))))) - (cond ((or (symbolp val-form-1) (symbolp val-form-2)) - `(equal ,(listify-fields val-form-1) - ,(listify-fields val-form-2))) - (t - `(and ,@(mapcar #'(lambda (v1 v2) `(= ,v1 ,v2)) - val-form-1 val-form-2)))))) - -(defun compile-test (subj test funstate) - (when (and (consp test) (symbolp (car test)) (not (keywordp (car test)))) - (setf subj (car test) - test (cdr test))) - (let ((key (if (consp test) (car test) test)) - (body (if (consp test) (cdr test) nil))) - (cond ((null key) - nil) - ((eq key t) - t) - ((eq key :constant) - (let* ((arg (arg-or-lose subj funstate)) - (fields (arg-fields arg)) - (consts body)) - (when (not (= (length fields) (length consts))) - (pd-error "number of constants doesn't match number of fields ~ - in: (~s :constant~{ ~s~})" - subj body)) - (compare-fields-form (gen-arg-forms arg :numeric funstate) - consts))) - ((eq key :positive) - `(> ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric) - 0)) - ((eq key :negative) - `(< ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric) - 0)) - ((eq key :same-as) - (let ((arg1 (arg-or-lose subj funstate)) - (arg2 (arg-or-lose (car body) funstate))) - (unless (and (= (length (arg-fields arg1)) - (length (arg-fields arg2))) - (every #'(lambda (bs1 bs2) - (= (byte-size bs1) (byte-size bs2))) - (arg-fields arg1) - (arg-fields arg2))) - (pd-error "Can't compare differently sized fields: ~ - (~s :same-as ~s)" subj (car body))) - (compare-fields-form (gen-arg-forms arg1 :numeric funstate) - (gen-arg-forms arg2 :numeric funstate)))) - ((eq key :or) - `(or ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate)) - body))) - ((eq key :and) - `(and ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate)) - body))) - ((eq key :not) - `(not ,(compile-test subj (car body) funstate))) - ((and (consp key) (null body)) - (compile-test subj key funstate)) - (t - (pd-error "Bogus test-form: ~s" test))))) - -;;; ---------------------------------------------------------------- - -(defun find-first-field-name (tree) - "Returns the first non-keyword symbol in a depth-first search of TREE." - (cond ((null tree) - nil) - ((and (symbolp tree) (not (keywordp tree))) - tree) - ((atom tree) - nil) - ((eq (car tree) 'quote) - nil) - (t - (or (find-first-field-name (car tree)) - (find-first-field-name (cdr tree)))))) - -(defun string-or-qsym-p (thing) - (or (stringp thing) - (and (consp thing) - (eq (car thing) 'quote) - (or (stringp (cadr thing)) - (symbolp (cadr thing)))))) - -(defun strip-quote (thing) - (if (and (consp thing) (eq (car thing) 'quote)) - (cadr thing) - thing)) - -(defun compile-printer-list (sources funstate) - (unless (null sources) - ;; Coalesce adjacent symbols/strings, and convert to strings if possible, - ;; since they require less consing to write. - (do ((el (car sources) (car sources)) - (names nil (cons (strip-quote el) names))) - ((not (string-or-qsym-p el)) - (when names - ;; concatenate adjacent strings and symbols - (let ((string - (apply #'concatenate - 'string - (mapcar #'string (nreverse names))))) - (push (if (some #'alpha-char-p string) - `',(make-symbol string) ; preserve casifying output - string) - sources)))) - (pop sources)) - (cons (compile-printer-body (car sources) funstate) - (compile-printer-list (cdr sources) funstate)))) - -(defun compile-print (arg-name funstate &optional printer) - (let* ((arg (arg-or-lose arg-name funstate)) - (printer (or printer (arg-printer arg))) - (printer-val (value-or-source printer)) - (printer-src (source-form printer))) - (remember-printer-use arg funstate) - (cond ((stringp printer-val) - `(local-format-arg ,(arg-value-form arg funstate) ,printer-val)) - ((vectorp printer-val) - `(local-princ - (aref ,printer-src - ,(arg-value-form arg funstate :numeric)))) - ((or (functionp printer-val) - (and (consp printer-val) (eq (car printer-val) 'function))) - `(local-call-arg-printer ,(arg-value-form arg funstate) - ,printer-src)) - ((or (null printer-val) (eq printer-val t)) - `(,(if (arg-use-label arg) 'local-princ16 'local-princ) - ,(arg-value-form arg funstate))) - (t - (pd-error "Illegal printer: ~s" printer-src))))) - -(defun compile-printer-body (source funstate) - (cond ((null source) - nil) - ((eq source :name) - `(local-print-name)) - ((eq source :tab) - `(local-tab-to-arg-column)) - ((keywordp source) - (pd-error "Unknown printer element: ~s" source)) - ((symbolp source) - (compile-print source funstate)) - ((atom source) - `(local-princ ',source)) - ((eq (car source) :using) - (unless (or (stringp (cadr source)) - (and (listp (cadr source)) - (eq (caadr source) 'function))) - (pd-error "First arg to :USING must be a string or #'function")) - (compile-print (caddr source) funstate - (cons (eval (cadr source)) (cadr source)))) - ((eq (car source) :plus-integer) - ;; prints the given field proceed with a + or a - - (let ((form - (arg-value-form (arg-or-lose (cadr source) funstate) - funstate - :numeric))) - `(progn - (when (>= ,form 0) - (local-write-char #\+)) - (local-princ ,form)))) - ((eq (car source) 'quote) - `(local-princ ,source)) - ((eq (car source) 'function) - `(local-call-global-printer ,source)) - ((eq (car source) :cond) - `(cond ,@(mapcar #'(lambda (clause) - `(,(compile-test (find-first-field-name - (cdr clause)) - (car clause) - funstate) - ,@(compile-printer-list (cdr clause) - funstate))) - (cdr source)))) - ;; :if, :unless, and :when are replaced by :cond during preprocessing - (t - `(progn ,@(compile-printer-list source funstate))))) - -;;; ---------------------------------------------------------------- -;;; Note that these things are compiled with (speed 3) (safety 0) more -;;; for the resulting size of the code than for actual speed (compiling -;;; with space>speed usually increases the size of the code!)... - -(defun make-printer-defun (source funstate function-name) - (let ((printer-form (compile-printer-list source funstate)) - (bindings (make-arg-temp-bindings funstate))) - `(defun ,function-name (chunk inst stream dstate) - (declare (type dchunk chunk) - (type instruction inst) - (type stream stream) - (type disassem-state dstate) - (optimize (speed 3) (safety 0) (debug 0))) - (macrolet ((local-format-arg (arg fmt) - `(funcall (formatter ,fmt) stream ,arg))) - (flet ((local-tab-to-arg-column () - (tab (dstate-argument-column dstate) stream)) - (local-print-name () - (princ (inst-print-name inst) stream)) - (local-write-char (ch) - (write-char ch stream)) - (local-princ (thing) - (princ thing stream)) - (local-princ16 (thing) - (princ16 thing stream)) - (local-call-arg-printer (arg printer) - (funcall printer arg stream dstate)) - (local-call-global-printer (fun) - (funcall fun chunk inst stream dstate)) - (local-filtered-value (offset) - (declare (type filtered-value-index offset)) - (aref (dstate-filtered-values dstate) offset)) - (local-extract (bytespec) - (dchunk-extract chunk bytespec)) - (lookup-label (lab) - (or (gethash lab (dstate-label-hash dstate)) - lab)) - (adjust-label (val adjust-fun) - (funcall adjust-fun val dstate))) - (declare (ignorable #'local-tab-to-arg-column - #'local-print-name - #'local-princ #'local-princ16 - #'local-write-char - #'local-call-arg-printer - #'local-call-global-printer - #'local-extract - #'local-filtered-value - #'lookup-label #'adjust-label) - (inline local-tab-to-arg-column - local-princ local-princ16 - local-call-arg-printer local-call-global-printer - local-filtered-value local-extract - lookup-label adjust-label)) - (let* ,bindings - ,@printer-form)))))) - -;;; ---------------------------------------------------------------- - -(defun all-arg-refs-relevent-p (printer args) - (cond ((or (null printer) (keywordp printer) (eq printer t)) - t) - ((symbolp printer) - (find printer args :key #'arg-name)) - ((listp printer) - (every #'(lambda (x) (all-arg-refs-relevent-p x args)) - printer)) - (t t))) - -(defun pick-printer-choice (choices args) - (dolist (choice choices - (pd-error "No suitable choice found in ~s" choices)) - (when (all-arg-refs-relevent-p choice args) - (return choice)))) - -(defun preprocess-chooses (printer args) - (cond ((atom printer) - printer) - ((eq (car printer) :choose) - (pick-printer-choice (cdr printer) args)) - (t - (sharing-mapcar #'(lambda (sub) (preprocess-chooses sub args)) - printer)))) - -;;; ---------------------------------------------------------------- - -(defun preprocess-test (subj form args) - (multiple-value-bind (subj test) - (if (and (consp form) (symbolp (car form)) (not (keywordp (car form)))) - (values (car form) (cdr form)) - (values subj form)) - (let ((key (if (consp test) (car test) test)) - (body (if (consp test) (cdr test) nil))) - (case key - (:constant - (if (null body) - ;; if no supplied constant values, just any constant is ok, just - ;; see if there's some constant value in the arg. - (not - (null - (arg-value - (or (find subj args :key #'arg-name) - (pd-error "Unknown argument ~s" subj))))) - ;; otherwise, defer to run-time - form)) - ((:or :and :not) - (sharing-cons - form - subj - (sharing-cons - test - key - (sharing-mapcar - #'(lambda (sub-test) - (preprocess-test subj sub-test args)) - body)))) - (t form))))) - -(defun preprocess-conditionals (printer args) - (if (atom printer) - printer - (case (car printer) - (:unless - (preprocess-conditionals - `(:cond ((:not ,(nth 1 printer)) ,@(nthcdr 2 printer))) - args)) - (:when - (preprocess-conditionals `(:cond (,(cdr printer))) args)) - (:if - (preprocess-conditionals - `(:cond (,(nth 1 printer) ,(nth 2 printer)) - (t ,(nth 3 printer))) - args)) - (:cond - (sharing-cons - printer - :cond - (sharing-mapcar - #'(lambda (clause) - (let ((filtered-body - (sharing-mapcar - #'(lambda (sub-printer) - (preprocess-conditionals sub-printer args)) - (cdr clause)))) - (sharing-cons - clause - (preprocess-test (find-first-field-name filtered-body) - (car clause) - args) - filtered-body))) - (cdr printer)))) - (quote printer) - (t - (sharing-mapcar - #'(lambda (sub-printer) - (preprocess-conditionals sub-printer args)) - printer))))) - -(defun preprocess-printer (printer args) - "Returns a version of the disassembly-template PRINTER with compile-time - tests (e.g. :constant without a value), and any :CHOOSE operators resolved - properly for the args ARGS. (:CHOOSE Sub*) simply returns the first Sub in - which every field reference refers to a valid arg." - (preprocess-conditionals (preprocess-chooses printer args) args)) - -;;; ---------------------------------------------------------------- - -(defstruct (cached-function (:conc-name cached-fun-)) - (funstate nil :type (or null funstate)) - (constraint nil :type list) - (name nil :type (or null symbol))) - -(defun find-cached-function (cached-funs args constraint) - (dolist (cached-fun cached-funs nil) - (let ((funstate (cached-fun-funstate cached-fun))) - (when (and (equal constraint (cached-fun-constraint cached-fun)) - (or (null funstate) - (funstate-compatible-p funstate args))) - (return cached-fun))))) - -(defmacro with-cached-function ((name-var funstate-var cache cache-slot - args &key constraint prefix) - &body defun-maker-forms) - (let ((cache-var (gensym)) - (constraint-var (gensym))) - `(let* ((,constraint-var ,constraint) - (,cache-var (find-cached-function (,cache-slot ,cache) - ,args ,constraint-var))) - (cond (,cache-var - #+nil - (Format t "~&; Using cached function ~s~%" - (cached-fun-name ,cache-var)) - (values (cached-fun-name ,cache-var) nil)) - (t - (let* ((,name-var (gensym ,prefix)) - (,funstate-var (make-funstate ,args)) - (,cache-var - (make-cached-function :name ,name-var - :funstate ,funstate-var - :constraint ,constraint-var))) - #+nil - (format t "~&; Making new function ~s~%" - (cached-fun-name ,cache-var)) - (values ,name-var - `(progn - ,(progn ,@defun-maker-forms) - (eval-when (compile eval) - (push ,,cache-var - (,',cache-slot ',,cache))))))))))) - -;;; ---------------------------------------------------------------- - -(defstruct function-cache - (printers nil :type list) - (labellers nil :type list) - (prefilters nil :type list)) - -(defun find-printer-fun (printer-source args cache) - (if (null printer-source) - (values nil nil) - (let ((printer-source (preprocess-printer printer-source args))) - (with-cached-function - (name funstate cache function-cache-printers args - :constraint printer-source - :prefix "PRINTER") - (make-printer-defun printer-source funstate name))))) - -(defun find-labeller-fun (args cache) - (let ((labelled-fields - (mapcar #'arg-name (remove-if-not #'arg-use-label args)))) - (if (null labelled-fields) - (values nil nil) - (with-cached-function - (name funstate cache function-cache-labellers args - :prefix "LABELLER" - :constraint labelled-fields) - (let ((labels-form 'labels)) - (dolist (arg args) - (when (arg-use-label arg) - (setf labels-form - `(let ((labels ,labels-form) - (addr - ,(arg-value-form arg funstate :adjusted nil))) - (if (assoc addr labels :test #'eq) - labels - (cons (cons addr nil) labels)))))) - `(defun ,name (chunk labels dstate) - (declare (type list labels) - (type dchunk chunk) - (type disassem-state dstate) - (optimize (speed 3) (safety 0) (debug 0))) - (flet ((local-filtered-value (offset) - (declare (type filtered-value-index offset)) - (aref (dstate-filtered-values dstate) offset)) - (local-extract (bytespec) - (dchunk-extract chunk bytespec)) - (adjust-label (val adjust-fun) - (funcall adjust-fun val dstate))) - (declare (ignorable #'local-filtered-value #'local-extract - #'adjust-label) - (inline local-filtered-value local-extract - adjust-label)) - (let* ,(make-arg-temp-bindings funstate) - ,labels-form)))))))) - -(defun find-prefilter-fun (args cache) - (let ((filtered-args - (mapcar #'arg-name (remove-if-not #'arg-prefilter args)))) - (if (null filtered-args) - (values nil nil) - (with-cached-function - (name funstate cache function-cache-prefilters args - :prefix "PREFILTER" - :constraint filtered-args) - (collect ((forms)) - (dolist (arg args) - (let ((pf (arg-prefilter arg))) - (when pf - (forms - `(setf (local-filtered-value ,(arg-position arg)) - ,(maybe-listify - (gen-arg-forms arg :filtering funstate))))) - )) - `(defun ,name (chunk dstate) - (declare (type dchunk chunk) - (type disassem-state dstate) - (optimize (speed 3) (safety 0) (debug 0))) - (flet (((setf local-filtered-value) (value offset) - (declare (type filtered-value-index offset)) - (setf (aref (dstate-filtered-values dstate) offset) - value)) - (local-filter (value filter) - (funcall filter value dstate)) - (local-extract (bytespec) - (dchunk-extract chunk bytespec))) - (declare (ignorable #'local-filter #'local-extract) - (inline (setf local-filtered-value) - local-filter local-extract)) - ;; use them for side-effects only - (let* ,(make-arg-temp-bindings funstate) - ,@(forms))))))))) - -;;; ---------------------------------------------------------------- - -(defun set-arg-from-type (arg type-name table) - (let ((type-arg (find type-name table :key #'arg-name))) - (when (null type-arg) - (pd-error "Unknown argument type: ~s" type-name)) - (setf (arg-printer arg) (arg-printer type-arg)) - (setf (arg-prefilter arg) (arg-prefilter type-arg)) - (setf (arg-sign-extend-p arg) (arg-sign-extend-p type-arg)) - (setf (arg-use-label arg) (arg-use-label type-arg)))) - -(defun modify-or-add-arg (arg-name - args - type-table - &key - (value nil value-p) - (type nil type-p) - (prefilter nil prefilter-p) - (printer nil printer-p) - (sign-extend nil sign-extend-p) - (use-label nil use-label-p) - (field nil field-p) - (fields nil fields-p) - format-length) - (let* ((arg-pos (position arg-name args :key #'arg-name)) - (arg - (if (null arg-pos) - (let ((arg (make-argument :name arg-name))) - (if (null args) - (setf args (list arg)) - (push arg (cdr (last args)))) - arg) - (setf (nth arg-pos args) (copy-argument (nth arg-pos args)))))) - (when (and field-p (not fields-p)) - (setf fields (list field)) - (setf fields-p t)) - (when type-p - (set-arg-from-type arg type type-table)) - (when value-p - (setf (arg-value arg) value)) - (when prefilter-p - (setf (arg-prefilter arg) prefilter)) - (when sign-extend-p - (setf (arg-sign-extend-p arg) sign-extend)) - (when printer-p - (setf (arg-printer arg) printer)) - (when use-label-p - (setf (arg-use-label arg) use-label)) - (when fields-p - (when (null format-length) - (error - "~@<In arg ~s: ~3i~:_~ - Can't specify fields except using DEFINE-INSTRUCTION-FORMAT.~:>" - arg-name)) - (setf (arg-fields arg) - (mapcar #'(lambda (bytespec) - (when (> (+ (byte-position bytespec) - (byte-size bytespec)) - format-length) - (error "~@<In arg ~s: ~3i~:_~ - Field ~s doesn't fit in an ~ - instruction-format ~d bits wide.~:>" - arg-name - bytespec - format-length)) - (correct-dchunk-bytespec-for-endianness - bytespec - format-length - (c:backend-byte-order c:*target-backend*))) - fields)) - ) - args)) - -;;; ---------------------------------------------------------------- -;;; Compile time info that we stash in the package of the machine backend - -(defun format-table-name () - (intern "*DISASSEMBLER-INSTRUCTION-FORMATS*")) -(defun arg-type-table-name () - (intern "*DISASSEMBLER-ARG-TYPES*")) -(defun function-cache-name () - (intern "*DISASSEMBLER-CACHED-FUNCTIONS*")) - -;;; ---------------------------------------------------------------- - -(defparameter *arg-function-params* - '((:printer . (value stream dstate)) - (:use-label . (value dstate)) - (:prefilter . (value dstate)))) - -;;; detect things that obviously don't need wrapping, like variable-refs & -;;; #'function -(defun doesnt-need-wrapping-p (form) - (or (symbolp form) - (and (listp form) - (eq (car form) 'function) - (symbolp (cadr form))))) - -(defun make-wrapper (form arg-name funargs prefix) - (if (and (listp form) - (eq (car form) 'function)) - ;; a function def - (let ((wrapper-name (symbolicate prefix "-" arg-name "-WRAPPER")) - (wrapper-args nil)) - (dotimes (i (length funargs)) - (push (gensym) wrapper-args)) - (values `#',wrapper-name - `(defun ,wrapper-name ,wrapper-args - (funcall ,form ,@wrapper-args)))) - ;; something else - (let ((wrapper-name (symbolicate "*" prefix "-" arg-name "-WRAPPER*"))) - (values wrapper-name `(defparameter ,wrapper-name ,form))))) - -(defun munge-fun-refs (params evalp &optional wrap-defs-p (prefix "")) - (let ((params (copy-list params))) - (do ((tail params (cdr tail)) - (wrapper-defs nil)) - ((null tail) - (values params (nreverse wrapper-defs))) - (let ((fun-arg (assoc (car tail) *arg-function-params*))) - (when fun-arg - (let* ((fun-form (cadr tail)) - (quoted-fun-form `',fun-form)) - (when (and wrap-defs-p (not (doesnt-need-wrapping-p fun-form))) - (multiple-value-bind (access-form wrapper-def-form) - (make-wrapper fun-form (car fun-arg) (cdr fun-arg) prefix) - (setf quoted-fun-form `',access-form) - (push wrapper-def-form wrapper-defs))) - (if evalp - (setf (cadr tail) - `(make-valsrc ,fun-form ,quoted-fun-form)) - (setf (cadr tail) - fun-form)))))))) - -;;; ---------------------------------------------------------------- - -(defun gen-preamble-form (args) - "Generate a form to specify global disassembler params. See the - documentation for SET-DISASSEM-PARAMS for more info." - (destructuring-bind - (&key instruction-alignment - address-size - (opcode-column-width nil opcode-column-width-p)) - args - `(progn - (eval-when (compile eval) - ;; these are not in the params because they only exist at compile time - (defparameter ,(format-table-name) (make-hash-table)) - (defparameter ,(arg-type-table-name) nil) - (defparameter ,(function-cache-name) (make-function-cache))) - (let ((params - (or (c:backend-disassem-params c:*target-backend*) - (setf (c:backend-disassem-params c:*target-backend*) - (make-params :backend c::*target-backend*))))) - (declare (ignorable params)) - ,(when instruction-alignment - `(setf (params-instruction-alignment params) - (bits-to-bytes ,instruction-alignment))) - ,(when address-size - `(setf (params-location-column-width params) - (* 2 ,address-size))) - ,(when opcode-column-width-p - `(setf (params-opcode-column-width params) ,opcode-column-width)) - 'disassem-params)))) - -(defun gen-clear-info-form () - `(eval-when (compile eval) - (setf ,(format-table-name) nil) - (setf ,(arg-type-table-name) nil))) - -(defun update-args-form (var name-form descrip-forms evalp - &optional format-length-form) - `(setf ,var - ,(if evalp - `(modify-or-add-arg ,name-form - ,var - ,(arg-type-table-name) - ,@(and format-length-form - `(:format-length - ,format-length-form)) - ,@descrip-forms) - `(apply #'modify-or-add-arg - ,name-form - ,var - ,(arg-type-table-name); - ,@(and format-length-form - `(:format-length ,format-length-form)) - ',descrip-forms)))) - -(defun gen-arg-type-def-form (name args &optional (evalp t)) - "Generate a form to define a disassembler argument type. See - DEFINE-ARGUMENT-TYPE for more info." - (multiple-value-bind (args wrapper-defs) - (munge-fun-refs args evalp t name) - `(progn - ,@wrapper-defs - (eval-when (compile eval) - ,(update-args-form (arg-type-table-name) `',name args evalp)) - ',name))) - -(defun maybe-quote (evalp form) - (if (or evalp (self-evaluating-p form)) form `',form)) - -(defun maybe-quote-list (evalp list) - (if evalp - list - (mapcar #'(lambda (el) (maybe-quote nil el)) list))) - -(defun gen-arg-access-macro-def-form (arg args format-name) - (let* ((funstate (make-funstate args)) - (arg-val-form (arg-value-form arg funstate :adjusted)) - (bindings (make-arg-temp-bindings funstate))) - `(defmacro ,(symbolicate format-name "-" (arg-name arg)) (chunk dstate) - `(let ((chunk ,chunk) (dstate ,dstate)) - (declare (ignorable chunk dstate)) - (flet ((local-filtered-value (offset) - (declare (type filtered-value-index offset)) - (aref (dstate-filtered-values dstate) offset)) - (local-extract (bytespec) - (dchunk-extract chunk bytespec))) - (declare (ignorable #'local-filtered-value #'local-extract) - (inline local-filtered-value local-extract)) - (let* ,',bindings - ,',arg-val-form)))))) - -(defun gen-format-def-form (header descrips &optional (evalp t)) - "Generate a form to define an instruction format. See - DEFINE-INSTRUCTION-FORMAT for more info." - (when (atom header) - (setf header (list header))) - (destructuring-bind (name length &key default-printer include) - header - (let ((args-var (gensym)) - (length-var (gensym)) - (all-wrapper-defs nil) - (arg-count 0)) - (collect ((arg-def-forms)) - (dolist (descrip descrips) - (let ((name (pop descrip))) - (multiple-value-bind (descrip wrapper-defs) - (munge-fun-refs - descrip evalp t (format nil "~:@(~a~)-~d" name arg-count)) - (arg-def-forms - (update-args-form args-var `',name descrip evalp length-var)) - (setf all-wrapper-defs - (nconc wrapper-defs all-wrapper-defs))) - (incf arg-count))) - `(progn - ,@all-wrapper-defs - (eval-when (compile eval) - (let ((,length-var ,length) - (,args-var - ,(and include - `(copy-list - (format-args - (format-or-lose ,include - ,(format-table-name))))))) - ,@(arg-def-forms) - (setf (gethash ',name ,(format-table-name)) - (make-instruction-format - :name ',name - :length (bits-to-bytes ,length-var) - :default-printer ,(maybe-quote evalp default-printer) - :args ,args-var)) - (eval - `(progn - ,@(mapcar #'(lambda (arg) - (when (arg-fields arg) - (gen-arg-access-macro-def-form - arg ,args-var ',name))) - ,args-var))) - ))))))) - -;;; ---------------------------------------------------------------- - -(defun compute-mask-id (args) - (let ((mask dchunk-zero) - (id dchunk-zero)) - (dolist (arg args (values mask id)) - (let ((av (arg-value arg))) - (when av - (do ((fields (arg-fields arg) (cdr fields)) - (values (if (atom av) (list av) av) (cdr values))) - ((null fields)) - (let ((field-mask (dchunk-make-mask (car fields)))) - (when (/= (dchunk-and mask field-mask) dchunk-zero) - (pd-error "Field ~s in arg ~s overlaps some other field" - (car fields) - (arg-name arg))) - (dchunk-insertf id (car fields) (car values)) - (dchunk-orf mask field-mask)))))))) - -(defun install-inst-flavors (name flavors) - (setf (gethash name - (params-instructions - (c:backend-disassem-params c:*target-backend*))) - flavors)) - -(defun format-or-lose (name table) - (or (gethash name table) - (pd-error "Unknown instruction format ~s" name))) - -(defun filter-overrides (overrides evalp) - (mapcar #'(lambda (override) - (list* (car override) (cadr override) - (munge-fun-refs (cddr override) evalp))) - overrides)) - -(defun gen-args-def-form (overrides format-form &optional (evalp t)) - (let ((args-var (gensym))) - `(let ((,args-var (copy-list (format-args ,format-form)))) - ,@(mapcar #'(lambda (override) - (update-args-form args-var - `',(car override) - (and (cdr override) - (cons :value (cdr override))) - evalp)) - overrides) - ,args-var))) - -(defun gen-printer-def-forms-def-form (name def &optional (evalp t)) - (destructuring-bind (format-name (&rest field-defs) - &optional (printer-form :default) - &key - ((:print-name print-name-form) `',name) - control) - def - (let ((format-var (gensym)) - (field-defs (filter-overrides field-defs evalp))) - `(let* ((*current-instruction-flavor* ',(cons name format-name)) - (,format-var (format-or-lose ',format-name ,(format-table-name))) - (args ,(gen-args-def-form field-defs format-var evalp)) - (funcache ,(function-cache-name))) - (multiple-value-bind (printer-fun printer-defun) - (find-printer-fun ,(if (eq printer-form :default) - `(format-default-printer ,format-var) - (maybe-quote evalp printer-form)) - args funcache) - (multiple-value-bind (labeller-fun labeller-defun) - (find-labeller-fun args funcache) - (multiple-value-bind (prefilter-fun prefilter-defun) - (find-prefilter-fun args funcache) - (multiple-value-bind (mask id) - (compute-mask-id args) - (values - `(make-instruction ',',name - ',',format-name - ,',print-name-form - ,(format-length ,format-var) - ,mask - ,id - ,(and printer-fun `#',printer-fun) - ,(and labeller-fun `#',labeller-fun) - ,(and prefilter-fun `#',prefilter-fun) - ,',control) - `(progn - ,@(and printer-defun (list printer-defun)) - ,@(and labeller-defun (list labeller-defun)) - ,@(and prefilter-defun (list prefilter-defun)))) - )))))))) - - -;;; ---------------------------------------------------------------- -;;; combining instructions where one specializes another - -(defun inst-specializes-p (special general) - "Returns non-NIL if the instruction SPECIAL is a more specific version of - GENERAL (i.e., the same instruction, but with more constraints)." - (declare (type instruction special general)) - (let ((smask (inst-mask special)) - (gmask (inst-mask general))) - (and (dchunk= (inst-id general) - (dchunk-and (inst-id special) gmask)) - (dchunk-strict-superset-p smask gmask)))) - -;;; a bit arbitrary, but should work ok... -(defun specializer-rank (inst) - "Returns an integer corresponding to the specifivity of the instruction INST." - (declare (type instruction inst)) - (* (dchunk-count-bits (inst-mask inst)) 4)) - -(defun order-specializers (insts) - "Order the list of instructions INSTS with more specific (more constant - bits, or same-as argument constains) ones first. Returns the ordered list." - (declare (type list insts)) - (sort insts - #'(lambda (i1 i2) - (> (specializer-rank i1) (specializer-rank i2))))) - -(defun specialization-error (insts) - (error "Instructions either aren't related or conflict in some way:~% ~s" insts)) - -(defun try-specializing (insts) - "Given a list of instructions INSTS, Sees if one of these instructions is a - more general form of all the others, in which case they are put into its - specializers list, and it is returned. Otherwise an error is signaled." - (declare (type list insts)) - (let ((masters (copy-list insts))) - (dolist (possible-master insts) - (dolist (possible-specializer insts) - (unless (or (eq possible-specializer possible-master) - (inst-specializes-p possible-specializer possible-master)) - (setf masters (delete possible-master masters)) - (return) ; exit the inner loop - ))) - (cond ((null masters) - (specialization-error insts)) - ((cdr masters) - (error "Multiple specializing masters: ~s" masters)) - (t - (let ((master (car masters))) - (setf (inst-specializers master) - (order-specializers (remove master insts))) - master))))) - -;;; ---------------------------------------------------------------- -;;; choosing an instruction - -(declaim (inline inst-matches-p choose-inst-specialization)) - -(defun inst-matches-p (inst chunk) - "Returns non-NIL if all constant-bits in INST match CHUNK." - (declare (type instruction inst) - (type dchunk chunk)) - (dchunk= (dchunk-and (inst-mask inst) chunk) (inst-id inst))) - -(defun choose-inst-specialization (inst chunk) - "Given an instruction object, INST, and a bit-pattern, CHUNK, picks the - most specific instruction on INST's specializer list who's constraints are - met by CHUNK. If none do, then INST is returned." - (declare (type instruction inst) - (type dchunk chunk)) - (or (dolist (spec (inst-specializers inst) nil) - (declare (type instruction spec)) - (when (inst-matches-p spec chunk) - (return spec))) - inst)) - -;;; ---------------------------------------------------------------- -;;; an instruction space holds all known machine instructions in a form that -;;; can be easily searched - -(defstruct (inst-space (:conc-name ispace-) (:print-function %print-ispace)) - (valid-mask dchunk-zero :type dchunk) ; applies to *children* - (choices nil :type list) - ) - -(defun %print-ispace (ispace stream level) - (declare (ignore level)) - (print-unreadable-object (ispace stream :type t :identity t))) - -(defstruct (inst-space-choice (:conc-name ischoice-)) - (common-id dchunk-zero :type dchunk) ; applies to *parent's* mask - (subspace (required-argument) :type (or inst-space instruction)) - ) - -;;; ---------------------------------------------------------------- -;;; searching for an instruction in instruction space - -(defun find-inst (chunk inst-space) - "Returns the instruction object within INST-SPACE corresponding to the - bit-pattern CHUNK, or NIL if there isn't one." - (declare (type dchunk chunk) - (type (or null inst-space instruction) inst-space)) - (etypecase inst-space - (null nil) - (instruction - (if (inst-matches-p inst-space chunk) - (choose-inst-specialization inst-space chunk) - nil)) - (inst-space - (let* ((mask (ispace-valid-mask inst-space)) - (id (dchunk-and mask chunk))) - (declare (type dchunk id mask)) - (dolist (choice (ispace-choices inst-space)) - (declare (type inst-space-choice choice)) - (when (dchunk= id (ischoice-common-id choice)) - (return (find-inst chunk (ischoice-subspace choice))))))))) - -;;; ---------------------------------------------------------------- -;;; building the instruction space - -(defun build-inst-space (insts &optional (initial-mask dchunk-one)) - "Returns an instruction-space object corresponding to the list of - instructions INSTS. If the optional parameter INITIAL-MASK is supplied, only - bits it has set are used." - ;; This is done by finding any set of bits that's common to - ;; all instructions, building an instruction-space node that selects on those - ;; bits, and recursively handle sets of instructions with a common value for - ;; these bits (which, since there should be fewer instructions than in INSTS, - ;; should have some additional set of bits to select on, etc). If there - ;; are no common bits, or all instructions have the same value within those - ;; bits, TRY-SPECIALIZING is called, which handles the cases of many - ;; variations on a single instruction. - (declare (type list insts) - (type dchunk initial-mask)) - (cond ((null insts) - nil) - ((null (cdr insts)) - (car insts)) - (t - (let ((vmask (dchunk-copy initial-mask))) - (dolist (inst insts) - (dchunk-andf vmask (inst-mask inst))) - (if (dchunk-zerop vmask) - (try-specializing insts) - (let ((buckets nil)) - (dolist (inst insts) - (let* ((common-id (dchunk-and (inst-id inst) vmask)) - (bucket (assoc common-id buckets :test #'dchunk=))) - (cond ((null bucket) - (push (list common-id inst) buckets)) - (t - (push inst (cdr bucket)))))) - (let ((submask (dchunk-clear initial-mask vmask))) - (if (= (length buckets) 1) - (try-specializing insts) - (make-inst-space - :valid-mask vmask - :choices (mapcar #'(lambda (bucket) - (make-inst-space-choice - :subspace (build-inst-space - (cdr bucket) - submask) - :common-id (car bucket))) - buckets)))))))))) - -;;; ---------------------------------------------------------------- -;;; an inst-space printer for debugging purposes - -(defun print-masked-binary (num mask word-size &optional (show word-size)) - (do ((bit (1- word-size) (1- bit))) - ((< bit 0)) - (write-char (cond ((logbitp bit mask) - (if (logbitp bit num) #\1 #\0)) - ((< bit show) #\x) - (t #\space))))) - -(defun print-inst-bits (inst) - (print-masked-binary (inst-id inst) - (inst-mask inst) - dchunk-bits - (bytes-to-bits (inst-length inst)))) - -(defun print-inst-space (inst-space &optional (indent 0)) - "Prints a nicely formatted version of INST-SPACE." - (etypecase inst-space - (null) - (instruction - (format t "~vt[~a(~a)~40t" indent - (inst-name inst-space) - (inst-format-name inst-space)) - (print-inst-bits inst-space) - (dolist (inst (inst-specializers inst-space)) - (format t "~%~vt:~a~40t" indent (inst-name inst)) - (print-inst-bits inst)) - (write-char #\]) - (terpri)) - (inst-space - (format t "~vt---- ~8,'0x ----~%" - indent - (ispace-valid-mask inst-space)) - (map nil - #'(lambda (choice) - (format t "~vt~8,'0x ==>~%" - (+ 2 indent) - (ischoice-common-id choice)) - (print-inst-space (ischoice-subspace choice) - (+ 4 indent))) - (ispace-choices inst-space))))) - -;;;; ---------------------------------------------------------------- -;;;; the actual disassembly part -;;;; ---------------------------------------------------------------- - -;;; Code object layout: -;;; header-word -;;; code-size (starting from first inst, in words) -;;; entry-points (points to first function header) -;;; debug-info -;;; trace-table-offset (starting from first inst, in bytes) -;;; constant1 -;;; constant2 -;;; ... -;;; <padding to dual-word boundry> -;;; start of instructions -;;; ... -;;; function-headers and lra's buried in here randomly -;;; ... -;;; start of trace-table -;;; <padding to dual-word boundry> -;;; -;;; Function header layout (dual word aligned): -;;; header-word -;;; self pointer -;;; next pointer (next function header) -;;; name -;;; arglist -;;; type -;;; -;;; LRA layout (dual word aligned): -;;; header-word - -(declaim (inline words-to-bytes bytes-to-words)) - -(eval-when (eval load compile) ; used in a defconstant - (defun words-to-bytes (num) - "Converts a word-offset NUM to a byte-offset." - (declare (type offset num)) - (ash num vm:word-shift)) - ) - -(defun bytes-to-words (num) - "Converts a byte-offset NUM to a word-offset." - (declare (type offset num)) - (ash num (- vm:word-shift))) - -(defconstant lra-size (words-to-bytes 1)) - -;;; ---------------------------------------------------------------- -;;; - -(defstruct offs-hook - (offset 0 :type offset) - (function (required-argument) :type function) - (before-address nil :type (member t nil))) - -(defstruct (segment (:conc-name seg-) - (:print-function %print-segment) - (:constructor %make-segment)) - (sap-maker (required-argument) :type (function () system:system-area-pointer)) - (length 0 :type length) - (virtual-location 0 :type address) - (storage-info nil :type (or null storage-info)) - (code nil :type (or null kernel:code-component)) - (hooks nil :type list) - ) - -(defun %print-segment (seg stream level) - (declare (ignore level)) - (print-unreadable-object (seg stream :type t) - (let ((addr (system:sap-int (funcall (seg-sap-maker seg))))) - (format stream "#x~x[~d]~:[ (#x~x)~;~*~]~@[ in ~s~]" - addr - (seg-length seg) - (= (seg-virtual-location seg) addr) - (seg-virtual-location seg) - (seg-code seg))))) - -;;; ---------------------------------------------------------------- - -;;; All state during disassembly. We store some seemingly redundant -;;; information so that we can allow garbage collect during disassembly and -;;; not get tripped up by a code block being moved... -(defstruct (disassem-state (:conc-name dstate-) - (:print-function %print-dstate) - (:constructor %make-dstate)) - (cur-offs 0 :type offset) ; offset of current pos in segment - (next-offs 0 :type offset) ; offset of next position - - (segment-sap (required-argument) :type system:system-area-pointer) - ; a sap pointing to our segment - (segment nil :type (or null segment)) ; the current segment - - (alignment vm:word-bytes :type alignment) ; what to align to in most cases - (byte-order :little-endian - :type (member :big-endian :little-endian)) - - (properties nil :type list) ; for user code to hang stuff off of - (filtered-values (make-array max-filtered-value-index) - :type filtered-value-vector) - - (addr-print-len nil :type ; used for prettifying printing - (or null (integer 0 20))) - (argument-column 0 :type column) - (output-state :beginning ; to make output look nicer - :type (member :beginning - :block-boundary - nil)) - - (labels nil :type list) ; alist of (address . label-number) - (label-hash (make-hash-table) ; same thing in a different form - :type hash-table) - - (fun-hooks nil :type list) ; list of function - - ;; these next two are popped as they are used - (cur-labels nil :type list) ; alist of (address . label-number) - (cur-offs-hooks nil :type list) ; list of offs-hook - - (notes nil :type list) ; for the current location - - (current-valid-locations nil ; currently active source variables - :type (or null (vector bit))) - - (params (required-argument) :type params) ; a handy pointer ... - ) - -(defun %print-dstate (dstate stream level) - (declare (ignore level)) - (print-unreadable-object (dstate stream :type t) - (format stream "+~d~@[ in ~s~]" (dstate-cur-offs dstate) (dstate-segment dstate)))) - -(defmacro dstate-get-prop (dstate name) - "Get the value of the property called NAME in DSTATE. Also setf'able." - `(getf (dstate-properties ,dstate) ,name)) - -(defun dstate-cur-addr (dstate) - "Returns the absolute address of the current instruction in DSTATE." - (the address (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate)))) - -(defun dstate-next-addr (dstate) - "Returns the absolute address of the next instruction in DSTATE." - (the address (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-next-offs dstate)))) - -;;; ---------------------------------------------------------------- -;;; function ops - -(defun fun-self (fun) - (declare (type compiled-function fun)) - (kernel:%function-self fun)) - -(defun fun-code (fun) - (declare (type compiled-function fun)) - (kernel:function-code-header (fun-self fun))) - -(defun fun-next (fun) - (declare (type compiled-function fun)) - (kernel:%function-next fun)) - -(defun fun-address (function) - (declare (type compiled-function function)) - (- (kernel:get-lisp-obj-address function) vm:function-pointer-type)) - -(defun fun-insts-offset (function) - "Offset of FUNCTION from the start of its code-component's instruction area." - (declare (type compiled-function function)) - (- (fun-address function) - (system:sap-int (kernel:code-instructions (fun-code function))))) - -(defun fun-offset (function) - "Offset of FUNCTION from the start of its code-component." - (declare (type compiled-function function)) - (words-to-bytes (kernel:get-closure-length function))) - -;;; ---------------------------------------------------------------- -;;; Operations on code-components (which hold the instructions for -;;; one or more functions). - -(defun code-inst-area-length (code-component) - "Returns the length of the instruction area in CODE-COMPONENT." - (declare (type kernel:code-component code-component)) - (kernel:code-header-ref code-component vm:code-trace-table-offset-slot)) - -(defun code-inst-area-address (code-component) - "Returns the address of the instruction area in CODE-COMPONENT." - (declare (type kernel:code-component code-component)) - (system:sap-int (kernel:code-instructions code-component))) - -(defun code-first-function (code-component) - "Returns the first function in CODE-COMPONENT." - (declare (type kernel:code-component code-component)) - (kernel:code-header-ref code-component vm:code-trace-table-offset-slot)) - -(defun segment-offs-to-code-offs (offset segment) - (system:without-gcing - (let* ((seg-base-addr (system:sap-int (funcall (seg-sap-maker segment)))) - (code-addr - (logandc1 vm:lowtag-mask - (kernel:get-lisp-obj-address (seg-code segment)))) - (addr (+ offset seg-base-addr))) - (declare (type address seg-base-addr code-addr addr)) - (- addr code-addr)))) - -(defun code-offs-to-segment-offs (offset segment) - (system:without-gcing - (let* ((seg-base-addr (system:sap-int (funcall (seg-sap-maker segment)))) - (code-addr - (logandc1 vm:lowtag-mask - (kernel:get-lisp-obj-address (seg-code segment)))) - (addr (+ offset code-addr))) - (declare (type address seg-base-addr code-addr addr)) - (- addr seg-base-addr)))) - -(defun code-insts-offs-to-segment-offs (offset segment) - (system:without-gcing - (let* ((seg-base-addr (system:sap-int (funcall (seg-sap-maker segment)))) - (code-insts-addr - (system:sap-int (kernel:code-instructions (seg-code segment)))) - (addr (+ offset code-insts-addr))) - (declare (type address seg-base-addr code-insts-addr addr)) - (- addr seg-base-addr)))) - -;;; ---------------------------------------------------------------- - -(defun lra-hook (chunk stream dstate) - (declare (type dchunk chunk) - (ignore chunk) - (type (or null stream) stream) - (type disassem-state dstate)) - (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate)) - (* 2 vm:word-bytes)) - ;; check type - (= (system:sap-ref-8 (dstate-segment-sap dstate) - (if (eq (dstate-byte-order dstate) - :little-endian) - (dstate-cur-offs dstate) - (+ (dstate-cur-offs dstate) - (1- lra-size)))) - vm:return-pc-header-type)) - (unless (null stream) - (princ '.lra stream)) - (incf (dstate-next-offs dstate) lra-size)) - nil) - -(defun fun-header-hook (stream dstate) - "Print the function-header (entry-point) pseudo-instruction at the current - location in DSTATE to STREAM." - (declare (type (or null stream) stream) - (type disassem-state dstate)) - (unless (null stream) - (let* ((seg (dstate-segment dstate)) - (code (seg-code seg)) - (woffs - (bytes-to-words - (segment-offs-to-code-offs (dstate-cur-offs dstate) seg))) - (name - (kernel:code-header-ref code (+ woffs vm:function-name-slot))) - (args - (kernel:code-header-ref code (+ woffs vm:function-arglist-slot))) - (type - (kernel:code-header-ref code (+ woffs vm:function-type-slot)))) - (format stream ".~a ~s~:a" 'entry name args) - (note #'(lambda (stream) - (format stream "~:s" type)) ; use format to print NIL as () - dstate))) - (incf (dstate-next-offs dstate) - (words-to-bytes vm:function-code-offset))) - -;;; ---------------------------------------------------------------- - -(defun alignment-hook (chunk stream dstate) - (declare (type dchunk chunk) - (ignore chunk) - (type (or null stream) stream) - (type disassem-state dstate)) - (let ((location - (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate))) - (alignment (dstate-alignment dstate))) - (unless (aligned-p location alignment) - (when stream - (format stream "~a~vt~d~%" '.align - (dstate-argument-column dstate) - alignment)) - (incf(dstate-next-offs dstate) - (- (align location alignment) location))) - nil)) - -(defun rewind-current-segment (dstate segment) - (declare (type disassem-state dstate) - (type segment segment)) - (setf (dstate-segment dstate) segment) - (setf (dstate-cur-offs-hooks dstate) - (stable-sort (nreverse (copy-list (seg-hooks segment))) - #'(lambda (oh1 oh2) - (or (< (offs-hook-offset oh1) (offs-hook-offset oh2)) - (and (= (offs-hook-offset oh1) - (offs-hook-offset oh2)) - (offs-hook-before-address oh1) - (not (offs-hook-before-address oh2))))))) - (setf (dstate-cur-offs dstate) 0) - (setf (dstate-cur-labels dstate) (dstate-labels dstate))) - -(defun do-offs-hooks (before-address stream dstate) - (declare (type (or null stream) stream) - (type disassem-state dstate)) - (let ((cur-offs (dstate-cur-offs dstate))) - (setf (dstate-next-offs dstate) cur-offs) - (loop - (let ((next-hook (car (dstate-cur-offs-hooks dstate)))) - (when (null next-hook) - (return)) - (let ((hook-offs (offs-hook-offset next-hook))) - (when (or (> hook-offs cur-offs) - (and (= hook-offs cur-offs) - before-address - (not (offs-hook-before-address next-hook)))) - (return)) - (unless (< hook-offs cur-offs) - (funcall (offs-hook-function next-hook) stream dstate)) - (pop (dstate-cur-offs-hooks dstate)) - (unless (= (dstate-next-offs dstate) cur-offs) - (return))))))) - -(defun do-fun-hooks (chunk stream dstate) - (let ((hooks (dstate-fun-hooks dstate)) - (cur-offs (dstate-cur-offs dstate))) - (setf (dstate-next-offs dstate) cur-offs) - (dolist (hook hooks nil) - (let ((prefix-p (funcall hook chunk stream dstate))) - (unless (= (dstate-next-offs dstate) cur-offs) - (return prefix-p)))))) - -(defun handle-bogus-instruction (stream dstate) - (let ((alignment (dstate-alignment dstate))) - (unless (null stream) - (multiple-value-bind (words bytes) - (truncate alignment vm:word-bytes) - (when (> words 0) - (print-words words stream dstate)) - (when (> bytes 0) - (print-bytes bytes stream dstate)))) - (incf (dstate-next-offs dstate) alignment))) - -(defun map-segment-instructions (function segment dstate &optional stream) - "Iterate through the instructions in SEGMENT, calling FUNCTION - for each instruction, with arguments of CHUNK, STREAM, and DSTATE." - (declare (type function function) - (type segment segment) - (type disassem-state dstate) - (type (or null stream) stream)) - - (let ((ispace (get-inst-space (dstate-params dstate))) - (prefix-p nil)) ; just processed a prefix inst - - (rewind-current-segment dstate segment) - - (loop - (when (>= (dstate-cur-offs dstate) - (seg-length (dstate-segment dstate))) - ;; done! - (return)) - - (setf (dstate-next-offs dstate) (dstate-cur-offs dstate)) - - (do-offs-hooks t stream dstate) - (unless (or prefix-p (null stream)) - (print-current-address stream dstate)) - (do-offs-hooks nil stream dstate) - - (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) - (system:without-gcing - (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment))) - - (let ((chunk - (sap-ref-dchunk (dstate-segment-sap dstate) - (dstate-cur-offs dstate) - (dstate-byte-order dstate)))) - (let ((fun-prefix-p (do-fun-hooks chunk stream dstate))) - (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) - (setf prefix-p fun-prefix-p) - (let ((inst (find-inst chunk ispace))) - (cond ((null inst) - (handle-bogus-instruction stream dstate)) - (t - (setf (dstate-next-offs dstate) - (+ (dstate-cur-offs dstate) - (inst-length inst))) - - (let ((prefilter (inst-prefilter inst)) - (control (inst-control inst))) - (when prefilter - (funcall prefilter chunk dstate)) - - (funcall function chunk inst) - - (setf prefix-p (null (inst-printer inst))) - - (when control - (funcall control chunk inst stream dstate)))))) - ))))) - - (setf (dstate-cur-offs dstate) (dstate-next-offs dstate)) - - (unless (null stream) - (unless prefix-p - (print-notes-and-newline stream dstate)) - (setf (dstate-output-state dstate) nil))))) - -;;; ---------------------------------------------------------------- - -(defun add-segment-labels (segment dstate) - "Make an initial non-printing disassembly pass through DSTATE, noting any - addresses that are referenced by instructions in this segment." - ;; add labels at the beginning with a label-number of nil; we'll notice - ;; later and fill them in (and sort them) - (declare (type disassem-state dstate)) - (let ((labels (dstate-labels dstate))) - (map-segment-instructions - #'(lambda (chunk inst) - (declare (type dchunk chunk) (type instruction inst)) - (let ((labeller (inst-labeller inst))) - (when labeller - (setf labels (funcall labeller chunk labels dstate))))) - segment - dstate) - (setf (dstate-labels dstate) labels) - ;; erase any notes that got there by accident - (setf (dstate-notes dstate) nil))) - -(defun number-labels (dstate) - "If any labels in DSTATE have been added since the last call to this - function, give them label-numbers, enter them in the hash-table, and make - sure the label list is in sorted order." - (let ((labels (dstate-labels dstate))) - (when (and labels (null (cdar labels))) - ;; at least one label left un-numbered - (setf labels (sort labels #'< :key #'car)) - (let ((max -1) - (label-hash (dstate-label-hash dstate))) - (dolist (label labels) - (when (not (null (cdr label))) - (setf max (max max (cdr label))))) - (dolist (label labels) - (when (null (cdr label)) - (incf max) - (setf (cdr label) max) - (setf (gethash (car label) label-hash) - (format nil "L~d" max))))) - (setf (dstate-labels dstate) labels)))) - -;;; ---------------------------------------------------------------- - -(defun get-inst-space (params) - "Get the instruction-space from PARAMS, creating it if necessary." - (declare (type params params)) - (let ((ispace (params-inst-space params))) - (when (null ispace) - (let ((insts nil)) - (maphash #'(lambda (name inst-flavs) - (declare (ignore name)) - (dolist (flav inst-flavs) - (push flav insts))) - (params-instructions params)) - (setf ispace (build-inst-space insts))) - (setf (params-inst-space params) ispace)) - ispace)) - -;;; ---------------------------------------------------------------- -;;; add global hooks - -(defun add-offs-hook (segment addr hook) - (let ((entry (cons addr hook))) - (if (null (seg-hooks segment)) - (setf (seg-hooks segment) (list entry)) - (push entry (cdr (last (seg-hooks segment))))))) - -(defun add-offs-note-hook (segment addr note) - (add-offs-hook segment - addr - #'(lambda (stream dstate) - (declare (type (or null stream) stream) - (type disassem-state dstate)) - (when stream - (note note dstate))))) - -(defun add-offs-comment-hook (segment addr comment) - (add-offs-hook segment - addr - #'(lambda (stream dstate) - (declare (type (or null stream) stream) - (ignore dstate)) - (when stream - (write-string ";;; " stream) - (etypecase comment - (string - (write-string comment stream)) - (function - (funcall comment stream))) - (terpri stream))))) - -(defun add-fun-hook (dstate function) - (push function (dstate-fun-hooks dstate))) - -;;; ---------------------------------------------------------------- - -(defun set-location-printing-range (dstate from length) - (setf (dstate-addr-print-len dstate) - ;; 4 bits per hex digit - (ceiling (integer-length (logxor from (+ from length))) 4))) - -(defun print-current-address (stream dstate) - "Print the current address in DSTATE to STREAM, plus any labels that - correspond to it, and leave the cursor in the instruction column." - (declare (type stream stream) - (type disassem-state dstate)) - (let* ((location - (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate))) - (location-column-width - (params-location-column-width (dstate-params dstate))) - (plen (dstate-addr-print-len dstate))) - - (when (null plen) - (setf plen location-column-width) - (set-location-printing-range dstate - (seg-virtual-location (dstate-segment dstate)) - (seg-length (dstate-segment dstate)))) - (when (eq (dstate-output-state dstate) :beginning) - (setf plen location-column-width)) - - (fresh-line stream) - - ;; print the location - ;; [this is equivalent to (format stream "~v,'0x:" plen printed-value), but - ;; usually avoids any consing] - (tab0 (- location-column-width plen) stream) - (let* ((printed-bits (* 4 plen)) - (printed-value (ldb (byte printed-bits 0) location)) - (leading-zeros - (truncate (- printed-bits (integer-length printed-value)) 4))) - (dotimes (i leading-zeros) - (write-char #\0 stream)) - (unless (zerop printed-value) - (write printed-value :stream stream :base 16 :radix nil)) - (write-char #\: stream)) - - ;; print any labels - (loop - (let* ((next-label (car (dstate-cur-labels dstate))) - (label-location (car next-label))) - (when (or (null label-location) (> label-location location)) - (return)) - (unless (< label-location location) - (format stream " L~d:" (cdr next-label))) - (pop (dstate-cur-labels dstate)))) - - ;; move to the instruction column - (tab0 (+ location-column-width 1 label-column-width) stream) - )) - -;;; ---------------------------------------------------------------- - -(defmacro with-print-restrictions (&rest body) - `(let ((*print-pretty* t) - (*print-lines* 2) - (*print-length* 4) - (*print-level* 3)) - ,@body)) - -(defun print-notes-and-newline (stream dstate) - "Print a newline to STREAM, inserting any pending notes in DSTATE as - end-of-line comments. If there is more than one note, a separate line - will be used for each one." - (declare (type stream stream) - (type disassem-state dstate)) - (with-print-restrictions - (dolist (note (dstate-notes dstate)) - (format stream "~vt; " *note-column*) - (etypecase note - (string - (write-string note stream)) - (function - (funcall note stream))) - (terpri stream)) - (fresh-line stream) - (setf (dstate-notes dstate) nil))) - -(defun print-bytes (num stream dstate) - "Disassemble NUM bytes to STREAM as simple `BYTE' instructions" - (declare (type offset num) - (type stream stream) - (type disassem-state dstate)) - (format stream "~a~vt" 'BYTE (dstate-argument-column dstate)) - (let ((sap (dstate-segment-sap dstate)) - (start-offs (dstate-cur-offs dstate))) - (dotimes (offs num) - (unless (zerop offs) - (write-string ", " stream)) - (format stream "#x~2,'0x" (system:sap-ref-8 sap (+ offs start-offs)))))) - -(defun print-words (num stream dstate) - "Disassemble NUM machine-words to STREAM as simple `WORD' instructions" - (declare (type offset num) - (type stream stream) - (type disassem-state dstate)) - (format stream "~a~vt" 'WORD (dstate-argument-column dstate)) - (let ((sap (dstate-segment-sap dstate)) - (start-offs (dstate-cur-offs dstate)) - (byte-order (dstate-byte-order dstate))) - (dotimes (word-offs num) - (unless (zerop word-offs) - (write-string ", " stream)) - (let ((word 0) (bit-shift 0)) - (dotimes (byte-offs vm:word-bytes) - (let ((byte - (system:sap-ref-8 - sap - (+ start-offs (* word-offs vm:word-bytes) byte-offs)))) - (setf word - (if (eq byte-order :big-endian) - (+ (ash word vm:byte-bits) byte) - (+ word (ash byte bit-shift)))) - (incf bit-shift vm:byte-bits))) - (format stream "#x~v,'0x" (ash vm:word-bits -2) word))))) - -;;; ---------------------------------------------------------------- - -(defvar *default-dstate-hooks* (list #'lra-hook)) - -(defun make-dstate (params &optional (fun-hooks *default-dstate-hooks*)) - "Make a disassembler-state object." - (declare (type params params)) - (let ((sap - ;; a random address - (system:vector-sap (coerce #() '(vector (unsigned-byte 8))))) - (alignment - (params-instruction-alignment params)) - (arg-column - (+ (or *opcode-column-width* (params-opcode-column-width params) 0) - (params-location-column-width params) - 1 - label-column-width))) - - (when (> alignment 1) - (push #'alignment-hook fun-hooks)) - - (%make-dstate :segment-sap sap - :params params - :fun-hooks fun-hooks - :argument-column arg-column - :alignment alignment - :byte-order (c:backend-byte-order (params-backend params))))) - -(defun add-fun-header-hooks (segment) - (declare (type segment segment)) - (do ((fun (kernel:code-header-ref (seg-code segment) - vm:code-entry-points-slot) - (fun-next fun)) - (length (seg-length segment))) - ((null fun)) - (let ((offset (code-offs-to-segment-offs (fun-offset fun) segment))) - (when (<= 0 offset length) - (push (make-offs-hook :offset offset :function #'fun-header-hook) - (seg-hooks segment)))))) - -;;; ---------------------------------------------------------------- -;;; A sap-maker is a no-argument function that returns a sap. - -(declaim (inline sap-maker)) - -(defun sap-maker (function input offset) - (declare (optimize (speed 3)) - (type (function (t) system:system-area-pointer) function) - (type offset offset)) - (let ((old-sap (system:sap+ (funcall function input) offset))) - (declare (type system:system-area-pointer old-sap)) - #'(lambda () - (let ((new-addr - (+ (system:sap-int (funcall function input)) offset))) - ;; Saving the sap like this avoids consing except when the sap - ;; changes (because the sap-int, arith, etc., get inlined). - (declare (type address new-addr)) - (if (= (system:sap-int old-sap) new-addr) - old-sap - (setf old-sap (system:int-sap new-addr))))))) - -(defun vector-sap-maker (vector offset) - (declare (optimize (speed 3)) - (type offset offset)) - (sap-maker #'system:vector-sap vector offset)) - -(defun code-sap-maker (code offset) - (declare (optimize (speed 3)) - (type kernel:code-component code) - (type offset offset)) - (sap-maker #'kernel:code-instructions code offset)) - -(defun memory-sap-maker (address) - (declare (optimize (speed 3)) - (type address address)) - (let ((sap (system:int-sap address))) - #'(lambda () sap))) - -;;; ---------------------------------------------------------------- - -(defun make-segment (sap-maker length - &key - code virtual-location - debug-function source-form-cache - hooks) - "Return a memory segment located at the system-area-pointer returned by - SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE. - Optional keyword arguments include :VIRTUAL-LOCATION (by default the same as - the address), :DEBUG-FUNCTION, :SOURCE-FORM-CACHE (a source-form-cache - object), and :HOOKS (a list of offs-hook objects)." - (declare (type (function () system:system-area-pointer) sap-maker) - (type length length) - (type (or null address) virtual-location) - (type (or null di:debug-function) debug-function) - (type (or null source-form-cache) source-form-cache)) - (let* ((segment - (%make-segment - :sap-maker sap-maker - :length length - :virtual-location (or virtual-location - (system:sap-int (funcall sap-maker))) - :hooks hooks - :code code))) - (add-debugging-hooks segment debug-function source-form-cache) - (add-fun-header-hooks segment) - segment)) - -(defun make-vector-segment (vector offset &rest args) - (declare (type vector vector) - (type offset offset) - (inline make-segment)) - (apply #'make-segment (vector-sap-maker vector offset) args)) - -(defun make-code-segment (code offset length &rest args) - (declare (type kernel:code-component code) - (type offset offset) - (inline make-segment)) - (apply #'make-segment (code-sap-maker code offset) length :code code args)) - -(defun make-memory-segment (address &rest args) - (declare (type address address) - (inline make-segment)) - (apply #'make-segment (memory-sap-maker address) args)) - -;;; ---------------------------------------------------------------- - -;;; just for fun -(defun print-fun-headers (function) - (declare (type compiled-function function)) - (let* ((self (fun-self function)) - (code (kernel:function-code-header self))) - (format t "Code-header ~s: size: ~s, trace-table-offset: ~s~%" - code - (kernel:code-header-ref code vm:code-code-size-slot) - (kernel:code-header-ref code vm:code-trace-table-offset-slot)) - (do ((fun (kernel:code-header-ref code vm:code-entry-points-slot) - (fun-next fun))) - ((null fun)) - (let ((fun-offset (kernel:get-closure-length fun))) - ;; There is function header fun-offset words from the - ;; code header. - (format t "Fun-header ~s at offset ~d (words): ~s~a => ~s~%" - fun - fun-offset - (kernel:code-header-ref - code (+ fun-offset vm:function-name-slot)) - (kernel:code-header-ref - code (+ fun-offset vm:function-arglist-slot)) - (kernel:code-header-ref - code (+ fun-offset vm:function-type-slot))))))) - -;;; ---------------------------------------------------------------- -;;; getting at the source code... - -(defstruct (source-form-cache (:conc-name sfcache-)) - (debug-source nil :type (or null di:debug-source)) - (top-level-form-index -1 :type fixnum) - (top-level-form nil :type list) - (form-number-mapping-table nil :type (or null (vector list))) - (last-location-retrieved nil :type (or null di:code-location)) - (last-form-retrieved -1 :type fixnum) - ) - -(defun get-top-level-form (debug-source tlf-index) - (let ((name (di:debug-source-name debug-source))) - (ecase (di:debug-source-from debug-source) - (:file - (cond ((not (probe-file name)) - (warn "The source file ~s no longer seems to exist" name) - nil) - (t - (let ((start-positions - (di:debug-source-start-positions debug-source))) - (cond ((null start-positions) - (warn "No start positions map") - nil) - (t - (let* ((local-tlf-index - (- tlf-index - (di:debug-source-root-number debug-source))) - (char-offset - (aref start-positions local-tlf-index))) - (with-open-file (f name) - (cond ((= (di:debug-source-created debug-source) - (file-write-date name)) - (file-position f char-offset)) - (t - (warn "Source file ~s has been modified; ~@ - Using form offset instead of file index" - name) - (dotimes (i local-tlf-index) (read f)))) - (read f) - )))))))) - ((:lisp :stream) - (aref name tlf-index))))) - -(defun cache-valid (loc cache) - (and cache - (and (eq (di:code-location-debug-source loc) - (sfcache-debug-source cache)) - (eq (di:code-location-top-level-form-offset loc) - (sfcache-top-level-form-index cache))))) - -(defun get-source-form (loc context &optional cache) - (let* ((cache-valid (cache-valid loc cache)) - (tlf-index (di:code-location-top-level-form-offset loc)) - (form-number (di:code-location-form-number loc)) - (top-level-form - (if cache-valid - (sfcache-top-level-form cache) - (get-top-level-form (di:code-location-debug-source loc) - tlf-index))) - (mapping-table - (if cache-valid - (sfcache-form-number-mapping-table cache) - (di:form-number-translations top-level-form tlf-index)))) - (when (and (not cache-valid) cache) - (setf (sfcache-debug-source cache) (di:code-location-debug-source loc) - (sfcache-top-level-form-index cache) tlf-index - (sfcache-top-level-form cache) top-level-form - (sfcache-form-number-mapping-table cache) mapping-table)) - (cond ((null top-level-form) - nil) - ((> form-number (length mapping-table)) - (warn "Bogus form-number in form! The source file has probably ~@ - been changed too much to cope with") - (when cache - ;; disable future warnings - (setf (sfcache-top-level-form cache) nil)) - nil) - (t - (when cache - (setf (sfcache-last-location-retrieved cache) loc) - (setf (sfcache-last-form-retrieved cache) form-number)) - (di:source-path-context top-level-form - (aref mapping-table form-number) - context))))) - -(defun get-different-source-form (loc context &optional cache) - (if (and (cache-valid loc cache) - (or (= (di:code-location-form-number loc) - (sfcache-last-form-retrieved cache)) - (and (sfcache-last-location-retrieved cache) - (di:code-location= - loc - (sfcache-last-location-retrieved cache))))) - (values nil nil) - (values (get-source-form loc context cache) t))) - -;;; ---------------------------------------------------------------- -;;; stuff to use debugging-info to augment the disassembly - -(defun code-function-map (code) - (declare (type kernel:code-component code)) - (di::get-debug-info-function-map (kernel:%code-debug-info code))) - -(defstruct location-group - (locations #() :type (vector (or list fixnum))) - ) - -(defstruct storage-info - (groups nil :type list) ; alist of (name . location-group) - (debug-variables #() :type vector) - ) - -(defun dstate-debug-variables (dstate) - "Return the vector of debug-variables currently associated with DSTATE." - (declare (type disassem-state dstate)) - (storage-info-debug-variables (seg-storage-info (dstate-segment dstate)))) - -(defun find-valid-storage-location (offset lg-name dstate) - "Given the OFFSET of a location within the location-group called LG-NAME, - see if there's a current mapping to a source variable in DSTATE, and if so, - return the offset of that variable in the current debug-variable vector." - (declare (type offset offset) - (type symbol lg-name) - (type disassem-state dstate)) - (let* ((storage-info - (seg-storage-info (dstate-segment dstate))) - (location-group - (and storage-info - (cdr (assoc lg-name (storage-info-groups storage-info))))) - (currently-valid - (dstate-current-valid-locations dstate))) - (and location-group - (not (null currently-valid)) - (let ((locations (location-group-locations location-group))) - (and (< offset (length locations)) - (let ((used-by (aref locations offset))) - (and used-by - (let ((debug-var-num - (typecase used-by - (fixnum - (and (not - (zerop (bit currently-valid used-by))) - used-by)) - (list - (some #'(lambda (num) - (and (not - (zerop - (bit currently-valid num))) - num)) - used-by))))) - (and debug-var-num - (progn - ;; Found a valid storage reference! - ;; can't use it again until it's revalidated... - (setf (bit (dstate-current-valid-locations - dstate) - debug-var-num) - 0) - debug-var-num)) - )))))))) - -(defun grow-vector (vec new-len &optional initial-element) - "Return a new vector which has the same contents as the old one VEC, plus - new cells (for a total size of NEW-LEN). The additional elements are - initailized to INITIAL-ELEMENT." - (declare (type vector vec) - (type fixnum new-len)) - (let ((new - (make-sequence `(vector ,(array-element-type vec) ,new-len) - new-len - :initial-element initial-element))) - (dotimes (i (length vec)) - (setf (aref new i) (aref vec i))) - new)) - -(defun storage-info-for-debug-function (debug-function) - "Returns a STORAGE-INFO struction describing the object-to-source - variable mappings from DEBUG-FUNCTION." - (declare (type di:debug-function debug-function)) - (let ((sc-vec (c::backend-sc-numbers c:*native-backend*)) - (groups nil) - (debug-variables (di::debug-function-debug-variables debug-function))) - (and debug-variables - (dotimes (debug-var-offset - (length debug-variables) - (make-storage-info :groups groups - :debug-variables debug-variables)) - (let ((debug-var (aref debug-variables debug-var-offset))) - #+nil - (format t ";;; At offset ~d: ~s~%" debug-var-offset debug-var) - (let* ((sc-offset - (di::compiled-debug-variable-sc-offset debug-var)) - (sb-name - (c:sb-name - (c:sc-sb (aref sc-vec (c:sc-offset-scn sc-offset)))))) - #+nil - (format t ";;; SET: ~s[~d]~%" - sb-name (c:sc-offset-offset sc-offset)) - (unless (null sb-name) - (let ((group (cdr (assoc sb-name groups)))) - (when (null group) - (setf group (make-location-group)) - (push `(,sb-name . ,group) groups)) - (let* ((locations (location-group-locations group)) - (length (length locations)) - (offset (c:sc-offset-offset sc-offset))) - (when (>= offset length) - (setf locations - (grow-vector locations - (max (* 2 length) - (1+ offset)) - nil) - (location-group-locations group) - locations)) - (let ((already-there (aref locations offset))) - (cond ((null already-there) - (setf (aref locations offset) debug-var-offset)) - ((eql already-there debug-var-offset)) - (t - (if (listp already-there) - (pushnew debug-var-offset - (aref locations offset)) - (setf (aref locations offset) - (list debug-var-offset - already-there))))) - ))))))) - ))) - -(defun source-available-p (debug-function) - (handler-case - (di:do-debug-function-blocks (block debug-function) - (declare (ignore block)) - (return t)) - (di:no-debug-blocks () nil))) - -(defun print-block-boundary (stream dstate) - (let ((os (dstate-output-state dstate))) - (when (not (eq os :beginning)) - (when (not (eq os :block-boundary)) - (terpri stream)) - (setf (dstate-output-state dstate) - :block-boundary)))) - -(defun add-source-tracking-hooks (segment debug-function &optional sfcache) - "Add hooks to track to track the source code in SEGMENT during - disassembly. SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE - structure, in which case it is used to cache forms from files." - (declare (type segment segment) - (type (or null di:debug-function) debug-function) - (type (or null source-form-cache) sfcache)) - (let ((last-block-pc -1)) - (flet ((add-hook (pc fun &optional before-address) - (push (make-offs-hook - :offset pc ;; ##### FIX to account for non-zero offs in code - :function fun - :before-address before-address) - (seg-hooks segment)))) - (handler-case - (di:do-debug-function-blocks (block debug-function) - (let ((first-location-in-block-p t)) - (di:do-debug-block-locations (loc block) - (let ((pc (di::compiled-code-location-pc loc))) - - ;; Put blank lines in at block boundaries - (when (and first-location-in-block-p - (/= pc last-block-pc)) - (setf first-location-in-block-p nil) - (add-hook pc - #'(lambda (stream dstate) - (print-block-boundary stream dstate)) - t) - (setf last-block-pc pc)) - - ;; Print out corresponding source; this information is not - ;; all that accurate, but it's better than nothing - (unless (zerop (di:code-location-form-number loc)) - (multiple-value-bind (form new) - (get-different-source-form loc 0 sfcache) - (when new - (let ((at-block-begin (= pc last-block-pc))) - (add-hook - pc - #'(lambda (stream dstate) - (declare (ignore dstate)) - (when stream - (unless at-block-begin - (terpri stream)) - (format stream ";;; [~d] " - (di:code-location-form-number loc)) - (prin1-short form stream) - (terpri stream) - (terpri stream))) - t))))) - - ;; Keep track of variable live-ness as best we can - (let ((live-set - (copy-seq (di::compiled-code-location-live-set loc)))) - (add-hook - pc - #'(lambda (stream dstate) - (declare (ignore stream)) - (setf (dstate-current-valid-locations dstate) - live-set) - #+nil - (note #'(lambda (stream) - (let ((*print-length* nil)) - (format stream "Live set: ~s" - live-set))) - dstate)))) - )))) - (di:no-debug-blocks () nil))))) - -(defun add-debugging-hooks (segment debug-function &optional sfcache) - (when debug-function - (setf (seg-storage-info segment) - (storage-info-for-debug-function debug-function)) - (add-source-tracking-hooks segment debug-function sfcache) - (let ((kind (di:debug-function-kind debug-function))) - (flet ((anh (n) - (push (make-offs-hook - :offset 0 - :function #'(lambda (stream dstate) - (declare (ignore stream)) - (note n dstate))) - (seg-hooks segment)))) - (case kind - (:external) - ((nil) - (anh "No-arg-parsing entry point")) - (t - (anh #'(lambda (stream) - (format stream "~s entry point" kind))))))))) - -;;; ---------------------------------------------------------------- - -(defun get-function-segments (function) - "Returns a list of the segments of memory containing machine code - instructions for FUNCTION." - (declare (type compiled-function function)) - (let* ((code (fun-code function)) - (function-map (code-function-map code)) - (fname (kernel:%function-name function)) - (sfcache (make-source-form-cache))) - (let ((first-block-seen-p nil) - (nil-block-seen-p nil) - (last-offset 0) - (last-debug-function nil) - (segments nil)) - (flet ((add-seg (offs len df) - (when (> len 0) - (push (make-code-segment code offs len - :debug-function df - :source-form-cache sfcache) - segments)))) - (dotimes (fmap-index (length function-map)) - (let ((fmap-entry (aref function-map fmap-index))) - (etypecase fmap-entry - (integer - (when first-block-seen-p - (add-seg last-offset - (- fmap-entry last-offset) - last-debug-function) - (setf last-debug-function nil)) - (setf last-offset fmap-entry)) - (c::compiled-debug-function - (let ((name (c::compiled-debug-function-name fmap-entry)) - (kind (c::compiled-debug-function-kind fmap-entry))) - #+nil - (format t ";;; SAW ~s ~s ~s,~s ~d,~d~%" - name kind first-block-seen-p nil-block-seen-p - last-offset - (c::compiled-debug-function-start-pc fmap-entry)) - (cond (#+nil (eq last-offset fun-offset) - (and (equal name fname) (not first-block-seen-p)) - (setf first-block-seen-p t)) - ((eq kind :external) - (when first-block-seen-p - (return))) - ((eq kind nil) - (when nil-block-seen-p - (return)) - (when first-block-seen-p - (setf nil-block-seen-p t)))) - (setf last-debug-function - (di::make-compiled-debug-function fmap-entry code)) - ))))) - (let ((max-offset (code-inst-area-length code))) - (when (and first-block-seen-p last-debug-function) - (add-seg last-offset - (- max-offset last-offset) - last-debug-function)) - (if (null segments) - (let ((offs (fun-insts-offset function))) - (make-code-segment code offs (- max-offset offs))) - (nreverse segments))))))) - -(defun get-code-segments (code - &optional - (start-offs 0) - (length (code-inst-area-length code))) - "Returns a list of the segments of memory containing machine code - instructions for the code-component CODE. If START-OFFS and/or LENGTH is - supplied, only that part of the code-segment is used (but these are - constrained to lie within the code-segment)." - (declare (type kernel:code-component code) - (type offset start-offs) - (type length length)) - (let ((segments nil)) - (when code - (let ((function-map (code-function-map code)) - (sfcache (make-source-form-cache))) - (let ((last-offset 0) - (last-debug-function nil)) - (flet ((add-seg (offs len df) - (let* ((restricted-offs - (min (max start-offs offs) (+ start-offs length))) - (restricted-len - (- (min (max start-offs (+ offs len)) - (+ start-offs length)) - restricted-offs))) - (when (> restricted-len 0) - (push (make-code-segment code - restricted-offs restricted-len - :debug-function df - :source-form-cache sfcache) - segments))))) - (dotimes (fmap-index (length function-map)) - (let ((fmap-entry (aref function-map fmap-index))) - (etypecase fmap-entry - (integer - (add-seg last-offset (- fmap-entry last-offset) - last-debug-function) - (setf last-debug-function nil) - (setf last-offset fmap-entry)) - (c::compiled-debug-function - (setf last-debug-function - (di::make-compiled-debug-function fmap-entry code))) - ))) - (when last-debug-function - (add-seg last-offset - (- (code-inst-area-length code) last-offset) - last-debug-function)))))) - (if (null segments) - (make-code-segment code start-offs length) - (nreverse segments)))) - -;;; ---------------------------------------------------------------- - -#+nil -(defun find-function-segment (fun) - "Return the address of the instructions for function and its length. - The length is computed using a heuristic, and so may not be accurate." - (declare (type compiled-function fun)) - (let* ((code - (fun-code fun)) - (fun-addr - (- (kernel:get-lisp-obj-address fun) vm:function-pointer-type)) - (max-length - (code-inst-area-length code)) - (upper-bound - (+ (code-inst-area-address code) max-length))) - (do ((some-fun (code-first-function code) - (fun-next some-fun))) - ((null some-fun) - (values fun-addr (- upper-bound fun-addr))) - (let ((some-addr (fun-address some-fun))) - (when (and (> some-addr fun-addr) - (< some-addr upper-bound)) - (setf upper-bound some-addr)))))) - -;;; ---------------------------------------------------------------- - -(defun segment-overflow (segment dstate) - "Returns two values: the amount by which the last instruction in the - segment goes past the end of the segment, and the offset of the end of the - segment from the beginning of that instruction. If all instructions fit - perfectly, this will return 0 and 0." - (declare (type segment segment) - (type disassem-state dstate)) - (let ((seglen (seg-length segment)) - (last-start 0)) - (map-segment-instructions #'(lambda (chunk inst) - (declare (ignore chunk inst)) - (setf last-start (dstate-cur-offs dstate))) - segment - dstate) - (values (- (dstate-cur-offs dstate) seglen) - (- seglen last-start)))) - -(defun label-segments (seglist dstate) - "Computes labels for all the memory segments in SEGLIST and adds them to - DSTATE. It's important to call this function with all the segments you're - interested in, so it can find references from one to another." - (declare (type list seglist) - (type disassem-state dstate)) - (dolist (seg seglist) - (add-segment-labels seg dstate)) - ;; now remove any labels that don't point anywhere in the segments we have - (setf (dstate-labels dstate) - (remove-if #'(lambda (lab) - (not - (some #'(lambda (seg) - (let ((start (seg-virtual-location seg))) - (<= start - (car lab) - (+ start (seg-length seg))))) - seglist))) - (dstate-labels dstate)))) - -(defun disassemble-segment (segment stream dstate) - "Disassemble the machine code instructions in SEGMENT to STREAM." - (declare (type segment segment) - (type stream stream) - (type disassem-state dstate)) - (let ((*print-pretty* nil)) ; otherwise the pp conses hugely - (number-labels dstate) - (map-segment-instructions - #'(lambda (chunk inst) - (declare (type dchunk chunk) (type instruction inst)) - (let ((printer (inst-printer inst))) - (when printer - (funcall printer chunk inst stream dstate)))) - segment - dstate - stream))) - -(defun disassemble-segments (segments stream dstate) - "Disassemble the machine code instructions in each memory segment in - SEGMENTS in turn to STREAM." - (declare (type list segments) - (type stream stream) - (type disassem-state dstate)) - (unless (null segments) - (let ((first (car segments)) - (last (car (last segments)))) - (set-location-printing-range dstate - (seg-virtual-location first) - (- (+ (seg-virtual-location last) - (seg-length last)) - (seg-virtual-location first))) - (setf (dstate-output-state dstate) :beginning) - (dolist (seg segments) - (disassemble-segment seg stream dstate))))) - -;;; ---------------------------------------------------------------- -;;; top-level functions - -(defun disassemble-function (function &key (stream *standard-output*) - (use-labels t) - (backend c:*native-backend*)) - "Disassemble the machine code instructions for FUNCTION." - (declare (type compiled-function function) - (type stream stream) - (type (member t nil) use-labels) - (type c::backend backend)) - (let* ((dstate (make-dstate (c:backend-disassem-params backend))) - (segments (get-function-segments function))) - (when use-labels - (label-segments segments dstate)) - (disassemble-segments segments stream dstate))) - -(defun compile-function-lambda-expr (function) - (declare (type function function)) - (multiple-value-bind - (lambda closurep name) - (function-lambda-expression function) - (declare (ignore name)) - (when closurep - (error "Cannot compile a lexical closure")) - (compile nil lambda))) - -(defun compiled-function-or-lose (thing &optional (name thing)) - (cond ((or (symbolp thing) - (and (listp thing) - (eq (car thing) 'lisp:setf))) - (compiled-function-or-lose (fdefinition thing) thing)) - ((eval:interpreted-function-p thing) - (compile-function-lambda-expr thing)) - ((functionp thing) - thing) - ((and (listp thing) - (eq (car thing) 'lisp::lambda)) - (compile nil thing)) - (t - (error "Can't make a compiled function from ~S" name)))) - -(defun disassemble (object &optional (stream *standard-output*) - &key (use-labels t) - (backend c:*native-backend*)) - "Disassemble the machine code associated with OBJECT, which can be a - function, a lambda expression, or a symbol with a function definition. If - it is not already compiled, the compiler is called to produce something to - disassemble. If STREAM is T, *STANDARD-OUTPUT* is used (so you can - use the keywords without having to type it!)." - (declare (type (or function symbol cons) object) - (type (or (member t) stream) stream) - (type (member t nil) use-labels) - (type c::backend backend)) - (disassemble-function (fun-self ; we can't detect closures, so - ; be careful - (compiled-function-or-lose object)) - :stream (if (eq stream t) - *standard-output* - stream) - :use-labels use-labels - :backend backend)) - -(defun disassemble-memory (address - length - &key - (stream *standard-output*) - code-component - (use-labels t) - (backend c:*backend*)) - "Disassembles the given area of memory starting at ADDRESS and LENGTH long. - Note that if CODE-COMPONENT is NIL and this memory could move during a GC, - you'd better disable it around the call to this function." - (declare (type (or address system:system-area-pointer) address) - (type length length) - (type stream stream) - (type (or null kernel:code-component) code-component) - (type (member t nil) use-labels) - (type c::backend backend)) - (let* ((address - (if (system:system-area-pointer-p address) - (system:sap-int address) - address)) - (dstate (make-dstate (c:backend-disassem-params backend))) - (segments - (if code-component - (let ((code-offs - (- address - (system:sap-int - (kernel:code-instructions code-component))))) - (when (or (< code-offs 0) - (> code-offs (code-inst-area-length code-component))) - (error "Address ~x not in the code component ~s." - address code-component)) - (get-code-segments code-component code-offs length)) - (list (make-memory-segment address length))))) - (when use-labels - (label-segments segments dstate)) - (disassemble-segments segments stream dstate))) - -(defun disassemble-code-component (code-component &key - (stream *standard-output*) - (use-labels t) - (backend c:*native-backend*)) - "Disassemble the machine code instructions associated with - CODE-COMPONENT (this may include multiple entry points)." - (declare (type (or null kernel:code-component compiled-function) - code-component) - (type stream stream) - (type (member t nil) use-labels) - (type c::backend backend)) - (let* ((code-component - (if (functionp code-component) - (fun-code code-component) - code-component)) - (dstate (make-dstate (c:backend-disassem-params backend))) - (segments (get-code-segments code-component))) - (when use-labels - (label-segments segments dstate)) - (disassemble-segments segments stream dstate))) - -;;; ---------------------------------------------------------------- -;;; Code for making useful segments from arbitrary lists of code-blocks - -;;; The maximum size of an instruction -- this includes pseudo-instructions -;;; like error traps with their associated operands, so it should be big enough -;;; to include them (i.e. it's not just 4 on a risc machine!). -(defconstant max-instruction-size 16) - -(defun sap-to-vector (sap start end) - (let* ((length (- end start)) - (result (make-array length :element-type '(unsigned-byte 8))) - (sap (system:sap+ sap start))) - (dotimes (i length) - (setf (aref result i) (system:sap-ref-8 sap i))) - result)) - -(defun add-block-segments (sap amount seglist location connecting-vec dstate) - (declare (type list seglist) - (type integer location) - (type (or null (vector (unsigned-byte 8))) connecting-vec) - (type disassem-state dstate)) - (flet ((addit (seg overflow) - (let ((length (+ (seg-length seg) overflow))) - (when (> length 0) - (setf (seg-length seg) length) - (incf location length) - (push seg seglist))))) - (let ((connecting-overflow 0)) - (when connecting-vec - ;; tack on some of the new block to the old overflow vector - (let* ((beginning-of-block-amount - (if sap (min max-instruction-size amount) 0)) - (connecting-vec - (if sap - (concatenate - '(vector (unsigned-byte 8)) - connecting-vec - (sap-to-vector sap 0 beginning-of-block-amount)) - connecting-vec))) - (when (and (< (length connecting-vec) max-instruction-size) - (not (null sap))) - (return-from add-block-segments - ;; We want connecting vectors to be large enough to hold - ;; any instruction, and since the current sap wasn't large - ;; enough to do this (and is now entirely on the end of the - ;; overflow-vector), just save it for next time. - (values seglist location connecting-vec))) - (when (> (length connecting-vec) 0) - (let ((seg - (make-vector-segment connecting-vec - 0 - (- (length connecting-vec) - beginning-of-block-amount) - :virtual-location location))) - (setf connecting-overflow (segment-overflow seg dstate)) - (addit seg connecting-overflow))))) - (cond ((null sap) - ;; Nothing more to add. - (values seglist location nil)) - ((< (- amount connecting-overflow) max-instruction-size) - ;; We can't create a segment with the minimum size - ;; required for an instruction, so just keep on accumulating - ;; in the overflow vector for the time-being. - (values seglist - location - (sap-to-vector sap connecting-overflow amount))) - (t - ;; Put as much as we can into a new segment, and the rest - ;; into the overflow-vector. - (let* ((initial-length - (- amount connecting-overflow max-instruction-size)) - (seg - (make-segment #'(lambda () - (system:sap+ sap connecting-overflow)) - initial-length - :virtual-location location)) - (overflow - (segment-overflow seg dstate))) - (addit seg overflow) - (values seglist - location - (sap-to-vector sap - (+ connecting-overflow (seg-length seg)) - amount)))))))) - -;;; ---------------------------------------------------------------- -;;; Code to disassemble assembler segments. - -(defun assem-segment-to-disassem-segments (assem-segment dstate) - (declare (type new-assem:segment assem-segment) - (type disassem-state dstate)) - (let ((location 0) - (disassem-segments nil) - (connecting-vec nil)) - (new-assem:segment-map-output - assem-segment - #'(lambda (sap amount) - (multiple-value-setq (disassem-segments location connecting-vec) - (add-block-segments sap amount - disassem-segments location - connecting-vec - dstate)))) - (when connecting-vec - (setf disassem-segments - (add-block-segments nil nil - disassem-segments location - connecting-vec - dstate))) - (sort disassem-segments #'< :key #'seg-virtual-location))) - -(defun disassemble-assem-segment (assem-segment stream backend) - "Disassemble the machine code instructions associated with - ASSEM-SEGMENT (of type new-assem:segment)." - (declare (type new-assem:segment assem-segment) - (type stream stream) - (type c::backend backend)) - (let* ((dstate (make-dstate (c:backend-disassem-params backend))) - (disassem-segments - (assem-segment-to-disassem-segments assem-segment dstate))) - (label-segments disassem-segments dstate) - (disassemble-segments disassem-segments stream dstate))) - -;;; ---------------------------------------------------------------- -;;; Routines to find things in the lisp environment. Obviously highly -;;; implementation specific! - -(defconstant groked-symbol-slots - (sort `((,vm:symbol-value-slot . symbol-value) - (,vm:symbol-plist-slot . symbol-plist) - (,vm:symbol-name-slot . symbol-name) - (,vm:symbol-package-slot . symbol-package)) - #'< - :key #'car) - "An alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots in a -symbol object that we know about.") - -(defun grok-symbol-slot-ref (address) - "Given ADDRESS, try and figure out if which slot of which symbol is being - refered to. Of course we can just give up, so it's not a big deal... - Returns two values, the symbol and the name of the access function of the - slot." - (declare (type address address)) - (if (not (aligned-p address vm:word-bytes)) - (values nil nil) - (do ((slots-tail groked-symbol-slots (cdr slots-tail))) - ((null slots-tail) - (values nil nil)) - (let* ((field (car slots-tail)) - (slot-offset (words-to-bytes (car field))) - (maybe-symbol-addr (- address slot-offset)) - (maybe-symbol - (kernel:make-lisp-obj - (+ maybe-symbol-addr vm:other-pointer-type)))) - (when (symbolp maybe-symbol) - (return (values maybe-symbol (cdr field)))))))) - -(defconstant nil-addr (kernel:get-lisp-obj-address nil)) - -(defun grok-nil-indexed-symbol-slot-ref (byte-offset) - "Given a BYTE-OFFSET from NIL, try and figure out if which slot of which - symbol is being refered to. Of course we can just give up, so it's not a big - deal... Returns two values, the symbol and the access function." - (declare (type offset byte-offset)) - (grok-symbol-slot-ref (+ nil-addr byte-offset))) - -(defun get-nil-indexed-object (byte-offset) - "Returns the lisp object located BYTE-OFFSET from NIL." - (declare (type offset byte-offset)) - (kernel:make-lisp-obj (+ nil-addr byte-offset))) - -(defun get-code-constant (byte-offset dstate) - "Returns two values; the lisp-object located at BYTE-OFFSET in the constant - area of the code-object in the current segment and T, or NIL and NIL if - there is no code-object in the current segment." - (declare (type offset byte-offset) - (type disassem-state dstate)) - (let ((code (seg-code (dstate-segment dstate)))) - (if code - (values - (kernel:code-header-ref code - (ash (+ byte-offset vm:other-pointer-type) - (- vm:word-shift))) - t) - (values nil nil)))) - -(defvar *assembler-routines-by-addr* nil) - -(defun find-assembler-routine (address) - "Returns the name of the primitive lisp assembler routine located at - ADDRESS, or NIL if there isn't one." - (declare (type address address)) - (when (null *assembler-routines-by-addr*) - (setf *assembler-routines-by-addr* (make-hash-table)) - (maphash #'(lambda (name address) - (setf (gethash address *assembler-routines-by-addr*) name)) - lisp::*assembler-routines*)) - (gethash address *assembler-routines-by-addr*)) - -;;; ---------------------------------------------------------------- -;;; some handy function for machine-dependent code to use... - -(declaim (maybe-inline sap-ref-int read-suffix)) - -(defun sap-ref-int (sap offset length byte-order) - (declare (type system:system-area-pointer sap) - (type (unsigned-byte 16) offset) - (type (member 1 2 4) length) - (type (member :little-endian :big-endian) byte-order) - (optimize (speed 3) (safety 0))) - (ecase length - (1 (system:sap-ref-8 sap offset)) - (2 (if (eq byte-order :big-endian) - (+ (ash (system:sap-ref-8 sap offset) 8) - (system:sap-ref-8 sap (+ offset 1))) - (+ (ash (system:sap-ref-8 sap (+ offset 1)) 8) - (system:sap-ref-8 sap offset)))) - (4 (if (eq byte-order :big-endian) - (+ (ash (system:sap-ref-8 sap offset) 24) - (ash (system:sap-ref-8 sap (+ 1 offset)) 16) - (ash (system:sap-ref-8 sap (+ 2 offset)) 8) - (system:sap-ref-8 sap (+ 3 offset))) - (+ (system:sap-ref-8 sap offset) - (ash (system:sap-ref-8 sap (+ 1 offset)) 8) - (ash (system:sap-ref-8 sap (+ 2 offset)) 16) - (ash (system:sap-ref-8 sap (+ 3 offset)) 24)))))) - -(defun read-suffix (length dstate) - (declare (type (member 8 16 32) length) - (type disassem-state dstate) - (optimize (speed 3) (safety 0))) - (let ((length (ecase length (8 1) (16 2) (32 4)))) - (declare (type (unsigned-byte 3) length)) - (prog1 - (sap-ref-int (dstate-segment-sap dstate) - (dstate-next-offs dstate) - length - (dstate-byte-order dstate)) - (incf (dstate-next-offs dstate) length)))) - -(defun read-signed-suffix (length dstate) - (declare (type (member 8 16 32) length) - (type disassem-state dstate) - (optimize (speed 3) (safety 0))) - (sign-extend (read-suffix length dstate) length)) - -;;; ---------------------------------------------------------------- -;;; optional routines to make notes about code - -(defun note (note dstate) - "Store NOTE (which can be either a string or a function with a single - stream argument) to be printed as an end-of-line comment after the current - instruction is disassembled." - (declare (type (or string function) note) - (type disassem-state dstate)) - (push note (dstate-notes dstate))) - -(defun prin1-short (thing stream) - (with-print-restrictions - (prin1 thing stream))) - -(defun prin1-quoted-short (thing stream) - (if (self-evaluating-p thing) - (prin1-short thing stream) - (prin1-short `',thing stream))) - -(defun note-code-constant (byte-offset dstate) - "Store a note about the lisp constant located BYTE-OFFSET bytes from the - current code-component, to be printed as an end-of-line comment after the - current instruction is disassembled." - (declare (type offset byte-offset) - (type disassem-state dstate)) - (multiple-value-bind (const valid) - (get-code-constant byte-offset dstate) - (when valid - (note #'(lambda (stream) - (prin1-quoted-short const stream)) - dstate)) - const)) - -(defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate) - "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL - is a valid slot in a symbol, store a note describing which symbol and slot, - to be printed as an end-of-line comment after the current instruction is - disassembled. Returns non-NIL iff a note was recorded." - (declare (type offset nil-byte-offset) - (type disassem-state dstate)) - (multiple-value-bind (symbol access-fun) - (grok-nil-indexed-symbol-slot-ref nil-byte-offset) - (when access-fun - (note #'(lambda (stream) - (prin1 (if (eq access-fun 'symbol-value) - symbol - `(,access-fun ',symbol)) - stream)) - dstate)) - access-fun)) - -(defun maybe-note-nil-indexed-object (nil-byte-offset dstate) - "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL - is a valid lisp object, store a note describing which symbol and slot, to - be printed as an end-of-line comment after the current instruction is - disassembled. Returns non-NIL iff a note was recorded." - (declare (type offset nil-byte-offset) - (type disassem-state dstate)) - (let ((obj (get-nil-indexed-object nil-byte-offset))) - (note #'(lambda (stream) - (prin1-quoted-short obj stream)) - dstate) - t)) - -(defun maybe-note-assembler-routine (address note-address-p dstate) - "If ADDRESS is the address of a primitive assembler routine, store a note - describing which one, to be printed as an end-of-line comment after the - current instruction is disassembled. Returns non-NIL iff a note was - recorded. If NOTE-ADDRESS-P is non-NIL, a note of the address is also made." - (declare (type address address) - (type disassem-state dstate)) - (let ((name (find-assembler-routine address))) - (unless (null name) - (note #'(lambda (stream) - (if NOTE-ADDRESS-P - (format stream "#x~8,'0x: ~s" address name) - (prin1 name stream))) - dstate)) - name)) - -(defun maybe-note-single-storage-ref (offset sc-name dstate) - "If there's a valid mapping from OFFSET in the storage class SC-NAME to a - source variable, make a note of the source-variable name, to be printed as - an end-of-line comment after the current instruction is disassembled. - Returns non-NIL iff a note was recorded." - (declare (type offset offset) - (type symbol sc-name) - (type disassem-state dstate)) - (let ((storage-location - (find-valid-storage-location offset sc-name dstate))) - (when storage-location - (note #'(lambda (stream) - (princ (di:debug-variable-symbol - (aref (storage-info-debug-variables - (seg-storage-info (dstate-segment dstate))) - storage-location)) - stream)) - dstate) - t))) - -(defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate) - "If there's a valid mapping from OFFSET in the storage-base called SB-NAME - to a source variable, make a note equating ASSOC-WITH with the - source-variable name, to be printed as an end-of-line comment after the - current instruction is disassembled. Returns non-NIL iff a note was - recorded." - (declare (type offset offset) - (type symbol sb-name) - (type (or symbol string) assoc-with) - (type disassem-state dstate)) - (let ((storage-location - (find-valid-storage-location offset sb-name dstate))) - (when storage-location - (note #'(lambda (stream) - (format stream "~a = ~s" - assoc-with - (di:debug-variable-symbol - (aref (dstate-debug-variables dstate) - storage-location)) - stream)) - dstate) - t))) - -;;; ---------------------------------------------------------------- -;;; these should be somewhere else... - -(defun get-error-name (errnum backend) - (car (svref (c:backend-internal-errors backend) errnum))) - -(defun get-sc-name (sc-offs backend) - (c::location-print-name - (c::make-random-tn :kind :normal - :sc (svref (c::backend-sc-numbers backend) - (c:sc-offset-scn sc-offs)) - :offset (c:sc-offset-offset sc-offs)))) - -;;; ---------------------------------------------------------------- - -(defun handle-break-args (error-parse-fun stream dstate) - "When called from an error break instruction's :DISASSEM-CONTROL (or - :DISASSEM-PRINTER) function, will correctly deal with printing the - arguments to the break. - - ERROR-PARSE-FUN should be a function that accepts: - 1) a SYSTEM-AREA-POINTER - 2) a BYTE-OFFSET from the SAP to begin at - 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return - the byte length of the arguments (to avoid unnecessary consing) - It should read information from the SAP starting at BYTE-OFFSET, and return - four values: - 1) the error number - 2) the total length, in bytes, of the information - 3) a list of SC-OFFSETs of the locations of the error parameters - 4) a list of the length (as read from the SAP), in bytes, of each of the - return-values." - (declare (type function error-parse-fun) - (type (or null stream) stream) - (type disassem-state dstate)) - (multiple-value-bind (errnum adjust sc-offsets lengths) - (funcall error-parse-fun - (dstate-segment-sap dstate) - (dstate-next-offs dstate) - (null stream)) - (when stream - (setf (dstate-cur-offs dstate) - (dstate-next-offs dstate)) - (flet ((emit-err-arg (note) - (let ((num (pop lengths))) - (print-notes-and-newline stream dstate) - (print-current-address stream dstate) - (print-bytes num stream dstate) - (incf (dstate-cur-offs dstate) num) - (when note - (note note dstate))))) - (let ((backend (params-backend (dstate-params dstate)))) - (emit-err-arg nil) - (emit-err-arg (symbol-name (get-error-name errnum backend))) - (dolist (sc-offs sc-offsets) - (emit-err-arg (get-sc-name sc-offs backend))))) - ) - (incf (dstate-next-offs dstate) adjust) - )) diff --git a/compiler/dyncount.lisp b/compiler/dyncount.lisp deleted file mode 100644 index 4f31496de7dcffb01da7f4523459f15dda46700f..0000000000000000000000000000000000000000 --- a/compiler/dyncount.lisp +++ /dev/null @@ -1,90 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/dyncount.lisp,v 1.6 1992/08/04 08:24:49 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains support for collecting dynamic vop statistics. -;;; -(in-package "C") - -(export '(*collect-dynamic-statistics*)) - -(export '(count-me)) - - -(defvar *collect-dynamic-statistics* nil - "When T, emit extra code to collect dynamic statistics about vop usages.") - -(defvar *dynamic-counts-tn* nil - "Holds the TN for the counts vector.") - - -(defstruct (dyncount-info - (:print-function %print-dyncount-info) - (:make-load-form-fun :just-dump-it-normally)) - for - (counts (required-argument) :type (simple-array (unsigned-byte 32) (*))) - (vops (required-argument) :type simple-vector)) - - -(defprinter dyncount-info - for - counts - vops) - -(defun setup-dynamic-count-info (component) - (declare (ignore component)) - (error "Dynamic statistic collection not implemented for the new-assembler.") - #+nil - (let* ((info (ir2-component-dyncount-info (component-info component))) - (vops (dyncount-info-vops info))) - (when (producing-fasl-file) - (fasl-validate-structure info *compile-object*)) - (do-ir2-blocks (block component) - (let* ((start-vop (ir2-block-start-vop block)) - (1block (ir2-block-block block)) - (block-number (block-number 1block))) - (when (and start-vop block-number) - (let* ((index (1- block-number)) - (counts (svref vops index)) - (length (length counts))) - (do ((vop start-vop (vop-next vop))) - ((null vop)) - (let ((vop-name (vop-info-name (vop-info vop)))) - (do ((i 0 (+ i 4))) - ((or (>= i length) (eq (svref counts i) vop-name)) - (when (>= i length) - (incf length 4) - (let ((new-counts - (make-array length :initial-element 0))) - (when counts - (replace new-counts counts)) - (setf counts new-counts)) - (setf (svref counts i) vop-name)) - (incf (svref counts (1+ i))))))) - (setf (svref vops index) counts))))) - (assem:count-instructions - #'(lambda (vop bytes elsewherep) - (let ((block-number (block-number (ir2-block-block (vop-block vop))))) - (when block-number - (let* ((name (vop-info-name (vop-info vop))) - (counts (svref vops (1- block-number))) - (length (length counts))) - (do ((i 0 (+ i 4))) - ((>= i length) - (error "VOP ~S didn't exist earlier!~% counts=~S" - name counts)) - (when (eq (svref counts i) name) - (incf (svref counts (+ i (if elsewherep 3 2))) bytes) - (return))))))) - *code-segment* - *elsewhere*)) - (undefined-value)) diff --git a/compiler/entry.lisp b/compiler/entry.lisp deleted file mode 100644 index f750d93967e10beceed38f2b6be167c82345af06..0000000000000000000000000000000000000000 --- a/compiler/entry.lisp +++ /dev/null @@ -1,126 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/entry.lisp,v 1.9 1991/05/16 00:24:38 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Code in this file handles VM-independent details of run-time -;;; function representation that primarily concern IR2 conversion and the -;;; dumper/loader. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; Entry-Analyze -- Interface -;;; -;;; This phase runs before IR2 conversion, initializing each XEP's -;;; Entry-Info structure. We call the VM-supplied Select-Component-Format -;;; function to make VM-dependent initializations in the IR2-Component. This -;;; includes setting the IR2-Component-Kind and allocating fixed implementation -;;; overhead in the constant pool. If there was a forward reference to a -;;; function, then the ENTRY-INFO will already exist, but will be -;;; uninitialized. -;;; -(defun entry-analyze (component) - (let ((2comp (component-info component))) - (dolist (fun (component-lambdas component)) - (when (external-entry-point-p fun) - (let ((info (or (leaf-info fun) - (setf (leaf-info fun) (make-entry-info))))) - (compute-entry-info fun info) - (push info (ir2-component-entries 2comp)))))) - - (select-component-format component) - (undefined-value)) - - -;;; Make-Arg-Names -- Internal -;;; -;;; Takes the list representation of the debug arglist and turns it into a -;;; string. -;;; -(defun make-arg-names (x) - (declare (type functional x)) - (let ((args (functional-arg-documentation x))) - (assert (not (eq args :unspecified))) - (if (null args) - "()" - (let ((*print-pretty* t) - (*print-escape* t) - (*print-base* 10) - (*print-radix* nil) - (*print-case* :downcase)) - (write-to-string args))))) - - -;;; Compute-Entry-Info -- Internal -;;; -;;; Initialize Info structure to correspond to the XEP lambda Fun. -;;; -(defun compute-entry-info (fun info) - (declare (type clambda fun) (type entry-info info)) - (let ((bind (lambda-bind fun)) - (internal-fun (functional-entry-function fun))) - (setf (entry-info-closure-p info) - (not (null (environment-closure (lambda-environment fun))))) - (setf (entry-info-offset info) (gen-label)) - (setf (entry-info-name info) - (let ((name (leaf-name internal-fun))) - (or name - (component-name (block-component (node-block bind)))))) - (when (policy bind (>= debug 1)) - (setf (entry-info-arguments info) (make-arg-names internal-fun)) - (setf (entry-info-type info) (type-specifier (leaf-type internal-fun))))) - (undefined-value)) - - -;;; REPLACE-TOP-LEVEL-XEPS -- Interface -;;; -;;; Replace all references to Component's non-closure XEPS that appear in -;;; top-level components, changing to :TOP-LEVEL-XEP functionals. If the -;;; cross-component ref is not in a :TOP-LEVEL component, or is to a closure, -;;; then substitution is suppressed. -;;; -;;; When a cross-component ref is not substituted, we return T to indicate that -;;; early deletion of this component's IR1 should not be done. We also return -;;; T if this component contains :TOP-LEVEL lambdas (though it is not a -;;; :TOP-LEVEL component.) -;;; -;;; We deliberately don't use the normal reference deletion, since we don't -;;; want to trigger deletion of the XEP (although it shouldn't hurt, since this -;;; is called after Component is compiled.) Instead, we just clobber the -;;; REF-LEAF. -;;; -(defun replace-top-level-xeps (component) - (let ((res nil)) - (dolist (lambda (component-lambdas component)) - (case (functional-kind lambda) - (:external - (let* ((ef (functional-entry-function lambda)) - (new (make-functional :kind :top-level-xep - :info (leaf-info lambda) - :name (leaf-name ef) - :lexenv (make-null-environment))) - (closure (environment-closure - (lambda-environment (main-entry ef))))) - (dolist (ref (leaf-refs lambda)) - (let ((ref-component (block-component (node-block ref)))) - (cond ((eq ref-component component)) - ((or (not (eq (component-kind ref-component) :top-level)) - closure) - (setq res t)) - (t - (setf (ref-leaf ref) new) - (push ref (leaf-refs new)))))))) - (:top-level - (setq res t)))) - res)) diff --git a/compiler/envanal.lisp b/compiler/envanal.lisp deleted file mode 100644 index 5c91803e973c12ef6651a78b1009ce64181785d4..0000000000000000000000000000000000000000 --- a/compiler/envanal.lisp +++ /dev/null @@ -1,394 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/envanal.lisp,v 1.22 1992/09/15 17:46:41 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; The environment analysis phase for the compiler. This phase annotates -;;; IR1 with a hierarchy environment structures, determining the environment -;;; that each Lambda allocates its variables and finding what values are closed -;;; over by each environment. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; Environment-Analyze -- Interface -;;; -;;; Do environment analysis on the code in Component. This involves various -;;; things: -;;; 1] Make an Environment structure for each non-let lambda, assigning the -;;; lambda-environment for all lambdas. -;;; 2] Find all values that need to be closed over by each environment. -;;; 3] Scan the blocks in the component closing over non-local-exit -;;; continuations. -;;; 4] Delete all non-top-level functions with no references. This should -;;; only get functions with non-NULL kinds, since normal functions are -;;; deleted when their references go to zero. If *byte-compiling*, then -;;; don't delete optional entries with no references, since the byte -;;; interpreter wants to call entries that the XEP doesn't. -;;; -(defun environment-analyze (component) - (declare (type component component)) - (assert (not (component-new-functions component))) - (dolist (fun (component-lambdas component)) - (reinit-lambda-environment fun)) - (dolist (fun (component-lambdas component)) - (compute-closure fun) - (dolist (let (lambda-lets fun)) - (compute-closure let))) - - (find-non-local-exits component) - (find-cleanup-points component) - (tail-annotate component) - - (dolist (fun (component-lambdas component)) - (when (null (leaf-refs fun)) - (let ((kind (functional-kind fun))) - (unless (or (eq kind :top-level) - (and *byte-compiling* (eq kind :optional))) - (assert (member kind '(:optional :cleanup :escape))) - (setf (functional-kind fun) nil) - (delete-functional fun))))) - - (undefined-value)) - - -;;; PRE-ENVIRONMENT-ANALYZE-TOP-LEVEL -- Interface -;;; -;;; Called on component with top-level lambdas before the compilation of the -;;; associated non-top-level code to detect closed over top-level variables. -;;; We just do COMPUTE-CLOSURE on all the lambdas. This will pre-allocate -;;; environments for all the functions with closed-over top-level variables. -;;; The post-pass will use the existing structure, rather than allocating a new -;;; one. -;;; -(defun pre-environment-analyze-top-level (component) - (declare (type component component)) - (dolist (lambda (component-lambdas component)) - (compute-closure lambda) - (dolist (let (lambda-lets lambda)) - (compute-closure let))) - (undefined-value)) - - -;;; GET-LAMBDA-ENVIRONMENT -- Internal -;;; -;;; If Fun has an environment, return it, otherwise assign one. -;;; -(defun get-lambda-environment (fun) - (declare (type clambda fun)) - (let* ((fun (lambda-home fun)) - (env (lambda-environment fun))) - (or env - (let ((res (make-environment :function fun))) - (setf (lambda-environment fun) res) - (dolist (lambda (lambda-lets fun)) - (setf (lambda-environment lambda) res)) - res)))) - - -;;; REINIT-LAMBDA-ENVIRONMENT -- Internal -;;; -;;; If Fun has no environment, assign one, otherwise clean up variables that -;;; have no sets or refs. If a var has no references, we remove it from the -;;; closure. If it has no sets, we clear the INDIRECT flag. This is -;;; necessary because pre-analysis is done before optimization. -;;; -(defun reinit-lambda-environment (fun) - (let ((old (lambda-environment (lambda-home fun)))) - (cond (old - (setf (environment-closure old) - (delete-if #'(lambda (x) - (and (lambda-var-p x) - (null (leaf-refs x)))) - (environment-closure old))) - (flet ((clear (fun) - (dolist (var (lambda-vars fun)) - (unless (lambda-var-sets var) - (setf (lambda-var-indirect var) nil))))) - (clear fun) - (dolist (let (lambda-lets fun)) - (clear let)))) - (t - (get-lambda-environment fun)))) - (undefined-value)) - - -;;; GET-NODE-ENVIRONMENT -- Internal -;;; -;;; Get node's environment, assigning one if necessary. -;;; -(defun get-node-environment (node) - (declare (type node node)) - (get-lambda-environment (node-home-lambda node))) - - -;;; Compute-Closure -- Internal -;;; -;;; Find any variables in Fun with references outside of the home -;;; environment and close over them. If a closed over variable is set, then we -;;; set the Indirect flag so that we will know the closed over value is really -;;; a pointer to the value cell. We also warn about unreferenced variables -;;; here, just because it's a convenient place to do it. -;;; -(defun compute-closure (fun) - (declare (type clambda fun)) - (let ((env (get-lambda-environment fun))) - (note-unreferenced-vars fun) - (dolist (var (lambda-vars fun)) - (dolist (ref (leaf-refs var)) - (let ((ref-env (get-node-environment ref))) - (unless (eq ref-env env) - (when (lambda-var-sets var) - (setf (lambda-var-indirect var) t)) - (close-over var ref-env env)))) - (dolist (set (basic-var-sets var)) - (let ((set-env (get-node-environment set))) - (unless (eq set-env env) - (setf (lambda-var-indirect var) t) - (close-over var set-env env)))))) - - (undefined-value)) - - -;;; Close-Over -- Internal -;;; -;;; Make sure that Thing is closed over in Ref-Env and in all environments -;;; for the functions that reference Ref-Env's function (not just calls.) -;;; Home-Env is Thing's home environment. When we reach the home environment, -;;; we stop propagating the closure. -;;; -(defun close-over (thing ref-env home-env) - (declare (type environment ref-env home-env)) - (cond ((eq ref-env home-env)) - ((member thing (environment-closure ref-env))) - (t - (push thing (environment-closure ref-env)) - (dolist (call (leaf-refs (environment-function ref-env))) - (close-over thing (get-node-environment call) home-env)))) - (undefined-value)) - - -;;;; Non-local exit: - - -;;; Insert-NLX-Entry-Stub -- Internal -;;; -;;; Insert the entry stub before the original exit target, and add a new -;;; entry to the Environment-Nlx-Info. The %NLX-Entry call in the stub is -;;; passed the NLX-Info as an argument so that the back end knows what entry is -;;; being done. -;;; -;;; The link from the Exit block to the entry stub is changed to be a link to -;;; the component head. Similarly, the Exit block is linked to the component -;;; tail. This leaves the entry stub reachable, but makes the flow graph less -;;; confusing to flow analysis. -;;; -;;; If a catch or an unwind-protect, then we set the Lexenv for the last node -;;; in the cleanup code to be the enclosing environment, to represent the fact -;;; that the binding was undone as a side-effect of the exit. This will cause -;;; a lexical exit to be broken up if we are actually exiting the scope (i.e. -;;; a BLOCK), and will also do any other cleanups that may have to be done on -;;; the way. -;;; -(defun insert-nlx-entry-stub (exit env) - (declare (type environment env) (type exit exit)) - (let* ((exit-block (node-block exit)) - (next-block (first (block-succ exit-block))) - (cleanup (entry-cleanup (exit-entry exit))) - (info (make-nlx-info :cleanup cleanup - :continuation (node-cont exit))) - (entry (exit-entry exit)) - (new-block (insert-cleanup-code exit-block next-block - entry - `(%nlx-entry ',info) - (entry-cleanup entry))) - (component (block-component new-block))) - (unlink-blocks exit-block new-block) - (link-blocks exit-block (component-tail component)) - (link-blocks (component-head component) new-block) - - (setf (nlx-info-target info) new-block) - (push info (environment-nlx-info env)) - (push info (cleanup-nlx-info cleanup)) - (when (member (cleanup-kind cleanup) '(:catch :unwind-protect)) - (setf (node-lexenv (block-last new-block)) - (node-lexenv entry)))) - - (undefined-value)) - - -;;; Note-Non-Local-Exit -- Internal -;;; -;;; Do stuff necessary to represent a non-local exit from the node Exit into -;;; Env. This is called for each non-local exit node, of which there may be -;;; several per exit continuation. This is what we do: -;;; -- If there isn't any NLX-Info entry in the environment, make an entry -;;; stub, otherwise just move the exit block link to the component tail. -;;; -- Close over the NLX-Info in the exit environment. -;;; -- If the exit is from an :Escape function, then substitute a constant -;;; reference to NLX-Info structure for the escape function reference. This -;;; will cause the escape function to be deleted (although not removed from -;;; the DFO.) The escape function is no longer needed, and we don't want to -;;; emit code for it. We then also change the %NLX-ENTRY call to use -;;; the NLX continuation so that there will be a use to represent the NLX -;;; use. -;;; -(defun note-non-local-exit (env exit) - (declare (type environment env) (type exit exit)) - (let ((entry (exit-entry exit)) - (cont (node-cont exit)) - (exit-fun (node-home-lambda exit))) - - (if (find-nlx-info entry cont) - (let ((block (node-block exit))) - (assert (= (length (block-succ block)) 1)) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (component-tail (block-component block)))) - (insert-nlx-entry-stub exit env)) - - (let ((info (find-nlx-info entry cont))) - (assert info) - (close-over info (node-environment exit) env) - (when (eq (functional-kind exit-fun) :escape) - (mapc #'(lambda (x) - (setf (node-derived-type x) *wild-type*)) - (leaf-refs exit-fun)) - (substitute-leaf (find-constant info) exit-fun) - (let ((node (block-last (nlx-info-target info)))) - (delete-continuation-use node) - (add-continuation-use node (nlx-info-continuation info)))))) - - (undefined-value)) - - -;;; Find-Non-Local-Exits -- Internal -;;; -;;; Iterate over the Exits in Component, calling Note-Non-Local-Exit when we -;;; find a block that ends in a non-local Exit node. We also ensure that all -;;; Exit nodes are either non-local or degenerate by calling IR1-Optimize-Exit -;;; on local exits. This makes life simpler for later phases. -;;; -(defun find-non-local-exits (component) - (declare (type component component)) - (dolist (lambda (component-lambdas component)) - (dolist (entry (lambda-entries lambda)) - (dolist (exit (entry-exits entry)) - (let ((target-env (node-environment entry))) - (if (eq (node-environment exit) target-env) - (unless *converting-for-interpreter* - (maybe-delete-exit exit)) - (note-non-local-exit target-env exit)))))) - - (undefined-value)) - - -;;;; Cleanup emission: - -;;; Emit-Cleanups -- Internal -;;; -;;; Zoom up the cleanup nesting until we hit Cleanup1, accumulating cleanup -;;; code as we go. When we are done, convert the cleanup code in an implicit -;;; MV-Prog1. We have to force local call analysis of new references to -;;; Unwind-Protect cleanup functions. If we don't actually have to do -;;; anything, then we don't insert any cleanup code. -;;; -;;; If we do insert cleanup code, we check that Block1 doesn't end in a "tail" -;;; local call. -;;; -;;; We don't need to adjust the ending cleanup of the cleanup block, since -;;; the cleanup blocks are inserted at the start of the DFO, and are thus never -;;; scanned. -;;; -(defun emit-cleanups (block1 block2) - (declare (type cblock block1 block2)) - (collect ((code) - (reanalyze-funs)) - (let ((cleanup2 (block-start-cleanup block2))) - (do ((cleanup (block-end-cleanup block1) - (node-enclosing-cleanup (cleanup-mess-up cleanup)))) - ((eq cleanup cleanup2)) - (let* ((node (cleanup-mess-up cleanup)) - (args (when (basic-combination-p node) - (basic-combination-args node)))) - (ecase (cleanup-kind cleanup) - (:special-bind - (code `(%special-unbind ',(continuation-value (first args))))) - (:catch - (code `(%catch-breakup))) - (:unwind-protect - (code `(%unwind-protect-breakup)) - (let ((fun (ref-leaf (continuation-use (second args))))) - (reanalyze-funs fun) - (code `(%funcall ,fun)))) - ((:block :tagbody) - (dolist (nlx (cleanup-nlx-info cleanup)) - (code `(%lexical-exit-breakup ',nlx))))))) - - (when (code) - (assert (not (node-tail-p (block-last block1)))) - (insert-cleanup-code block1 block2 - (block-last block1) - `(progn ,@(code))) - (dolist (fun (reanalyze-funs)) - (local-call-analyze-1 fun))))) - - (undefined-value)) - - -;;; Find-Cleanup-Points -- Internal -;;; -;;; Loop over the blocks in component, calling Emit-Cleanups when we see a -;;; successor in the same environment with a different cleanup. We ignore the -;;; cleanup transition if it is to a cleanup enclosed by the current cleanup, -;;; since in that case we are just messing up the environment, hence this is -;;; not the place to clean it. -;;; -(defun find-cleanup-points (component) - (declare (type component component)) - (do-blocks (block1 component) - (let ((env1 (block-environment block1)) - (cleanup1 (block-end-cleanup block1))) - (dolist (block2 (block-succ block1)) - (when (block-start block2) - (let ((env2 (block-environment block2)) - (cleanup2 (block-start-cleanup block2))) - (unless (or (not (eq env2 env1)) - (eq cleanup1 cleanup2) - (and cleanup2 - (eq (node-enclosing-cleanup - (cleanup-mess-up cleanup2)) - cleanup1))) - (emit-cleanups block1 block2))))))) - (undefined-value)) - - -;;; Tail-Annotate -- Internal -;;; -;;; Mark all tail-recursive uses of function result continuations with the -;;; corresponding tail-set. Nodes whose type is NIL (i.e. don't return) such -;;; as calls to ERROR are never annotated as tail in order to preserve -;;; debugging information. -;;; -(defun tail-annotate (component) - (declare (type component component)) - (dolist (fun (component-lambdas component)) - (let ((ret (lambda-return fun))) - (when ret - (let ((result (return-result ret))) - (do-uses (use result) - (when (and (immediately-used-p result use) - (or (not (eq (node-derived-type use) *empty-type*)) - (not (basic-combination-p use)) - (eq (basic-combination-kind use) :local))) - (setf (node-tail-p use) t))))))) - (undefined-value)) diff --git a/compiler/eval-comp.lisp b/compiler/eval-comp.lisp deleted file mode 100644 index e7c505c80023d156960d5875eb6c766ef7e30b50..0000000000000000000000000000000000000000 --- a/compiler/eval-comp.lisp +++ /dev/null @@ -1,308 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/eval-comp.lisp,v 1.22 1992/11/25 10:32:12 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file represents the current state of on-going development on compiler -;;; hooks for an interpreter that takes the compiler's IR1 of a program. -;;; -;;; Written by Bill Chiles. -;;; - -(in-package "C") - -(proclaim '(special *constants* *free-variables* *compile-component* - *code-vector* *next-location* *result-fixups* - *free-functions* *source-paths* *failed-optimizations* - *seen-blocks* *seen-functions* *list-conflicts-table* - *continuation-number* *continuation-numbers* - *number-continuations* *tn-id* *tn-ids* *id-tns* - *label-ids* *label-id* *id-labels* - *compiler-error-count* - *compiler-warning-count* *compiler-note-count* - *compiler-error-output* *compiler-error-bailout* - *compiler-trace-output* - *last-source-context* *last-original-source* - *last-source-form* *last-format-string* *last-format-args* - *last-message-count* *check-consistency* - *all-components* *converting-for-interpreter* - *source-info* *block-compile* *current-path* - *current-component* *lexical-environment*)) - -(export '(compile-for-eval lambda-eval-info-frame-size - lambda-eval-info-args-passed lambda-eval-info-entries - lambda-eval-info-function entry-node-info-st-top - entry-node-info-nlx-tag)) - - -;;; COMPILE-FOR-EVAL -- Public. -;;; -;;; This translates form into the compiler's IR1 and performs environment -;;; analysis. It is sort of a combination of NCOMPILE-FILE, SUB-COMPILE-FILE, -;;; COMPILE-TOP-LEVEL, and COMPILE-COMPONENT. -;;; -(defun compile-for-eval (form quietly) - (with-ir1-namespace - (let* ((*block-compile* nil) - (*lexical-environment* (make-null-environment)) - ;; - (*compiler-error-output* - (if quietly - (make-broadcast-stream) - *error-output*)) - (*compiler-trace-output* nil) - (*compiler-error-bailout* - #'(lambda () (error "Fatal error, aborting evaluation."))) - ;; - (*current-path* nil) - (*last-source-context* nil) - (*last-original-source* nil) - (*last-source-form* nil) - (*last-format-string* nil) - (*last-format-args* nil) - (*last-message-count* 0) - ;; - (*compiler-error-count* 0) - (*compiler-warning-count* 0) - (*compiler-note-count* 0) - (*source-info* (make-lisp-source-info form)) - (*converting-for-interpreter* t) - (*gensym-counter* 0)) - - (clear-stuff nil) - (find-source-paths form 0) - ;; - ;; This LET comes from COMPILE-TOP-LEVEL. - ;; The noted DOLIST is a splice from a call that COMPILE-TOP-LEVEL makes. - (with-compilation-unit () - (let ((lambdas (list (ir1-top-level form '(original-source-start 0 0) - t)))) - (declare (list lambdas)) - (dolist (lambda lambdas) - (let* ((component - (block-component (node-block (lambda-bind lambda)))) - (*all-components* (list component))) - (local-call-analyze component))) - (multiple-value-bind (components top-components) - (find-initial-dfo lambdas) - (let ((*all-components* (append components top-components))) - (when *check-consistency* - (check-ir1-consistency *all-components*)) - ;; - ;; This DOLIST body comes from the beginning of - ;; COMPILE-COMPONENT. - (dolist (component *all-components*) - (ir1-finalize component) - (let ((*compile-component* component)) - (environment-analyze component)) - (annotate-component-for-eval component)) - (when *check-consistency* - (check-ir1-consistency *all-components*)))) - (car lambdas)))))) - - -;;;; Annotating IR1 for interpretation. - -(defstruct (lambda-eval-info (:print-function print-lambda-eval-info) - (:constructor make-lambda-eval-info - (frame-size args-passed entries))) - frame-size ;Number of stack locations needed to hold locals. - args-passed ;Number of referenced arguments passed to lambda. - entries ;A-list mapping entry nodes to stack locations. - (function nil)) ;A function object corresponding to this lambda. - -(defun print-lambda-eval-info (obj str n) - (declare (ignore n obj)) - (format str "#<Lambda-eval-info>")) - -(defstruct (entry-node-info (:print-function print-entry-node-info) - (:constructor make-entry-node-info - (st-top nlx-tag))) - st-top ;Stack top when we encounter the entry node. - nlx-tag) ;Tag to which to throw to get back entry node's context. - -(defun print-entry-node-info (obj str n) - (declare (ignore n obj)) - (format str "#<Entry-node-info>")) - - -;;; Some compiler funny functions have definitions, so the interpreter can -;;; call them. These require special action to coordinate the interpreter, -;;; system call stack, and the environment. The annotation prepass marks the -;;; references to these as :unused, so the interpreter doesn't try to fetch -;;; function's through these undefined symbols. -;;; -(defconstant undefined-funny-funs - '(%special-bind %special-unbind %more-arg-context %unknown-values %catch - %unwind-protect %catch-breakup %unwind-protect-breakup %lexical-exit-breakup - %continue-unwind %nlx-entry)) - -;;; Some kinds of functions are only passed as arguments to funny functions, -;;; and are never actually evaluated at run time. -;;; -(defconstant non-closed-function-kinds '(:cleanup :escape)) - -;;; ANNOTATE-COMPONENT-FOR-EVAL -- Internal. -;;; -;;; This annotates continuations, lambda-vars, and lambdas. For each -;;; continuation, we cache how its destination uses its value. This only buys -;;; efficiency when the code executes more than once, but the overhead of this -;;; part of the prepass for code executed only once should be negligible. -;;; -;;; As a special case to aid interpreting local function calls, we sometimes -;;; note the continuation as :unused. This occurs when there is a local call, -;;; and there is no actual function object to call; we mark the continuation as -;;; :unused since there is nothing to push on the interpreter's stack. -;;; Normally we would see a reference to a function that we would push on the -;;; stack to later pop and apply to the arguments on the stack. To determine -;;; when we have a local call with no real function object, we look at the node -;;; to see if it is a reference with a destination that is a :local combination -;;; whose function is the reference node's continuation. -;;; -;;; After checking for virtual local calls, we check for funny functions the -;;; compiler refers to for calling to note certain operations. These functions -;;; are undefined, and if the interpreter tried to reference the function cells -;;; of these symbols, it would get an error. We mark the continuations -;;; delivering the values of these references as :unused, so the reference -;;; never takes place. -;;; -;;; For each lambda-var, including a lambda's vars and its let's vars, we note -;;; the stack offset used to access and store that variable. Then we note the -;;; lambda with the total number of variables, so we know how big its stack -;;; frame is. Also in the lambda's info is the number of its arguments that it -;;; actually references; the interpreter never pushes or pops an unreferenced -;;; argument, so we can't just use LENGTH on LAMBDA-VARS to know how many args -;;; the caller passed. -;;; -;;; For each entry node in a lambda, we associate in the lambda-eval-info the -;;; entry node with a stack offset. Evaluation code stores the frame pointer -;;; in this slot upon processing the entry node to aid stack cleanup and -;;; correct frame manipulation when processing exit nodes. -;;; -(defun annotate-component-for-eval (component) - (do-blocks (b component) - (do-nodes (node cont b) - (let* ((dest (continuation-dest cont)) - (refp (typep node 'ref)) - (leaf (if refp (ref-leaf node)))) - (setf (continuation-info cont) - (cond ((and refp dest (typep dest 'basic-combination) - (eq (basic-combination-kind dest) :local) - (eq (basic-combination-fun dest) cont)) - :unused) - ((and leaf (typep leaf 'global-var) - (eq (global-var-kind leaf) :global-function) - (member (c::global-var-name leaf) undefined-funny-funs - :test #'eq)) - :unused) - ((and leaf (typep leaf 'clambda) - (member (functional-kind leaf) - non-closed-function-kinds)) - (assert (not (eq (functional-kind leaf) :escape))) - :unused) - (t - (typecase dest - ;; Change locations in eval.lisp that think :return could - ;; occur. - ((or mv-combination creturn exit) :multiple) - (null :unused) - (t :single)))))))) - (dolist (lambda (component-lambdas component)) - (let ((locals-count 0) - (args-passed-count 0)) - (dolist (var (lambda-vars lambda)) - (setf (leaf-info var) locals-count) - (incf locals-count) - (when (leaf-refs var) (incf args-passed-count))) - (dolist (let (lambda-lets lambda)) - (dolist (var (lambda-vars let)) - (setf (leaf-info var) locals-count) - (incf locals-count))) - (let ((entries nil)) - (dolist (e (lambda-entries lambda)) - (ecase (process-entry-node-p e) - (:blow-it-off) - (:local-lexical-exit - (push (cons e (make-entry-node-info locals-count nil)) - entries) - (incf locals-count)) - (:non-local-lexical-exit - (push (cons e - (make-entry-node-info locals-count (incf locals-count))) - entries) - (incf locals-count)))) - (setf (lambda-info lambda) - (make-lambda-eval-info locals-count args-passed-count - entries)))))) - -;;; PROCESS-ENTRY-NODE-P -- Internal. -;;; -(defun process-entry-node-p (entry) - (let ((entry-cleanup (entry-cleanup entry))) - (dolist (nlx (environment-nlx-info (node-environment entry)) - :local-lexical-exit) - (let ((cleanup (nlx-info-cleanup nlx))) - (when (eq entry-cleanup cleanup) - (ecase (cleanup-kind cleanup) - ((:block :tagbody) - (return :non-local-lexical-exit)) - ((:catch :unwind-protect) - (return :blow-it-off)))))))) - - -;;; Sometime consider annotations to exclude processign of exit nodes when -;;; we want to do a tail-p thing. -;;; - - -;;;; Defining funny functions for interpreter. - -#| -%listify-rest-args %more-arg %verify-argument-count %argument-count-error -%odd-keyword-arguments-error %unknown-keyword-argument-error -|# - -(defun %verify-argument-count (supplied-args defined-args) - (unless (= supplied-args defined-args) - (error "Wrong argument count, wanted ~D and got ~D." - defined-args supplied-args))) - -;;; Use (SETF SYMBOL-FUNCTION) insetad of DEFUN so that the compiler -;;; doesn't try to compile the hidden %THROW MV-CALL in the throw below as -;;; a local recursive call. -;;; -(setf (symbol-function '%throw) - #'(lambda (tag &rest args) - (throw tag (values-list args)))) - -(defun %more-arg (args index) - (nth index args)) - -(defun %listify-rest-args (ptr count) - (declare (ignore count)) - ptr) - -(defun %argument-count-error (args-passed-count) - (error "Wrong number of arguments passed -- ~S." args-passed-count)) - -(defun %odd-keyword-arguments-error () - (error "Function called with odd number of keyword arguments.")) - -(defun %unknown-keyword-argument-error (keyword) - (error "Unknown keyword argument -- ~S." keyword)) - -(defun %progv (vars vals fun) - (progv vars vals - (funcall fun))) - -(defun %cleanup-point ()) - -(defun value-cell-ref (x) (value-cell-ref x)) diff --git a/compiler/eval.lisp b/compiler/eval.lisp deleted file mode 100644 index 557f2668d92ceaa68848a347751aca50be7e292e..0000000000000000000000000000000000000000 --- a/compiler/eval.lisp +++ /dev/null @@ -1,1291 +0,0 @@ -;;; -*- Package: eval; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/eval.lisp,v 1.20 1992/09/07 15:37:19 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the interpreter. We first convert to the compiler's -;;; IR1 and interpret that. -;;; -;;; Written by Rob MacLachlan and Bill Chiles. -;;; - -(in-package "EVAL") - -(export '(internal-eval *eval-stack-trace* *internal-apply-node-trace* - *interpreted-function-cache-minimum-size* - *interpreted-function-cache-threshold* - flush-interpreted-function-cache - trace-eval interpreted-function-p - interpreted-function-lambda-expression - interpreted-function-closure - interpreted-function-name - interpreted-function-arglist - interpreted-function-type - make-interpreted-function)) - - -;;;; Interpreter stack. - -(defvar *eval-stack* (make-array 100) - "This is the interpreter's evaluation stack.") -(defvar *eval-stack-top* 0 - "This is the next free element of the interpreter's evaluation stack.") - -;;; Setting this causes the stack operations to dump a trace. -;;; -(defvar *eval-stack-trace* nil) - - -;;; EVAL-STACK-PUSH -- Internal. -;;; -;;; Push value on *eval-stack*, growing the stack if necessary. This returns -;;; value. We save *eval-stack-top* in a local and increment the global before -;;; storing value on the stack to prevent a GC timing problem. If we stored -;;; value on the stack using *eval-stack-top* as an index, and we GC'ed before -;;; incrementing *eval-stack-top*, then INTERPRETER-GC-HOOK would clear the -;;; location. -;;; -(defun eval-stack-push (value) - (let ((len (length (the simple-vector *eval-stack*)))) - (when (= len *eval-stack-top*) - (when *eval-stack-trace* (format t "[PUSH: growing stack.]~%")) - (let ((new-stack (make-array (ash len 1)))) - (replace new-stack *eval-stack* :end1 len :end2 len) - (setf *eval-stack* new-stack)))) - (let ((top *eval-stack-top*)) - (when *eval-stack-trace* (format t "pushing ~D.~%" top)) - (incf *eval-stack-top*) - (setf (svref *eval-stack* top) value))) - -;;; EVAL-STACK-POP -- Internal. -;;; -;;; This returns the last value pushed on *eval-stack* and decrements the top -;;; pointer. We forego setting elements off the end of the stack to nil for GC -;;; purposes because there is a *before-gc-hook* to take care of this for us. -;;; However, because of the GC hook, we must be careful to grab the value -;;; before decrementing *eval-stack-top* since we could GC between the -;;; decrement and the reference, and the hook would clear the stack slot. -;;; -(defun eval-stack-pop () - (when (zerop *eval-stack-top*) - (error "Attempt to pop empty eval stack.")) - (let* ((new-top (1- *eval-stack-top*)) - (value (svref *eval-stack* new-top))) - (when *eval-stack-trace* (format t "popping ~D --> ~S.~%" new-top value)) - (setf *eval-stack-top* new-top) - value)) - -;;; EVAL-STACK-EXTEND -- Internal. -;;; -;;; This allocates n locations on the stack, bumping the top pointer and -;;; growing the stack if necessary. We set new slots to nil in case we GC -;;; before having set them; we don't want to hold on to potential garbage -;;; from old stack fluctuations. -;;; -(defun eval-stack-extend (n) - (let ((len (length (the simple-vector *eval-stack*)))) - (when (> (+ n *eval-stack-top*) len) - (when *eval-stack-trace* (format t "[EXTEND: growing stack.]~%")) - (let ((new-stack (make-array (+ n (ash len 1))))) - (replace new-stack *eval-stack* :end1 len :end2 len) - (setf *eval-stack* new-stack)))) - (let ((new-top (+ *eval-stack-top* n))) - (when *eval-stack-trace* (format t "extending to ~D.~%" new-top)) - (do ((i *eval-stack-top* (1+ i))) - ((= i new-top)) - (setf (svref *eval-stack* i) nil)) - (setf *eval-stack-top* new-top))) - -;;; EVAL-STACK-SHRINK -- Internal. -;;; -;;; The anthesis of EVAL-STACK-EXTEND. -;;; -(defun eval-stack-shrink (n) - (when *eval-stack-trace* - (format t "shrinking to ~D.~%" (- *eval-stack-top* n))) - (decf *eval-stack-top* n)) - -;;; EVAL-STACK-SET-TOP -- Internal. -;;; -;;; This is used to shrink the stack back to a previous frame pointer. -;;; -(defun eval-stack-set-top (ptr) - (when *eval-stack-trace* (format t "setting top to ~D.~%" ptr)) - (setf *eval-stack-top* ptr)) - - -;;; EVAL-STACK-LOCAL -- Internal. -;;; -;;; This returns a local variable from the current stack frame. This is used -;;; for references the compiler represents as a lambda-var leaf. This is a -;;; macro for SETF purposes. -;;; -(defmacro eval-stack-local (fp offset) - `(svref *eval-stack* (+ ,fp ,offset))) - - -;;;; Interpreted functions: - -(defstruct (eval-function - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (format stream "#<EVAL-FUNCTION ~S>" - (eval-function-name s))))) - ;; - ;; The name of this interpreted function, or NIL if none specified. - (name nil) - ;; - ;; This function's debug arglist. - (arglist nil) - ;; - ;; A lambda that can be converted to get the definition. - (lambda nil) - ;; - ;; If this function has been converted, then this is the XEP. If this is - ;; false, then the function is not in the cache (or is in the process of - ;; being removed.) - (definition nil :type (or c::clambda null)) - ;; - ;; The number of consequtive GCs that this function has been unused. This is - ;; used to control cache replacement. - (gcs 0 :type c::index) - ;; - ;; True if Lambda has been converted at least once, and thus warnings should - ;; be suppressed on additional conversions. - (converted-once nil)) - - -(defvar *interpreted-function-cache-minimum-size* 25 - "If the interpreted function cache has more functions than this come GC time, - then attempt to prune it according to - *INTERPRETED-FUNCTION-CACHE-THRESHOLD*.") - -(defvar *interpreted-function-cache-threshold* 3 - "If an interpreted function goes uncalled for more than this many GCs, then - it is eligible for flushing from the cache.") - -(proclaim '(type c::index - *interpreted-function-cache-minimum-size* - *interpreted-function-cache-threshold*)) - - -;;; The list of EVAL-FUNCTIONS that have translated definitions. -;;; -(defvar *interpreted-function-cache* nil) -(proclaim '(type list *interpreted-function-cache*)) - - -;;; MAKE-INTERPRETED-FUNCTION -- Interface -;;; -;;; Return a function that will lazily convert Lambda when called, and will -;;; cache translations. -;;; -(defun make-interpreted-function (lambda) - (let ((eval-fun (make-eval-function :lambda lambda - :arglist (second lambda)))) - #'(lambda (&rest args) - (let ((fun (eval-function-definition eval-fun)) - (args (cons (length args) args))) - (setf (eval-function-gcs eval-fun) 0) - (internal-apply (or fun (convert-eval-fun eval-fun)) - args '#()))))) - - -;;; GET-EVAL-FUNCTION -- Internal -;;; -(defun get-eval-function (x) - (let ((res (system:find-if-in-closure #'eval-function-p x))) - (assert res) - res)) - - -;;; CONVERT-EVAL-FUN -- Internal -;;; -;;; Eval a FUNCTION form, grab the definition and stick it in. -;;; -(defun convert-eval-fun (eval-fun) - (declare (type eval-function eval-fun)) - (let* ((new (eval-function-definition - (get-eval-function - (internal-eval `#',(eval-function-lambda eval-fun) - (eval-function-converted-once eval-fun)))))) - (setf (eval-function-definition eval-fun) new) - (setf (eval-function-converted-once eval-fun) t) - (let ((name (eval-function-name eval-fun))) - (setf (c::leaf-name new) name) - (setf (c::leaf-name (c::main-entry (c::functional-entry-function new))) - name)) - (push eval-fun *interpreted-function-cache*) - new)) - - -;;; INTERPRETED-FUNCTION-LAMDBA-EXPRESSION -- Interface -;;; -;;; Get the CLAMBDA for the XEP, then look at the inline expansion info in -;;; the real function. -;;; -(defun interpreted-function-lambda-expression (x) - (let* ((eval-fun (get-eval-function x)) - (lambda (eval-function-lambda eval-fun))) - (if lambda - (values lambda nil (eval-function-name eval-fun)) - (let ((fun (c::functional-entry-function - (eval-function-definition eval-fun)))) - (values (c::functional-inline-expansion fun) - (if (let ((env (c::functional-lexenv fun))) - (or (c::lexenv-functions env) - (c::lexenv-variables env) - (c::lexenv-blocks env) - (c::lexenv-tags env))) - t nil) - (or (eval-function-name eval-fun) - (c::component-name - (c::block-component - (c::node-block (c::lambda-bind fun)))))))))) - - -;;; INTERPRETED-FUNCTION-TYPE -- Interface -;;; -;;; Return a FUNCTION-TYPE describing an eval function. We just grab the -;;; LEAF-TYPE of the definition, converting the definition if not currently -;;; cached. -;;; -(defvar *already-looking-for-type-of* nil) -;;; -(defun interpreted-function-type (fun) - (if (member fun *already-looking-for-type-of*) - (specifier-type 'function) - (let* ((*already-looking-for-type-of* - (cons fun *already-looking-for-type-of*)) - (eval-fun (get-eval-function fun)) - (def (or (eval-function-definition eval-fun) - (system:without-gcing - (convert-eval-fun eval-fun) - (eval-function-definition eval-fun))))) - (c::leaf-type (c::functional-entry-function def))))) - - -;;; -;;; INTERPRETED-FUNCTION-{NAME,ARGLIST} -- Interface -;;; -(defun interpreted-function-name (x) - (multiple-value-bind (ig1 ig2 res) - (interpreted-function-lambda-expression x) - (declare (ignore ig1 ig2)) - res)) -;;; -(defun (setf interpreted-function-name) (val x) - (let* ((eval-fun (get-eval-function x)) - (def (eval-function-definition eval-fun))) - (when def - (setf (c::leaf-name def) val) - (setf (c::leaf-name (c::main-entry (c::functional-entry-function def))) - val)) - (setf (eval-function-name eval-fun) val))) -;;; -(defun interpreted-function-arglist (x) - (eval-function-arglist (get-eval-function x))) -;;; -(defun (setf interpreted-function-arglist) (val x) - (setf (eval-function-arglist (get-eval-function x)) val)) - - -;;; INTERPRETED-FUNCTION-ENVIRONMENT -- Interface -;;; -;;; The environment should be the only SIMPLE-VECTOR in the closure. We -;;; have to throw in the EVAL-FUNCTION-P test, since structure are currently -;;; also SIMPLE-VECTORs. -;;; -(defun interpreted-function-closure (x) - (system:find-if-in-closure #'(lambda (x) - (and (simple-vector-p x) - (not (eval-function-p x)))) - x)) - - -;;; INTERPRETER-GC-HOOK -- Internal -;;; -;;; Clear the unused portion of the eval stack, and flush the definitions of -;;; all functions in the cache that haven't been used enough. -;;; -(defun interpreter-gc-hook () - (let ((len (length (the simple-vector *eval-stack*)))) - (do ((i *eval-stack-top* (1+ i))) - ((= i len)) - (setf (svref *eval-stack* i) nil))) - - (let ((num (- (length *interpreted-function-cache*) - *interpreted-function-cache-minimum-size*))) - (when (plusp num) - (setq *interpreted-function-cache* - (delete-if #'(lambda (x) - (when (>= (eval-function-gcs x) - *interpreted-function-cache-threshold*) - (setf (eval-function-definition x) nil) - t)) - *interpreted-function-cache* - :count num)))) - - (dolist (fun *interpreted-function-cache*) - (incf (eval-function-gcs fun)))) -;;; -(pushnew 'interpreter-gc-hook ext:*before-gc-hooks*) - - -;;; FLUSH-INTERPRETED-FUNCTION-CACHE -- Interface -;;; -(defun flush-interpreted-function-cache () - "Clear all entries in the eval function cache. This allows the internal - representation of the functions to be reclaimed, and also lazily forces - macroexpansions to be recomputed." - (dolist (fun *interpreted-function-cache*) - (setf (eval-function-definition fun) nil)) - (setq *interpreted-function-cache* ())) - - -;;;; INTERNAL-APPLY-LOOP macros. - -;;; These macros are intimately related to INTERNAL-APPLY-LOOP. They assume -;;; variables established by this function, and they assume they can return -;;; from a block by that name. This is sleazy, but we justify it as follows: -;;; They are so specialized in use, and their invocation became lengthy, that -;;; we allowed them to slime some access to things in their expanding -;;; environment. These macros don't really extend our Lisp syntax, but they do -;;; provide some template expansion service; it is these cleaner circumstance -;;; that require a more rigid programming style. -;;; -;;; Since these are macros expanded almost solely for c::combination nodes, -;;; they cascade from the end of this logical page to the beginning here. -;;; Therefore, it is best you start looking at them from the end of this -;;; section, backwards from normal scanning mode for Lisp code. -;;; - -;;; DO-COMBINATION -- Internal. -;;; -;;; This runs a function on some arguments from the stack. If the combination -;;; occurs in a tail recursive position, then we do the call such that we -;;; return from tail-p-function with whatever values the call produces. With a -;;; :local call, we have to restore the stack to its previous frame before -;;; doing the call. The :full call mechanism does this for us. If it is NOT a -;;; tail recursive call, and we're in a multiple value context, then then push -;;; a list of the returned values. Do the same thing if we're in a :return -;;; context. Push a single value, without listifying it, for a :single value -;;; context. Otherwise, just call for side effect. -;;; -;;; Node is the combination node, and cont is its continuation. Frame-ptr -;;; is the current frame pointer, and closure is the current environment for -;;; closure variables. Call-type is either :full or :local, and when it is -;;; local, lambda is the IR1 lambda to apply. -;;; -;;; This assumes the following variables are present: node, cont, frame-ptr, -;;; and closure. It also assumes a block named internal-apply-loop. -;;; -(defmacro do-combination (call-type lambda mv-or-normal) - (let* ((args (gensym)) - (calling-closure (gensym)) - (invoke-fun (ecase mv-or-normal - (:mv-call 'mv-internal-invoke) - (:normal 'internal-invoke))) - (args-form (ecase mv-or-normal - (:mv-call - `(mv-eval-stack-args - (length (c::mv-combination-args node)))) - (:normal - `(eval-stack-args (c:lambda-eval-info-args-passed - (c::lambda-info ,lambda)))))) - (call-form (ecase call-type - (:full `(,invoke-fun - (length (c::basic-combination-args node)))) - (:local `(internal-apply - ,lambda ,args-form - (compute-closure node ,lambda frame-ptr - closure) - nil)))) - (tailp-call-form - (ecase call-type - (:full `(return-from - internal-apply-loop - ;; INVOKE-FUN takes care of the stack itself. - (,invoke-fun (length (c::basic-combination-args node)) - frame-ptr))) - (:local `(let ((,args ,args-form) - (,calling-closure - (compute-closure node ,lambda frame-ptr closure))) - ;; No need to clean up stack slots for GC due to - ;; ext:*before-gc-hook*. - (eval-stack-set-top frame-ptr) - (return-from - internal-apply-loop - (internal-apply ,lambda ,args ,calling-closure - nil))))))) - `(cond ((c::node-tail-p node) - ,tailp-call-form) - (t - (ecase (c::continuation-info cont) - ((:multiple :return) - (eval-stack-push (multiple-value-list ,call-form))) - (:single - (eval-stack-push ,call-form)) - (:unused ,call-form)))))) - -;;; SET-BLOCK -- Internal. -;;; -;;; This sets the variable block in INTERNAL-APPLY-LOOP, and it announces this -;;; by setting set-block-p for later loop iteration maintenance. -;;; -(defmacro set-block (exp) - `(progn - (setf block ,exp) - (setf set-block-p t))) - -;;; CHANGE-BLOCKS -- Internal. -;;; -;;; This sets all the iteration variables in INTERNAL-APPLY-LOOP to iterate -;;; over a new block's nodes. Block-exp is optional because sometimes we have -;;; already set block, and we only need to bring the others into agreement. -;;; If we already set block, then clear the variable that announces this, -;;; set-block-p. -;;; -(defmacro change-blocks (&optional block-exp) - `(progn - ,(if block-exp - `(setf block ,block-exp) - `(setf set-block-p nil)) - (setf node (c::continuation-next (c::block-start block))) - (setf last-cont (c::node-cont (c::block-last block))))) - - -;;; This controls printing visited nodes in INTERNAL-APPLY-LOOP. We use it -;;; here, and INTERNAL-INVOKE uses it to print function call looking output -;;; to further describe c::combination nodes. -;;; -(defvar *internal-apply-node-trace* nil) -;;; -(defun maybe-trace-funny-fun (node name &rest args) - (when *internal-apply-node-trace* - (format t "(~S ~{ ~S~}) c~S~%" - name args (c::cont-num (c::node-cont node))))) - - -;;; DO-FUNNY-FUNCTION -- Internal. -;;; -;;; This implements the intention of the virtual function name. This is a -;;; macro because some of these actions must occur without a function call. -;;; For example, calling a dispatch function to implement special binding would -;;; be a no-op because returning from that function would cause the system to -;;; undo any special bindings it established. -;;; -;;; NOTE: update C:ANNOTATE-COMPONENT-FOR-EVAL and/or c::undefined-funny-funs -;;; if you add or remove branches in this routine. -;;; -;;; This assumes the following variables are present: node, cont, frame-ptr, -;;; args, closure, block, and last-cont. It also assumes a block named -;;; internal-apply-loop. -;;; -(defmacro do-funny-function (funny-fun-name) - (let ((name (gensym))) - `(let ((,name ,funny-fun-name)) - (ecase ,name - (c::%special-bind - (let ((value (eval-stack-pop)) - (global-var (eval-stack-pop))) - (maybe-trace-funny-fun node ,name global-var value) - (system:%primitive bind value (c::global-var-name global-var)))) - (c::%special-unbind - ;; Throw away arg telling me which special, and tell the dynamic - ;; binding mechanism to unbind one variable. - (eval-stack-pop) - (maybe-trace-funny-fun node ,name) - (system:%primitive unbind)) - (c::%catch - (let* ((tag (eval-stack-pop)) - (nlx-info (eval-stack-pop)) - (fell-through-p nil) - ;; Ultimately THROW and CATCH will fix the interpreter's stack - ;; since this is necessary for compiled CATCH's and those in - ;; the initial top level function. - (stack-top *eval-stack-top*) - (values - (multiple-value-list - (catch tag - (maybe-trace-funny-fun node ,name tag) - (multiple-value-setq (block node cont last-cont) - (internal-apply-loop (c::continuation-next cont) - frame-ptr lambda args closure)) - (setf fell-through-p t))))) - (cond (fell-through-p - ;; We got here because we just saw the C::%CATCH-BREAKUP - ;; funny function inside the above recursive call to - ;; INTERNAL-APPLY-LOOP. Therefore, we just received and - ;; stored the current state of evaluation for falling - ;; through. - ) - (t - ;; Fix up the interpreter's stack after having thrown here. - ;; We won't need to do this in the final implementation. - (eval-stack-set-top stack-top) - ;; Take the values received in the list bound above, and - ;; massage them into the form expected by the continuation - ;; of the non-local-exit info. - (ecase (c::continuation-info - (c::nlx-info-continuation nlx-info)) - (:single - (eval-stack-push (car values))) - ((:multiple :return) - (eval-stack-push values)) - (:unused)) - ;; We want to continue with the code after the CATCH body. - ;; The non-local-exit info tells us where this is, but we - ;; know that block only contains a call to the funny - ;; function C::%NLX-ENTRY, which simply is a place holder - ;; for the compiler IR1. We want to skip the target block - ;; entirely, so we say it is the block we're in now and say - ;; the current cont is the last-cont. This makes the COND - ;; at the end of INTERNAL-APPLY-LOOP do the right thing. - (setf block (c::nlx-info-target nlx-info)) - (setf cont last-cont))))) - (c::%unwind-protect - ;; Cleanup function not pushed due to special-case :UNUSED - ;; annotation in ANNOTATE-COMPONENT-FOR-EVAL. - (let* ((nlx-info (eval-stack-pop)) - (fell-through-p nil) - (stack-top *eval-stack-top*)) - (unwind-protect - (progn - (maybe-trace-funny-fun node ,name) - (multiple-value-setq (block node cont last-cont) - (internal-apply-loop (c::continuation-next cont) - frame-ptr lambda args closure)) - (setf fell-through-p t)) - (cond (fell-through-p - ;; We got here because we just saw the - ;; C::%UNWIND-PROTECT-BREAKUP funny function inside the - ;; above recursive call to INTERNAL-APPLY-LOOP. - ;; Therefore, we just received and stored the current - ;; state of evaluation for falling through. - ) - (t - ;; Fix up the interpreter's stack after having thrown here. - ;; We won't need to do this in the final implementation. - (eval-stack-set-top stack-top) - ;; - ;; Push some bogus values for exit context to keep the - ;; MV-BIND in the UNWIND-PROTECT translation happy. - (eval-stack-push '(nil nil 0)) - (let ((node (c::continuation-next - (c::block-start - (car (c::block-succ - (c::nlx-info-target nlx-info))))))) - (internal-apply-loop node frame-ptr lambda args - closure))))))) - ((c::%catch-breakup c::%unwind-protect-breakup c::%continue-unwind) - ;; This shows up when we locally exit a CATCH body -- fell through. - ;; Return the current state of evaluation to the previous invocation - ;; of INTERNAL-APPLY-LOOP which happens to be running in the - ;; c::%catch branch of this code. - (maybe-trace-funny-fun node ,name) - (return-from internal-apply-loop - (values block node cont last-cont))) - (c::%nlx-entry - (maybe-trace-funny-fun node ,name) - ;; This just marks a spot in the code for CATCH, UNWIND-PROTECT, and - ;; non-local lexical exits (GO or RETURN-FROM). - ;; Do nothing since c::%catch does it all when it catches a THROW. - ;; Do nothing since c::%unwind-protect does it all when - ;; it catches a THROW. - ) - (c::%more-arg-context - (let* ((fixed-arg-count (1+ (eval-stack-pop))) - ;; Add 1 to actual fixed count for extra arg expected by - ;; external entry points (XEP) which some IR1 lambdas have. - ;; The extra arg is the number of arguments for arg count - ;; consistency checking. C::%MORE-ARG-CONTEXT always runs - ;; within an XEP, so the lambda has an extra arg. - (more-args (nthcdr fixed-arg-count args))) - (maybe-trace-funny-fun node ,name fixed-arg-count) - (assert (eq (c::continuation-info cont) :multiple)) - (eval-stack-push (list more-args (length more-args))))) - (c::%unknown-values - (error "C::%UNKNOWN-VALUES should never be in interpreter's IR1.")) - (c::%lexical-exit-breakup - ;; We see this whenever we locally exit the extent of a lexical - ;; target. That is, we are truly locally exiting an extent we could - ;; have non-locally lexically exited. Return the :fell-through flag - ;; and the current state of evaluation to the previous invocation - ;; of INTERNAL-APPLY-LOOP which happens to be running in the - ;; c::entry branch of INTERNAL-APPLY-LOOP. - (maybe-trace-funny-fun node ,name) - ;; - ;; Discard the NLX-INFO arg... - (eval-stack-pop) - (return-from internal-apply-loop - (values :fell-through block node cont last-cont))))))) - - -;;; COMBINATION-NODE -- Internal. -;;; -;;; This expands for the two types of combination nodes INTERNAL-APPLY-LOOP -;;; sees. Type is either :mv-call or :normal. Node is the combination node, -;;; and cont is its continuation. Frame-ptr is the current frame pointer, and -;;; closure is the current environment for closure variables. -;;; -;;; Most of the real work is done by DO-COMBINATION. This first determines if -;;; the combination node describes a :full call which DO-COMBINATION directly -;;; handles. If the call is :local, then we either invoke an IR1 lambda, or we -;;; just bind some LET variables. If the call is :local, and type is :mv-call, -;;; then we can only be binding multiple values. Otherwise, the combination -;;; node describes a function known to the compiler, but this may be a funny -;;; function that actually isn't ever defined. We either take some action for -;;; the funny function or do a :full call on the known true function, but the -;;; interpreter doesn't do optimizing stuff for functions known to the -;;; compiler. -;;; -;;; This assumes the following variables are present: node, cont, frame-ptr, -;;; and closure. It also assumes a block named internal-apply-loop. -;;; -(defmacro combination-node (type) - (let* ((kind (gensym)) - (fun (gensym)) - (lambda (gensym)) - (letp (gensym)) - (letp-bind (ecase type - (:mv-call nil) - (:normal - `((,letp (eq (c::functional-kind ,lambda) :let)))))) - (local-branch - (ecase type - (:mv-call - `(store-mv-let-vars ,lambda frame-ptr - (length (c::mv-combination-args node)))) - (:normal - `(if ,letp - (store-let-vars ,lambda frame-ptr) - (do-combination :local ,lambda ,type)))))) - `(let ((,kind (c::basic-combination-kind node)) - (,fun (c::basic-combination-fun node))) - (cond ((member ,kind '(:full :error)) - (do-combination :full nil ,type)) - ((eq ,kind :local) - (let* ((,lambda (c::ref-leaf (c::continuation-use ,fun))) - ,@letp-bind) - ,local-branch)) - ((eq (c::continuation-info ,fun) :unused) - (assert (typep ,kind 'c::function-info)) - (do-funny-function (c::continuation-function-name ,fun))) - (t - (assert (typep ,kind 'c::function-info)) - (do-combination :full nil ,type)))))) - - -(defun trace-eval (on) - (setf *eval-stack-trace* on) - (setf *internal-apply-node-trace* on)) - - -;;;; INTERNAL-EVAL: - -(proclaim '(special lisp::*already-evaled-this*)) - -;;; INTERNAL-EVAL -- Interface -;;; -;;; Evaluate an arbitary form. We convert the form, then call internal -;;; apply on it. If *ALREADY-EVALED-THIS* is true, then we bind it to NIL -;;; around the apply to limit the inhibition to the lexical scope of the -;;; EVAL-WHEN. -;;; -(defun internal-eval (form &optional quietly) - (let ((res (c:compile-for-eval form quietly))) - (if lisp::*already-evaled-this* - (let ((lisp::*already-evaled-this* nil)) - (internal-apply res nil '#())) - (internal-apply res nil '#())))) - - -;;; MAKE-INDIRECT-VALUE-CELL -- Internal. -;;; -;;; Later this will probably be the same weird internal thing the compiler -;;; makes to represent these things. -;;; -(defun make-indirect-value-cell (value) - (list value)) -;;; -(defmacro indirect-value (value-cell) - `(car ,value-cell)) - - -;;; VALUE -- Internal. -;;; -;;; This passes on a node's value appropriately, possibly returning from -;;; function to do so. When we are tail-p, don't push the value, return it on -;;; the system's actual call stack; when we blow out of function this way, we -;;; must return the interpreter's stack to the its state before this call to -;;; function. When we're in a multiple value context or heading for a return -;;; node, we push a list of the value for easier handling later. Otherwise, -;;; just push the value on the interpreter's stack. -;;; -(defmacro value (node info value frame-ptr function) - `(cond ((c::node-tail-p ,node) - (eval-stack-set-top ,frame-ptr) - (return-from ,function ,value)) - ((member ,info '(:multiple :return) :test #'eq) - (eval-stack-push (list ,value))) - (t (assert (eq ,info :single)) - (eval-stack-push ,value)))))) - - -(defun maybe-trace-nodes (node) - (when *internal-apply-node-trace* - (format t "<~A-node> c~S~%" - (type-of node) - (c::cont-num (c::node-cont node))))) - -;;; INTERNAL-APPLY -- Internal. -;;; -;;; This interprets lambda, a compiler IR1 data structure representing a -;;; function, applying it to args. Closure is the environment in which to run -;;; lambda, the variables and such closed over to form lambda. The call occurs -;;; on the interpreter's stack, so save the current top and extend the stack -;;; for this lambda's call frame. Then store the args into locals on the -;;; stack. -;;; -;;; Args is the list of arguments to apply to. If IGNORE-UNUSED is true, then -;;; values for un-read variables are present in the argument list, and must be -;;; discarded (always true except in a local call.) Args may run out of values -;;; before vars runs out of variables (in the case of an XEP with optionals); -;;; we just do CAR of nil and store nil. This is not the proper defaulting -;;; (which is done by explicit code in the XEP.) -;;; -(defun internal-apply (lambda args closure &optional (ignore-unused t)) - (let ((frame-ptr *eval-stack-top*)) - (eval-stack-extend (c:lambda-eval-info-frame-size (c::lambda-info lambda))) - (do ((vars (c::lambda-vars lambda) (cdr vars)) - (args args)) - ((null vars)) - (let ((var (car vars))) - (cond ((c::leaf-refs var) - (setf (eval-stack-local frame-ptr (c::lambda-var-info var)) - (if (c::lambda-var-indirect var) - (make-indirect-value-cell (pop args)) - (pop args)))) - (ignore-unused (pop args))))) - (internal-apply-loop (c::lambda-bind lambda) frame-ptr lambda args - closure))) - -;;; INTERNAL-APPLY-LOOP -- Internal. -;;; -;;; This does the work of INTERNAL-APPLY. This also calls itself recursively -;;; for certain language features, such as CATCH. First is the node at which -;;; to start interpreting. Frame-ptr is the current frame pointer for -;;; accessing local variables. Lambda is the IR1 lambda from which comes the -;;; nodes a given call to this function processes, and closure is the -;;; environment for interpreting lambda. Args is the argument list for the -;;; lambda given to INTERNAL-APPLY, and we have to carry it around with us -;;; in case of more-arg or rest-arg processing which is represented explicitly -;;; in the compiler's IR1. -;;; -;;; Due to having a truly tail recursive interpreter, some of the branches -;;; handling a given node need to RETURN-FROM this routine. Also, some calls -;;; this makes to do work for it must occur in tail recursive positions. -;;; Because of this required access to this function lexical environment and -;;; calling positions, we often are unable to break off logical chunks of code -;;; into functions. We have written macros intended solely for use in this -;;; routine, and due to all the local stuff they need to access and length -;;; complex calls, we have written them to sleazily access locals from this -;;; routine. In addition to assuming a block named internal-apply-loop exists, -;;; they set and reference the following variables: node, cont, frame-ptr, -;;; closure, block, last-cont, and set-block-p. -;;; -(defun internal-apply-loop (first frame-ptr lambda args closure) - (declare (optimize (debug-info 2))) - (let* ((block (c::node-block first)) - (last-cont (c::node-cont (c::block-last block))) - (node first) - (set-block-p nil)) - (loop - (let ((cont (c::node-cont node))) - (etypecase node - (c::ref - (maybe-trace-nodes node) - (let ((info (c::continuation-info cont))) - (unless (eq info :unused) - (value node info (leaf-value node frame-ptr closure) - frame-ptr internal-apply-loop)))) - (c::combination - (maybe-trace-nodes node) - (combination-node :normal)) - (c::cif - (maybe-trace-nodes node) - ;; IF nodes always occur at the end of a block, so pick another. - (set-block (if (eval-stack-pop) - (c::if-consequent node) - (c::if-alternative node)))) - (c::bind - (maybe-trace-nodes node) - ;; Ignore bind nodes since INTERNAL-APPLY extends the stack for - ;; all of a lambda's locals, and the c::combination branch - ;; handles LET binds (moving values off stack top into locals). - ) - (c::cset - (maybe-trace-nodes node) - (let ((info (c::continuation-info cont)) - (res (set-leaf-value node frame-ptr closure - (eval-stack-pop)))) - (unless (eq info :unused) - (value node info res frame-ptr internal-apply-loop)))) - (c::entry - (maybe-trace-nodes node) - (let ((info (cdr (assoc node (c:lambda-eval-info-entries - (c::lambda-info lambda)))))) - ;; No info means no-op entry for CATCH or UNWIND-PROTECT. - (when info - ;; Store stack top for restoration in local exit situation - ;; in c::exit branch. - (setf (eval-stack-local frame-ptr - (c:entry-node-info-st-top info)) - *eval-stack-top*) - (let ((tag (c:entry-node-info-nlx-tag info))) - (when tag - ;; Non-local lexical exit (someone closed over a - ;; GO tag or BLOCK name). - (let ((unique-tag (cons nil nil)) - values) - (setf (eval-stack-local frame-ptr tag) unique-tag) - (if (eq cont last-cont) - (change-blocks (car (c::block-succ block))) - (setf node (c::continuation-next cont))) - (loop - (multiple-value-setq (values block node cont last-cont) - (catch unique-tag - (internal-apply-loop node frame-ptr - lambda args closure))) - - (when (eq values :fell-through) - ;; We hit a %LEXICAL-EXIT-BREAKUP. - ;; Interpreting state is set with MV-SETQ above. - ;; Just get out of this branch and go on. - (return)) - - (unless (eq values :non-local-go) - ;; We know we're non-locally exiting from a - ;; BLOCK with values (saw a RETURN-FROM). - (ecase (c::continuation-info cont) - (:single - (eval-stack-push (car values))) - ((:multiple :return) - (eval-stack-push values)) - (:unused))) - ;; - ;; Start interpreting again at the target, skipping - ;; the %NLX-ENTRY block. - (setf node - (c::continuation-next - (c::block-start - (car (c::block-succ block)))))))))))) - (c::exit - (maybe-trace-nodes node) - (let* ((incoming-values (c::exit-value node)) - (values (if incoming-values (eval-stack-pop)))) - (cond - ((eq (c::lambda-environment lambda) - (c::block-environment (c::continuation-block cont))) - ;; Local exit. - ;; Fixup stack top and massage values for destination. - (eval-stack-set-top - (eval-stack-local frame-ptr - (c:entry-node-info-st-top - (cdr (assoc (c::exit-entry node) - (c:lambda-eval-info-entries - (c::lambda-info lambda))))))) - (ecase (c::continuation-info cont) - (:single - (assert incoming-values) - (eval-stack-push (car values))) - ((:multiple :return) - (assert incoming-values) - (eval-stack-push values)) - (:unused))) - (t - (let ((info (c::find-nlx-info (c::exit-entry node) cont))) - (throw - (svref closure - (position info - (c::environment-closure - (c::node-environment node)) - :test #'eq)) - (if incoming-values - (values values (c::nlx-info-target info) nil cont) - (values :non-local-go (c::nlx-info-target info))))))))) - (c::creturn - (maybe-trace-nodes node) - (let ((values (eval-stack-pop))) - (eval-stack-set-top frame-ptr) - (return-from internal-apply-loop (values-list values)))) - (c::mv-combination - (maybe-trace-nodes node) - (combination-node :mv-call))) - ;; See function doc below. - (reference-this-var-to-keep-it-alive node) - (reference-this-var-to-keep-it-alive frame-ptr) - (reference-this-var-to-keep-it-alive closure) - (cond ((not (eq cont last-cont)) - (setf node (c::continuation-next cont))) - ;; Currently only the last node in a block causes this loop to - ;; change blocks, so we never just go to the next node when - ;; the current node's branch tried to change blocks. - (set-block-p - (change-blocks)) - (t - ;; Cif nodes set the block for us, but other last nodes do not. - (change-blocks (car (c::block-succ block))))))))) - -;;; REFERENCE-THIS-VAR-TO-KEEP-IT-ALIVE -- Internal. -;;; -;;; This function allows a reference to a variable that the compiler cannot -;;; easily eliminate as unnecessary. We use this at the end of the node -;;; dispatch in INTERNAL-APPLY-LOOP to make sure the node variable has a -;;; valid value. Each node branch tends to reference it at the beginning, -;;; and then there is no reference but a set at the end; the compiler then -;;; kills the variable between the reference in the dispatch branch and when -;;; we set it at the end. The problem is that most error will occur in the -;;; interpreter within one of these node dispatch branches. -;;; -(defun reference-this-var-to-keep-it-alive (node) - node) - - -;;; SET-LEAF-VALUE -- Internal. -;;; -;;; This sets a c::cset node's var to value, returning value. When var is -;;; local, we have to compare its home environment to the current one, node's -;;; environment. If they're the same, we check to see if the var is indirect, -;;; and store the value on the stack or in the value cell as appropriate. -;;; Otherwise, var is a closure variable, and since we're setting it, we know -;;; it's location contains an indirect value object. -;;; -(defun set-leaf-value (node frame-ptr closure value) - (let ((var (c::set-var node))) - (typecase var - (c::global-var - (setf (symbol-value (c::global-var-name var)) value)) - (c::lambda-var - (set-leaf-value-lambda-var node var frame-ptr closure value))))) - -;;; SET-LEAF-VALUE-LAMBDA-VAR -- Internal Interface. -;;; -;;; This does SET-LEAF-VALUE for a lambda-var leaf. The debugger tools' -;;; internals uses this also to set interpreted local variables. -;;; -(defun set-leaf-value-lambda-var (node var frame-ptr closure value) - (let ((env (c::node-environment node))) - (cond ((not (eq (c::lambda-environment (c::lambda-var-home var)) - env)) - (setf (indirect-value - (svref closure - (position var (c::environment-closure env) - :test #'eq))) - value)) - ((c::lambda-var-indirect var) - (setf (indirect-value - (eval-stack-local frame-ptr (c::lambda-var-info var))) - value)) - (t - (setf (eval-stack-local frame-ptr (c::lambda-var-info var)) - value))))) - -;;; LEAF-VALUE -- Internal. -;;; -;;; This figures out how to return a value for a ref node. Leaf is the ref's -;;; structure that tells us about the value, and it is one of the following -;;; types: -;;; constant -- It knows its own value. -;;; global-var -- It's either a value or function reference. Get it right. -;;; local-var -- This may on the stack or in the current closure, the -;;; environment for the lambda INTERNAL-APPLY is currently -;;; executing. If the leaf's home environment is the same -;;; as the node's home environment, then the value is on the -;;; stack, else it's in the closure since it came from another -;;; environment. Whether the var comes from the stack or the -;;; closure, it could have come from a closure, and it could -;;; have been closed over for setting. When this happens, the -;;; actual value is stored in an indirection object, so -;;; indirect. See COMPUTE-CLOSURE for the description of -;;; the structure of the closure argument to this function. -;;; functional -- This is a reference to an interpreted function that may -;;; be passed or called anywhere. We return a real function -;;; that calls INTERNAL-APPLY, closing over the leaf. We also -;;; have to compute a closure, running environment, for the -;;; lambda in case it references stuff in the current -;;; environment. If the closure is empty and there is no -;;; functional environment, then we use -;;; MAKE-INTERPRETED-FUNCTION to make a cached translation. -;;; Since it is too late to lazily convert, we set up the -;;; EVAL-FUNCTION to be already converted. -;;; -(defun leaf-value (node frame-ptr closure) - (let ((leaf (c::ref-leaf node))) - (typecase leaf - (c::constant - (c::constant-value leaf)) - (c::global-var - (locally (declare (optimize (safety 1))) - (if (eq (c::global-var-kind leaf) :global-function) - (let ((name (c::global-var-name leaf))) - (if (symbolp name) - (symbol-function name) - (fdefinition name))) - (symbol-value (c::global-var-name leaf))))) - (c::lambda-var - (leaf-value-lambda-var node leaf frame-ptr closure)) - (c::functional - (let* ((calling-closure (compute-closure node leaf frame-ptr closure)) - (real-fun (c::functional-entry-function leaf)) - (arg-doc (c::functional-arg-documentation real-fun))) - (cond ((c:lambda-eval-info-function (c::leaf-info leaf))) - ((and (zerop (length calling-closure)) - (null (c::lexenv-functions - (c::functional-lexenv real-fun)))) - (let* ((res (make-interpreted-function - (c::functional-inline-expansion real-fun))) - (eval-fun (get-eval-function res))) - (push eval-fun *interpreted-function-cache*) - (setf (eval-function-definition eval-fun) leaf) - (setf (eval-function-converted-once eval-fun) t) - (setf (eval-function-arglist eval-fun) arg-doc) - (setf (eval-function-name eval-fun) (c::leaf-name real-fun)) - (setf (c:lambda-eval-info-function (c::leaf-info leaf)) res) - res)) - (t - (let ((eval-fun (make-eval-function - :definition leaf - :name (c::leaf-name real-fun) - :arglist arg-doc))) - #'(lambda (&rest args) - (declare (list args)) - (internal-apply (eval-function-definition eval-fun) - (cons (length args) args) - calling-closure)))))))))) - -;;; LEAF-VALUE-LAMBDA-VAR -- Internal Interface. -;;; -;;; This does LEAF-VALUE for a lambda-var leaf. The debugger tools' internals -;;; uses this also to reference interpreted local variables. -;;; -(defun leaf-value-lambda-var (node leaf frame-ptr closure) - (let* ((env (c::node-environment node)) - (temp - (if (eq (c::lambda-environment (c::lambda-var-home leaf)) - env) - (eval-stack-local frame-ptr (c::lambda-var-info leaf)) - (svref closure - (position leaf (c::environment-closure env) - :test #'eq))))) - (if (c::lambda-var-indirect leaf) - (indirect-value temp) - temp))) - -;;; COMPUTE-CLOSURE -- Internal. -;;; -;;; This computes a closure for a local call and for returned call'able closure -;;; objects. Sometimes the closure is a simple-vector of no elements. Node -;;; is either a reference node or a combination node. Leaf is either the leaf -;;; of the reference node or the lambda to internally apply for the combination -;;; node. Frame-ptr is the current frame pointer for fetching current values -;;; to store in the closure. Closure is the current closure, the currently -;;; interpreting lambda's closed over environment. -;;; -;;; A computed closure is a vector corresponding to the list of closure -;;; variables described in an environment. The position of a lambda-var in -;;; this closure list is the index into the closure vector of values. -;;; -;;; Functional-env is the environment description for leaf, the lambda for which -;;; we're computing a closure. This environment describes which of lambda's -;;; vars we find in lambda's closure when it's running, versus finding them -;;; on the stack. For each lambda-var in the functional environment's closure -;;; list, if the lambda-var's home environment is the current environment, then -;;; get a value off the stack and store it in the closure we're computing. -;;; Otherwise that lambda-var's value comes from somewhere else, but we have it -;;; in our current closure, the environment we're running in as we compute this -;;; new closure. Find this value the same way we do in LEAF-VALUE, by finding -;;; the lambda-var's position in the current environment's description of the -;;; current closure. -;;; -(defun compute-closure (node leaf frame-ptr closure) - (let* ((current-env (c::node-environment node)) - (current-closure-vars (c::environment-closure current-env)) - (functional-env (c::lambda-environment leaf)) - (functional-closure-vars (c::environment-closure functional-env)) - (functional-closure (make-array (length functional-closure-vars)))) - (do ((vars functional-closure-vars (cdr vars)) - (i 0 (1+ i))) - ((null vars)) - (let ((ele (car vars))) - (setf (svref functional-closure i) - (etypecase ele - (c::lambda-var - (if (eq (c::lambda-environment (c::lambda-var-home ele)) - current-env) - (eval-stack-local frame-ptr (c::lambda-var-info ele)) - (svref closure - (position ele current-closure-vars - :test #'eq)))) - (c::nlx-info - (if (eq (c::block-environment (c::nlx-info-target ele)) - current-env) - (eval-stack-local - frame-ptr - (c:entry-node-info-nlx-tag - (cdr (assoc ;; entry node for non-local extent - (c::cleanup-mess-up (c::nlx-info-cleanup ele)) - (c::lambda-eval-info-entries - (c::lambda-info - ;; lambda INTERNAL-APPLY-LOOP tosses around. - (c::environment-function - (c::node-environment node)))))))) - (svref closure - (position ele current-closure-vars - :test #'eq)))))))) - functional-closure)) - -;;; INTERNAL-INVOKE -- Internal. -;;; -;;; INTERNAL-APPLY uses this to invoke a function from the interpreter's stack -;;; on some arguments also taken from the stack. When tail-p is non-nil, -;;; control does not return to INTERNAL-APPLY to further interpret the current -;;; IR1 lambda, so INTERNAL-INVOKE must clean up the current interpreter's -;;; stack frame. -;;; -(defun internal-invoke (arg-count &optional tailp) - (let ((args (eval-stack-args arg-count)) ;LET says this init form runs first. - (fun (eval-stack-pop))) - (when tailp (eval-stack-set-top tailp)) - (when *internal-apply-node-trace* - (format t "(~S~{ ~S~})~%" fun args)) - (apply fun args))) - -;;; MV-INTERNAL-INVOKE -- Internal. -;;; -;;; Almost just like INTERNAL-INVOKE. We call MV-EVAL-STACK-ARGS, and our -;;; function is in a list on the stack instead of simply on the stack. -;;; -(defun mv-internal-invoke (arg-count &optional tailp) - (let ((args (mv-eval-stack-args arg-count)) ;LET runs this init form first. - (fun (car (eval-stack-pop)))) - (when tailp (eval-stack-set-top tailp)) - (when *internal-apply-node-trace* - (format t "(~S~{ ~S~})~%" fun args)) - (apply fun args))) - - -;;; EVAL-STACK-ARGS -- Internal. -;;; -;;; This returns a list of the top arg-count elements on the interpreter's -;;; stack. This removes them from the stack. -;;; -(defun eval-stack-args (arg-count) - (let ((args nil)) - (dotimes (i arg-count args) - (push (eval-stack-pop) args)))) - -;;; MV-EVAL-STACK-ARGS -- Internal. -;;; -;;; This assumes the top count elements on interpreter's stack are lists. This -;;; returns a single list with all the elements from these lists. -;;; -(defun mv-eval-stack-args (count) - (if (= count 1) - (eval-stack-pop) - (let ((last (eval-stack-pop))) - (dotimes (i (1- count)) - (let ((next (eval-stack-pop))) - (setf last - (if next (nconc next last) last)))) - last))) - -;;; STORE-LET-VARS -- Internal. -;;; -;;; This stores lambda's vars, stack locals, from values popped off the stack. -;;; When a var has no references, the compiler computes IR1 such that the -;;; continuation delivering the value for the unreference var appears unused. -;;; Because of this, the interpreter drops the value on the floor instead of -;;; saving it on the stack for binding, so we only pop a value when the var has -;;; some reference. INTERNAL-APPLY uses this for c::combination nodes -;;; representing LET's. -;;; -;;; When storing the local, if it is indirect, then someone closes over it for -;;; setting instead of just for referencing. We then store an indirection cell -;;; with the value, and the referencing code for locals knows how to get the -;;; actual value. -;;; -(defun store-let-vars (lambda frame-ptr) - (let* ((vars (c::lambda-vars lambda)) - (args (eval-stack-args (count-if #'c::leaf-refs vars)))) - (declare (list vars args)) - (dolist (v vars) - (when (c::leaf-refs v) - (setf (eval-stack-local frame-ptr (c::lambda-var-info v)) - (if (c::lambda-var-indirect v) - (make-indirect-value-cell (pop args)) - (pop args))))))) - -;;; STORE-MV-LET-VARS -- Internal. -;;; -;;; This is similar to STORE-LET-VARS, but the values for the locals appear on -;;; the stack in a list due to forms that delivered multiple values to this -;;; lambda/let. Unlike STORE-LET-VARS, there is no control over the delivery -;;; of a value for an unreferenced var, so we drop the corresponding value on -;;; the floor when no one references it. INTERNAL-APPLY uses this for -;;; c::mv-combination nodes representing LET's. -;;; -(defun store-mv-let-vars (lambda frame-ptr count) - (assert (= count 1)) - (let ((args (eval-stack-pop))) - (dolist (v (c::lambda-vars lambda)) - (if (c::leaf-refs v) - (setf (eval-stack-local frame-ptr (c::lambda-var-info v)) - (if (c::lambda-var-indirect v) - (make-indirect-value-cell (pop args)) - (pop args))) - (pop args))))) - -#| -;;; STORE-MV-LET-VARS -- Internal. -;;; -;;; This stores lambda's vars, stack locals, from multiple values stored on the -;;; top of the stack in a list. Since these values arrived multiply, there is -;;; no control over the delivery of each value for an unreferenced var, so -;;; unlike STORE-LET-VARS, we have values for variables never used. We drop -;;; the value corresponding to an unreferenced var on the floor. -;;; INTERNAL-APPLY uses this for c::mv-combination nodes representing LET's. -;;; -;;; IR1 represents variables bound from multiple values in a list in the -;;; opposite order of the values list. We use STORE-MV-LET-VARS-AUX to recurse -;;; down the vars list until we bottom out, storing values on the way back up -;;; the recursion. You must do this instead of NREVERSE'ing the args list, so -;;; when we run out of values, we store nil's in the correct lambda-vars. -;;; -(defun store-mv-let-vars (lambda frame-ptr count) - (assert (= count 1)) - (print (c::lambda-vars lambda)) - (store-mv-let-vars-aux frame-ptr (c::lambda-vars lambda) (eval-stack-pop))) -;;; -(defun store-mv-let-vars-aux (frame-ptr vars args) - (if vars - (let ((remaining-args (store-mv-let-vars-aux frame-ptr (cdr vars) args)) - (v (car vars))) - (when (c::leaf-refs v) - (setf (eval-stack-local frame-ptr (c::lambda-var-info v)) - (if (c::lambda-var-indirect v) - (make-indirect-value-cell (car remaining-args)) - (car remaining-args)))) - (cdr remaining-args)) - args)) -|# diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp deleted file mode 100644 index 8f4cbd29f75ea11e5f7bee055464a4db063cd2c2..0000000000000000000000000000000000000000 --- a/compiler/float-tran.lisp +++ /dev/null @@ -1,291 +0,0 @@ -;;; -*- Mode: Lisp; Package: C; Log: code.log -*- -;;; -;;; ********************************************************************** -;;; 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/float-tran.lisp,v 1.14 1992/08/13 18:03:59 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains floating-point specific transforms, and may be somewhat -;;; implementation dependent in its assumptions of what the formats are. -;;; -;;; Author: Rob MacLachlan -;;; -(in-package "C") - - -;;;; Coercions: - -#-new-compiler -(progn - (defun %single-float (x) (coerce x 'single-float)) - (defun %double-float (x) (coerce x 'double-float))) - -(defknown %single-float (real) single-float (movable foldable flushable)) -(defknown %double-float (real) double-float (movable foldable flushable)) - -(deftransform float ((n &optional f) (* &optional single-float)) - '(%single-float n)) - -(deftransform float ((n f) (* double-float)) - '(%double-float n)) - -(deftransform %single-float ((n) (single-float)) - 'n) - -(deftransform %double-float ((n) (double-float)) - 'n) - -(deftransform coerce ((n type) - (* (constant-argument - (member float short-float single-float)))) - '(%single-float n)) - -(deftransform coerce ((n type) - (* (constant-argument - (member double-float long-float)))) - '(%double-float n)) - -;;; Not strictly float functions, but primarily useful on floats: -;;; -(macrolet ((frob (fun ufun) - `(progn - (defknown ,ufun (real) integer (movable foldable flushable)) - (deftransform ,fun ((x &optional by) - (* &optional - (constant-argument (member 1)))) - '(let ((res (,ufun x))) - (values res (- x res))))))) - (frob truncate %unary-truncate) - (frob round %unary-round)) - - -;;;; Float accessors: - -(defknown make-single-float ((signed-byte 32)) single-float - (movable foldable flushable)) - -(defknown make-double-float ((signed-byte 32) (unsigned-byte 32)) double-float - (movable foldable flushable)) - -(defknown single-float-bits (single-float) (signed-byte 32) - (movable foldable flushable)) - -(defknown double-float-high-bits (double-float) (signed-byte 32) - (movable foldable flushable)) - -(defknown double-float-low-bits (double-float) (unsigned-byte 32) - (movable foldable flushable)) - - -(defun make-single-float (x) (make-single-float x)) -(defun make-double-float (hi lo) (make-double-float hi lo)) -(defun single-float-bits (x) (single-float-bits x)) -(defun double-float-high-bits (x) (double-float-high-bits x)) -(defun double-float-low-bits (x) (double-float-low-bits x)) - -(def-source-transform float-sign (float1 &optional (float2 nil f2-p)) - (let ((n-f1 (gensym))) - (if f2-p - `(* (float-sign ,float1) (abs ,float2)) - `(let ((,n-f1 ,float1)) - (declare (float ,n-f1)) - (if (minusp (if (typep ,n-f1 'single-float) - (single-float-bits ,n-f1) - (double-float-high-bits ,n-f1))) - (float -1 ,n-f1) - (float 1 ,n-f1)))))) - - -;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, SCALE-FLOAT: -;;; -;;; Convert these operations to format specific versions when the format is -;;; known. -;;; - -(deftype single-float-exponent () - `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias - vm:single-float-digits) - ,(- vm:single-float-normal-exponent-max vm:single-float-bias))) - -(deftype double-float-exponent () - `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias - vm:double-float-digits) - ,(- vm:double-float-normal-exponent-max vm:double-float-bias))) - - -(deftype single-float-int-exponent () - `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias - (* vm:single-float-digits 2)) - ,(- vm:single-float-normal-exponent-max vm:single-float-bias - vm:single-float-digits))) - -(deftype double-float-int-exponent () - `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias - (* vm:double-float-digits 2)) - ,(- vm:double-float-normal-exponent-max vm:double-float-bias - vm:double-float-digits))) - -(deftype single-float-significand () - `(integer 0 (,(ash 1 vm:single-float-digits)))) - -(deftype double-float-significand () - `(integer 0 (,(ash 1 vm:double-float-digits)))) - -(defknown decode-single-float (single-float) - (values single-float single-float-exponent (single-float -1f0 1f0)) - (movable foldable flushable)) - -(defknown decode-double-float (double-float) - (values double-float double-float-exponent (double-float -1d0 1d0)) - (movable foldable flushable)) - -(defknown integer-decode-single-float (single-float) - (values single-float-significand single-float-int-exponent (integer -1 1)) - (movable foldable flushable)) - -(defknown integer-decode-double-float (double-float) - (values double-float-significand double-float-int-exponent (integer -1 1)) - (movable foldable flushable))) - -(defknown scale-single-float (single-float fixnum) single-float - (movable foldable flushable)) - -(defknown scale-double-float (double-float fixnum) double-float - (movable foldable flushable)) - -(deftransform decode-float ((x) (single-float)) - '(decode-single-float x)) - -(deftransform decode-float ((x) (double-float)) - '(decode-double-float x)) - -(deftransform integer-decode-float ((x) (single-float)) - '(integer-decode-single-float x)) - -(deftransform integer-decode-float ((x) (double-float)) - '(integer-decode-double-float x)) - -(deftransform scale-float ((f ex) (single-float *)) - '(scale-single-float f ex)) - -(deftransform scale-float ((f ex) (double-float *)) - '(scale-double-float f ex)) - - -;;;; Float contagion: - -;;; FLOAT-CONTAGION-ARG1, ARG2 -- Internal -;;; -;;; Do some stuff to recognize when the luser is doing mixed float and -;;; rational arithmetic, or different float types, and fix it up. If we don't, -;;; he won't even get so much as an efficency note. -;;; -(deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node) - `(,(continuation-function-name (basic-combination-fun node)) - (float x y) y)) -;;; -(deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node) - `(,(continuation-function-name (basic-combination-fun node)) - x (float y x))) - -(dolist (x '(+ * / -)) - (%deftransform x '(function (rational float) *) #'float-contagion-arg1) - (%deftransform x '(function (float rational) *) #'float-contagion-arg2)) - -(dolist (x '(= < > + * / -)) - (%deftransform x '(function (single-float double-float) *) - #'float-contagion-arg1) - (%deftransform x '(function (double-float single-float) *) - #'float-contagion-arg2)) - - -;;; Prevent zerop, plusp, minusp from losing horribly. We can't in general -;;; float rational args to comparison, since Common Lisp semantics says we are -;;; supposed to compare as rationals, but we can do it for any rational that -;;; has a precise representation as a float (such as 0). -;;; -(macrolet ((frob (op) - `(deftransform ,op ((x y) (float rational)) - (unless (constant-continuation-p y) - (give-up "Can't open-code float to rational comparison.")) - (let ((val (continuation-value y))) - (unless (eql (rational (float val)) val) - (give-up "~S doesn't have a precise float representation." - val))) - `(,',op x (float y x))))) - (frob <) - (frob >) - (frob =)) - - -;;;; Irrational derive-type methods: - -;;; Derive the result to be float for argument types in the appropriate domain. -;;; -(dolist (stuff '((asin (real (-1.0) (1.0))) - (acos (real (-1.0) (1.0))) - (acosh (real 1.0)) - (atanh (real (-1.0) (1.0))) - (sqrt (real 0.0)))) - (destructuring-bind (name type) stuff - (let ((type (specifier-type type))) - (setf (function-info-derive-type (function-info-or-lose name)) - #'(lambda (call) - (declare (type combination call)) - (when (csubtypep (continuation-type - (first (combination-args call))) - type) - (specifier-type 'float))))))) - - -;;;; Irrational transforms: - -(defknown (%sin %cos %tan %asin %acos %atan %sinh %cosh %tanh %asinh - %acosh %atanh %exp %expm1 %log %log10 %log1p %cbrt %sqrt) - (double-float) double-float - (movable foldable flushable)) - -(defknown (%atan2 %pow %hypot) - (double-float double-float) double-float - (movable foldable flushable)) - -(dolist (stuff '((exp %exp *) - (log %log float) - (sqrt %sqrt float) - (sin %sin *) - (cos %cos *) - (tan %tan *) - (asin %asin float) - (acos %acos float) - (atan %atan *) - (sinh %sinh *) - (cosh %cosh *) - (tanh %tanh *) - (asinh %asinh *) - (acosh %acosh float) - (atanh %atanh float))) - (destructuring-bind (name prim rtype) stuff - (deftransform name ((x) '(single-float) rtype :eval-name t) - `(coerce (,prim (coerce x 'double-float)) 'single-float)) - (deftransform name ((x) '(double-float) rtype :eval-name t) - `(,prim x)))) - -(dolist (stuff '((expt %pow t) - (atan %atan2 t))) - (destructuring-bind (name prim rtype) stuff - (deftransform name ((x y) '(single-float) rtype :eval-name t) - `(coerce (,prim (coerce x 'double-float) - (coerce y 'double-float)) - 'single-float)) - (deftransform name ((x y) '(double-float) rtype :eval-name t) - `(,prim x y)))) - -(deftransform log ((x y) (float float) float) - '(/ (log x) (log y))) - diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp deleted file mode 100644 index 8320ff95c4801e8d31ded21e13ae078477d8cac5..0000000000000000000000000000000000000000 --- a/compiler/fndb.lisp +++ /dev/null @@ -1,1163 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/fndb.lisp,v 1.52 1992/12/17 14:35:07 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file defines all the standard functions to be known functions. -;;; Each function has type and side-effect information, and may also have IR1 -;;; optimizers. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") - -(in-package "LISP") -(import '( - %aset - %bitset - %charset - %primitive - %put - %puthash - %rplaca - %rplacd - %sbitset - %scharset - %set-documentation - %set-fdefinition - %set-fill-pointer - %set-row-major-aref - %setelt - %setnth - %standard-char-p - %svset - %typep - array-header-p - base-char-p - double-float-p - long-float-p - short-float-p - single-float-p - string<* - string>* - string<=* - string>=* - string=* - string/=* - %sp-string-compare - ) - "C") - -(in-package "KERNEL") - -(export '(%caller-frame-and-pc %with-array-data)) - -(in-package 'c) - - -;;;; Information for known functions: - -(defknown coerce (t type-specifier) t - (movable foldable) ; Is defined to signal errors. - :derive-type (result-type-specifier-nth-arg 2)) - -(defknown type-of (t) t (foldable flushable)) - -;;; Can be affected by type definitions... -(defknown (upgraded-complex-part-type upgraded-array-element-type) - (type-specifier) type-specifier - (flushable)) - - -;;;; In the "Predicates" chapter: - -(defknown typep (t type-specifier) boolean (foldable flushable)) -(defknown subtypep (type-specifier type-specifier) (values boolean boolean) - (foldable flushable)) - -(defknown (null symbolp atom consp listp numberp integerp rationalp floatp - complexp characterp stringp bit-vector-p vectorp - simple-vector-p simple-string-p simple-bit-vector-p arrayp - packagep functionp compiled-function-p not) - (t) boolean (movable foldable flushable)) - - -(defknown (eq eql) (t t) boolean (movable foldable flushable)) -(defknown (equal equalp) (t t) boolean (foldable flushable recursive)) - - -;;;; In the "Control Structure" chapter: - -;;; Not flushable, since required to signal an error if unbound. -(defknown (symbol-value symbol-function) (symbol) t ()) - -(defknown boundp (symbol) boolean (flushable)) -(defknown fboundp ((or symbol cons)) boolean (flushable explicit-check)) -(defknown special-form-p (symbol) t (movable foldable flushable)) ; They never change... -(defknown set (symbol t) t (unsafe) - :derive-type #'result-type-last-arg) -(defknown fdefinition ((or symbol cons)) function (unsafe explicit-check)) -(defknown %set-fdefinition ((or symbol cons) function) function - (unsafe explicit-check)) -(defknown makunbound (symbol) symbol) -(defknown fmakunbound ((or symbol cons)) (or symbol cons) - (unsafe explicit-check)) -(defknown (get-setf-method get-setf-method-multiple-value) - ((or list symbol) &optional lexical-environment) - (values list list list form form) - (flushable)) -(defknown apply (callable t &rest t) *) ; ### Last arg must be List... -(defknown funcall (callable &rest t) *) - -(defknown (mapcar maplist mapcan mapcon) (callable list &rest list) list - (call)) - -(defknown (mapc mapl) (callable list &rest list) list (foldable call)) - -;;; We let values-list be foldable, since constant-folding will turn it into -;;; VALUES. VALUES is not foldable, since MV constants are represented by a -;;; call to VALUES. -;;; -(defknown values (&rest t) * (movable flushable unsafe)) -(defknown values-list (list) * (movable foldable flushable)) - - -;;;; In the "Macros" chapter: - -(defknown macro-function (symbol &optional lexical-environment) - (or function null) - (flushable)) -(defknown (macroexpand macroexpand-1) (t &optional lexical-environment) - (values form &optional boolean)) - -(defknown compiler-macro-function (t &optional lexical-environment) - (or function null) - (flushable)) -(defknown (compiler-macroexpand compiler-macroexpand-1) - (t &optional lexical-environment) - (values form &optional boolean)) - - -;;;; In the "Declarations" chapter: - -(defknown proclaim (list) void) - - -;;;; In the "Symbols" chapter: - -(defknown get (symbol t &optional t) t (flushable)) -(defknown remprop (symbol t) t) -(defknown symbol-plist (symbol) list (flushable)) -(defknown getf (list t &optional t) t (foldable flushable)) -(defknown get-properties (list list) (values t t list) (foldable flushable)) -(defknown symbol-name (symbol) simple-string (movable foldable flushable)) -(defknown make-symbol (string) symbol (flushable)) -(defknown copy-symbol (symbol &optional t) symbol (flushable)) -(defknown gensym (&optional (or string unsigned-byte)) symbol ()) -(defknown symbol-package (symbol) (or package null) (flushable)) -(defknown keywordp (t) boolean (flushable)) ; If someone uninterns it... - - -;;;; In the "Packages" chapter: - - -(deftype packagelike () '(or stringlike package)) -(deftype symbols () '(or list symbol)) - -;;; Should allow a package name, I think, tho CLtL II doesn't say so... -(defknown gentemp (&optional string packagelike) symbol) - -(defknown make-package (stringlike &key (:use list) (:nicknames list) - ;; ### Extensions... - (:internal-symbols index) (:external-symbols index)) - package) -(defknown find-package (stringlike) (or package null) (flushable)) -(defknown package-name (packagelike) (or simple-string null) (flushable)) -(defknown package-nicknames (packagelike) list (flushable)) -(defknown rename-package (packagelike stringlike &optional list) package) -(defknown package-use-list (packagelike) list (flushable)) -(defknown package-used-by-list (packagelike) list (flushable)) -(defknown package-shadowing-symbols (packagelike) list (flushable)) -(defknown list-all-packages () list (flushable)) -(defknown intern (string &optional packagelike) - (values symbol (member :internal :external :inherited nil)) - ()) -(defknown find-symbol (string &optional packagelike) - (values symbol (member :internal :external :inherited nil)) - (flushable)) -(defknown (export import) (symbols &optional packagelike) truth) -(defknown unintern (symbol &optional packagelike) boolean) -(defknown unexport (symbols &optional packagelike) truth) -(defknown shadowing-import (symbols &optional packagelike) truth) -(defknown shadow ((or symbol string list) &optional packagelike) truth) -(defknown (use-package unuse-package) ((or list packagelike) &optional packagelike) truth) -(defknown find-all-symbols (stringlike) list (flushable)) - - -;;;; In the "Numbers" chapter: - -(defknown zerop (number) boolean (movable foldable flushable explicit-check)) -(defknown (plusp minusp) (real) boolean - (movable foldable flushable explicit-check)) -(defknown (oddp evenp) (integer) boolean - (movable foldable flushable explicit-check)) -(defknown (= /=) (number &rest number) boolean - (movable foldable flushable explicit-check)) -(defknown (< > <= >=) (real &rest real) boolean - (movable foldable flushable explicit-check)) -(defknown (max min) (real &rest real) real - (movable foldable flushable explicit-check)) - -(defknown + (&rest number) number - (movable foldable flushable explicit-check)) -(defknown - (number &rest number) number - (movable foldable flushable explicit-check)) -(defknown * (&rest number) number - (movable foldable flushable explicit-check)) -(defknown / (number &rest number) number - (movable foldable flushable explicit-check)) -(defknown (1+ 1-) (number) number - (movable foldable flushable explicit-check)) - -(defknown conjugate (number) number - (movable foldable flushable explicit-check)) - -(defknown gcd (&rest integer) unsigned-byte - (movable foldable flushable explicit-check) - #|:derive-type 'boolean-result-type|#) -(defknown lcm (&rest integer) unsigned-byte - (movable foldable flushable explicit-check)) - -(defknown exp (number) irrational - (movable foldable flushable explicit-check recursive) - :derive-type #'result-type-float-contagion) - -(defknown expt (number number) number - (movable foldable flushable explicit-check recursive)) -(defknown log (number &optional real) irrational - (movable foldable flushable explicit-check)) -(defknown sqrt (number) irrational - (movable foldable flushable explicit-check)) -(defknown isqrt (unsigned-byte) unsigned-byte - (movable foldable flushable explicit-check)) - -(defknown (abs phase signum) (number) number - (movable foldable flushable explicit-check)) -(defknown cis (real) (complex float) - (movable foldable flushable explicit-check)) - -(defknown (sin cos) (number) - (or (float -1.0 1.0) (complex (float -1.0 1.0))) - (movable foldable flushable explicit-check recursive) - :derive-type #'result-type-float-contagion) - -(defknown atan - (number &optional real) irrational - (movable foldable flushable explicit-check recursive) - :derive-type #'result-type-float-contagion) - -(defknown (tan sinh cosh tanh asinh) - (number) irrational (movable foldable flushable explicit-check recursive) - :derive-type #'result-type-float-contagion) - -(defknown (asin acos acosh atanh) - (number) irrational - (movable foldable flushable explicit-check recursive)) - -(defknown float (real &optional float) float - (movable foldable flushable explicit-check)) - -(defknown (rational rationalize) (real) rational - (movable foldable flushable explicit-check)) - -(defknown (numerator denominator) (rational) integer - (movable foldable flushable)) - -(defknown (floor ceiling truncate round) - (real &optional real) (values integer real) - (movable foldable flushable explicit-check)) - -(defknown (mod rem) (real real) real - (movable foldable flushable explicit-check)) - -(defknown (ffloor fceiling fround ftruncate) - (real &optional real) (values float float) - (movable foldable flushable explicit-check)) - -(defknown decode-float (float) (values float float-exponent float) - (movable foldable flushable explicit-check)) -(defknown scale-float (float float-exponent) float - (movable foldable flushable explicit-check)) -(defknown float-radix (float) float-radix - (movable foldable flushable explicit-check)) -(defknown float-sign (float &optional float) float - (movable foldable flushable explicit-check)) -(defknown (float-digits float-precision) (float) float-digits - (movable foldable flushable explicit-check)) -(defknown integer-decode-float (float) - (values integer float-exponent (member -1 1)) - (movable foldable flushable explicit-check)) - -(defknown complex (real &optional real) number - (movable foldable flushable explicit-check)) - -(defknown (realpart imagpart) (number) real (movable foldable flushable)) - -(defknown (logior logxor logand logeqv) (&rest integer) integer - (movable foldable flushable explicit-check)) - -(defknown (lognand lognor logandc1 logandc2 logorc1 logorc2) - (integer integer) integer - (movable foldable flushable explicit-check)) - -(defknown boole (boole-code integer integer) integer - (movable foldable flushable)) - -(defknown lognot (integer) integer (movable foldable flushable explicit-check)) -(defknown logtest (integer integer) boolean (movable foldable flushable)) -(defknown logbitp (bit-index integer) boolean (movable foldable flushable)) -(defknown ash (integer ash-index) integer (movable foldable flushable explicit-check)) -(defknown (logcount integer-length) (integer) bit-index - (movable foldable flushable explicit-check)) -(defknown byte (bit-index bit-index) byte-specifier - (movable foldable flushable)) -(defknown (byte-size byte-position) (byte-specifier) bit-index - (movable foldable flushable)) -(defknown ldb (byte-specifier integer) integer (movable foldable flushable)) -(defknown ldb-test (byte-specifier integer) boolean - (movable foldable flushable)) -(defknown mask-field (byte-specifier integer) integer - (movable foldable flushable)) -(defknown dpb (integer byte-specifier integer) integer - (movable foldable flushable)) -(defknown deposit-field (integer byte-specifier integer) integer - (movable foldable flushable)) -(defknown random (real &optional random-state) real ()) -(defknown make-random-state (&optional (or (member nil t) random-state)) - random-state (flushable)) -(defknown random-state-p (t) boolean (movable foldable flushable)) - -;;; In "Characters" chapter: -(defknown (standard-char-p graphic-char-p alpha-char-p - upper-case-p lower-case-p both-case-p alphanumericp) - (character) boolean (movable foldable flushable)) - -(defknown digit-char-p (character &optional unsigned-byte) - (or (integer 0 35) null) (movable foldable flushable)) - -(defknown (char= char/= char< char> char<= char>= char-equal char-not-equal - char-lessp char-greaterp char-not-greaterp char-not-lessp) - (character &rest character) boolean (movable foldable flushable)) - -(defknown character (t) character (movable foldable flushable)) -(defknown char-code (character) char-code (movable foldable flushable)) -(defknown code-char (char-code) base-char (movable foldable flushable)) -(defknown (char-upcase char-downcase) (character) character - (movable foldable flushable)) -(defknown digit-char (integer &optional integer) - (or character null) (movable foldable flushable)) -(defknown char-int (character) char-code (movable foldable flushable)) -(defknown char-name (character) (or simple-string null) - (movable foldable flushable)) -(defknown name-char (stringable) (or character null) - (movable foldable flushable)) - - -;;;; In the "Sequences" chapter: - -(defknown elt (sequence index) t (foldable flushable)) - -(defknown subseq (sequence index &optional sequence-end) consed-sequence - (foldable flushable) - :derive-type (sequence-result-nth-arg 1)) - -(defknown copy-seq (sequence) consed-sequence (foldable flushable) - :derive-type #'result-type-first-arg) - - -(defknown length (sequence) index (foldable flushable)) - -(defknown reverse (sequence) consed-sequence (foldable flushable) - :derive-type #'result-type-first-arg) - -(defknown nreverse (sequence) sequence () - :derive-type #'result-type-first-arg) - -(defknown make-sequence (type-specifier index &key (:initial-element t)) consed-sequence - (movable flushable unsafe) - :derive-type (result-type-specifier-nth-arg 1)) - -(defknown concatenate (type-specifier &rest sequence) consed-sequence - (foldable flushable) - :derive-type (result-type-specifier-nth-arg 1)) - -(defknown map (type-specifier callable sequence &rest sequence) consed-sequence - (flushable call) -; :derive-type 'type-spec-arg1 Nope... (map nil ...) returns null, not nil. - ) - -;;; Returns predicate result... -(defknown some (callable sequence &rest sequence) t - (foldable flushable call)) - -(defknown (every notany notevery) (callable sequence &rest sequence) boolean - (foldable flushable call)) - -;;; Unsafe for :Initial-Value... -(defknown reduce (callable sequence &key (:from-end t) (:start index) - (:end sequence-end) (:initial-value t) (:key callable)) - t - (foldable flushable call unsafe)) - -(defknown fill (sequence t &key (:start index) (:end sequence-end)) sequence - (unsafe) - :derive-type #'result-type-first-arg) - -(defknown replace (sequence sequence &key (:start1 index) (:end1 sequence-end) - (:start2 index) (:end2 sequence-end)) - consed-sequence () - :derive-type #'result-type-first-arg) - -(defknown remove - (t sequence &key (:from-end t) (:test callable) - (:test-not callable) (:start index) (:end sequence-end) - (:count sequence-end) (:key callable)) - consed-sequence - (flushable call) - :derive-type (sequence-result-nth-arg 2)) - -(defknown substitute - (t t sequence &key (:from-end t) (:test callable) - (:test-not callable) (:start index) (:end sequence-end) - (:count sequence-end) (:key callable)) - consed-sequence - (flushable call) - :derive-type (sequence-result-nth-arg 3)) - -(defknown (remove-if remove-if-not) - (callable sequence &key (:from-end t) (:start index) (:end sequence-end) - (:count sequence-end) (:key callable)) - consed-sequence - (flushable call) - :derive-type (sequence-result-nth-arg 2)) - -(defknown (substitute-if substitute-if-not) - (t callable sequence &key (:from-end t) (:start index) (:end sequence-end) - (:count sequence-end) (:key callable)) - consed-sequence - (flushable call) - :derive-type (sequence-result-nth-arg 3)) - -(defknown delete - (t sequence &key (:from-end t) (:test callable) - (:test-not callable) (:start index) (:end sequence-end) - (:count sequence-end) (:key callable)) - sequence - (flushable call) - :derive-type (sequence-result-nth-arg 2)) - -(defknown nsubstitute - (t t sequence &key (:from-end t) (:test callable) - (:test-not callable) (:start index) (:end sequence-end) - (:count sequence-end) (:key callable)) - sequence - (flushable call) - :derive-type (sequence-result-nth-arg 3)) - -(defknown (delete-if delete-if-not) - (callable sequence &key (:from-end t) (:start index) (:end sequence-end) - (:count sequence-end) (:key callable)) - sequence - (flushable call) - :derive-type (sequence-result-nth-arg 2)) - -(defknown (nsubstitute-if nsubstitute-if-not) - (t callable sequence &key (:from-end t) (:start index) (:end sequence-end) - (:count sequence-end) (:key callable)) - sequence - (flushable call) - :derive-type (sequence-result-nth-arg 3)) - -(defknown remove-duplicates - (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) - (:end sequence-end) (:key callable)) - consed-sequence - (flushable call) - :derive-type (sequence-result-nth-arg 1)) - -(defknown delete-duplicates - (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) - (:end sequence-end) (:key callable)) - sequence - (flushable call) - :derive-type (sequence-result-nth-arg 1)) - -(defknown find (t sequence &key (:test callable) (:test-not callable) - (:start index) (:from-end t) (:end sequence-end) (:key callable)) - t - (foldable flushable call)) - -(defknown (find-if find-if-not) - (callable sequence &key (:from-end t) (:start index) (:end sequence-end) - (:key callable)) - t - (foldable flushable call)) - -(defknown position (t sequence &key (:test callable) (:test-not callable) - (:start index) (:from-end t) (:end sequence-end) - (:key callable)) - (or index null) - (foldable flushable call)) - -(defknown (position-if position-if-not) - (callable sequence &key (:from-end t) (:start index) (:end sequence-end) - (:key callable)) - (or index null) - (foldable flushable call)) - -(defknown count (t sequence &key (:test callable) (:test-not callable) - (:start index) (:from-end t) (:end sequence-end) - (:key callable)) - index - (foldable flushable call)) - -(defknown (count-if count-if-not) - (callable sequence &key (:from-end t) (:start index) (:end sequence-end) - (:key callable)) - index - (foldable flushable call)) - -(defknown (mismatch search) - (sequence sequence &key (:from-end t) (:test callable) (:test-not callable) - (:start1 index) (:end1 sequence-end) (:start2 index) (:end2 sequence-end) - (:key callable)) - (or index null) - (foldable flushable call)) - -;;; Not flushable, since vector sort guaranteed in-place... -(defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence - (call) - :derive-type (sequence-result-nth-arg 1)) - -(defknown merge (type-specifier sequence sequence callable - &key (:key callable)) - sequence - (flushable call) - :derive-type (result-type-specifier-nth-arg 1)) - - -;;;; In the "Manipulating List Structure" chapter: - -(defknown (car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr - cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar - cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - first second third fourth fifth sixth seventh eighth ninth tenth - rest) - (list) t (foldable flushable)) - -(defknown cons (t t) cons (movable flushable unsafe)) - -(defknown tree-equal (t t &key (:test callable) (:test-not callable)) boolean - (foldable flushable call)) -(defknown endp (t) boolean (foldable flushable movable)) -(defknown list-length (list) (or index null) (foldable flushable)) -(defknown (nth nthcdr) (index list) t (foldable flushable)) -(defknown last (list &optional index) list (foldable flushable)) -(defknown list (&rest t) list (movable flushable unsafe)) -(defknown list* (t &rest t) t (movable flushable unsafe)) -(defknown make-list (index &key (:initial-element t)) list - (movable flushable unsafe)) - -;;; -;;; All but last must be list... -(defknown append (&rest t) t (flushable)) - -(defknown copy-list (list) list (flushable)) -(defknown copy-alist (list) list (flushable)) -(defknown copy-tree (t) t (flushable)) -(defknown revappend (list t) t (flushable)) -(defknown nconc (&rest list) list ()) -(defknown nreconc (list list) list ()) -(defknown butlast (list &optional index) list (flushable)) -(defknown nbutlast (list &optional index) list ()) -(defknown ldiff (list list) list (flushable)) -(defknown (rplaca rplacd) (cons t) list (unsafe)) - -(defknown (nsubst subst) (t t t &key (:key callable) (:test callable) - (:test-not callable)) - list (flushable unsafe call)) - -(defknown (subst-if subst-if-not nsubst-if nsubst-if-not) - (t t t &key (:key callable)) - list (flushable unsafe call)) - -(defknown (sublis nsublis) (list t &key (:key callable) (:test callable) - (:test-not callable)) - list (flushable unsafe call)) - -(defknown member (t list &key (:key callable) (:test callable) - (:test-not callable)) - list (foldable flushable call)) -(defknown (member-if member-if-not) (callable list &key (:key callable)) - list (foldable flushable call)) - -(defknown tailp (list list) boolean (foldable flushable)) - -(defknown adjoin (t list &key (:key callable) (:test callable) - (:test-not callable)) - list (foldable flushable unsafe call)) - -(defknown (union intersection set-difference set-exclusive-or) - (list list &key (:key callable) (:test callable) (:test-not callable)) - list - (foldable flushable call)) - -(defknown (nunion nintersection nset-difference nset-exclusive-or) - (list list &key (:key callable) (:test callable) (:test-not callable)) - list - (foldable flushable call)) - -(defknown subsetp - (list list &key (:key callable) (:test callable) (:test-not callable)) - boolean - (foldable flushable call)) - -(defknown acons (t t t) list (movable flushable unsafe)) -(defknown pairlis (t t &optional t) list (flushable unsafe)) - -(defknown (rassoc assoc) - (t list &key (:key callable) (:test callable) (:test-not callable)) - list (foldable flushable call)) -(defknown (assoc-if-not assoc-if rassoc-if rassoc-if-not) - (callable list &key (:key callable)) list (foldable flushable call)) - - -;;;; In the "Hash Tables" chapter: - -(defknown make-hash-table - (&key (:test callable) (:size index) - (:rehash-size (or (integer 1) (float (1.0)))) - (:rehash-threshold (real 0 1))) - hash-table - (flushable unsafe)) -(defknown hash-table-p (t) boolean (movable foldable flushable)) -(defknown gethash (t hash-table &optional t) (values t boolean) - (foldable flushable unsafe)) -(defknown %puthash (t hash-table t) t (unsafe)) -(defknown remhash (t hash-table) boolean ()) -(defknown maphash (callable hash-table) null (foldable flushable call)) -(defknown clrhash (hash-table) hash-table ()) -(defknown hash-table-count (hash-table) index (foldable flushable)) -(defknown hash-table-rehash-size (hash-table) (or (integer 1) (float (1.0))) - (foldable flushable)) -(defknown hash-table-rehash-threshold (hash-table) (real 0 1) - (foldable flushable)) -(defknown hash-table-size (hash-table) index (foldable flushable)) -(defknown hash-table-test (hash-table) symbol (foldable flushable)) -(deftype non-negative-fixnum () `(integer 0 ,most-positive-fixnum)) -(defknown sxhash (t) non-negative-fixnum (foldable flushable)) - - -;;;; In the "Arrays" chapter: - -(defknown make-array ((or index list) &key (:element-type type-specifier) - (:initial-element t) (:initial-contents t) - (:adjustable t) (:fill-pointer t) - (:displaced-to (or array null)) - (:displaced-index-offset index)) - array (flushable unsafe)) - -(defknown vector (&rest t) simple-vector (flushable unsafe)) - -(defknown aref (array &rest index) t (foldable flushable)) -(defknown row-major-aref (array index) t (foldable flushable)) - -(defknown array-element-type (array) type-specifier (foldable flushable)) -(defknown array-rank (array) array-rank (foldable flushable)) -(defknown array-dimension (array array-rank) index (foldable flushable)) -(defknown array-dimensions (array) list (foldable flushable)) -(defknown array-in-bounds-p (array &rest index) boolean (foldable flushable)) -(defknown array-row-major-index (array &rest index) array-total-size - (foldable flushable)) -(defknown array-total-size (array) array-total-size (foldable flushable)) -(defknown adjustable-array-p (array) boolean (movable foldable flushable)) - -(defknown svref (simple-vector index) t (foldable flushable)) -(defknown bit ((array bit) &rest index) bit (foldable flushable)) -(defknown sbit ((simple-array bit) &rest index) bit (foldable flushable)) - -(defknown (bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2 - bit-orc1 bit-orc2) - ((array bit) (array bit) &optional (or (array bit) (member t))) - (array bit) - (foldable) - #|:derive-type #'result-type-last-arg|#) - -(defknown bit-not ((array bit) &optional (or (array bit) (member t))) - (array bit) - (foldable) - #|:derive-type #'result-type-last-arg|#) - -(defknown array-has-fill-pointer-p (array) boolean (movable foldable flushable)) -(defknown fill-pointer (vector) index (foldable flushable)) -(defknown vector-push (t vector) (or index null) ()) -(defknown vector-push-extend (t vector &optional index) index ()) -(defknown vector-pop (vector) t ()) - -(defknown adjust-array - (array (or index list) &key (:element-type type-specifier) - (:initial-element t) (:initial-contents list) - (:fill-pointer t) (:displaced-to (or array null)) - (:displaced-index-offset index)) - array (unsafe)) -; :derive-type 'result-type-arg1) Not even close... - - -;;;; In the "Strings" chapter: - -(defknown char (string index) character (foldable flushable)) -(defknown schar (simple-string index) character (foldable flushable)) - -(deftype stringable () '(or character string symbol)) - -(defknown (string= string-equal) - (stringable stringable &key (:start1 index) (:end1 sequence-end) - (:start2 index) (:end2 sequence-end)) - boolean - (foldable flushable)) - -(defknown (string< string> string<= string>= string/= string-lessp - string-greaterp string-not-lessp string-not-greaterp - string-not-equal) - (stringable stringable &key (:start1 index) (:end1 sequence-end) - (:start2 index) (:end2 sequence-end)) - (or index null) - (foldable flushable)) - -(defknown make-string (index &key (:initial-element character)) - simple-string (flushable)) - -(defknown (string-trim string-left-trim string-right-trim) - (sequence stringable) simple-string (flushable)) - -(defknown (string-upcase string-downcase string-capitalize) - (stringable &key (:start index) (:end sequence-end)) - simple-string (flushable)) - -(defknown (nstring-upcase nstring-downcase nstring-capitalize) - (string &key (:start index) (:end sequence-end)) - string ()) - -(defknown string (stringable) string - (flushable explicit-check)) - - -;;; Internal non-keyword versions of string predicates: - -(defknown (string<* string>* string<=* string>=* string/=*) - (stringable stringable index sequence-end index sequence-end) - (or index null) - (foldable flushable)) - -(defknown string=* - (stringable stringable index sequence-end index sequence-end) - boolean - (foldable flushable)) - - -;;;; In the "Eval" chapter: - -(defknown eval (t) *) -(defknown constantp (t) boolean (foldable flushable)) - - -;;;; In the "Streams" chapter: - -(defknown make-synonym-stream (symbol) stream (flushable)) -(defknown make-broadcast-stream (&rest stream) stream (flushable)) -(defknown make-concatenated-stream (&rest stream) stream (flushable)) -(defknown make-two-way-stream (stream stream) stream (flushable)) -(defknown make-echo-stream (stream stream) stream (flushable)) -(defknown make-string-input-stream (string &optional index index) stream (flushable unsafe)) -(defknown make-string-output-stream () stream (flushable)) -(defknown get-output-stream-string (stream) simple-string ()) -(defknown streamp (t) boolean (movable foldable flushable)) -(defknown stream-element-type (stream) type-specifier (movable foldable flushable)) -(defknown (output-stream-p input-stream-p) (stream) boolean (movable foldable - flushable)) -(defknown close (stream &key (:abort t)) stream ()) - - -;;;; In the "Input/Output" chapter: - -;;; The I/O functions are currently given effects ANY under the theory that -;;; code motion over I/O operations is particularly confusing and not very -;;; important for efficency. - -(defknown copy-readtable (&optional (or readtable null) readtable) readtable - ()) -(defknown readtablep (t) boolean (movable foldable flushable)) - -(defknown set-syntax-from-char - (character character &optional (or readtable null) readtable) void - ()) - -(defknown set-macro-character (character callable &optional t readtable) void - (unsafe)) -(defknown get-macro-character (character &optional readtable) - (values callable boolean) (flushable)) - -(defknown make-dispatch-macro-character (character &optional t readtable) - void ()) -(defknown set-dispatch-macro-character - (character character callable &optional readtable) void - (unsafe)) -(defknown get-dispatch-macro-character - (character character &optional readtable) callable - (flushable)) - -;;; May return any type due to eof-value... -(defknown (read read-preserving-whitespace read-char-no-hang read-char) - (&optional streamlike t t t) t (explicit-check)) - -(defknown read-delimited-list (character &optional streamlike t) t - (explicit-check)) -(defknown read-line (&optional streamlike t t t) (values t boolean) - (explicit-check)) -(defknown unread-char (character &optional streamlike) t - (explicit-check)) -(defknown peek-char (&optional (or character (member nil t)) streamlike t t t) - t - (explicit-check)) -(defknown listen (&optional streamlike) boolean (flushable explicit-check)) - -(defknown clear-input (&optional stream) null (explicit-check)) - -(defknown read-from-string - (string &optional t t &key (:start index) (:end sequence-end) - (:preserve-whitespace t)) - t) -(defknown parse-integer - (string &key (:start index) (:end sequence-end) (:radix (integer 2 36)) - (:junk-allowed t)) - (or integer null ())) - -(defknown read-byte (stream &optional t t) t (explicit-check)) - -(defknown write - (t &key (:stream streamlike) (:escape t) (:radix t) (:base (integer 2 36)) - (:circle t) (:pretty t) (:level (or unsigned-byte null)) (:readably t) - (:length (or unsigned-byte null)) (:case t) (:array t) (:gensym t) - (:lines (or unsigned-byte null)) (:right-margin (or unsigned-byte null)) - (:miser-width (or unsigned-byte null)) (:pprint-dispatch t)) - t - (any explicit-check) - :derive-type #'result-type-first-arg) - -(defknown (prin1 print princ) (t &optional streamlike) t (any explicit-check) - :derive-type #'result-type-first-arg) - -;;; xxx-TO-STRING not foldable because they depend on the dynamic environment. -(defknown write-to-string - (t &key (:escape t) (:radix t) (:base (integer 2 36)) (:readably t) - (:circle t) (:pretty t) (:level (or unsigned-byte null)) - (:length (or unsigned-byte null)) (:case t) (:array t) (:gensym t) - (:lines (or unsigned-byte null)) (:right-margin (or unsigned-byte null)) - (:miser-width (or unsigned-byte null)) (:pprint-dispatch t)) - simple-string - (foldable flushable explicit-check)) - -(defknown (prin1-to-string princ-to-string) (t) simple-string (flushable)) - -(defknown write-char (character &optional streamlike) character - (explicit-check)) -(defknown (write-string write-line) - (string &optional streamlike &key (:start index) (:end sequence-end)) - string - (explicit-check)) - -(defknown (terpri finish-output force-output clear-output) - (&optional streamlike) null - (explicit-check)) - -(defknown fresh-line (&optional streamlike) boolean - (explicit-check)) - -(defknown write-byte (integer stream) integer - (explicit-check)) - -(defknown format ((or streamlike string) (or string function) &rest t) - (or string null) - (explicit-check)) - -(defknown (y-or-n-p yes-or-no-p) (&optional string &rest t) boolean - (explicit-check)) - - -;;;; In the "File System Interface" chapter: - -(defknown wild-pathname-p (pathnamelike &optional (member nil :host :device - :directory :name - :type :version)) - boolean - (foldable flushable)) -(defknown pathname-match-p (pathnamelike pathnamelike) boolean - (foldable flushable)) -(defknown translate-pathname (pathnamelike pathnamelike pathnamelike &key) - pathname - (foldable flushable)) - -;;; Need to add the logical pathname stuff here. - -(defknown pathname (pathnamelike) pathname (foldable flushable)) -(defknown truename (pathnamelike) pathname ()) - -(defknown parse-namestring - (pathnamelike &optional pathname-host pathnamelike - &key (:start index) (:end sequence-end) (:junk-allowed t)) - (values (or pathname null) index) - ()) - -(defknown merge-pathnames - (pathnamelike &optional pathnamelike pathname-version) - pathname - (foldable flushable)) - -(defknown make-pathname - (&key (:defaults pathnamelike) (:host pathname-host) (:device pathname-device) - (:directory (or pathname-directory string (member :wild))) - (:name (or pathname-name string (member :wild))) - (:type (or pathname-type string (member :wild))) - (:version pathname-version) (:case (member :local :common))) - pathname (foldable flushable)) - -(defknown pathnamep (t) boolean (movable foldable flushable)) - -(defknown pathname-host (pathnamelike &key (:case (member :local :common))) - pathname-host (foldable flushable)) -(defknown pathname-device (pathnamelike &key (:case (member :local :common))) - pathname-device (foldable flushable)) -(defknown pathname-directory (pathnamelike &key (:case (member :local :common))) - pathname-directory (foldable flushable)) -(defknown pathname-name (pathnamelike &key (:case (member :local :common))) - pathname-name (foldable flushable)) -(defknown pathname-type (pathnamelike &key (:case (member :local :common))) - pathname-type (foldable flushable)) -(defknown pathname-version (pathnamelike) - pathname-version (foldable flushable)) - -(defknown (namestring file-namestring directory-namestring host-namestring) - (pathnamelike) simple-string - (foldable flushable)) - -(defknown enough-namestring (pathnamelike &optional pathnamelike) - simple-string - (foldable flushable)) - -(defknown user-homedir-pathname (&optional t) pathname (flushable)) - -(defknown open - (pathnamelike &key (:direction (member :input :output :io :probe)) - (:element-type type-specifier) - (:if-exists (member :error :new-version :rename - :rename-and-delete :overwrite :append - :supersede nil)) - (:if-does-not-exist (member :error :create nil))) - (or stream null)) - -(defknown rename-file (pathnamelike filename) (values pathname pathname pathname)) -(defknown delete-file (pathnamelike) t) -(defknown probe-file (pathnamelike) (or pathname null) (flushable)) -(defknown file-write-date (pathnamelike) (or unsigned-byte null) (flushable)) -(defknown file-author (pathnamelike) (or simple-string null) (flushable)) - -(defknown file-position (stream &optional - (or unsigned-byte (member :start :end))) - (or unsigned-byte (member t nil))) -(defknown file-length (stream) (or unsigned-byte null) (flushable)) - -(defknown load - ((or filename stream) - &key (:verbose t) (:print t) (:if-does-not-exist (member :error :create nil)) - (:if-source-newer (member :load-source :load-object :query :compile)) - (:contents (or null (member :source :binary)))) - t) - -(defknown directory (pathnamelike &key (:check-for-subdirs t) (:all t) - (:follow-links t)) - list (flushable)) - - -;;;; In the "Errors" chapter: - -(defknown error (t &rest t) nil) ; Never returns... -(defknown cerror (string t &rest t) null) -(defknown warn (t &rest t) null) -(defknown break (&optional t &rest t) null) - - -;;;; In the "Miscellaneous" Chapter. - -;;; ### Compiler interface non-standard... -(defknown compile (symbol &optional (or list function null)) - (values (or function symbol) boolean boolean)) - -(deftype optional-filename () '(or filename (member t nil))) - -(defknown compile-file - ((or optional-filename list) &key (:output-file optional-filename) (:error-file optional-filename) - (:trace-file optional-filename) (:error-output t) (:load t) (:verbose t) - (:print t) (:progress t) (:block-compile t) (:entry-points list)) - (values (or pathname null) boolean boolean)) -(defknown disassemble (callable &optional stream) void) - -(defknown documentation ((or symbol cons) symbol) - (or string null) - (flushable)) - -(defknown describe (t &optional stream) (values)) -(defknown inspect (t) (values)) - -(defknown room (&optional (member t nil :default)) void) -(defknown ed (&optional (or symbol cons filename) &key (:init t) (:display t)) - t) -(defknown dribble (&optional filename &key (:if-exists t)) t) - -(defknown apropos (stringlike &optional packagelike t) (values)) -(defknown apropos-list (stringlike &optional packagelike t) list (flushable)) - -(defknown get-decoded-time () - (values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31) - (integer 1 12) unsigned-byte (integer 0 6) boolean (rational 0 (24))) - (flushable)) - -(defknown get-universal-time () unsigned-byte (flushable)) - -(defknown decode-universal-time (unsigned-byte &optional (integer 0 23)) - (values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31) - (integer 1 12) unsigned-byte (integer 0 6) boolean (rational 0 (24))) - (flushable)) - -(defknown encode-universal-time - ((integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31) - (integer 1 12) unsigned-byte &optional (rational 0 (24))) - unsigned-byte - (flushable)) - -(defknown (get-internal-run-time get-internal-real-time) - () internal-time (flushable)) - -(defknown sleep ((or (rational 0) (float 0.0))) null) - -(defknown (lisp-implementation-type - lisp-implementation-version machine-type machine-version - machine-instance software-type software-version short-site-name - long-site-name) - () simple-string (flushable)) - -(defknown identity (t) t (movable foldable flushable unsafe) - :derive-type #'result-type-first-arg) - -(defknown constantly (t &rest t) function (movable flushable)) -(defknown complement (function) function (movable flushable)) - - -;;;; Magical compiler frobs: - -;;; Can't fold in general because of SATISFIES. There is a special optimizer -;;; anyway. -(defknown %typep (t (or type-specifier ctype)) boolean - (movable flushable explicit-check)) - -(defknown %cleanup-point () void) -(defknown %special-bind (t t) void) -(defknown %special-unbind (t) void) -(defknown %listify-rest-args (t t) list (flushable)) -(defknown %more-arg-context (t t) (values t fixnum) (flushable)) -(defknown %more-arg (t t) t) -(defknown %verify-argument-count (t t) *) -(defknown %argument-count-error (t) nil) -(defknown %unknown-values () *) -(defknown %catch (t t) void) -(defknown %unwind-protect (t t) void) -(defknown (%catch-breakup %unwind-protect-breakup) () void) -(defknown %lexical-exit-breakup (t) void) -(defknown %continue-unwind (t t t) nil) -(defknown %throw (t &rest t) nil); This is MV-called. -(defknown %nlx-entry (t) *) -(defknown %%primitive (t t &rest t) *) -(defknown %pop-values (t) void) -(defknown %type-check-error (t t) nil) -(defknown %odd-keyword-arguments-error () nil) -(defknown %unknown-keyword-argument-error (t) nil) -(defknown (%ldb %mask-field) (bit-index bit-index integer) unsigned-byte - (movable foldable flushable explicit-check)) -(defknown (%dpb %deposit-field) (integer bit-index bit-index integer) integer - (movable foldable flushable explicit-check)) -(defknown %negate (number) number (movable foldable flushable explicit-check)) -(defknown %check-bound (array index fixnum) index (movable foldable flushable)) -(defknown data-vector-ref (array index) t (foldable flushable explicit-check)) -(defknown data-vector-set (array index t) t (unsafe explicit-check)) -(defknown kernel:%caller-frame-and-pc () (values t t) (flushable)) -(defknown kernel:%with-array-data (array index (or index null)) - (values (simple-array * (*)) index index index) - (foldable flushable)) -(defknown %set-symbol-package (symbol t) t (unsafe)) -(defknown %coerce-to-function (t) function (flushable)) - -;;; Structure slot accessors or setters are magically "known" to be these -;;; functions, although the var remains the Slot-Accessor describing the actual -;;; function called. -;;; -(defknown %slot-accessor (t) t (foldable flushable)) -(defknown %slot-setter (t t) t (unsafe)) - - -;;;; Setf inverses: - -(defknown %aset (array &rest t) t (unsafe)) -(defknown %set-row-major-aref (array index t) t (unsafe)) -(defknown %rplaca (cons t) t (unsafe)) -(defknown %rplacd (cons t) t (unsafe)) -(defknown %put (symbol t t) t (unsafe)) -(defknown %setelt (sequence index t) t (unsafe)) -(defknown %svset (simple-vector index t) t (unsafe)) -(defknown %bitset (bit-vector &rest index) bit (unsafe)) -(defknown %sbitset (simple-bit-vector &rest index) bit (unsafe)) -(defknown %charset (string index character) character (unsafe)) -(defknown %scharset (simple-string index character) character (unsafe)) -(defknown %set-symbol-value (symbol t) t (unsafe)) -(defknown fset (symbol function) function (unsafe)) -(defknown %set-symbol-plist (symbol t) t (unsafe)) -(defknown %set-documentation ((or symbol cons) symbol (or string null)) - (or string null) - ()) -(defknown %setnth (index list t) t (unsafe)) -(defknown %set-fill-pointer (vector index) (unsafe)) - - -;;;; Internal type predicates: -;;; -;;; Simple typep uses that don't have any standard predicate are translated -;;; into non-standard unary predicates. - -(defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p - long-float-p base-char-p %standard-char-p structurep - array-header-p) - (t) boolean (movable foldable flushable)) - - -;;;; Miscellaneous "sub-primitives": - -(defknown %sp-string-compare - (simple-string index index simple-string index index) - (or index null) - (foldable flushable)) diff --git a/compiler/generic/core.lisp b/compiler/generic/core.lisp deleted file mode 100644 index 9169d5c26da81d6df29fd31254fb6adb74a2f3a2..0000000000000000000000000000000000000000 --- a/compiler/generic/core.lisp +++ /dev/null @@ -1,337 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/generic/core.lisp,v 1.21 1992/12/17 09:27:11 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; -;;; This file contains stuff that knows how to load compiled code directly -;;; into core, e.g. incremental compilation. -;;; -(in-package "C") - - -;;; The CORE-OBJECT structure holds the state needed to resolve cross-component -;;; references during in-core compilation. -;;; -(defstruct (core-object - (:constructor make-core-object ()) - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (format stream "#<Core-Object>")))) - ;; - ;; A hashtable translating ENTRY-INFO structures to the corresponding actual - ;; FUNCTIONs for functions in this compilation. - (entry-table (make-hash-table :test #'eq) :type hash-table) - ;; - ;; A hashtable translating ENTRY-INFO structures to a list of pairs - ;; (<code object> . <offset>) describing the places that need to be - ;; backpatched to point to the function for ENTRY-INFO. - (patch-table (make-hash-table :test #'eq) :type hash-table) - ;; - ;; A list of all the DEBUG-INFO objects created, kept so that we can - ;; backpatch with the source info. - (debug-info () :type list)) - - -;;; NOTE-FUNCTION -- Internal. -;;; -;;; Note the existance of FUNCTION. -;;; -(defun note-function (info function object) - (declare (type function function) - (type core-object object)) - (let ((patch-table (core-object-patch-table object))) - (dolist (patch (gethash info patch-table)) - (setf (code-header-ref (car patch) (the index (cdr patch))) function)) - (remhash info patch-table)) - (setf (gethash info (core-object-entry-table object)) function) - (undefined-value)) - - -;;; MAKE-FUNCTION-ENTRY -- Internal -;;; -;;; Make a function entry, filling in slots from the ENTRY-INFO. -;;; -(defun make-function-entry (entry code-obj object) - (declare (type entry-info entry) (type core-object object)) - (let ((offset (label-position (entry-info-offset entry)))) - (declare (type index offset)) - (unless (zerop (logand offset vm:lowtag-mask)) - (error "Unaligned function object, offset = #x~X." offset)) - (let ((res (%primitive compute-function code-obj offset))) - (setf (%function-self res) res) - (setf (%function-next res) (%code-entry-points code-obj)) - (setf (%code-entry-points code-obj) res) - (setf (%function-name res) (entry-info-name entry)) - (setf (%function-arglist res) (entry-info-arguments entry)) - (setf (%function-type res) (entry-info-type entry)) - - (note-function entry res object)))) - -;;; DO-CORE-FIXUPS -- Internal -;;; -;;; Do "load-time" fixups on the code vector. -;;; -(defun do-core-fixups (code fixups) - (declare (list fixups)) - (dolist (info fixups) - (let* ((kind (first info)) - (fixup (second info)) - (name (fixup-name fixup)) - (flavor (fixup-flavor fixup)) - (offset (third info))) - (multiple-value-bind - (value found) - (ecase flavor - (:assembly-routine - (assert (symbolp name)) - (gethash name lisp::*assembler-routines*)) - (:foreign - (assert (stringp name)) - (gethash name lisp::*foreign-symbols*))) - (unless found - (error (ecase flavor - (:assembly-routine "Undefined assembler routine: ~S") - (:foreign "Unknown foreign symbol: ~S")) - name)) - (vm:fixup-code-object code offset value kind))))) - - -;;; REFERENCE-CORE-FUNCTION -- Internal -;;; -;;; Stick a reference to the function Fun in Code-Object at index I. If the -;;; function hasn't been compiled yet, make a note in the Patch-Table. -;;; -(defun reference-core-function (code-obj i fun object) - (declare (type core-object object) (type functional fun) - (type index i)) - (let* ((info (leaf-info fun)) - (found (gethash info (core-object-entry-table object)))) - (if found - (setf (code-header-ref code-obj i) found) - (push (cons code-obj i) - (gethash info (core-object-patch-table object))))) - (undefined-value)) - - -;;; MAKE-CORE-COMPONENT -- Interface -;;; -;;; Dump a component to core. We pass in the assembler fixups, code vector -;;; and node info. -;;; -(defun make-core-component (component segment length trace-table fixups object) - (declare (type component component) - (type new-assem:segment segment) - (type index length) - (list trace-table fixups) - (type core-object object)) - (without-gcing - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp)) - (trace-table (pack-trace-table trace-table)) - (trace-table-len (length trace-table)) - (trace-table-bits (* trace-table-len bits-per-entry)) - (total-length (+ length (ceiling trace-table-bits vm:byte-bits))) - (box-num (- (length constants) vm:code-trace-table-offset-slot)) - (code-obj (%primitive allocate-code-object box-num total-length)) - (fill-ptr (code-instructions code-obj))) - (declare (type index box-num total-length)) - - (new-assem:segment-map-output - segment - #'(lambda (sap amount) - (declare (type system-area-pointer sap) - (type index amount)) - (system-area-copy sap 0 fill-ptr 0 - (* amount vm:byte-bits)) - (setf fill-ptr (sap+ fill-ptr amount)))) - (do-core-fixups code-obj fixups) - - (dolist (entry (ir2-component-entries 2comp)) - (make-function-entry entry code-obj object)) - - (vm:sanctify-for-execution code-obj) - - (let ((info (debug-info-for-component component))) - (push info (core-object-debug-info object)) - (setf (%code-debug-info code-obj) info)) - - (setf (code-header-ref code-obj vm:code-trace-table-offset-slot) length) - (copy-to-system-area trace-table (* vm:vector-data-offset vm:word-bits) - fill-ptr 0 trace-table-bits) - - (do ((index vm:code-constants-offset (1+ index))) - ((>= index (length constants))) - (let ((const (aref constants index))) - (etypecase const - (null) - (constant - (setf (code-header-ref code-obj index) - (constant-value const))) - (list - (ecase (car const) - (:entry - (reference-core-function code-obj index - (cdr const) object)) - (:fdefinition - (setf (code-header-ref code-obj index) - (lisp::fdefinition-object (cdr const) t)))))))))) - (undefined-value)) - - -;;; MAKE-CORE-BYTE-COMPONENT -- Interface. -;;; -(defun make-core-byte-component (segment constants xeps object) - (declare (type new-assem:segment segment) - (type vector constants) - (type list xeps) - (type core-object object)) - (without-gcing - (let* ((num-constants (length constants)) - (length (byte-output-length segment)) - (code-obj (%primitive allocate-code-object - (the index (1+ num-constants)) - length)) - (fill-ptr (code-instructions code-obj))) - (declare (type index length) - (type system-area-pointer fill-ptr)) - - (new-assem:segment-map-output - segment - #'(lambda (sap amount) - (declare (type system-area-pointer sap) - (type index amount)) - (system-area-copy sap 0 fill-ptr 0 - (* amount vm:byte-bits)) - (setf fill-ptr (sap+ fill-ptr amount)))) - - (dolist (noise xeps) - (let ((xep (cdr noise))) - (setf (byte-xep-component xep) code-obj) - (note-function (lambda-info (car noise)) - (make-byte-compiled-function xep) - object))) - - (dotimes (index num-constants) - (let ((const (aref constants index)) - (code-obj-index (+ index vm:code-constants-offset))) - (etypecase const - (null) - (constant - (setf (code-header-ref code-obj code-obj-index) - (constant-value const))) - (list - (ecase (car const) - (:entry - (reference-core-function code-obj code-obj-index (cdr const) - object)) - (:fdefinition - (setf (code-header-ref code-obj code-obj-index) - (lisp::fdefinition-object (cdr const) t))) - (:type-predicate - (setf (code-header-ref code-obj code-obj-index) - (load-type-predicate (type-specifier (cdr const))))) - (:xep - (let ((xep (cdr (assoc (cdr const) xeps :test #'eq)))) - (assert xep) - (setf (code-header-ref code-obj code-obj-index) xep)))))))))) - - (undefined-value)) - - -;;; CORE-CALL-TOP-LEVEL-LAMBDA -- Interface -;;; -;;; Call the top-level lambda function dumped for Entry, returning the -;;; values. Entry may be a :TOP-LEVEL-XEP functional. -;;; -(defun core-call-top-level-lambda (entry object) - (declare (type functional entry) (type core-object object)) - (funcall (or (gethash (leaf-info entry) - (core-object-entry-table object)) - (error "Unresolved forward reference.")))) - - -;;; FIX-CORE-SOURCE-INFO -- Interface -;;; -;;; Backpatch all the DEBUG-INFOs dumped so far with the specified -;;; SOURCE-INFO list. We also check that there are no outstanding forward -;;; references to functions. -;;; -(defun fix-core-source-info (info object source-info) - (declare (type source-info info) (type core-object object)) - (assert (zerop (hash-table-count (core-object-patch-table object)))) - (let ((res (debug-source-for-info info))) - (dolist (sinfo res) - (setf (debug-source-info sinfo) source-info)) - (dolist (info (core-object-debug-info object)) - (setf (compiled-debug-info-source info) res)) - (setf (core-object-debug-info object) ())) - (undefined-value)) - - -;;;; Code-instruction-streams - -(defstruct (code-instruction-stream - (:print-function %print-code-inst-stream) - (:include stream - (lisp::sout #'code-inst-stream-sout) - (lisp::bout #'code-inst-stream-bout) - (lisp::misc #'code-inst-stream-misc)) - (:constructor make-code-instruction-stream - (code-object - &aux - (current (code-instructions code-object)) - (end (sap+ current - (* (%code-code-size code-object) - vm:word-bytes)))))) - code-object - current - end) - -(defun %print-code-inst-stream (code-inst-stream stream depth) - (declare (ignore depth)) - (format stream "#<Code Instruction Stream for ~S>" - (code-instruction-stream-code-object code-inst-stream))) - -(defun code-inst-stream-sout (stream string start end) - (let* ((start (or start 0)) - (end (or end (length string))) - (length (- end start)) - (current (code-instruction-stream-current stream)) - (new (sap+ current length))) - (when (sap> new (code-instruction-stream-end stream)) - (error "Writing ~D bytes to ~S would cause it to overflow." - length stream)) - (copy-to-system-area string (+ (* start vm:byte-bits) - (* vm:vector-data-offset vm:word-bits)) - current 0 - (* length vm:byte-bits)) - (setf (code-instruction-stream-current stream) new))) - -(defun code-inst-stream-bout (stream byte) - (declare (type code-instruction-stream stream) - (type (unsigned-byte 8) byte)) - (let* ((current (code-instruction-stream-current stream)) - (new (sap+ current 1))) - (when (sap> new (code-instruction-stream-end stream)) - (error "Writing another byte to ~S would cause it to overflow." - stream)) - (setf (sap-ref-8 current 0) byte) - (setf (code-instruction-stream-current stream) new))) - -(defun code-inst-stream-misc (stream method &optional arg1 arg2) - (declare (ignore arg1 arg2)) - (case method - (:close - (lisp::set-closed-flame stream)) - (t - nil))) diff --git a/compiler/generic/utils.lisp b/compiler/generic/utils.lisp deleted file mode 100644 index 37191e48b9ec19bdda1fe92430b0e629ca691c26..0000000000000000000000000000000000000000 --- a/compiler/generic/utils.lisp +++ /dev/null @@ -1,77 +0,0 @@ -;;; -*- Package: VM; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/generic/utils.lisp,v 1.4 1992/07/13 01:45:12 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Utility functions needed by the back end to generate code. -;;; -;;; Written by William Lott. -;;; - -(in-package "VM") - -(export '(fixnum static-symbol-p static-symbol-offset offset-static-symbol - static-function-offset)) - - - -;;;; Handy routine for making fixnums: - -(defun fixnum (num) - "Make a fixnum out of NUM. (i.e. shift by two bits if it will fit.)" - (if (<= #x-20000000 num #x1fffffff) - (ash num 2) - (error "~D is too big for a fixnum." num))) - - - -;;;; Routines for dealing with static symbols. - -(defun static-symbol-p (symbol) - (or (null symbol) - (and (member symbol static-symbols) t))) - -(defun static-symbol-offset (symbol) - "Returns the byte offset of the static symbol Symbol." - (if symbol - (let ((posn (position symbol static-symbols))) - (unless posn (error "~S is not a static symbol." symbol)) - (+ (* posn (pad-data-block symbol-size)) - (pad-data-block (1- symbol-size)) - other-pointer-type - (- list-pointer-type))) - 0)) - -(defun offset-static-symbol (offset) - "Given a byte offset, Offset, returns the appropriate static symbol." - (if (zerop offset) - nil - (multiple-value-bind - (n rem) - (truncate (+ offset list-pointer-type (- other-pointer-type) - (- (pad-data-block (1- symbol-size)))) - (pad-data-block symbol-size)) - (unless (and (zerop rem) (<= 0 n (1- (length static-symbols)))) - (error "Byte offset, ~D, is not correct." offset)) - (elt static-symbols n)))) - -(defun static-function-offset (name) - "Return the (byte) offset from NIL to the start of the fdefn object - for the static function NAME." - (let ((static-syms (length static-symbols)) - (static-function-index (position name static-functions))) - (unless static-function-index - (error "~S isn't a static function." name)) - (+ (* static-syms (pad-data-block symbol-size)) - (pad-data-block (1- symbol-size)) - (- list-pointer-type) - (* static-function-index (pad-data-block fdefn-size)) - (* fdefn-raw-addr-slot word-bytes)))) diff --git a/compiler/generic/vm-ir2tran.lisp b/compiler/generic/vm-ir2tran.lisp deleted file mode 100644 index 25112780241ca051c742f4b04e33f5176ecaf7b0..0000000000000000000000000000000000000000 --- a/compiler/generic/vm-ir2tran.lisp +++ /dev/null @@ -1,153 +0,0 @@ -;;; -*- Package: C -*- -;;; -;;; ********************************************************************** -;;; 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/generic/vm-ir2tran.lisp,v 1.5 1992/12/18 11:19:50 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file -;;; -(in-package :c) - -(export '(slot set-slot make-unbound-marker fixed-alloc var-alloc)) - -(defoptimizer ir2-convert-reffer ((object) node block name offset lowtag) - (let* ((cont (node-cont node)) - (locs (continuation-result-tns - cont (list (backend-any-primitive-type *backend*)))) - (res (first locs))) - (vop slot node block (continuation-tn node block object) - name offset lowtag res) - (move-continuation-result node block locs cont))) - -#+gengc -(defun needs-remembering (cont) - (if (csubtypep (continuation-type cont) - (load-time-value (specifier-type '(or fixnum character - (member t nil))))) - nil - t)) - -(defoptimizer ir2-convert-setter ((object value) node block name offset lowtag) - (let ((value-tn (continuation-tn node block value))) - (vop set-slot node block (continuation-tn node block object) value-tn - name offset lowtag #+gengc (needs-remembering value)) - (move-continuation-result node block (list value-tn) (node-cont node)))) - -(defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag) - (let ((value-tn (continuation-tn node block value))) - (vop set-slot node block (continuation-tn node block object) value-tn - name offset lowtag #+gengc (needs-remembering value)) - (move-continuation-result node block (list value-tn) (node-cont node)))) - -(defun do-inits (node block name result lowtag inits args) - (let ((unbound-marker-tn nil)) - (dolist (init inits) - (let ((kind (car init)) - (slot (cdr init))) - (vop set-slot node block result - (ecase kind - (:arg - (assert args) - (continuation-tn node block (pop args))) - (:unbound - (or unbound-marker-tn - (setf unbound-marker-tn - (let ((tn (make-restricted-tn - nil - (sc-number-or-lose 'vm::any-reg - *backend*)))) - (vop make-unbound-marker node block tn) - tn)))) - (:null - (emit-constant nil))) - name slot lowtag #+gengc nil)))) - (assert (null args))) - -(defoptimizer ir2-convert-fixed-allocation - ((&rest args) node block name words type lowtag inits) - (let* ((cont (node-cont node)) - (locs (continuation-result-tns - cont (list (backend-any-primitive-type *backend*)))) - (result (first locs))) - (vop fixed-alloc node block name words type lowtag result) - (do-inits node block name result lowtag inits args) - (move-continuation-result node block locs cont))) - -(defoptimizer ir2-convert-variable-allocation - ((extra &rest args) node block name words type lowtag inits) - (let* ((cont (node-cont node)) - (locs (continuation-result-tns - cont (list (backend-any-primitive-type *backend*)))) - (result (first locs))) - (if (constant-continuation-p extra) - (let ((words (+ (continuation-value extra) words))) - (vop fixed-alloc node block name words type lowtag result)) - (vop var-alloc node block (continuation-tn node block extra) name words - type lowtag result)) - (do-inits node block name result lowtag inits args) - (move-continuation-result node block locs cont))) - - - -;;;; Replacements for stuff in ir2tran to make gengc work. - -#+gengc -(defun ir2-convert-set (node block) - (declare (type cset node) (type ir2-block block)) - (let* ((cont (node-cont node)) - (leaf (set-var node)) - (val (continuation-tn node block (set-value node))) - (locs (if (continuation-info cont) - (continuation-result-tns - cont (list (primitive-type (leaf-type leaf)))) - nil))) - (etypecase leaf - (lambda-var - (when (leaf-refs leaf) - (let ((tn (find-in-environment leaf (node-environment node)))) - (if (lambda-var-indirect leaf) - (vop value-cell-set node block tn val - (needs-remembering val)) - (emit-move node block val tn))))) - (global-var - (ecase (global-var-kind leaf) - ((:special :global) - (assert (symbolp (leaf-name leaf))) - (vop set node block (emit-constant (leaf-name leaf)) val - (needs-remembering val)))))) - - (when locs - (emit-move node block val (first locs)) - (move-continuation-result node block locs cont))) - (undefined-value)) - - -#+gengc -(defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block) - (vop value-cell-set node block - (find-in-environment (continuation-value info) (node-environment node)) - (emit-constant 0) - nil)) - - -#+gengc -(defoptimizer (%slot-setter ir2-convert) ((value str) node block) - (let ((val (continuation-tn node block value))) - (vop structure-set node block - (continuation-tn node block str) - val - (dsd-index - (slot-accessor-slot - (ref-leaf - (continuation-use - (combination-fun node))))) - (needs-remembering value)) - - (move-continuation-result node block (list val) (node-cont node)))) diff --git a/compiler/generic/vm-macs.lisp b/compiler/generic/vm-macs.lisp deleted file mode 100644 index 9cef0bc3910b727e4b148d96ab4a28de64e3531f..0000000000000000000000000000000000000000 --- a/compiler/generic/vm-macs.lisp +++ /dev/null @@ -1,254 +0,0 @@ -;;; -*- Package: VM -*- -;;; -;;; ********************************************************************** -;;; 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/generic/vm-macs.lisp,v 1.11 1992/12/16 21:35:52 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains some macros and constants that are object-format -;;; specific or are used for defining the object format. -;;; -;;; Written by William Lott and Christopher Hoover. -;;; -(in-package "VM") - - - -;;;; Other random stuff. - -;;; PAD-DATA-BLOCK -- Internal Interface. -;;; -;;; This returns a form that returns a dual-word aligned number of bytes when -;;; given a number of words. -;;; -(defmacro pad-data-block (words) - `(logandc2 (+ (ash ,words word-shift) lowtag-mask) lowtag-mask)) - -;;; DEFENUM -- Internal Interface. -;;; -(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1)) - &rest identifiers) - (let ((results nil) - (index 0) - (start (eval start)) - (step (eval step))) - (dolist (id identifiers) - (when id - (multiple-value-bind - (root docs) - (if (consp id) - (values (car id) (cdr id)) - (values id nil)) - (push `(defconstant ,(intern (concatenate 'simple-string - (string prefix) - (string root) - (string suffix))) - ,(+ start (* step index)) - ,@docs) - results))) - (incf index)) - `(eval-when (compile load eval) - ,@(nreverse results)))) - - -;;;; Primitive object definition stuff. - -(export '(primitive-object primitive-object-p - primitive-object-name primitive-object-header - primitive-object-lowtag primitive-object-options - primitive-object-slots primitive-object-size - primitive-object-variable-length slot-name slot-docs slot-rest-p - slot-offset slot-length slot-options *primitive-objects* - define-for-each-primitive-object)) - - -(defun remove-keywords (options keywords) - (cond ((null options) nil) - ((member (car options) keywords) - (remove-keywords (cddr options) keywords)) - (t - (list* (car options) (cadr options) - (remove-keywords (cddr options) keywords))))) - -(defstruct (prim-object-slot - (:conc-name slot-) - (:constructor make-slot (name docs rest-p offset length options)) - (:make-load-form-fun :just-dump-it-normally)) - (name nil :type symbol) - (docs nil :type (or null simple-string)) - (rest-p nil :type (member t nil)) - (offset 0 :type fixnum) - (length 1 :type fixnum) - (options nil :type list)) - -(defstruct (primitive-object - (:make-load-form-fun :just-dump-it-normally)) - (name nil :type symbol) - (header nil :type symbol) - (lowtag nil :type symbol) - (options nil :type list) - (slots nil :type list) - (size 0 :type fixnum) - (variable-length nil :type (member t nil))) - - -(defvar *primitive-objects* nil) - -(defun %define-primitive-object (primobj) - (let ((name (primitive-object-name primobj))) - (setf *primitive-objects* - (cons primobj - (remove name *primitive-objects* - :key #'primitive-object-name :test #'eq))) - name)) - - -(defmacro define-primitive-object - ((name &key header lowtag alloc-trans (type t)) - &rest slot-specs) - (collect ((slots) (exports) (constants) (forms) (inits)) - (let ((offset (if header 1 0)) - (variable-length nil)) - (dolist (spec slot-specs) - (when variable-length - (error "No more slots can follow a :rest-p slott.")) - (destructuring-bind - (slot-name &rest options - &key docs rest-p (length (if rest-p 0 1)) - ((:type slot-type) t) init - (ref-known nil ref-known-p) ref-trans - (set-known nil set-known-p) set-trans - &allow-other-keys) - (if (atom spec) (list spec) spec) - (slots (make-slot slot-name docs rest-p offset length - (remove-keywords options - '(:docs :rest-p :length)))) - (let ((offset-sym (symbolicate name "-" slot-name - (if rest-p "-OFFSET" "-SLOT")))) - (constants `(defconstant ,offset-sym ,offset - ,@(when docs (list docs)))) - (exports offset-sym)) - (when ref-trans - (when ref-known-p - (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known))) - (forms `(def-reffer ,ref-trans ,offset ,lowtag))) - (when set-trans - (when set-known-p - (forms `(defknown ,set-trans - ,(if (listp set-trans) - (list slot-type type) - (list type slot-type)) - ,slot-type - ,set-known))) - (forms `(def-setter ,set-trans ,offset ,lowtag))) - (when init - (inits (cons init offset))) - (when rest-p - (setf variable-length t)) - (incf offset length))) - (unless variable-length - (let ((size (symbolicate name "-SIZE"))) - (constants `(defconstant ,size ,offset - ,(format nil - "Number of slots used by each ~S~ - ~@[~* including the header~]." - name header))) - (exports size))) - (when alloc-trans - (forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header - ,lowtag ',(inits)))) - `(progn - (export ',(exports)) - (eval-when (compile load eval) - (%define-primitive-object - ',(make-primitive-object :name name - :header header - :lowtag lowtag - :slots (slots) - :size offset - :variable-length variable-length)) - ,@(constants)) - ,@(forms))))) - - - -;;;; reffer and setter definition stuff. - -(in-package :c) - -(export '(def-reffer def-setter def-alloc)) - -(defun %def-reffer (name offset lowtag) - (let ((info (function-info-or-lose name))) - (setf (function-info-ir2-convert info) - #'(lambda (node block) - (ir2-convert-reffer node block name offset lowtag))) - (setf (function-info-ltn-annotate info) #'annotate-funny-call)) - name) - -(defmacro def-reffer (name offset lowtag) - `(%def-reffer ',name ,offset ,lowtag)) - -(defun %def-setter (name offset lowtag) - (let ((info (function-info-or-lose name))) - (setf (function-info-ir2-convert info) - (if (listp name) - #'(lambda (node block) - (ir2-convert-setfer node block name offset lowtag)) - #'(lambda (node block) - (ir2-convert-setter node block name offset lowtag)))) - (setf (function-info-ltn-annotate info) #'annotate-funny-call)) - name) - -(defmacro def-setter (name offset lowtag) - `(%def-setter ',name ,offset ,lowtag)) - -(defun %def-alloc (name words variable-length header lowtag inits) - (let ((info (function-info-or-lose name))) - (setf (function-info-ir2-convert info) - (if variable-length - #'(lambda (node block) - (ir2-convert-variable-allocation node block name words header - lowtag inits)) - #'(lambda (node block) - (ir2-convert-fixed-allocation node block name words header - lowtag inits)))) - (setf (function-info-ltn-annotate info) #'annotate-funny-call)) - name) - -(defmacro def-alloc (name words variable-length header lowtag inits) - `(%def-alloc ',name ,words ,variable-length ,header ,lowtag ,inits)) - - -;;;; Some general constant definitions: - -(in-package "C") - -(export '(fasl-file-implementations - pmax-fasl-file-implementation - sparc-fasl-file-implementation - rt-fasl-file-implementation - rt-afpa-fasl-file-implementation - x86-fasl-file-implementation - hppa-fasl-file-implementation)) - -;;; Constants for the different implementations. These are all defined in -;;; one place to make sure they are all unique. - -(defparameter fasl-file-implementations - '(nil "Pmax" "Sparc" "RT" "RT/AFPA" "x86" "HPPA")) -(defconstant pmax-fasl-file-implementation 1) -(defconstant sparc-fasl-file-implementation 2) -(defconstant rt-fasl-file-implementation 3) -(defconstant rt-afpa-fasl-file-implementation 4) -(defconstant x86-fasl-file-implementation 5) -(defconstant hppa-fasl-file-implementation 6) - -;;; The maximum number of SCs in any implementation. -(defconstant sc-number-limit 32) diff --git a/compiler/generic/vm-typetran.lisp b/compiler/generic/vm-typetran.lisp deleted file mode 100644 index 8a13aacbd3d6038d35ef0100450553a7320c2d3d..0000000000000000000000000000000000000000 --- a/compiler/generic/vm-typetran.lisp +++ /dev/null @@ -1,67 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/generic/vm-typetran.lisp,v 1.10 1992/03/07 17:15:05 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-typetran.lisp,v 1.10 1992/03/07 17:15:05 wlott Exp $ -;;; -;;; This file contains the implimentation specific type transformation magic. -;;; Basically, the various non-standard predicates that can be used in typep -;;; transformations. -;;; -;;; Written by William Lott. -;;; - -(in-package "C") - - -;;;; Internal predicates: -;;; -;;; These type predicates are used to implement simple cases of typep. They -;;; shouldn't be used explicitly. - -(define-type-predicate base-char-p base-char) -(define-type-predicate bignump bignum) -(define-type-predicate double-float-p double-float) -(define-type-predicate fixnump fixnum) -(define-type-predicate long-float-p long-float) -(define-type-predicate ratiop ratio) -(define-type-predicate short-float-p short-float) -(define-type-predicate single-float-p single-float) -(define-type-predicate simple-array-p simple-array) -(define-type-predicate simple-array-unsigned-byte-2-p - (simple-array (unsigned-byte 2) (*))) -(define-type-predicate simple-array-unsigned-byte-4-p - (simple-array (unsigned-byte 4) (*))) -(define-type-predicate simple-array-unsigned-byte-8-p - (simple-array (unsigned-byte 8) (*))) -(define-type-predicate simple-array-unsigned-byte-16-p - (simple-array (unsigned-byte 16) (*))) -(define-type-predicate simple-array-unsigned-byte-32-p - (simple-array (unsigned-byte 32) (*))) -(define-type-predicate simple-array-single-float-p - (simple-array single-float (*))) -(define-type-predicate simple-array-double-float-p - (simple-array double-float (*))) -(define-type-predicate system-area-pointer-p system-area-pointer) -(define-type-predicate unsigned-byte-32-p (unsigned-byte 32)) -(define-type-predicate signed-byte-32-p (signed-byte 32)) -(define-type-predicate weak-pointer-p weak-pointer) -(define-type-predicate scavenger-hook-p scavenger-hook) -(define-type-predicate code-component-p code-component) -(define-type-predicate lra-p lra) -(define-type-predicate fdefn-p fdefn) - -;;; Unlike the un-%'ed versions, these are true type predicates, accepting any -;;; type object. -;;; -;(define-type-predicate %string-char-p string-char) -(define-type-predicate %standard-char-p standard-char) diff --git a/compiler/globals.lisp b/compiler/globals.lisp deleted file mode 100644 index f4a4858c28a2f9bc448d13ce7ef80956d4a84bee..0000000000000000000000000000000000000000 --- a/compiler/globals.lisp +++ /dev/null @@ -1,10 +0,0 @@ - -(in-package "C") -(proclaim '(special - *defprint-pretty* *event-info* *event-note-threshold* - *compiler-error-context* - *converting-for-interpreter* - *undefined-warnings* - *code-segment* *elsewhere* - *collect-dynamic-statistics* *count-vop-usages* *dynamic-counts-tn* - *source-info*)) diff --git a/compiler/gtn.lisp b/compiler/gtn.lisp deleted file mode 100644 index 1f33eda625f1a94e5ea64a23f024a49cd4a1033c..0000000000000000000000000000000000000000 --- a/compiler/gtn.lisp +++ /dev/null @@ -1,246 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/gtn.lisp,v 1.13 1992/04/01 15:30:08 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the GTN pass in the compiler. GTN allocates the TNs -;;; that hold the values of lexical variables and determines the calling -;;; conventions and passing locations used in function calls. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; GTN-Analyze -- Interface -;;; -;;; We make a pass over the component's environments, assigning argument -;;; passing locations and return conventions and TNs for local variables. -;;; -(defun gtn-analyze (component) - (setf (component-info component) (make-ir2-component)) - (let ((funs (component-lambdas component))) - (dolist (fun funs) - (assign-ir2-environment fun) - (assign-return-locations fun) - (assign-ir2-nlx-info fun) - (assign-lambda-var-tns fun nil) - (dolist (let (lambda-lets fun)) - (assign-lambda-var-tns let t)))) - - (undefined-value)) - - -;;; Assign-Lambda-Var-TNs -- Internal -;;; -;;; We have to allocate the home TNs for variables before we can call -;;; Assign-IR2-Environment so that we can close over TNs that haven't had their -;;; home environment assigned yet. Here we evaluate the DEBUG-INFO/SPEED -;;; tradeoff to determine how variables are allocated. If SPEED is 3, then all -;;; variables are subject to lifetime analysis. Otherwise, only Let-P -;;; variables are allocated normally, and that can be inhibited by -;;; DEBUG-INFO = 3. -;;; -(defun assign-lambda-var-tns (fun let-p) - (declare (type clambda fun)) - (dolist (var (lambda-vars fun)) - (when (leaf-refs var) - (let* ((type (if (lambda-var-indirect var) - (backend-any-primitive-type *backend*) - (primitive-type (leaf-type var)))) - (temp (make-normal-tn type)) - (node (lambda-bind fun)) - (res (if (or (and let-p (policy node (< debug 3))) - (policy node (= speed 3))) - temp - (environment-debug-live-tn temp - (lambda-environment fun))))) - (setf (tn-leaf res) var) - (setf (leaf-info var) res)))) - (undefined-value)) - - -;;; Assign-IR2-Environment -- Internal -;;; -;;; Give an IR2-Environment structure to Fun. We make the TNs which hold -;;; environment values and the old-FP/return-PC. -;;; -(defun assign-ir2-environment (fun) - (declare (type clambda fun)) - (let ((env (lambda-environment fun))) - (collect ((env)) - (dolist (thing (environment-closure env)) - (let ((ptype (etypecase thing - (lambda-var - (if (lambda-var-indirect thing) - (backend-any-primitive-type *backend*) - (primitive-type (leaf-type thing)))) - (nlx-info (backend-any-primitive-type *backend*))))) - (env (cons thing (make-normal-tn ptype))))) - - (let ((res (make-ir2-environment - :environment (env) - :return-pc-pass (make-return-pc-passing-location - (external-entry-point-p fun))))) - (setf (environment-info env) res) - (setf (ir2-environment-old-fp res) - (make-old-fp-save-location env)) - (setf (ir2-environment-return-pc res) - (make-return-pc-save-location env))))) - - (undefined-value)) - - -;;; Has-Full-Call-Use -- Internal -;;; -;;; Return true if Fun's result continuation is used in a TR full call. We -;;; only consider explicit :Full calls. It is assumed that known calls are -;;; never part of a tail-recursive loop, so we don't need to enforce -;;; tail-recursion. In any case, we don't know which known calls will -;;; actually be full calls until after LTN. -;;; -(defun has-full-call-use (fun) - (declare (type clambda fun)) - (let ((return (lambda-return fun))) - (and return - (do-uses (use (return-result return) nil) - (when (and (node-tail-p use) - (basic-combination-p use) - (eq (basic-combination-kind use) :full)) - (return t)))))) - - -;;; Use-Standard-Returns -- Internal -;;; -;;; Return true if we should use the standard (unknown) return convention -;;; for a tail-set. We use the standard return convention when: -;;; -- We must use the standard convention to preserve tail-recursion, since -;;; the tail-set contains both an XEP and a TR full call. -;;; -- It appears to be more efficient to use the standard convention, since -;;; there are no non-TR local calls that could benefit from a non-standard -;;; convention. -;;; -(defun use-standard-returns (tails) - (declare (type tail-set tails)) - (let ((funs (tail-set-functions tails))) - (or (and (find-if #'external-entry-point-p funs) - (find-if #'has-full-call-use funs)) - (block punt - (dolist (fun funs t) - (dolist (ref (leaf-refs fun)) - (let* ((cont (node-cont ref)) - (dest (continuation-dest cont))) - (when (and (not (node-tail-p dest)) - (basic-combination-p dest) - (eq (basic-combination-fun dest) cont) - (eq (basic-combination-kind dest) :local)) - (return-from punt nil))))))))) - - -;;; RETURN-VALUE-EFFICENCY-NOTE -- Internal -;;; -;;; If policy indicates, give an efficency note about our inability to use -;;; the known return convention. We try to find a function in the tail set -;;; with non-constant return values to use as context. If there is no such -;;; function, then be more vague. -;;; -(defun return-value-efficency-note (tails) - (declare (type tail-set tails)) - (let ((funs (tail-set-functions tails))) - (when (policy (lambda-bind (first funs)) (> (max speed space) brevity)) - (dolist (fun funs - (let ((*compiler-error-context* (lambda-bind (first funs)))) - (compiler-note - "Return value count mismatch prevents known return ~ - from these functions:~ - ~{~% ~A~}" - (remove nil (mapcar #'leaf-name funs))))) - (let ((ret (lambda-return fun))) - (when ret - (let ((rtype (return-result-type ret))) - (multiple-value-bind (ignore count) - (values-types rtype) - (declare (ignore ignore)) - (when (eq count :unknown) - (let ((*compiler-error-context* (lambda-bind fun))) - (compiler-note - "Return type not fixed values, so can't use known return ~ - convention:~% ~S" - (type-specifier rtype))) - (return))))))))) - (undefined-value)) - - -;;; Return-Info-For-Set -- Internal -;;; -;;; Return a Return-Info structure describing how we should return from -;;; functions in the specified tail set. We use the unknown values convention -;;; if the number of values is unknown, or if it is a good idea for some other -;;; reason. Otherwise we allocate passing locations for a fixed number of -;;; values. -;;; -(defun return-info-for-set (tails) - (declare (type tail-set tails)) - (multiple-value-bind (types count) - (values-types (tail-set-type tails)) - (let ((ptypes (mapcar #'primitive-type types)) - (use-standard (use-standard-returns tails))) - (when (and (eq count :unknown) (not use-standard)) - (return-value-efficency-note tails)) - (if (or (eq count :unknown) use-standard) - (make-return-info :kind :unknown :count count :types ptypes) - (make-return-info - :kind :fixed - :count count - :types ptypes - :locations (mapcar #'make-normal-tn ptypes)))))) - - -;;; Assign-Return-Locations -- Internal -;;; -;;; If Tail-Set doesn't have any Info, then make a Return-Info for it. If -;;; we choose a return convention other than :Unknown, and this environment is -;;; for an XEP, then break tail recursion on the XEP calls, since we must -;;; always use unknown values when returning from an XEP. -;;; -(defun assign-return-locations (fun) - (declare (type clambda fun)) - (let* ((tails (lambda-tail-set fun)) - (returns (or (tail-set-info tails) - (setf (tail-set-info tails) - (return-info-for-set tails)))) - (return (lambda-return fun))) - (when (and return - (not (eq (return-info-kind returns) :unknown)) - (external-entry-point-p fun)) - (do-uses (use (return-result return)) - (setf (node-tail-p use) nil)))) - (undefined-value)) - - -;;; Assign-IR2-NLX-Info -- Internal -;;; -;;; Make an IR2-NLX-Info structure for each NLX entry point recorded. We -;;; call a VM supplied function to make the Save-SP restricted on the stack. -;;; The NLX-Entry VOP's :Force-To-Stack Save-P value doesn't do this, since the -;;; SP is an argument to the VOP, and thus isn't live afterwards. -;;; -(defun assign-ir2-nlx-info (fun) - (declare (type clambda fun)) - (let ((env (lambda-environment fun))) - (dolist (nlx (environment-nlx-info env)) - (setf (nlx-info-info nlx) - (make-ir2-nlx-info - :home (when (member (cleanup-kind (nlx-info-cleanup nlx)) - '(:block :tagbody)) - (make-normal-tn (backend-any-primitive-type *backend*))) - :save-sp (make-nlx-sp-tn env))))) - (undefined-value)) diff --git a/compiler/hppa/alloc.lisp b/compiler/hppa/alloc.lisp deleted file mode 100644 index 95b58f1b380f4ac5bf3dc29e37083b0082525c1b..0000000000000000000000000000000000000000 --- a/compiler/hppa/alloc.lisp +++ /dev/null @@ -1,197 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/alloc.lisp,v 1.1 1992/07/13 03:48:14 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Allocation VOPs for the HPPA port. -;;; -;;; Written by William Lott. -;;; - -(in-package "HPPA") - - -;;;; LIST and LIST* - -(define-vop (list-or-list*) - (:args (things :more t)) - (:temporary (:scs (descriptor-reg) :type list) ptr) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) - res) - (:info num) - (:results (result :scs (descriptor-reg))) - (:variant-vars star) - (:policy :safe) - (:generator 0 - (cond - ((zerop num) - (move null-tn result)) - ((and star (= num 1)) - (move (tn-ref-tn things) result)) - (t - (macrolet - ((maybe-load (tn) - (once-only ((tn tn)) - `(sc-case ,tn - ((any-reg descriptor-reg zero null) - ,tn) - (control-stack - (load-stack-tn temp ,tn) - temp))))) - (let* ((cons-cells (if star (1- num) num)) - (alloc (* (pad-data-block cons-size) cons-cells))) - (pseudo-atomic (:extra alloc) - (move alloc-tn res) - (inst dep list-pointer-type 31 3 res) - (move res ptr) - (dotimes (i (1- cons-cells)) - (storew (maybe-load (tn-ref-tn things)) ptr - cons-car-slot list-pointer-type) - (setf things (tn-ref-across things)) - (inst addi (pad-data-block cons-size) ptr ptr) - (storew ptr ptr - (- cons-cdr-slot cons-size) - list-pointer-type)) - (storew (maybe-load (tn-ref-tn things)) ptr - cons-car-slot list-pointer-type) - (storew (if star - (maybe-load (tn-ref-tn (tn-ref-across things))) - null-tn) - ptr cons-cdr-slot list-pointer-type)) - (move res result))))))) - - -(define-vop (list list-or-list*) - (:variant nil)) - -(define-vop (list* list-or-list*) - (:variant t)) - - -;;;; Special purpose inline allocators. - -(define-vop (allocate-code-object) - (:args (boxed-arg :scs (any-reg)) - (unboxed-arg :scs (any-reg))) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:temporary (:scs (any-reg) :from (:argument 0)) boxed) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) - (:generator 100 - (inst addi (fixnum (1+ code-trace-table-offset-slot)) boxed-arg boxed) - (inst dep 0 31 3 boxed) - (inst srl unboxed-arg word-shift unboxed) - (inst addi lowtag-mask unboxed unboxed) - (inst dep 0 31 3 unboxed) - (pseudo-atomic () - ;; Note: we don't have to subtract off the 4 that was added by - ;; pseudo-atomic, because depositing other-pointer-type just adds - ;; it right back. - (inst move alloc-tn result) - (inst dep other-pointer-type 31 3 result) - (inst add alloc-tn boxed alloc-tn) - (inst add alloc-tn unboxed alloc-tn) - (inst sll boxed (- type-bits word-shift) ndescr) - (inst addi code-header-type ndescr ndescr) - (storew ndescr result 0 other-pointer-type) - (storew unboxed result code-code-size-slot other-pointer-type) - (storew null-tn result code-entry-points-slot other-pointer-type) - (storew null-tn result code-debug-info-slot other-pointer-type)))) - -(define-vop (make-fdefn) - (:args (name :scs (descriptor-reg) :to :eval)) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg) :from :argument)) - (:policy :fast-safe) - (:translate make-fdefn) - (:generator 37 - (with-fixed-allocation (result temp fdefn-type fdefn-size) - (inst li (make-fixup "undefined_tramp" :foreign) temp) - (storew name result fdefn-name-slot other-pointer-type) - (storew null-tn result fdefn-function-slot other-pointer-type) - (storew temp result fdefn-raw-addr-slot other-pointer-type)))) - - -;;;; Automatic allocators for primitive objects. - -(define-for-each-primitive-object (obj) - (collect ((forms)) - (let* ((options (primitive-object-options obj)) - (alloc-trans (getf options :alloc-trans)) - (alloc-vop (getf options :alloc-vop alloc-trans)) - (header (primitive-object-header obj)) - (lowtag (primitive-object-lowtag obj)) - (size (primitive-object-size obj)) - (variable-length (primitive-object-variable-length obj)) - (need-unbound-marker nil)) - (collect ((args) (init-forms)) - (when (and alloc-vop variable-length) - (args 'extra-words)) - (dolist (slot (primitive-object-slots obj)) - (let* ((name (slot-name slot)) - (offset (slot-offset slot))) - (ecase (getf (slot-options slot) :init :zero) - (:zero) - (:null - (init-forms `(storew null-tn result ,offset ,lowtag))) - (:unbound - (setf need-unbound-marker t) - (init-forms `(storew temp result ,offset ,lowtag))) - (:arg - (args name) - (init-forms `(storew ,name result ,offset ,lowtag)))))) - (when (and (null alloc-vop) (args)) - (error "Slots ~S want to be initialized, but there is no alloc vop ~ - defined for ~S." - (args) (primitive-object-name obj))) - (when alloc-vop - (forms - `(define-vop (,alloc-vop) - (:args ,@(mapcar #'(lambda (name) - `(,name :scs (any-reg descriptor-reg))) - (args))) - ,@(when (or need-unbound-marker header variable-length) - `((:temporary (:scs (non-descriptor-reg)) temp))) - (:results (result :scs (descriptor-reg) :from :load)) - (:policy :fast-safe) - ,@(when alloc-trans - `((:translate ,alloc-trans))) - (:generator 37 - (pseudo-atomic (,@(unless variable-length - `(:extra (pad-data-block ,size)))) - (move alloc-tn result) - (inst dep ,lowtag 31 3 result) - ,@(cond - ((and header variable-length) - `((inst addi (* (1+ ,size) word-bytes) extra-words temp) - (inst dep 0 31 3 temp) - (inst add temp alloc-tn alloc-tn) - (inst sll extra-words (- type-bits word-shift) temp) - (inst addi (+ (ash (1- ,size) type-bits) ,header) - temp temp) - (storew temp result 0 ,lowtag))) - (variable-length - (error ":REST-P T with no header in ~S?" - (primitive-object-name obj))) - (header - `((inst li ,(logior (ash (1- size) type-bits) - (symbol-value header)) - temp) - (storew temp result 0 ,lowtag))) - (t - nil)) - ,@(when need-unbound-marker - `((inst li unbound-marker-type temp))) - ,@(init-forms)))))))) - (when (forms) - `(progn - ,@(forms))))) diff --git a/compiler/hppa/arith.lisp b/compiler/hppa/arith.lisp deleted file mode 100644 index 4fd1bbb0053293a4f8ff9ecfdb0a84c308b0c2e3..0000000000000000000000000000000000000000 --- a/compiler/hppa/arith.lisp +++ /dev/null @@ -1,853 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/arith.lisp,v 1.2 1992/08/04 14:14:12 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition arithmetic VOPs for the HP-PA. -;;; -;;; Written by William Lott. -;;; - -(in-package "HPPA") - - - -;;;; Unary operations. - -(define-vop (fixnum-unop) - (:args (x :scs (any-reg))) - (:results (res :scs (any-reg))) - (:note "inline fixnum arithmetic") - (:arg-types tagged-num) - (:result-types tagged-num) - (:policy :fast-safe)) - -(define-vop (signed-unop) - (:args (x :scs (signed-reg))) - (:results (res :scs (signed-reg))) - (:note "inline (signed-byte 32) arithmetic") - (:arg-types signed-num) - (:result-types signed-num) - (:policy :fast-safe)) - -(define-vop (fast-negate/fixnum fixnum-unop) - (:translate %negate) - (:generator 1 - (inst sub zero-tn x res))) - -(define-vop (fast-negate/signed signed-unop) - (:translate %negate) - (:generator 2 - (inst sub zero-tn x res))) - -(define-vop (fast-lognot/fixnum fixnum-unop) - (:temporary (:scs (any-reg) :type fixnum :to (:result 0)) - temp) - (:translate lognot) - (:generator 2 - (inst li (fixnum -1) temp) - (inst xor x temp res))) - -(define-vop (fast-lognot/signed signed-unop) - (:translate lognot) - (:generator 1 - (inst uaddcm zero-tn x res))) - - - -;;;; Binary fixnum operations. - -;;; Assume that any constant operand is the second arg... - -(define-vop (fast-fixnum-binop) - (:args (x :target r :scs (any-reg)) - (y :target r :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:results (r :scs (any-reg))) - (:result-types tagged-num) - (:note "inline fixnum arithmetic") - (:effects) - (:affected) - (:policy :fast-safe)) - -(define-vop (fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:note "inline (unsigned-byte 32) arithmetic") - (:effects) - (:affected) - (:policy :fast-safe)) - -(define-vop (fast-signed-binop) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) - (:arg-types signed-num signed-num) - (:results (r :scs (signed-reg))) - (:result-types signed-num) - (:note "inline (signed-byte 32) arithmetic") - (:effects) - (:affected) - (:policy :fast-safe)) - -(defmacro define-binop (translate cost untagged-cost op) - `(progn - (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") - fast-fixnum-binop) - (:args (x :target r :scs (any-reg)) - (y :target r :scs (any-reg))) - (:translate ,translate) - (:generator ,cost - (inst ,op x y r))) - (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") - fast-signed-binop) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) - (:translate ,translate) - (:generator ,untagged-cost - (inst ,op x y r))) - (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") - fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) - (:translate ,translate) - (:generator ,untagged-cost - (inst ,op x y r))))) - -(define-binop + 2 6 add) -(define-binop - 2 6 sub) -(define-binop logior 1 2 or) -(define-binop logand 1 2 and) -(define-binop logandc2 1 2 andcm) -(define-binop logxor 1 2 xor) - -(define-vop (fast-fixnum-c-binop fast-fixnum-binop) - (:args (x :target r :scs (any-reg))) - (:info y) - (:arg-types tagged-num (:constant integer))) - -(define-vop (fast-signed-c-binop fast-signed-binop) - (:args (x :target r :scs (signed-reg))) - (:info y) - (:arg-types tagged-num (:constant integer))) - -(define-vop (fast-unsigned-c-binop fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg))) - (:info y) - (:arg-types tagged-num (:constant integer))) - -(defmacro define-c-binop (translate cost untagged-cost tagged-type - untagged-type inst) - `(progn - (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") - fast-fixnum-c-binop) - (:arg-types tagged-num (:constant ,tagged-type)) - (:translate ,translate) - (:generator ,cost - (let ((y (fixnum y))) - ,inst))) - (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") - fast-signed-c-binop) - (:arg-types signed-num (:constant ,untagged-type)) - (:translate ,translate) - (:generator ,untagged-cost - ,inst)) - (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED") - fast-unsigned-c-binop) - (:arg-types unsigned-num (:constant ,untagged-type)) - (:translate ,translate) - (:generator ,untagged-cost - ,inst)))) - -(define-c-binop + 1 3 (signed-byte 9) (signed-byte 11) - (inst addi y x r)) -(define-c-binop - 1 3 - (integer #.(- (1- (ash 1 9))) #.(ash 1 9)) - (integer #.(- (1- (ash 1 11))) #.(ash 1 11)) - (inst addi (- y) x r)) - -;;; Special case fixnum + and - that trap on overflow. Useful when we don't -;;; know that the result is going to be a fixnum. - -(define-vop (fast-+/fixnum fast-+/fixnum=>fixnum) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types (:or signed-num unsigned-num)) - (:note nil) - (:generator 4 - (inst addo x y r))) - -(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types (:or signed-num unsigned-num)) - (:note nil) - (:generator 3 - (inst addio (fixnum y) x r))) - -(define-vop (fast--/fixnum fast--/fixnum=>fixnum) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types (:or signed-num unsigned-num)) - (:note nil) - (:generator 4 - (inst subo x y r))) - -(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types (:or signed-num unsigned-num)) - (:note nil) - (:generator 3 - (inst addio (- (fixnum y)) x r))) - -;;; Shifting - -(define-vop (fast-ash) - (:policy :fast-safe) - (:translate ash) - (:note "inline word ASH") - (:args (number :scs (signed-reg unsigned-reg)) - (count :scs (signed-reg))) - (:arg-types (:or signed-num unsigned-num) tagged-num) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:results (result :scs (signed-reg unsigned-reg))) - (:result-types (:or signed-num unsigned-num)) - (:generator 8 - (inst comb :>= count zero-tn positive :nullify t) - (inst sub zero-tn count temp) - (inst comiclr 31 temp zero-tn :>=) - (inst li 31 temp) - (inst mtctl temp :sar) - (inst extrs number 0 1 temp) - (inst b done) - (inst shd temp number :variable result) - POSITIVE - (inst subi 31 count temp) - (inst mtctl temp :sar) - (inst zdep number :variable 32 result) - DONE)) - -(define-vop (fast-ash-c) - (:policy :fast-safe) - (:translate ash) - (:note nil) - (:args (number :scs (signed-reg unsigned-reg))) - (:info count) - (:arg-types (:or signed-num unsigned-num) (:constant integer)) - (:results (result :scs (signed-reg unsigned-reg))) - (:result-types (:or signed-num unsigned-num)) - (:generator 1 - (cond ((< count 0) - ;; It is a right shift. - (sc-case number - (signed-reg (inst sra number (min (- count) 31) result)) - (unsigned-reg (inst srl number (min (- count) 31) result)))) - ((> count 0) - ;; It is a left shift. - (inst sll number (min count 31) result)) - (t - ;; Count=0? Shouldn't happen, but it's easy: - (move number result))))) - - -(define-vop (signed-byte-32-len) - (:translate integer-length) - (:note "inline (signed-byte 32) integer-length") - (:policy :fast-safe) - (:args (arg :scs (signed-reg) :target shift)) - (:arg-types signed-num) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) - (:generator 30 - (inst move arg shift :>=) - (inst uaddcm zero-tn shift shift) - (inst comb := shift zero-tn done) - (inst li 0 res) - LOOP - (inst srl shift 1 shift) - (inst comb :<> shift zero-tn loop) - (inst addi (fixnum 1) res res) - DONE)) - -(define-vop (unsigned-byte-32-count) - (:translate logcount) - (:note "inline (unsigned-byte 32) logcount") - (:policy :fast-safe) - (:args (arg :scs (unsigned-reg) :target num)) - (:arg-types unsigned-num) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0) - :target res) num) - (:temporary (:scs (non-descriptor-reg)) mask temp) - (:generator 30 - (inst li #x55555555 mask) - (inst srl arg 1 temp) - (inst and arg mask num) - (inst and temp mask temp) - (inst add num temp num) - (inst li #x33333333 mask) - (inst srl num 2 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst add num temp num) - (inst li #x0f0f0f0f mask) - (inst srl num 4 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst add num temp num) - (inst li #x00ff00ff mask) - (inst srl num 8 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst add num temp num) - (inst li #x0000ffff mask) - (inst srl num 16 temp) - (inst and num mask num) - (inst and temp mask temp) - (inst add num temp res))) - -;;; Multiply and Divide. - -(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) - (:args (x :scs (any-reg) :target x-pass) - (y :scs (any-reg) :target y-pass)) - (:temporary (:sc signed-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) x-pass) - (:temporary (:sc signed-reg :offset nl1-offset - :from (:argument 1) :to (:result 0)) y-pass) - (:temporary (:sc signed-reg :offset nl2-offset :target r - :from (:argument 1) :to (:result 0)) res-pass) - (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp) - (:temporary (:sc signed-reg :offset nl4-offset - :from (:argument 1) :to (:result 0)) sign) - (:temporary (:sc interior-reg :offset lip-offset) lip) - (:ignore lip sign) - (:translate *) - (:generator 30 - (unless (location= y y-pass) - (inst sra x 2 x-pass)) - (let ((fixup (make-fixup 'multiply :assembly-routine))) - (inst ldil fixup tmp) - (inst ble fixup lisp-heap-space tmp)) - (if (location= y y-pass) - (inst sra x 2 x-pass) - (inst move y y-pass)) - (move res-pass r))) - -(define-vop (fast-*/signed=>signed fast-signed-binop) - (:translate *) - (:args (x :scs (signed-reg) :target x-pass) - (y :scs (signed-reg) :target y-pass)) - (:temporary (:sc signed-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) x-pass) - (:temporary (:sc signed-reg :offset nl1-offset - :from (:argument 1) :to (:result 0)) y-pass) - (:temporary (:sc signed-reg :offset nl2-offset :target r - :from (:argument 1) :to (:result 0)) res-pass) - (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp) - (:temporary (:sc signed-reg :offset nl4-offset - :from (:argument 1) :to (:result 0)) sign) - (:temporary (:sc interior-reg :offset lip-offset) lip) - (:ignore lip sign) - (:translate *) - (:generator 31 - (let ((fixup (make-fixup 'multiply :assembly-routine))) - (move x x-pass) - (move y y-pass) - (inst ldil fixup tmp) - (inst ble fixup lisp-heap-space tmp :nullify t) - (inst nop) - (move res-pass r)))) - -(define-vop (fast-truncate/fixnum fast-fixnum-binop) - (:translate truncate) - (:args (x :scs (any-reg) :target x-pass) - (y :scs (any-reg) :target y-pass)) - (:temporary (:sc signed-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) x-pass) - (:temporary (:sc signed-reg :offset nl1-offset - :from (:argument 1) :to (:result 0)) y-pass) - (:temporary (:sc signed-reg :offset nl2-offset :target q - :from (:argument 1) :to (:result 0)) q-pass) - (:temporary (:sc signed-reg :offset nl3-offset :target r - :from (:argument 1) :to (:result 1)) r-pass) - (:results (q :scs (signed-reg)) - (r :scs (any-reg))) - (:result-types tagged-num tagged-num) - (:vop-var vop) - (:save-p :compute-only) - (:generator 30 - (let ((zero (generate-error-code vop division-by-zero-error x y))) - (inst bc := nil y zero-tn zero)) - (move x x-pass) - (move y y-pass) - (let ((fixup (make-fixup 'truncate :assembly-routine))) - (inst ldil fixup q-pass) - (inst ble fixup lisp-heap-space q-pass :nullify t)) - (inst nop) - (move q-pass q) - (move r-pass r))) - -(define-vop (fast-truncate/signed fast-signed-binop) - (:translate truncate) - (:args (x :scs (signed-reg) :target x-pass) - (y :scs (signed-reg) :target y-pass)) - (:temporary (:sc signed-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) x-pass) - (:temporary (:sc signed-reg :offset nl1-offset - :from (:argument 1) :to (:result 0)) y-pass) - (:temporary (:sc signed-reg :offset nl2-offset :target q - :from (:argument 1) :to (:result 0)) q-pass) - (:temporary (:sc signed-reg :offset nl3-offset :target r - :from (:argument 1) :to (:result 1)) r-pass) - (:results (q :scs (signed-reg)) - (r :scs (signed-reg))) - (:result-types signed-num signed-num) - (:vop-var vop) - (:save-p :compute-only) - (:generator 35 - (let ((zero (generate-error-code vop division-by-zero-error x y))) - (inst bc := nil y zero-tn zero)) - (move x x-pass) - (move y y-pass) - (let ((fixup (make-fixup 'truncate :assembly-routine))) - (inst ldil fixup q-pass) - (inst ble fixup lisp-heap-space q-pass :nullify t)) - (inst nop) - (move q-pass q) - (move r-pass r))) - - -;;;; Binary conditional VOPs: - -(define-vop (fast-conditional) - (:conditional) - (:info target not-p) - (:effects) - (:affected) - (:policy :fast-safe)) - -(define-vop (fast-conditional/fixnum fast-conditional) - (:args (x :scs (any-reg)) - (y :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison")) - -(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg))) - (:arg-types tagged-num (:constant (signed-byte 9))) - (:info target not-p y)) - -(define-vop (fast-conditional/signed fast-conditional) - (:args (x :scs (signed-reg)) - (y :scs (signed-reg))) - (:arg-types signed-num signed-num) - (:note "inline (signed-byte 32) comparison")) - -(define-vop (fast-conditional-c/signed fast-conditional/signed) - (:args (x :scs (signed-reg))) - (:arg-types signed-num (:constant (signed-byte 11))) - (:info target not-p y)) - -(define-vop (fast-conditional/unsigned fast-conditional) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:note "inline (unsigned-byte 32) comparison")) - -(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num (:constant (signed-byte 11))) - (:info target not-p y)) - - -(defmacro define-conditional-vop (translate signed-cond unsigned-cond) - `(progn - ,@(mapcar #'(lambda (suffix cost signed imm) - (unless (and (member suffix '(/fixnum -c/fixnum)) - (eq translate 'eql)) - `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" - translate suffix)) - ,(intern - (format nil "~:@(FAST-CONDITIONAL~A~)" - suffix))) - (:translate ,translate) - (:generator ,cost - (inst ,(if imm 'bci 'bc) - ,(if signed signed-cond unsigned-cond) - not-p - ,(if (eq suffix '-c/fixnum) - '(fixnum y) - 'y) - x - target))))) - '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) - '(3 2 5 4 5 4) - '(t t t t nil nil) - '(nil t nil t nil t)))) - -;; We switch < and > because the immediate has to come first. - -(define-conditional-vop < :> :>>) -(define-conditional-vop > :< :<<) - -;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a -;;; known fixnum. -;;; -(define-conditional-vop eql := :=) - -;;; These versions specify a fixnum restriction on their first arg. We have -;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on -;;; the first arg and a higher cost. The reason for doing this is to prevent -;;; fixnum specific operations from being used on word integers, spuriously -;;; consing the argument. -;;; -(define-vop (fast-eql/fixnum fast-conditional) - (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison") - (:translate eql) - (:generator 3 - (inst bc := not-p x y target))) -;;; -(define-vop (generic-eql/fixnum fast-eql/fixnum) - (:arg-types * tagged-num) - (:variant-cost 7)) - -(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg descriptor-reg))) - (:arg-types tagged-num (:constant (signed-byte 9))) - (:info target not-p y) - (:translate eql) - (:generator 2 - (inst bci := not-p (fixnum y) x target))) -;;; -(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) - (:arg-types * (:constant (signed-byte 14))) - (:variant-cost 6)) - - -;;;; 32-bit logical operations - -(define-vop (32bit-logical) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:policy :fast-safe)) - -(define-vop (32bit-logical-not 32bit-logical) - (:translate 32bit-logical-not) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:generator 1 - (inst uaddcm zero-tn x r))) - -(define-vop (32bit-logical-and 32bit-logical) - (:translate 32bit-logical-and) - (:generator 1 - (inst and x y r))) - -(deftransform 32bit-logical-nand ((x y) (* *)) - '(32bit-logical-not (32bit-logical-and x y))) - -(define-vop (32bit-logical-or 32bit-logical) - (:translate 32bit-logical-or) - (:generator 1 - (inst or x y r))) - -(deftransform 32bit-logical-nor ((x y) (* *)) - '(32bit-logical-not (32bit-logical-or x y))) - -(define-vop (32bit-logical-xor 32bit-logical) - (:translate 32bit-logical-xor) - (:generator 1 - (inst xor x y r))) - -(deftransform 32bit-logical-eqv ((x y) (* *)) - '(32bit-logical-not (32bit-logical-xor x y))) - -(deftransform 32bit-logical-andc1 ((x y) (* *)) - '(32bit-logical-and (32bit-logical-not x) y)) - -(define-vop (32bit-logical-andc2 32bit-logical) - (:translate 32bit-logical-andc2) - (:generator 1 - (inst andcm x y r))) - -(deftransform 32bit-logical-orc1 ((x y) (* *)) - '(32bit-logical-or (32bit-logical-not x) y)) - -(deftransform 32bit-logical-orc2 ((x y) (* *)) - '(32bit-logical-or x (32bit-logical-not y))) - - -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) - (:arg-types unsigned-num tagged-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:note "SHIFT-TOWARDS-START") - (:generator 1 - (inst subi 31 amount temp) - (inst mtctl temp :sar) - (inst zdep num :variable 32 r))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:generator 1 - (inst mtctl amount :sar) - (inst shd zero-tn num :variable r))) - - - -;;;; Bignum stuff. - -(define-vop (bignum-length get-header-data) - (:translate bignum::%bignum-length) - (:policy :fast-safe)) - -(define-vop (bignum-set-length set-header-data) - (:translate bignum::%bignum-set-length) - (:policy :fast-safe)) - -(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type - (unsigned-reg) unsigned-num bignum::%bignum-ref) - -(define-full-setter bignum-set * bignum-digits-offset other-pointer-type - (unsigned-reg) unsigned-num bignum::%bignum-set) - -(define-vop (digit-0-or-plus) - (:translate bignum::%digit-0-or-plusp) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:conditional) - (:info target not-p) - (:effects) - (:affected) - (:generator 1 - (inst bc :>= not-p digit zero-tn target))) - -(define-vop (add-w/carry) - (:translate bignum::%add-with-carry) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg)) - (carry :scs (unsigned-reg))) - (:result-types unsigned-num positive-fixnum) - (:generator 3 - (inst addi -1 c zero-tn) - (inst addc a b result) - (inst addc zero-tn zero-tn carry))) - -(define-vop (sub-w/borrow) - (:translate bignum::%subtract-with-borrow) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg)) - (borrow :scs (unsigned-reg))) - (:result-types unsigned-num positive-fixnum) - (:generator 4 - (inst addi -1 c zero-tn) - (inst subb a b result) - (inst addc zero-tn zero-tn borrow))) - -(define-vop (bignum-mult) - (:translate bignum::%multiply) - (:policy :fast-safe) - (:args (x-arg :scs (unsigned-reg) :target x) - (y-arg :scs (unsigned-reg) :target y)) - (:arg-types unsigned-num unsigned-num) - (:temporary (:scs (signed-reg) :from (:argument 0)) x) - (:temporary (:scs (signed-reg) :from (:argument 1)) y) - (:temporary (:scs (signed-reg)) tmp) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 3 - ;; Make sure X is less then Y. - (inst comclr x-arg y-arg tmp :<<) - (inst xor x-arg y-arg tmp) - (inst xor x-arg tmp x) - (inst xor y-arg tmp y) - - ;; Blow out of here if the result is zero. - (inst li 0 hi) - (inst comb := x zero-tn done) - (inst li 0 lo) - (inst li 0 tmp) - - LOOP - (inst comb :ev x zero-tn next-bit) - (inst srl x 1 x) - (inst add lo y lo) - (inst addc hi tmp hi) - NEXT-BIT - (inst add y y y) - (inst comb :<> x zero-tn loop) - (inst addc tmp tmp tmp) - - DONE)) - -(def-source-transform bignum:%multiply-and-add (x y carry &optional (extra 0)) - #+nil ;; This would be greate if it worked, but it doesn't. - (if (eql extra 0) - `(multiple-value-call #'bignum::%dual-word-add - (bignum:%multiply ,x ,y) - (values ,carry)) - `(multiple-value-call #'bignum::%dual-word-add - (multiple-value-call #'bignum::%dual-word-add - (bignum:%multiply ,x ,y) - (values ,carry)) - (values ,extra))) - (let ((hi (gensym "HI-")) - (lo (gensym "LO-"))) - (if (eql extra 0) - `(multiple-value-bind (,hi ,lo) (bignum:%multiply ,x ,y) - (bignum::%dual-word-add ,hi ,lo ,carry)) - `(multiple-value-bind (,hi ,lo) (bignum:%multiply ,x ,y) - (multiple-value-bind - (,hi ,lo) - (bignum::%dual-word-add ,hi ,lo ,carry) - (bignum::%dual-word-add ,hi ,lo ,extra)))))) - -(defknown bignum::%dual-word-add - (bignum-element-type bignum-element-type bignum-element-type) - (values bignum-element-type bignum-element-type) - (flushable movable)) - -(define-vop (dual-word-add) - (:policy :fast-safe) - (:translate bignum::%dual-word-add) - (:args (hi :scs (unsigned-reg) :to (:result 1)) - (lo :scs (unsigned-reg)) - (extra :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:results (hi-res :scs (unsigned-reg) :from (:result 1)) - (lo-res :scs (unsigned-reg) :from (:result 0))) - (:result-types unsigned-num unsigned-num) - (:affected) - (:effects) - (:generator 3 - (inst add lo extra lo-res) - (inst addc hi zero-tn hi-res))) - -(define-vop (bignum-lognot) - (:translate bignum::%lognot) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst uaddcm zero-tn x r))) - -(define-vop (fixnum-to-digit) - (:translate bignum::%fixnum-to-digit) - (:policy :fast-safe) - (:args (fixnum :scs (signed-reg))) - (:arg-types tagged-num) - (:results (digit :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (move fixnum digit))) - -(define-vop (bignum-floor) - (:translate bignum::%floor) - (:policy :fast-safe) - (:args (hi :scs (unsigned-reg) :to (:argument 1)) - (lo :scs (unsigned-reg) :to (:argument 0)) - (divisor :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp) - (:results (quo :scs (unsigned-reg) :from (:argument 0)) - (rem :scs (unsigned-reg) :from (:argument 1))) - (:result-types unsigned-num unsigned-num) - (:generator 65 - (inst sub zero-tn divisor temp) - (inst ds zero-tn temp zero-tn) - (inst add lo lo quo) - (inst ds hi divisor rem) - (inst addc quo quo quo) - (dotimes (i 31) - (inst ds rem divisor rem) - (inst addc quo quo quo)) - (inst comclr rem zero-tn zero-tn :>=) - (inst add divisor rem rem))) - -(define-vop (signify-digit) - (:translate bignum::%fixnum-digit-with-correct-sign) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg) :target res)) - (:arg-types unsigned-num) - (:results (res :scs (signed-reg))) - (:result-types signed-num) - (:generator 1 - (move digit res))) - -(define-vop (digit-lshr) - (:translate bignum::%digit-logical-shift-right) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg)) - (count :scs (unsigned-reg))) - (:arg-types unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 2 - (inst mtctl count :sar) - (inst shd zero-tn digit :variable result))) - -(define-vop (digit-ashr digit-lshr) - (:translate bignum::%ashr) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 1 - (inst extrs digit 0 1 temp) - (inst mtctl count :sar) - (inst shd temp digit :variable result))) - -(define-vop (digit-ashl digit-ashr) - (:translate bignum::%ashl) - (:generator 1 - (inst subi 31 count temp) - (inst mtctl temp :sar) - (inst zdep digit :variable 32 result))) - - -;;;; Static functions. - -(define-static-function two-arg-gcd (x y) :translate gcd) -(define-static-function two-arg-lcm (x y) :translate lcm) - -(define-static-function two-arg-* (x y) :translate *) -(define-static-function two-arg-/ (x y) :translate /) - -(define-static-function %negate (x) :translate %negate) - -(define-static-function two-arg-and (x y) :translate logand) -(define-static-function two-arg-ior (x y) :translate logior) -(define-static-function two-arg-xor (x y) :translate logxor) diff --git a/compiler/hppa/array.lisp b/compiler/hppa/array.lisp deleted file mode 100644 index 412038b4f8a6429f725fe5fb31e4f3edcdb453b6..0000000000000000000000000000000000000000 --- a/compiler/hppa/array.lisp +++ /dev/null @@ -1,347 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/array.lisp,v 1.3 1992/10/13 13:14:47 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the SPARC definitions for array operations. -;;; -;;; Written by William Lott -;;; -(in-package "HPPA") - - -;;;; Allocator for the array header. - -(define-vop (make-array-header) - (:translate make-array-header) - (:policy :fast-safe) - (:args (type :scs (any-reg)) - (rank :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) - (:results (result :scs (descriptor-reg))) - (:generator 0 - (pseudo-atomic () - (inst move alloc-tn header) - (inst dep other-pointer-type 31 3 header) - (inst addi (* (1+ array-dimensions-offset) word-bytes) rank ndescr) - (inst dep 0 31 3 ndescr) - (inst add alloc-tn ndescr alloc-tn) - (inst addi (fixnum (1- array-dimensions-offset)) rank ndescr) - (inst sll ndescr type-bits ndescr) - (inst or ndescr type ndescr) - (inst srl ndescr 2 ndescr) - (storew ndescr header 0 vm:other-pointer-type)) - (move header result))) - - -;;;; Additional accessors and setters for the array header. - -(defknown lisp::%array-dimension (t index) index - (flushable)) -(defknown lisp::%set-array-dimension (t index index) index - ()) - -(define-full-reffer %array-dimension * - array-dimensions-offset other-pointer-type - (any-reg) positive-fixnum lisp::%array-dimension) - -(define-full-setter %set-array-dimension * - array-dimensions-offset other-pointer-type - (any-reg) positive-fixnum lisp::%set-array-dimension) - - -(defknown lisp::%array-rank (t) index (flushable)) - -(define-vop (array-rank-vop) - (:translate lisp::%array-rank) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (loadw res x 0 vm:other-pointer-type) - (inst srl res type-bits res) - (inst addi (- (1- vm:array-dimensions-offset)) res res))) - - - -;;;; Bounds checking routine. - - -(define-vop (check-bound) - (:translate %check-bound) - (:policy :fast-safe) - (:args (array :scs (descriptor-reg)) - (bound :scs (any-reg descriptor-reg)) - (index :scs (any-reg descriptor-reg) :target result)) - (:results (result :scs (any-reg descriptor-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (let ((error (generate-error-code vop invalid-array-index-error - array bound index))) - (inst bc :>= nil index bound error)) - (move index result))) - - -;;;; Accessors/Setters - -;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos -;;; elements are represented in integer registers and are built out of -;;; 8, 16, or 32 bit elements. - -(eval-when (compile eval) - -(defmacro def-full-data-vector-frobs (type element-type &rest scs) - `(progn - (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type - vector-data-offset other-pointer-type ,scs ,element-type - data-vector-ref) - (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type - vector-data-offset other-pointer-type ,scs ,element-type - data-vector-set))) - -(defmacro def-partial-data-vector-frobs - (type element-type size signed &rest scs) - `(progn - (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type - ,size ,signed vector-data-offset other-pointer-type ,scs - ,element-type data-vector-ref) - (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type - ,size vector-data-offset other-pointer-type ,scs - ,element-type data-vector-set))) - -); eval-when (compile eval) - -(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg) - -(def-partial-data-vector-frobs simple-string base-char :byte nil base-char-reg) - -(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum - :byte nil unsigned-reg signed-reg) - -(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum - :short nil unsigned-reg signed-reg) - -(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num - unsigned-reg) - - -;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, -;;; and 4-bit vectors. -;;; - -(eval-when (compile eval) - -(defmacro def-small-data-vector-frobs (type bits) - (let* ((elements-per-word (floor vm:word-bits bits)) - (bit-shift (1- (integer-length elements-per-word)))) - `(progn - (define-vop (,(symbolicate 'data-vector-ref/ type)) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (result :scs (unsigned-reg) :from (:argument 0))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (inst srl index ,bit-shift temp) - (inst sh2add temp object lip) - (loadw result lip vector-data-offset other-pointer-type) - (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp) - ,@(unless (= bits 1) - `((inst addi ,(1- bits) temp temp))) - (inst mtctl temp :sar) - (inst extru result :variable ,bits result))) - (define-vop (,(symbolicate 'data-vector-ref-c/ type)) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:arg-types ,type (:constant index)) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 15 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) - vm:other-pointer-type))) - (cond ((typep offset '(signed-byte 14)) - (inst ldw offset object result)) - (t - (inst ldil (ldb (byte 21 11) offset) temp) - (inst ldw (ldb (byte 11 0) offset) temp result)))) - (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result)))) - (define-vop (,(symbolicate 'data-vector-set/ type)) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg)) - (value :scs (unsigned-reg zero immediate) :target result)) - (:arg-types ,type positive-fixnum positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp old) - (:temporary (:scs (interior-reg)) lip) - (:generator 25 - (inst srl index ,bit-shift temp) - (inst sh2add temp object lip) - (loadw old lip vector-data-offset other-pointer-type) - (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp) - ,@(unless (= bits 1) - `((inst addi ,(1- bits) temp temp))) - (inst mtctl temp :sar) - (inst dep (sc-case value (immediate (tn-value value)) (t value)) - :variable ,bits old) - (storew old lip vector-data-offset other-pointer-type) - (sc-case value - (immediate - (inst li (tn-value value) result)) - (t - (move value result))))) - (define-vop (,(symbolicate 'data-vector-set-c/ type)) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs (unsigned-reg zero immediate) :target result)) - (:arg-types ,type - (:constant index) - positive-fixnum) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) old) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (let ((offset (- (* (+ word vector-data-offset) word-bytes) - other-pointer-type))) - (cond ((typep offset '(signed-byte 14)) - (inst ldw offset object old)) - (t - (inst move object lip) - (inst addil (ldb (byte 21 11) offset) lip) - (inst ldw (ldb (byte 11 0) offset) lip old))) - (inst dep (sc-case value - (immediate (tn-value value)) - (t value)) - (+ (* extra ,bits) ,(1- bits)) - ,bits - old) - (if (typep offset '(signed-byte 14)) - (inst stw old offset object) - (inst stw old (ldb (byte 11 0) offset) lip))) - (sc-case value - (immediate - (inst li (tn-value value) result)) - (t - (move value result))))))))) - -); eval-when (compile eval) - -(def-small-data-vector-frobs simple-bit-vector 1) -(def-small-data-vector-frobs simple-array-unsigned-byte-2 2) -(def-small-data-vector-frobs simple-array-unsigned-byte-4 4) - -;;; And the float variants. -;;; - -(define-vop (data-vector-ref/simple-array-single-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:argument 1)) - (index :scs (any-reg) :to (:argument 0) :target offset)) - (:arg-types simple-array-single-float positive-fixnum) - (:results (value :scs (single-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) - (:result-types single-float) - (:generator 5 - (inst addi (- (* vector-data-offset word-bytes) other-pointer-type) - index offset) - (inst fldx offset object value))) - -(define-vop (data-vector-set/simple-array-single-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:argument 1)) - (index :scs (any-reg) :to (:argument 0) :target offset) - (value :scs (single-reg) :target result)) - (:arg-types simple-array-single-float positive-fixnum single-float) - (:results (result :scs (single-reg))) - (:result-types single-float) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) - (:generator 5 - (inst addi (- (* vector-data-offset word-bytes) other-pointer-type) - index offset) - (inst fstx value offset object) - (unless (location= result value) - (inst funop :copy value result)))) - -(define-vop (data-vector-ref/simple-array-double-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:argument 1)) - (index :scs (any-reg) :to (:argument 0) :target offset)) - (:arg-types simple-array-double-float positive-fixnum) - (:results (value :scs (double-reg))) - (:result-types double-float) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) - (:generator 7 - (inst sll index 1 offset) - (inst addi (- (* vector-data-offset word-bytes) other-pointer-type) - offset offset) - (inst fldx offset object value))) - -(define-vop (data-vector-set/simple-array-double-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:argument 1)) - (index :scs (any-reg) :to (:argument 0) :target offset) - (value :scs (double-reg) :target result)) - (:arg-types simple-array-double-float positive-fixnum double-float) - (:results (result :scs (double-reg))) - (:result-types double-float) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) - (:generator 20 - (inst sll index 1 offset) - (inst addi (- (* vector-data-offset word-bytes) other-pointer-type) - offset offset) - (inst fstx value offset object) - (unless (location= result value) - (inst funop :copy value result)))) - -;;; These vops are useful for accessing the bits of a vector irrespective of -;;; what type of vector it is. -;;; - -(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num - %raw-bits) -(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg) - unsigned-num %set-raw-bits) - - - -;;;; Misc. Array VOPs. - -(define-vop (get-vector-subtype get-header-data)) -(define-vop (set-vector-subtype set-header-data)) - diff --git a/compiler/hppa/c-call.lisp b/compiler/hppa/c-call.lisp deleted file mode 100644 index 314babac66d3a4247713386fc0a8db0f434c3e78..0000000000000000000000000000000000000000 --- a/compiler/hppa/c-call.lisp +++ /dev/null @@ -1,185 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/c-call.lisp,v 1.1 1992/07/13 03:48:17 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VOPs and other necessary machine specific support -;;; routines for call-out to C. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") -(use-package "ALIEN") -(use-package "ALIEN-INTERNALS") - -(defun my-make-wired-tn (prim-type-name sc-name offset) - (make-wired-tn (primitive-type-or-lose prim-type-name *backend*) - (sc-number-or-lose sc-name *backend*) - offset)) - -(defstruct arg-state - (args 0)) - -(defstruct (arg-info - (:constructor make-arg-info (offset prim-type reg-sc stack-sc))) - offset - prim-type - reg-sc - stack-sc) - -(def-alien-type-method (integer :arg-tn) (type state) - (let ((args (arg-state-args state))) - (setf (arg-state-args state) (1+ args)) - (if (alien-integer-type-signed type) - (make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack) - (make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))) - -(def-alien-type-method (system-area-pointer :arg-tn) (type state) - (declare (ignore type)) - (let ((args (arg-state-args state))) - (setf (arg-state-args state) (1+ args)) - (make-arg-info args 'system-area-pointer 'sap-reg 'sap-stack))) - -(def-alien-type-method (single-float :arg-tn) (type state) - (declare (ignore type)) - (let ((args (arg-state-args state))) - (setf (arg-state-args state) (1+ args)) - (make-arg-info args 'single-float 'single-reg 'single-stack))) - -(def-alien-type-method (double-float :arg-tn) (type state) - (declare (ignore type)) - (let ((args (logior (1+ (arg-state-args state)) 1))) - (setf (arg-state-args state) (1+ args)) - (make-arg-info args 'double-float 'double-reg 'double-stack))) - -(def-alien-type-method (integer :result-tn) (type) - (if (alien-integer-type-signed type) - (my-make-wired-tn 'signed-byte-32 'signed-reg nl4-offset) - (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl4-offset))) - -(def-alien-type-method (system-area-pointer :result-tn) (type) - (declare (ignore type)) - (my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset)) - -(def-alien-type-method (single-float :result-tn) (type) - (declare (ignore type)) - (my-make-wired-tn 'single-float 'single-reg 4)) - -(def-alien-type-method (double-float :result-tn) (type) - (declare (ignore type)) - (my-make-wired-tn 'double-float 'double-reg 4)) - -(def-alien-type-method (values :result-tn) (type) - (let ((values (alien-values-type-values type))) - (when values - (assert (null (cdr values))) - (invoke-alien-type-method :result-tn (car values))))) - -(defun make-argument-tns (type) - (let* ((state (make-arg-state)) - (args (mapcar #'(lambda (arg-type) - (invoke-alien-type-method :arg-tn arg-type state)) - (alien-function-type-arg-types type))) - ;; We need 8 words of cruft, and we need to round up to a multiple - ;; of 16 words. - (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15))) - (values - (mapcar #'(lambda (arg) - (declare (type arg-info arg)) - (let ((offset (arg-info-offset arg)) - (prim-type (arg-info-prim-type arg))) - (cond ((>= offset 4) - (my-make-wired-tn prim-type (arg-info-stack-sc arg) - (- frame-size offset 8 1))) - ((or (eq prim-type 'single-float) - (eq prim-type 'double-float)) - (my-make-wired-tn prim-type (arg-info-reg-sc arg) - (+ offset 4))) - (t - (my-make-wired-tn prim-type (arg-info-reg-sc arg) - (- nl0-offset offset)))))) - args) - (* frame-size word-bytes)))) - -(def-vm-support-routine make-call-out-tns (type) - (declare (type alien-function-type type)) - (multiple-value-bind - (arg-tns stack-size) - (make-argument-tns type) - (values (make-normal-tn *fixnum-primitive-type*) - stack-size - arg-tns - (invoke-alien-type-method - :result-tn - (alien-function-type-result-type type))))) - - -(define-vop (foreign-symbol-address) - (:translate foreign-symbol-address) - (:policy :fast-safe) - (:args) - (:arg-types (:constant simple-string)) - (:info foreign-symbol) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst li (make-fixup foreign-symbol :foreign) res))) - -(define-vop (call-out) - (:args (function :scs (sap-reg) :target cfunc) - (args :more t)) - (:results (results :more t)) - (:ignore args results) - (:save-p t) - (:temporary (:sc any-reg :offset cfunc-offset - :from (:argument 0) :to (:result 0)) cfunc) - (:temporary (:scs (any-reg) :to (:result 0)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:vop-var vop) - (:generator 0 - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (move function cfunc) - (let ((fixup (make-fixup "call_into_c" :foreign))) - (inst ldil fixup temp) - (inst ble fixup c-text-space temp :nullify t)) - (inst nop) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - - -(define-vop (alloc-number-stack-space) - (:info amount) - (:results (result :scs (sap-reg any-reg))) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 0 - (move nsp-tn result) - (unless (zerop amount) - (let ((delta (logandc2 (+ amount 63) 63))) - (cond ((< delta (ash 1 10)) - (inst addi delta nsp-tn nsp-tn)) - (t - (inst li delta temp) - (inst add temp nsp-tn nsp-tn))))))) - -(define-vop (dealloc-number-stack-space) - (:info amount) - (:policy :fast-safe) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 0 - (unless (zerop amount) - (let ((delta (- (logandc2 (+ amount 63) 63)))) - (cond ((<= (- (ash 1 10)) delta) - (inst addi delta nsp-tn nsp-tn)) - (t - (inst li delta temp) - (inst add temp nsp-tn nsp-tn))))))) diff --git a/compiler/hppa/call.lisp b/compiler/hppa/call.lisp deleted file mode 100644 index bdecd70b99e783122006c2900f86b7a67f5d39d8..0000000000000000000000000000000000000000 --- a/compiler/hppa/call.lisp +++ /dev/null @@ -1,1224 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/call.lisp,v 1.3 1992/10/16 16:35:29 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of function call for the HPPA. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - - -;;;; Interfaces to IR2 conversion: - -;;; Standard-Argument-Location -- Interface -;;; -;;; Return a wired TN describing the N'th full call argument passing -;;; location. -;;; -(def-vm-support-routine standard-argument-location (n) - (declare (type unsigned-byte n)) - (if (< n register-arg-count) - (make-wired-tn *any-primitive-type* - register-arg-scn - (elt register-arg-offsets n)) - (make-wired-tn *any-primitive-type* - control-stack-arg-scn n))) - - -;;; Make-Return-PC-Passing-Location -- Interface -;;; -;;; Make a passing location TN for a local call return PC. If standard is -;;; true, then use the standard (full call) location, otherwise use any legal -;;; location. Even in the non-standard case, this may be restricted by a -;;; desire to use a subroutine call instruction. -;;; -(def-vm-support-routine make-return-pc-passing-location (standard) - (if standard - (make-wired-tn *any-primitive-type* register-arg-scn lra-offset) - (make-restricted-tn *any-primitive-type* register-arg-scn))) - -;;; Make-Old-FP-Passing-Location -- Interface -;;; -;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass -;;; Old-FP in. This is (obviously) wired in the standard convention, but is -;;; totally unrestricted in non-standard conventions, since we can always fetch -;;; it off of the stack using the arg pointer. -;;; -(def-vm-support-routine make-old-fp-passing-location (standard) - (if standard - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset) - (make-normal-tn *fixnum-primitive-type*))) - -;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface -;;; -;;; Make the TNs used to hold Old-FP and Return-PC within the current -;;; function. We treat these specially so that the debugger can find them at a -;;; known location. -;;; -(def-vm-support-routine make-old-fp-save-location (env) - (specify-save-tn - (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) - (make-wired-tn *fixnum-primitive-type* - control-stack-arg-scn - ocfp-save-offset))) -;;; -(def-vm-support-routine make-return-pc-save-location (env) - (specify-save-tn - (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env) - (make-wired-tn *any-primitive-type* - control-stack-arg-scn - lra-save-offset))) - -;;; Make-Argument-Count-Location -- Interface -;;; -;;; Make a TN for the standard argument count passing location. We only -;;; need to make the standard location, since a count is never passed when we -;;; are using non-standard conventions. -;;; -(def-vm-support-routine make-argument-count-location () - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) - - -;;; MAKE-NFP-TN -- Interface -;;; -;;; Make a TN to hold the number-stack frame pointer. This is allocated -;;; once per component, and is component-live. -;;; -(def-vm-support-routine make-nfp-tn () - (component-live-tn - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset))) - -;;; MAKE-STACK-POINTER-TN () -;;; -(def-vm-support-routine make-stack-pointer-tn () - (make-normal-tn *fixnum-primitive-type*)) - -;;; MAKE-NUMBER-STACK-POINTER-TN () -;;; -(def-vm-support-routine make-number-stack-pointer-tn () - (make-normal-tn *fixnum-primitive-type*)) - -;;; Make-Unknown-Values-Locations -- Interface -;;; -;;; Return a list of TNs that can be used to represent an unknown-values -;;; continuation within a function. -;;; -(def-vm-support-routine make-unknown-values-locations () - (list (make-stack-pointer-tn) - (make-normal-tn *fixnum-primitive-type*))) - - -;;; Select-Component-Format -- Interface -;;; -;;; This function is called by the Entry-Analyze phase, allowing -;;; VM-dependent initialization of the IR2-Component structure. We push -;;; placeholder entries in the Constants to leave room for additional -;;; noise in the code object header. -;;; -(def-vm-support-routine select-component-format (component) - (declare (type component component)) - (dotimes (i code-constants-offset) - (vector-push-extend nil - (ir2-component-constants (component-info component)))) - (undefined-value)) - - -;;;; Frame hackery: - -;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal -;;; -;;; Return the number of bytes needed for the current non-descriptor stack. -;;; We have to allocate multiples of 64 bytes. -;;; -(defun bytes-needed-for-non-descriptor-stack-frame () - (logandc2 (+ (* (sb-allocated-size 'non-descriptor-stack) word-bytes) 63) - 63)) - -;;; Used for setting up the Old-FP in local call. -;;; -(define-vop (current-fp) - (:results (val :scs (any-reg))) - (:generator 1 - (move cfp-tn val))) - -;;; Used for computing the caller's NFP for use in known-values return. Only -;;; works assuming there is no variable size stuff on the nstack. -;;; -(define-vop (compute-old-nfp) - (:results (val :scs (any-reg))) - (:vop-var vop) - (:generator 1 - (let ((nfp (current-nfp-tn vop))) - (when nfp - (inst addi (- (bytes-needed-for-non-descriptor-stack-frame)) - nfp val))))) - -(define-vop (xep-allocate-frame) - (:info start-lab) - (:vop-var vop) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 1 - ;; Make sure the function is aligned, and drop a label pointing to this - ;; function header. - (align lowtag-bits) - (trace-table-entry trace-table-function-prologue) - (emit-label start-lab) - ;; Allocate function header. - (inst function-header-word) - (dotimes (i (1- function-header-code-offset)) - (inst word 0)) - ;; The start of the actual code. - ;; Fix CODE, cause the function object was passed in. - (let ((entry-point (gen-label))) - (emit-label entry-point) - (inst compute-code-from-fn lip-tn entry-point temp code-tn)) - ;; Build our stack frames. - (inst addi (* vm:word-bytes (sb-allocated-size 'control-stack)) - cfp-tn csp-tn) - (let ((nfp (current-nfp-tn vop))) - (when nfp - (move nsp-tn nfp) - (inst addi (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn nsp-tn))) - (trace-table-entry trace-table-normal))) - -(define-vop (allocate-frame) - (:results (res :scs (any-reg)) - (nfp :scs (any-reg))) - (:info callee) - (:generator 2 - (move csp-tn res) - (inst addi (* vm:word-bytes (sb-allocated-size 'control-stack)) - csp-tn csp-tn) - (when (ir2-environment-number-stack-p callee) - (move nsp-tn nfp) - (inst addi (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn nsp-tn)))) - -;;; Allocate a partial frame for passing stack arguments in a full call. Nargs -;;; is the number of arguments passed. If no stack arguments are passed, then -;;; we don't have to do anything. -;;; -(define-vop (allocate-full-call-frame) - (:info nargs) - (:results (res :scs (any-reg))) - (:generator 2 - (when (> nargs register-arg-count) - (move csp-tn res) - (inst addi (* nargs vm:word-bytes) csp-tn csp-tn)))) - - -;;; Default-Unknown-Values -- Internal -;;; -;;; Emit code needed at the return-point from an unknown-values call for a -;;; fixed number of values. Values is the head of the TN-Ref list for the -;;; locations that the values are to be received into. Nvals is the number of -;;; values that are to be received (should equal the length of Values). -;;; -;;; Move-Temp is a Descriptor-Reg TN used as a temporary. -;;; -;;; This code exploits the fact that in the unknown-values convention, a -;;; single value return returns at the return PC + 8, whereas a return of other -;;; than one value returns directly at the return PC. -;;; -;;; If 0 or 1 values are expected, then we just emit an instruction to reset -;;; the SP (which will only be executed when other than 1 value is returned.) -;;; -;;; In the general case, we have to do three things: -;;; -- Default unsupplied register values. This need only be done when a -;;; single value is returned, since register values are defaulted by the -;;; called in the non-single case. -;;; -- Default unsupplied stack values. This needs to be done whenever there -;;; are stack values. -;;; -- Reset SP. This must be done whenever other than 1 value is returned, -;;; regardless of the number of values desired. -;;; -;;; The general-case code looks like this: -#| - b regs-defaulted ; Skip if MVs - nop - - move a1 null-tn ; Default register values - ... - loadi nargs 1 ; Force defaulting of stack values - move old-fp csp ; Set up args for SP resetting - -regs-defaulted - subu temp nargs register-arg-count - - bltz temp default-value-7 ; jump to default code - addu temp temp -1 - loadw move-temp old-fp-tn 6 ; Move value to correct location. - store-stack-tn val4-tn move-temp - - bltz temp default-value-8 - addu temp temp -1 - loadw move-temp old-fp-tn 7 - store-stack-tn val5-tn move-temp - - ... - -defaulting-done - move sp old-fp ; Reset SP. -<end of code> - -<elsewhere> -default-value-7 - store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack) - -default-value-8 - store-stack-tn val5-tn null-tn ; Nil out 8'th value. - - ... - - br defaulting-done - nop -|# -;;; -(defun default-unknown-values (vop values nvals move-temp temp lra-label) - (declare (type (or tn-ref null) values) - (type unsigned-byte nvals) (type tn move-temp temp)) - (cond - ((<= nvals 1) - (assemble () - ;; Note that this is a single-value return point. This is actually - ;; the multiple-value entry point for a single desired value, but - ;; the code location has to be here, or the debugger backtrace - ;; gets confused. - (note-this-location vop :single-value-return) - (move ocfp-tn csp-tn) - (inst compute-code-from-lra code-tn lra-label temp code-tn))) - ((<= nvals register-arg-count) - (assemble () - ;; Note that this is an unknown-values return point. - (note-this-location vop :unknown-return) - ;; Branch off to the MV case. - (inst b regs-defaulted :nullify t) - - ;; Default any unsupplied values. - (do ((val (tn-ref-across values) (tn-ref-across val))) - ((null val)) - (inst move null-tn (tn-ref-tn val) - (if (tn-ref-across val) - :never - :tr))) - - REGS-DEFAULTED - - ;; Clear the stack. Note: the last move in the single value reg - ;; defaulting nullifies this, so this only happens in the mv case. - (move ocfp-tn csp-tn) - - ;; Fix CODE. - (inst compute-code-from-lra code-tn lra-label temp code-tn))) - (t - (collect ((defaults)) - (assemble (nil nil :labels (default-stack-vals)) - ;; Note that this is an unknown-values return point. - (note-this-location vop :unknown-return) - ;; Branch off to the MV case. - (inst b regs-defaulted :nullify t) - - ;; Default any unsupplied register values. - (do ((i 1 (1+ i)) - (val (tn-ref-across values) (tn-ref-across val))) - ((= i register-arg-count)) - (inst move null-tn (tn-ref-tn val))) - (inst b default-stack-vals) - (move ocfp-tn csp-tn) - - REGS-DEFAULTED - - (do ((i register-arg-count (1+ i)) - (val (do ((i 0 (1+ i)) - (val values (tn-ref-across val))) - ((= i register-arg-count) val)) - (tn-ref-across val))) - ((null val)) - - (let ((default-lab (gen-label)) - (tn (tn-ref-tn val))) - (defaults (cons default-lab tn)) - (inst bci :> nil (fixnum i) nargs-tn default-lab) - (loadw move-temp ocfp-tn i) - (store-stack-tn tn move-temp))) - - DEFAULTING-DONE - (move ocfp-tn csp-tn) - (inst compute-code-from-lra code-tn lra-label temp code-tn) - - (let ((defaults (defaults))) - (assert defaults) - (assemble (*elsewhere*) - (trace-table-entry trace-table-call-site) - DEFAULT-STACK-VALS - (do ((remaining defaults (cdr remaining))) - ((null remaining)) - (let ((def (car remaining))) - (emit-label (car def)) - (when (null (cdr remaining)) - (inst b defaulting-done)) - (store-stack-tn (cdr def) null-tn))) - (trace-table-entry trace-table-normal))))))) - (undefined-value)) - - -;;;; Unknown values receiving: - -;;; Receive-Unknown-Values -- Internal -;;; -;;; Emit code needed at the return point for an unknown-values call for an -;;; arbitrary number of values. -;;; -;;; We do the single and non-single cases with no shared code: there doesn't -;;; seem to be any potential overlap, and receiving a single value is more -;;; important efficiency-wise. -;;; -;;; When there is a single value, we just push it on the stack, returning -;;; the old SP and 1. -;;; -;;; When there is a variable number of values, we move all of the argument -;;; registers onto the stack, and return Args and Nargs. -;;; -;;; Args and Nargs are TNs wired to the named locations. We must -;;; explicitly allocate these TNs, since their lifetimes overlap with the -;;; results Start and Count (also, it's nice to be able to target them). -;;; -(defun receive-unknown-values (args nargs start count lra-label temp) - (declare (type tn args nargs start count temp)) - (assemble (nil nil :labels (variable-values)) - (inst b variable-values :nullify t) - - (inst compute-code-from-lra code-tn lra-label temp code-tn) - (inst move csp-tn start) - (inst stwm (first register-arg-tns) word-bytes csp-tn) - (inst li (fixnum 1) count) - - DONE - - (assemble (*elsewhere*) - (trace-table-entry trace-table-call-site) - VARIABLE-VALUES - (inst compute-code-from-lra code-tn lra-label temp code-tn) - (do ((arg register-arg-tns (rest arg)) - (i 0 (1+ i))) - ((null arg)) - (storew (first arg) args i)) - (move args start) - (move nargs count) - (inst b done :nullify t) - (trace-table-entry trace-table-normal))) - (undefined-value)) - -;;; VOP that can be inherited by unknown values receivers. The main thing this -;;; handles is allocation of the result temporaries. -;;; -(define-vop (unknown-values-receiver) - (:results (start :scs (any-reg)) - (count :scs (any-reg))) - (:temporary (:sc descriptor-reg :offset ocfp-offset - :from :eval :to (:result 0)) - values-start) - (:temporary (:sc any-reg :offset nargs-offset - :from :eval :to (:result 1)) - nvals) - (:temporary (:scs (non-descriptor-reg)) temp)) - - - -;;;; Local call with unknown values convention return: - -;;; Non-TR local call for a fixed number of values passed according to the -;;; unknown values convention. -;;; -;;; Args are the argument passing locations, which are specified only to -;;; terminate their lifetimes in the caller. -;;; -;;; Values are the return value locations (wired to the standard passing -;;; locations). -;;; -;;; Save is the save info, which we can ignore since saving has been done. -;;; Return-PC is the TN that the return PC should be passed in. -;;; Target is a continuation pointing to the start of the called function. -;;; Nvals is the number of values received. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (call-local) - (:args (cfp) - (nfp) - (args :more t)) - (:results (values :more t)) - (:save-p t) - (:move-args :local-call) - (:info arg-locs callee target nvals) - (:vop-var vop) - (:temporary (:scs (descriptor-reg) :from :eval) move-temp) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp) - (:ignore arg-locs args ocfp) - (:generator 5 - (trace-table-entry trace-table-call-site) - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (move nfp callee-nfp))) - (maybe-load-stack-tn cfp-tn cfp) - (inst compute-lra-from-code code-tn label temp - (callee-return-pc-tn callee)) - (note-this-location vop :call-site) - (inst b target :nullify t) - (emit-return-pc label) - (default-unknown-values vop values nvals move-temp temp label) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) - -;;; Non-TR local call for a variable number of return values passed according -;;; to the unknown values convention. The results are the start of the values -;;; glob and the number of values received. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (multiple-call-local unknown-values-receiver) - (:args (cfp) - (nfp) - (args :more t)) - (:save-p t) - (:move-args :local-call) - (:info save callee target) - (:ignore args save) - (:vop-var vop) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:generator 20 - (trace-table-entry trace-table-call-site) - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (move nfp callee-nfp))) - (maybe-load-stack-tn cfp-tn cfp) - (inst compute-lra-from-code code-tn label temp - (callee-return-pc-tn callee)) - (note-this-location vop :call-site) - (inst b target :nullify t) - (emit-return-pc label) - (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count label temp) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) - - -;;;; Local call with known values return: - -;;; Non-TR local call with known return locations. Known-value return works -;;; just like argument passing in local call. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (known-call-local) - (:args (cfp) - (nfp) - (args :more t)) - (:results (res :more t)) - (:move-args :local-call) - (:save-p t) - (:info save callee target) - (:ignore args res save) - (:vop-var vop) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 5 - (trace-table-entry trace-table-call-site) - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (move nfp callee-nfp))) - (maybe-load-stack-tn cfp-tn cfp) - (inst compute-lra-from-code code-tn label temp - (callee-return-pc-tn callee)) - (note-this-location vop :call-site) - (inst b target :nullify t) - (emit-return-pc label) - (note-this-location vop :known-return) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) - -;;; Return from known values call. We receive the return locations as -;;; arguments to terminate their lifetimes in the returning function. We -;;; restore FP and CSP and jump to the Return-PC. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (known-return) - (:args (old-fp :target old-fp-temp) - (return-pc :target return-pc-temp) - (vals :more t)) - (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp) - (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp) - (:temporary (:scs (interior-reg)) lip) - (:move-args :known-return) - (:info val-locs) - (:ignore val-locs vals) - (:vop-var vop) - (:generator 6 - (trace-table-entry trace-table-function-epilogue) - (maybe-load-stack-tn old-fp-temp old-fp) - (maybe-load-stack-tn return-pc-temp return-pc) - (move cfp-tn csp-tn) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move cur-nfp nsp-tn))) - (inst addi (- word-bytes other-pointer-type) return-pc-temp lip) - (inst bv lip) - (move old-fp-temp cfp-tn) - (trace-table-entry trace-table-normal))) - - -;;;; Full call: -;;; -;;; There is something of a cross-product effect with full calls. Different -;;; versions are used depending on whether we know the number of arguments or -;;; the name of the called function, and whether we want fixed values, unknown -;;; values, or a tail call. -;;; -;;; In full call, the arguments are passed creating a partial frame on the -;;; stack top and storing stack arguments into that frame. On entry to the -;;; callee, this partial frame is pointed to by FP. If there are no stack -;;; arguments, we don't bother allocating a partial frame, and instead set FP -;;; to SP just before the call. - -;;; Define-Full-Call -- Internal -;;; -;;; This macro helps in the definition of full call VOPs by avoiding code -;;; replication in defining the cross-product VOPs. -;;; -;;; Name is the name of the VOP to define. -;;; -;;; Named is true if the first argument is a symbol whose global function -;;; definition is to be called. -;;; -;;; Return is either :Fixed, :Unknown or :Tail: -;;; -- If :Fixed, then the call is for a fixed number of values, returned in -;;; the standard passing locations (passed as result operands). -;;; -- If :Unknown, then the result values are pushed on the stack, and the -;;; result values are specified by the Start and Count as in the -;;; unknown-values continuation representation. -;;; -- If :Tail, then do a tail-recursive call. No values are returned. -;;; The Old-Fp and Return-PC are passed as the second and third arguments. -;;; -;;; In non-tail calls, the pointer to the stack arguments is passed as the last -;;; fixed argument. If Variable is false, then the passing locations are -;;; passed as a more arg. Variable is true if there are a variable number of -;;; arguments passed on the stack. Variable cannot be specified with :Tail -;;; return. TR variable argument call is implemented separately. -;;; -;;; In tail call with fixed arguments, the passing locations are passed as a -;;; more arg, but there is no new-FP, since the arguments have been set up in -;;; the current frame. -;;; -(eval-when (compile eval) -(defmacro define-full-call (name named return variable) - (assert (not (and variable (eq return :tail)))) - `(define-vop (,name - ,@(when (eq return :unknown) - '(unknown-values-receiver))) - (:args - ,@(unless (eq return :tail) - '((new-fp :scs (any-reg) :to :eval))) - - ,(if named - '(fdefn :target fdefn-pass) - '(arg-fun :target lexenv)) - - ,@(when (eq return :tail) - '((ocfp :target ocfp-pass) - (lra :target lra-pass))) - - ,@(unless variable '((args :more t :scs (descriptor-reg))))) - - ,@(when (eq return :fixed) - '((:results (values :more t)))) - - (:save-p ,(if (eq return :tail) :compute-only t)) - - ,@(unless (or (eq return :tail) variable) - '((:move-args :full-call))) - - (:vop-var vop) - (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(nargs)) - ,@(when (eq return :fixed) '(nvals))) - - (:ignore - ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(args))) - - (:temporary (:sc descriptor-reg - :offset ocfp-offset - ,@(when (eq return :tail) - '(:from (:argument 1))) - ,@(unless (eq return :fixed) - '(:to :eval))) - ocfp-pass) - - (:temporary (:sc descriptor-reg - :offset lra-offset - ,@(when (eq return :tail) - '(:from (:argument 2))) - :to :eval) - lra-pass) - - ,@(if named - `((:temporary (:sc descriptor-reg :offset fdefn-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - fdefn-pass)) - - `((:temporary (:sc descriptor-reg :offset lexenv-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - lexenv) - (:temporary (:scs (descriptor-reg) - :from (:argument ,(if (eq return :tail) 2 1)) - :to :eval) - function))) - - (:temporary (:sc any-reg :offset nargs-offset :to :eval) - nargs-pass) - - ,@(when variable - (mapcar #'(lambda (name offset) - `(:temporary (:sc descriptor-reg - :offset ,offset - :to :eval) - ,name)) - register-arg-names register-arg-offsets)) - ,@(when (eq return :fixed) - '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) - - ,@(unless (eq return :tail) - '((:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) - - (:temporary (:scs (interior-reg) :type interior) lip) - - (:generator ,(+ (if named 5 0) - (if variable 19 1) - (if (eq return :tail) 0 10) - 15 - (if (eq return :unknown) 25 0)) - (trace-table-entry trace-table-call-site) - (let* ((cur-nfp (current-nfp-tn vop)) - ,@(unless (eq return :tail) - '((lra-label (gen-label)))) - (filler - (list :load-nargs - ,@(if (eq return :tail) - '((unless (location= ocfp ocfp-pass) - :load-ocfp) - (unless (location= lra lra-pass) - :load-lra) - (when cur-nfp - :frob-nfp)) - '((when cur-nfp - :frob-nfp) - :comp-lra - :save-fp - :load-fp))))) - (labels - ((do-next-filler () - (when filler - (ecase (pop filler) - ((nil) (do-next-filler)) - (:load-nargs - ,@(if variable - `((inst sub csp-tn new-fp nargs-pass) - ,@(let ((index -1)) - (mapcar #'(lambda (name) - `(loadw ,name new-fp - ,(incf index))) - register-arg-names))) - '((inst li (fixnum nargs) nargs-pass)))) - ,@(if (eq return :tail) - '((:load-ocfp - (sc-case ocfp - (any-reg - (inst move ocfp ocfp-pass)) - (control-stack - (loadw ocfp-pass cfp-tn (tn-offset ocfp))))) - (:load-lra - (sc-case lra - (descriptor-reg - (inst move lra lra-pass)) - (control-stack - (loadw lra-pass cfp-tn (tn-offset lra))))) - (:frob-nfp - (inst move cur-nfp nsp-tn))) - `((:frob-nfp - (store-stack-tn nfp-save cur-nfp)) - (:comp-lra - (inst compute-lra-from-code - code-tn lra-label temp lra-pass)) - (:save-fp - (inst move cfp-tn ocfp-pass)) - (:load-fp - ,(if variable - '(move new-fp cfp-tn) - '(if (> nargs register-arg-count) - (move new-fp cfp-tn) - (move csp-tn cfp-tn)))))))))) - - ,@(if named - `((sc-case fdefn - (descriptor-reg (move fdefn fdefn-pass)) - (control-stack - (loadw fdefn-pass cfp-tn (tn-offset fdefn)) - (do-next-filler)) - (constant - (loadw fdefn-pass code-tn (tn-offset fdefn) - other-pointer-type) - (do-next-filler))) - (loadw lip fdefn-pass fdefn-raw-addr-slot - other-pointer-type) - (do-next-filler)) - `((sc-case arg-fun - (descriptor-reg (move arg-fun lexenv)) - (control-stack - (loadw lexenv cfp-tn (tn-offset arg-fun)) - (do-next-filler)) - (constant - (loadw lexenv code-tn (tn-offset arg-fun) - other-pointer-type) - (do-next-filler))) - (loadw function lexenv closure-function-slot - function-pointer-type) - (do-next-filler) - (inst addi (- (ash function-header-code-offset word-shift) - function-pointer-type) - function lip))) - (loop - (cond ((null filler) - (return)) - ((null (car filler)) - (pop filler)) - ((null (cdr filler)) - (return)) - (t - (do-next-filler)))) - - (note-this-location vop :call-site) - (inst bv lip :nullify (null filler)) - (do-next-filler)) - - ,@(ecase return - (:fixed - '((emit-return-pc lra-label) - (default-unknown-values vop values nvals - move-temp temp lra-label) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)))) - (:unknown - '((emit-return-pc lra-label) - (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count - lra-label temp) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)))) - (:tail))) - (trace-table-entry trace-table-normal)))) -);eval-when - -(define-full-call call nil :fixed nil) -(define-full-call call-named t :fixed nil) -(define-full-call multiple-call nil :unknown nil) -(define-full-call multiple-call-named t :unknown nil) -(define-full-call tail-call nil :tail nil) -(define-full-call tail-call-named t :tail nil) - -(define-full-call call-variable nil :fixed t) -(define-full-call multiple-call-variable nil :unknown t) - - -;;; Defined separately, since needs special code that BLT's the arguments -;;; down. -;;; -(define-vop (tail-call-variable) - (:args (args-arg :scs (any-reg) :target args) - (function-arg :scs (descriptor-reg) :target lexenv) - (old-fp-arg :scs (any-reg) :target old-fp) - (lra-arg :scs (descriptor-reg) :target lra)) - - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) - (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) - (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp) - (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) - (:temporary (:scs (any-reg) :from (:argument 3)) tmp) - - (:vop-var vop) - - (:generator 75 - - ;; Move these into the passing locations if they are not already there. - (move args-arg args) - (move function-arg lexenv) - (move old-fp-arg old-fp) - (move lra-arg lra) - - ;; Clear the number stack if anything is there. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst move cur-nfp nsp-tn))) - - ;; And jump to the assembly-routine that does the bliting. - (let ((fixup (make-fixup 'tail-call-variable :assembly-routine))) - (inst ldil fixup tmp) - (inst be fixup lisp-heap-space tmp :nullify t)))) - - -;;;; Unknown values return: - -;;; Return a single value using the unknown-values convention. -;;; -(define-vop (return-single) - (:args (old-fp :scs (any-reg)) - (return-pc :scs (descriptor-reg)) - (value)) - (:ignore value) - (:vop-var vop) - (:generator 6 - ;; Clear the number stack. - (trace-table-entry trace-table-function-epilogue) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst move cur-nfp nsp-tn))) - ;; Clear the control stack, and restore the frame pointer. - (move cfp-tn csp-tn) - (move old-fp cfp-tn) - ;; Out of here. - (lisp-return return-pc :offset 1) - (trace-table-entry trace-table-normal))) - -;;; Do unknown-values return of a fixed number of values. The Values are -;;; required to be set up in the standard passing locations. Nvals is the -;;; number of values returned. -;;; -;;; If returning a single value, then deallocate the current frame, restore -;;; FP and jump to the single-value entry at Return-PC + 8. -;;; -;;; If returning other than one value, then load the number of values returned, -;;; NIL out unsupplied values registers, restore FP and return at Return-PC. -;;; When there are stack values, we must initialize the argument pointer to -;;; point to the beginning of the values block (which is the beginning of the -;;; current frame.) -;;; -(define-vop (return) - (:args - (old-fp :scs (any-reg)) - (return-pc :scs (descriptor-reg) :to (:eval 1)) - (values :more t)) - (:ignore values) - (:info nvals) - (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0) - (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1) - (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2) - (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3) - (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4) - (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) - (:vop-var vop) - (:generator 6 - ;; Clear the number stack. - (trace-table-entry trace-table-function-epilogue) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst move cur-nfp nsp-tn))) - ;; Establish the values pointer and values count. - (move cfp-tn val-ptr) - (inst li (fixnum nvals) nargs) - ;; restore the frame pointer and clear as much of the control - ;; stack as possible. - (move old-fp cfp-tn) - (inst addi (* nvals word-bytes) val-ptr csp-tn) - ;; pre-default any argument register that need it. - (when (< nvals register-arg-count) - (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) - (move null-tn reg))) - ;; And away we go. - (lisp-return return-pc) - (trace-table-entry trace-table-normal))) - -;;; Do unknown-values return of an arbitrary number of values (passed on the -;;; stack.) We check for the common case of a single return value, and do that -;;; inline using the normal single value return convention. Otherwise, we -;;; branch off to code that calls an assembly-routine. -;;; -(define-vop (return-multiple) - (:args - (old-fp-arg :scs (any-reg) :to (:eval 1)) - (lra-arg :scs (descriptor-reg) :to (:eval 1)) - (vals-arg :scs (any-reg) :target vals) - (nvals-arg :scs (any-reg) :target nvals)) - - (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp) - (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals) - (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) - (:temporary (:sc descriptor-reg :offset a0-offset) a0) - (:temporary (:scs (any-reg) :from (:eval 0)) tmp) - - (:vop-var vop) - (:node-var node) - - (:generator 13 - (trace-table-entry trace-table-function-epilogue) - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst move cur-nfp nsp-tn))) - - (unless (policy node (> space speed)) - ;; Check for the single case. - (inst comib :<> (fixnum 1) nvals-arg not-single) - (loadw a0 vals-arg) - - ;; Return with one value. - (move cfp-tn csp-tn) - (move old-fp-arg cfp-tn) - (lisp-return lra-arg :offset 1)) - - ;; Nope, not the single case. - NOT-SINGLE - (move old-fp-arg old-fp) - (move lra-arg lra) - (move vals-arg vals) - (move nvals-arg nvals) - (let ((fixup (make-fixup 'return-multiple :assembly-routine))) - (inst ldil fixup tmp) - (inst be fixup lisp-heap-space tmp :nullify t)) - (trace-table-entry trace-table-normal))) - - - -;;;; XEP hackery: - -;;; We don't need to do anything special for regular functions. -;;; -(define-vop (setup-environment) - (:info label) - (:ignore label) - (:generator 0 - ;; Don't bother doing anything. - )) - -;;; Get the lexical environment from it's passing location. -;;; -(define-vop (setup-closure-environment) - (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure - :to (:result 0)) - lexenv) - (:results (closure :scs (descriptor-reg))) - (:info label) - (:ignore label) - (:generator 6 - ;; Get result. - (move lexenv closure))) - -;;; Copy a more arg from the argument area to the end of the current frame. -;;; Fixed is the number of non-more arguments. -;;; -(define-vop (copy-more-arg) - (:temporary (:sc any-reg :offset nl0-offset) result) - (:temporary (:sc any-reg :offset nl1-offset) count) - (:temporary (:sc any-reg :offset nl2-offset) src) - (:temporary (:sc any-reg :offset nl3-offset) dst) - (:temporary (:sc descriptor-reg :offset l0-offset) temp) - (:info fixed) - (:generator 20 - ;; Figure out how many things we are going to copy. - (unless (zerop fixed) - (inst addi (- (fixnum fixed)) nargs-tn count)) - - ;; Blow out of here if is nothing to copy. - (inst comb :<= (if (zerop fixed) nargs-tn count) zero-tn done :nullify t) - - (when (< fixed register-arg-count) - ;; Save a pointer to the results so we can fill in register args. - ;; We don't need this if there are more fixed args than reg args. - (move csp-tn result)) - - ;; Allocate the space on the stack. - (inst add csp-tn (if (zerop fixed) nargs-tn count) csp-tn) - - (when (< fixed register-arg-count) - ;; We must stop when we run out of stack args, not when we run out of - ;; args in general. - (inst addi (fixnum (- register-arg-count)) nargs-tn count) - ;; Everything of interest in registers. - (inst comb :<= count zero-tn do-regs)) - ;; Initialize dst to be end of stack. - (move csp-tn dst) - - ;; Initialize src to be end of args. - (inst add cfp-tn nargs-tn src) - - LOOP - ;; *--dst = *--src, --count - (inst ldwm (- word-bytes) src temp) - (inst addib :> (fixnum -1) count loop) - (inst stwm temp (- word-bytes) dst) - - DO-REGS - (when (< fixed register-arg-count) - ;; Now we have to deposit any more args that showed up in registers. - ;; We know there is at least one more arg, otherwise we would have - ;; branched to done up at the top. - (inst addi (fixnum (- fixed)) nargs-tn count) - (do ((i fixed (1+ i))) - ((>= i register-arg-count)) - ;; Is this the last one? - (inst addib :<= (fixnum -1) count done) - ;; Store it relative to the pointer saved at the start. - (storew (nth i register-arg-tns) result (- i fixed)))) - DONE)) - -;;; More args are stored consequtively on the stack, starting immediately at -;;; the context pointer. The context pointer is not typed, so the lowtag is 0. -;;; -(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg) - - -;;; Turn more arg (context, count) into a list. -;;; -(define-vop (listify-rest-args) - (:args (context-arg :target context :scs (descriptor-reg)) - (count-arg :target count :scs (any-reg))) - (:arg-types * tagged-num) - (:temporary (:scs (any-reg) :from (:argument 0)) context) - (:temporary (:scs (any-reg) :from (:argument 1)) count) - (:temporary (:scs (descriptor-reg) :from :eval) temp) - (:temporary (:scs (non-descriptor-reg) :from :eval) dst) - (:results (result :scs (descriptor-reg))) - (:translate %listify-rest-args) - (:policy :safe) - (:generator 20 - (let ((loop (gen-label)) - (done (gen-label))) - (move context-arg context) - (move count-arg count) - ;; Check to see if there are any arguments. - (inst comb := count zero-tn done) - (move null-tn result) - - ;; We need to do this atomically. - (pseudo-atomic () - ;; Allocate a cons (2 words) for each item. - (inst move alloc-tn result) - (inst dep list-pointer-type 31 3 result) - (move result dst) - (inst sll count 1 temp) - (inst add alloc-tn temp alloc-tn) - - (emit-label loop) - ;; Grab one value and stash it in the car of this cons. - (inst ldwm word-bytes context temp) - (storew temp dst 0 vm:list-pointer-type) - - ;; Dec count, and if != zero, go back for more. - (inst addi (* 2 vm:word-bytes) dst dst) - (inst addib :> (fixnum -1) count loop :nullify t) - (storew dst dst -1 list-pointer-type) - - ;; NIL out the last cons. - (storew null-tn dst -1 list-pointer-type)) - (emit-label done)))) - -;;; Return the location and size of the more arg glob created by Copy-More-Arg. -;;; Supplied is the total number of arguments supplied (originally passed in -;;; NARGS.) Fixed is the number of non-rest arguments. -;;; -;;; We must duplicate some of the work done by Copy-More-Arg, since at that -;;; time the environment is in a pretty brain-damaged state, preventing this -;;; info from being returned as values. What we do is compute -;;; supplied - fixed, and return a pointer that many words below the current -;;; stack top. -;;; -(setf (info function source-transform 'c::%more-arg-context) nil) -;;; -(define-vop (more-arg-context) - (:policy :fast-safe) - (:translate c::%more-arg-context) - (:args (supplied :scs (any-reg))) - (:arg-types tagged-num (:constant fixnum)) - (:info fixed) - (:results (context :scs (descriptor-reg)) - (count :scs (any-reg))) - (:result-types t tagged-num) - (:note "more-arg-context") - (:generator 5 - (inst addi (fixnum (- fixed)) supplied count) - (inst sub csp-tn count context))) - - -;;; Signal wrong argument count error if Nargs isn't = to Count. -;;; -(define-vop (verify-argument-count) - (:args (nargs :scs (any-reg))) - (:arg-types positive-fixnum) - (:info count) - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (let ((err-lab - (generate-error-code vop invalid-argument-count-error nargs))) - (cond ((zerop count) - (inst bc :<> nil nargs zero-tn err-lab)) - (t - (inst bci :<> nil (fixnum count) nargs err-lab)))))) - -;;; Signal an argument count error. -;;; -(macrolet ((frob (name error &rest args) - `(define-vop (,name) - (:args ,@(mapcar #'(lambda (arg) - `(,arg :scs (any-reg descriptor-reg))) - args)) - (:vop-var vop) - (:save-p :compute-only) - (:generator 1000 - (error-call vop ,error ,@args))))) - (frob argument-count-error invalid-argument-count-error nargs) - (frob type-check-error object-not-type-error object type) - (frob odd-keyword-arguments-error odd-keyword-arguments-error) - (frob unknown-keyword-argument-error unknown-keyword-argument-error key) - (frob nil-function-returned-error nil-function-returned-error fun)) diff --git a/compiler/hppa/cell.lisp b/compiler/hppa/cell.lisp deleted file mode 100644 index bb5fd8c6a06ad8e3ddeae2cd6903e0750df4886f..0000000000000000000000000000000000000000 --- a/compiler/hppa/cell.lisp +++ /dev/null @@ -1,273 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/cell.lisp,v 1.2 1992/10/28 00:32:43 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of various primitive memory access -;;; VOPs for the HPPA -;;; -;;; Written by William Lott. -;;; - -(in-package "HPPA") - - -;;;; Data object definition macros. - -(define-for-each-primitive-object (obj) - (collect ((forms)) - (let ((lowtag (primitive-object-lowtag obj))) - (dolist (slot (primitive-object-slots obj)) - (let* ((name (slot-name slot)) - (offset (slot-offset slot)) - (rest-p (slot-rest-p slot)) - (slot-opts (slot-options slot)) - (ref-trans (getf slot-opts :ref-trans)) - (ref-vop (getf slot-opts :ref-vop ref-trans)) - (set-trans (getf slot-opts :set-trans)) - (setf-function-p (and (listp set-trans) - (= (length set-trans) 2) - (eq (car set-trans) 'setf))) - (setf-vop (getf slot-opts :setf-vop - (when setf-function-p - (intern (concatenate - 'simple-string - "SET-" - (string (cadr set-trans))))))) - (set-vop (getf slot-opts :set-vop - (if setf-vop nil set-trans)))) - (when ref-vop - (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref)) - (:variant ,offset ,lowtag) - ,@(when ref-trans - `((:translate ,ref-trans)))))) - (when (or set-vop setf-vop) - (forms `(define-vop ,(cond ((and rest-p setf-vop) - (error "Can't automatically generate ~ - a setf VOP for :rest-p ~ - slots: ~S in ~S" - name - (primitive-object-name obj))) - (rest-p `(,set-vop slot-set)) - ((and set-vop setf-function-p) - (error "Setf functions (list ~S) must ~ - use :setf-vops." - set-trans)) - (set-vop `(,set-vop cell-set)) - (setf-function-p - `(,setf-vop cell-setf-function)) - (t - `(,setf-vop cell-setf))) - (:variant ,offset ,lowtag) - ,@(when set-trans - `((:translate ,set-trans))))))))) - (when (forms) - `(progn - ,@(forms))))) - - - -;;;; Symbol hacking VOPs: - -;;; Do a cell ref with an error check for being unbound. -;;; -(define-vop (checked-cell-ref) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) - -;;; With Symbol-Value, we check that the value isn't the trap object. So -;;; Symbol-Value of NIL is NIL. -;;; -(define-vop (symbol-value checked-cell-ref) - (:translate symbol-value) - (:generator 9 - (move object obj-temp) - (loadw value obj-temp symbol-value-slot other-pointer-type) - (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) - (inst li unbound-marker-type temp) - (inst bc := nil value temp err-lab)))) - -;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. -(define-vop (boundp-frob) - (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value) - (:temporary (:type random :scs (non-descriptor-reg)) temp)) - -(define-vop (boundp boundp-frob) - (:translate boundp) - (:generator 9 - (loadw value object symbol-value-slot other-pointer-type) - (inst li unbound-marker-type temp) - (inst bc :<> not-p value temp target))) - -(define-vop (fast-symbol-value cell-ref) - (:variant symbol-value-slot other-pointer-type) - (:policy :fast) - (:translate symbol-value)) - - - -;;;; Fdefinition (fdefn) objects. - -(define-vop (safe-fdefn-function) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp) - (:generator 10 - (move obj-temp object) - (loadw value obj-temp fdefn-function-slot other-pointer-type) - (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) - (inst bc := nil value null-tn err-lab)))) - -(define-vop (set-fdefn-function) - (:policy :fast-safe) - (:translate (setf fdefn-function)) - (:args (function :scs (descriptor-reg) :target result) - (fdefn :scs (descriptor-reg))) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg)) type) - (:results (result :scs (descriptor-reg))) - (:generator 38 - (load-type type function (- function-pointer-type)) - (inst addi (- function-header-type) type type) - (inst comb := type zero-tn normal-fn) - (inst addi (- (ash function-header-code-offset word-shift) - function-pointer-type) - function lip) - (inst li (make-fixup "closure_tramp" :foreign) lip) - NORMAL-FN - (storew function fdefn fdefn-function-slot other-pointer-type) - (storew lip fdefn fdefn-raw-addr-slot other-pointer-type) - (move function result))) - -(define-vop (fdefn-makunbound) - (:policy :fast-safe) - (:translate fdefn-makunbound) - (:args (fdefn :scs (descriptor-reg) :target result)) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:generator 38 - (storew null-tn fdefn fdefn-function-slot other-pointer-type) - (inst li (make-fixup "undefined_tramp" :foreign) temp) - (storew temp fdefn fdefn-raw-addr-slot other-pointer-type) - (move fdefn result))) - - - -;;;; Binding and Unbinding. - -;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and -;;; the symbol on the binding stack and stuff the new value into the -;;; symbol. - -(define-vop (bind) - (:args (val :scs (any-reg descriptor-reg)) - (symbol :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:generator 5 - (loadw temp symbol symbol-value-slot other-pointer-type) - (inst addi (* binding-size word-bytes) bsp-tn bsp-tn) - (storew temp bsp-tn (- binding-value-slot binding-size)) - (storew symbol bsp-tn (- binding-symbol-slot binding-size)) - (storew val symbol symbol-value-slot other-pointer-type))) - -(define-vop (unbind) - (:temporary (:scs (descriptor-reg)) symbol value) - (:generator 0 - (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) - (loadw value bsp-tn (- binding-value-slot binding-size)) - (storew value symbol symbol-value-slot other-pointer-type) - (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) - (inst addi (- (* binding-size word-bytes)) bsp-tn bsp-tn))) - -(define-vop (unbind-to-here) - (:args (where :scs (descriptor-reg any-reg))) - (:temporary (:scs (descriptor-reg)) symbol value) - (:generator 0 - (inst comb := where bsp-tn done :nullify t) - (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) - - LOOP - (inst comb := symbol zero-tn skip) - (loadw value bsp-tn (- binding-value-slot binding-size)) - (storew value symbol symbol-value-slot other-pointer-type) - (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) - - SKIP - (inst addi (* -2 word-bytes) bsp-tn bsp-tn) - (inst comb :<> where bsp-tn loop :nullify t) - (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) - - DONE)) - - - -;;;; Closure indexing. - -(define-full-reffer closure-index-ref * - closure-info-offset function-pointer-type - (descriptor-reg any-reg) * %closure-index-ref) - -(define-full-setter set-funcallable-instance-info * - funcallable-instance-info-offset function-pointer-type - (descriptor-reg any-reg) * %set-funcallable-instance-info) - - - -;;;; Structure hackery: - -(define-vop (structure-length) - (:policy :fast-safe) - (:translate structure-length) - (:args (struct :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 4 - (loadw res struct 0 structure-pointer-type) - (inst srl res type-bits res))) - -(define-vop (structure-ref slot-ref) - (:variant structure-slots-offset structure-pointer-type) - (:policy :fast-safe) - (:translate structure-ref) - (:arg-types structure (:constant index))) - -(define-vop (structure-set slot-set) - (:policy :fast-safe) - (:translate structure-set) - (:variant structure-slots-offset structure-pointer-type) - (:arg-types structure (:constant index) *)) - -(define-full-reffer structure-index-ref * structure-slots-offset - structure-pointer-type (descriptor-reg any-reg) * structure-ref) - -(define-full-setter structure-index-set * structure-slots-offset - structure-pointer-type (descriptor-reg any-reg) * structure-set) - - - -;;;; Code object frobbing. - -(define-full-reffer code-header-ref * 0 other-pointer-type - (descriptor-reg any-reg) * code-header-ref) - -(define-full-setter code-header-set * 0 other-pointer-type - (descriptor-reg any-reg) * code-header-set) diff --git a/compiler/hppa/char.lisp b/compiler/hppa/char.lisp deleted file mode 100644 index 537b4d6d24d171c480de8db31618953c3bf1fee6..0000000000000000000000000000000000000000 --- a/compiler/hppa/char.lisp +++ /dev/null @@ -1,137 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/char.lisp,v 1.1 1992/07/13 03:48:20 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the HPPA VM definition of character operations. -;;; -;;; Written by William Lott -;;; -(in-package "HPPA") - - -;;;; Moves and coercions: - -;;; Move a tagged char to an untagged representation. -;;; -(define-vop (move-to-base-char) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (base-char-reg))) - (:generator 1 - (inst srl x type-bits y))) -;;; -(define-move-vop move-to-base-char :move - (any-reg descriptor-reg) (base-char-reg)) - -;;; Move an untagged char to a tagged representation. -;;; -(define-vop (move-from-base-char) - (:args (x :scs (base-char-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:generator 1 - (inst sll x type-bits y) - (inst addi base-char-type y y))) -;;; -(define-move-vop move-from-base-char :move - (base-char-reg) (any-reg descriptor-reg)) - -;;; Move untagged base-char values. -;;; -(define-vop (base-char-move) - (:args (x :target y - :scs (base-char-reg) - :load-if (not (location= x y)))) - (:results (y :scs (base-char-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move x y))) -;;; -(define-move-vop base-char-move :move - (base-char-reg) (base-char-reg)) - - -;;; Move untagged base-char arguments/return-values. -;;; -(define-vop (move-base-char-argument) - (:args (x :target y - :scs (base-char-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y base-char-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (base-char-reg - (move x y)) - (base-char-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-base-char-argument :move-argument - (any-reg base-char-reg) (base-char-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char -;;; to a descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (base-char-reg) (any-reg descriptor-reg)) - - - -;;;; Other operations: - -(define-vop (char-code) - (:translate char-code) - (:policy :fast-safe) - (:args (ch :scs (base-char-reg) :target res)) - (:arg-types base-char) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 1 - (move ch res))) - -(define-vop (code-char) - (:translate code-char) - (:policy :fast-safe) - (:args (code :scs (unsigned-reg) :target res)) - (:arg-types positive-fixnum) - (:results (res :scs (base-char-reg))) - (:result-types base-char) - (:generator 1 - (move code res))) - - -;;; Comparison of base-chars. -;;; -(define-vop (base-char-compare) - (:args (x :scs (base-char-reg)) - (y :scs (base-char-reg))) - (:arg-types base-char base-char) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:note "inline comparison") - (:variant-vars cond) - (:generator 3 - (inst bc cond not-p x y target))) - -(define-vop (fast-char=/base-char base-char-compare) - (:translate char=) - (:variant :=)) - -(define-vop (fast-char</base-char base-char-compare) - (:translate char<) - (:variant :<<)) - -(define-vop (fast-char>/base-char base-char-compare) - (:translate char>) - (:variant :>>)) diff --git a/compiler/hppa/debug.lisp b/compiler/hppa/debug.lisp deleted file mode 100644 index 22eaaa9ebde86b973f21bd9b7f8eeef677bcfc5f..0000000000000000000000000000000000000000 --- a/compiler/hppa/debug.lisp +++ /dev/null @@ -1,138 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/debug.lisp,v 1.1 1992/07/13 03:48:21 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Compiler support for the new whizzy debugger. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - - -(define-vop (debug-cur-sp) - (:translate current-sp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move csp-tn res))) - -(define-vop (debug-cur-fp) - (:translate current-fp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move cfp-tn res))) - -(define-vop (read-control-stack) - (:translate stack-ref) - (:policy :fast-safe) - (:args (object :scs (sap-reg)) - (offset :scs (any-reg))) - (:arg-types system-area-pointer positive-fixnum) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 5 - (inst ldwx offset object result))) - -(define-vop (read-control-stack-c) - (:translate stack-ref) - (:policy :fast-safe) - (:args (object :scs (sap-reg))) - (:info offset) - (:arg-types system-area-pointer (:constant (signed-byte 12))) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 4 - (inst ldw (* offset word-bytes) object result))) - -(define-vop (write-control-stack) - (:translate %set-stack-ref) - (:policy :fast-safe) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (any-reg)) - (value :scs (descriptor-reg) :target result)) - (:arg-types system-area-pointer positive-fixnum *) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:temporary (:scs (sap-reg) :from (:argument 1)) sap) - (:generator 2 - (inst add object offset sap) - (inst stw value 0 sap) - (move value result))) - -(define-vop (write-control-stack-c) - (:translate %set-stack-ref) - (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (value :scs (descriptor-reg) :target result)) - (:info offset) - (:arg-types system-area-pointer (:constant (signed-byte 12)) *) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 1 - (inst stw value (* offset word-bytes) sap) - (move value result))) - -(define-vop (code-from-mumble) - (:policy :fast-safe) - (:args (thing :scs (descriptor-reg) :to :save)) - (:results (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:variant-vars lowtag) - (:generator 5 - (loadw temp thing 0 lowtag) - (inst srl temp type-bits temp) - (inst comb := zero-tn temp done) - (move null-tn code) - (inst sll temp (1- (integer-length word-bytes)) temp) - (unless (= lowtag other-pointer-type) - (inst addi (- lowtag vm:other-pointer-type) temp temp)) - (inst sub thing temp code) - DONE)) - -(define-vop (code-from-lra code-from-mumble) - (:translate lra-code-header) - (:variant other-pointer-type)) - -(define-vop (code-from-function code-from-mumble) - (:translate function-code-header) - (:variant function-pointer-type)) - -(define-vop (make-lisp-obj) - (:policy :fast-safe) - (:translate make-lisp-obj) - (:args (value :scs (unsigned-reg) :target result)) - (:arg-types unsigned-num) - (:results (result :scs (descriptor-reg))) - (:generator 1 - (move value result))) - -(define-vop (get-lisp-obj-address) - (:policy :fast-safe) - (:translate get-lisp-obj-address) - (:args (thing :scs (descriptor-reg) :target result)) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (move thing result))) - -(define-vop (function-word-offset) - (:policy :fast-safe) - (:translate function-word-offset) - (:args (fun :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 5 - (loadw res fun 0 function-pointer-type) - (inst srl res type-bits res))) diff --git a/compiler/hppa/float.lisp b/compiler/hppa/float.lisp deleted file mode 100644 index 5be45a69540c712a8044352f09fcb690993921d1..0000000000000000000000000000000000000000 --- a/compiler/hppa/float.lisp +++ /dev/null @@ -1,601 +0,0 @@ -;;; -*- Package: hppa -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/float.lisp,v 1.2 1992/07/14 03:45:04 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the floating point support for the HP-PA. -;;; -;;; Written by William Lott. -;;; - -(in-package "HPPA") - - -;;;; Move functions. - -(define-move-function (load-fp-zero 1) (vop x y) - ((fp-single-zero) (single-reg) - (fp-double-zero) (double-reg)) - (inst funop :copy x y)) - - -(define-move-function (load-float 1) (vop x y) - ((single-stack) (single-reg) - (double-stack) (double-reg)) - (let ((offset (* (tn-offset x) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst flds offset (current-nfp-tn vop) y)) - (t - (inst ldo offset zero-tn lip-tn) - (inst fldx lip-tn (current-nfp-tn vop) y))))) - -(define-move-function (store-float 1) (vop x y) - ((single-reg) (single-stack) - (double-reg) (double-stack)) - (let ((offset (* (tn-offset y) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst fsts x offset (current-nfp-tn vop))) - (t - (inst ldo offset zero-tn lip-tn) - (inst fstx x lip-tn (current-nfp-tn vop)))))) - - - -;;;; Move VOPs - -(define-vop (move-float) - (:args (x :scs (single-reg double-reg) - :target y - :load-if (not (location= x y)))) - (:results (y :scs (single-reg double-reg) - :load-if (not (location= x y)))) - (:note "float move") - (:generator 0 - (unless (location= y x) - (inst funop :copy x y)))) - -(define-move-vop move-float :move (single-reg) (single-reg)) -(define-move-vop move-float :move (double-reg) (double-reg)) - - -(define-vop (move-from-float) - (:args (x :to :save)) - (:results (y :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:variant-vars size type data) - (:note "float to pointer coercion") - (:generator 13 - (with-fixed-allocation (y ndescr type size)) - (inst fsts x (- (* data word-bytes) other-pointer-type) y))) - -(macrolet ((frob (name sc &rest args) - `(progn - (define-vop (,name move-from-float) - (:args (x :scs (,sc) :to :save)) - (:variant ,@args)) - (define-move-vop ,name :move (,sc) (descriptor-reg))))) - (frob move-from-single single-reg - single-float-size single-float-type single-float-value-slot) - (frob move-from-double double-reg - double-float-size double-float-type double-float-value-slot)) - -(define-vop (move-from-float) - (:args (x :scs (descriptor-reg))) - (:results (y)) - (:variant-vars offset) - (:note "pointer to float coercion") - (:generator 2 - (inst flds (- (* offset word-bytes) other-pointer-type) x y))) - -(macrolet ((frob (name sc offset) - `(progn - (define-vop (,name move-from-float) - (:results (y :scs (,sc))) - (:variant ,offset)) - (define-move-vop ,name :move (descriptor-reg) (,sc))))) - (frob move-to-single single-reg single-float-value-slot) - (frob move-to-double double-reg double-float-value-slot)) - - -(define-vop (move-float-argument) - (:args (x :scs (single-reg double-reg) :target y) - (nfp :scs (any-reg) - :load-if (not (sc-is y single-reg double-reg)))) - (:results (y)) - (:note "float argument move") - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:generator 1 - (sc-case y - ((single-reg double-reg) - (unless (location= x y) - (inst funop :copy x y))) - ((single-stack double-stack) - (let ((offset (* (tn-offset y) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst fsts x offset nfp)) - (t - (inst ldo offset zero-tn index) - (inst fstx x index nfp)))))))) - -(define-move-vop move-float-argument :move-argument - (single-reg descriptor-reg) (single-reg)) -(define-move-vop move-float-argument :move-argument - (double-reg descriptor-reg) (double-reg)) - - -(define-move-vop move-argument :move-argument - (single-reg double-reg) (descriptor-reg)) - - - -;;;; Arithmetic VOPs. - -(define-vop (float-op) - (:args (x) (y)) - (:results (r)) - (:variant-vars operation) - (:policy :fast-safe) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:node-var node) - (:generator 0 - (inst fbinop operation x y r) - (when (policy node (or (= debug 3) (> safety speed))) - (note-next-instruction vop :internal-error) - (inst fsts fp-single-zero-tn 0 csp-tn)))) - -(macrolet ((frob (name sc zero-sc ptype) - `(define-vop (,name float-op) - (:args (x :scs (,sc ,zero-sc)) - (y :scs (,sc ,zero-sc))) - (:results (r :scs (,sc))) - (:arg-types ,ptype ,ptype) - (:result-types ,ptype)))) - (frob single-float-op single-reg fp-single-zero single-float) - (frob double-float-op double-reg fp-double-zero double-float)) - -(macrolet ((frob (translate op sname scost dname dcost) - `(progn - (define-vop (,sname single-float-op) - (:translate ,translate) - (:variant ,op) - (:variant-cost ,scost)) - (define-vop (,dname double-float-op) - (:translate ,translate) - (:variant ,op) - (:variant-cost ,dcost))))) - (frob + :add +/single-float 2 +/double-float 2) - (frob - :sub -/single-float 2 -/double-float 2) - (frob * :mpy */single-float 4 */double-float 5) - (frob / :div //single-float 12 //double-float 19)) - - -(macrolet ((frob (name translate sc type inst) - `(define-vop (,name) - (:args (x :scs (,sc))) - (:results (y :scs (,sc))) - (:translate ,translate) - (:policy :fast-safe) - (:arg-types ,type) - (:result-types ,type) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:node-var node) - (:generator 1 - ,inst - (when (policy node (or (= debug 3) (> safety speed))) - (note-next-instruction vop :internal-error) - (inst fsts fp-single-zero-tn 0 csp-tn)))))) - (frob abs/single-float abs single-reg single-float - (inst funop :abs x y)) - (frob abs/double-float abs double-reg double-float - (inst funop :abs x y)) - (frob %negate/single-float %negate single-reg single-float - (inst fbinop :sub fp-single-zero-tn x y)) - (frob %negate/double-float %negate double-reg double-float - (inst fbinop :sub fp-double-zero-tn x y))) - - -;;;; Comparison: - -(define-vop (float-compare) - (:args (x) (y)) - (:conditional) - (:info target not-p) - (:variant-vars condition complement) - (:policy :fast-safe) - (:note "inline float comparison") - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - ;; This is the condition to nullify the branch, so it is inverted. - (inst fcmp (if not-p condition complement) x y) - (note-next-instruction vop :internal-error) - (inst ftest) - (inst b target :nullify t))) - -(macrolet ((frob (name sc zero-sc ptype) - `(define-vop (,name float-compare) - (:args (x :scs (,sc ,zero-sc)) - (y :scs (,sc ,zero-sc))) - (:arg-types ,ptype ,ptype)))) - (frob single-float-compare single-reg fp-single-zero single-float) - (frob double-float-compare double-reg fp-double-zero double-float)) - -(macrolet ((frob (translate condition complement sname dname) - `(progn - (define-vop (,sname single-float-compare) - (:translate ,translate) - (:variant ,condition ,complement)) - (define-vop (,dname double-float-compare) - (:translate ,translate) - (:variant ,condition ,complement))))) - (frob < #b01001 #b10101 </single-float </double-float) - (frob > #b10001 #b01101 >/single-float >/double-float) - (frob eql #b00101 #b11001 eql/single-float eql/double-float)) - - -;;;; Conversion: - -(macrolet ((frob (name translate from-sc from-type to-sc to-type) - `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (,to-sc))) - (:arg-types ,from-type) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:node-var node) - (:generator 2 - (inst fcnvff x y) - (when (policy node (or (= debug 3) (> safety speed))) - (note-next-instruction vop :internal-error) - (inst fsts fp-single-zero-tn 0 csp-tn)))))) - (frob %single-float/double-float %single-float - double-reg double-float - single-reg single-float) - (frob %double-float/single-float %double-float - single-reg single-float - double-reg double-float)) - -(macrolet ((frob (name translate to-sc to-type) - `(define-vop (,name) - (:args (x :scs (signed-reg) - :load-if (not (sc-is x signed-stack)) - :target stack-temp)) - (:arg-types signed-num) - (:results (y :scs (,to-sc))) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:node-var node) - (:temporary (:scs (signed-stack) :from (:argument 0)) - stack-temp) - (:temporary (:scs (single-reg) :to (:result 0) :target y) - fp-temp) - (:temporary (:scs (any-reg) :from (:argument 0) - :to (:result 0)) index) - (:generator 5 - (let* ((nfp (current-nfp-tn vop)) - (stack-tn - (sc-case x - (signed-stack - x) - (signed-reg - (storew x nfp (tn-offset stack-temp)) - stack-temp))) - (offset (* (tn-offset stack-tn) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst flds offset nfp fp-temp)) - (t - (inst ldo offset zero-tn index) - (inst fldx index nfp fp-temp))) - (inst fcnvxf fp-temp y) - (when (policy node (or (= debug 3) (> safety speed))) - (note-next-instruction vop :internal-error) - (inst fsts fp-single-zero-tn 0 csp-tn))))))) - (frob %single-float/signed %single-float - single-reg single-float) - (frob %double-float/signed %double-float - double-reg double-float)) - - -(macrolet ((frob (trans from-sc from-type inst note) - `(define-vop (,(symbolicate trans "/" from-type)) - (:args (x :scs (,from-sc) - :target fp-temp)) - (:results (y :scs (signed-reg) - :load-if (not (sc-is y signed-stack)))) - (:arg-types ,from-type) - (:result-types signed-num) - (:translate ,trans) - (:policy :fast-safe) - (:note ,note) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp) - (:temporary (:scs (signed-stack) :to (:result 0) :target y) - stack-temp) - (:temporary (:scs (any-reg) :from (:argument 0) - :to (:result 0)) index) - (:generator 3 - (let* ((nfp (current-nfp-tn vop)) - (stack-tn - (sc-case y - (signed-stack y) - (signed-reg stack-temp))) - (offset (* (tn-offset stack-tn) word-bytes))) - (inst ,inst x fp-temp) - (cond ((< offset (ash 1 4)) - (note-next-instruction vop :internal-error) - (inst fsts fp-temp offset nfp)) - (t - (inst ldo offset zero-tn index) - (note-next-instruction vop :internal-error) - (inst fstx fp-temp index nfp))) - (unless (eq y stack-tn) - (loadw y nfp (tn-offset stack-tn)))))))) - (frob %unary-round single-reg single-float fcnvfx "inline float round") - (frob %unary-round double-reg double-float fcnvfx "inline float round") - (frob %unary-truncate single-reg single-float fcnvfxt - "inline float truncate") - (frob %unary-truncate double-reg double-float fcnvfxt - "inline float truncate")) - - -(define-vop (make-single-float) - (:args (bits :scs (signed-reg) - :load-if (or (not (sc-is bits signed-stack)) - (sc-is res single-stack)) - :target res)) - (:results (res :scs (single-reg) - :load-if (not (sc-is bits single-stack)))) - (:arg-types signed-num) - (:result-types single-float) - (:translate make-single-float) - (:policy :fast-safe) - (:vop-var vop) - (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp) - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:generator 2 - (let ((nfp (current-nfp-tn vop))) - (sc-case bits - (signed-reg - (sc-case res - (single-reg - (let ((offset (* (tn-offset temp) word-bytes))) - (inst stw bits offset nfp) - (cond ((< offset (ash 1 4)) - (inst flds offset nfp res)) - (t - (inst ldo offset zero-tn index) - (inst fldx index nfp res))))) - (single-stack - (inst stw bits (* (tn-offset res) word-bytes) nfp)))) - (signed-stack - (sc-case res - (single-reg - (let ((offset (* (tn-offset bits) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst flds offset nfp res)) - (t - (inst ldo offset zero-tn index) - (inst fldx index nfp res))))))))))) - -(define-vop (make-double-float) - (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) - (:results (res :scs (double-reg) - :load-if (not (sc-is res double-stack)))) - (:arg-types signed-num unsigned-num) - (:result-types double-float) - (:translate make-double-float) - (:policy :fast-safe) - (:temporary (:scs (double-stack) :to (:result 0)) temp) - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:vop-var vop) - (:generator 2 - (let* ((nfp (current-nfp-tn vop)) - (stack-tn (sc-case res - (double-stack res) - (double-reg temp))) - (offset (* (tn-offset stack-tn) word-bytes))) - (inst stw hi-bits offset nfp) - (inst stw lo-bits (+ offset word-bytes) nfp) - (cond ((eq stack-tn res)) - ((< offset (ash 1 4)) - (inst flds offset nfp res)) - (t - (inst ldo offset zero-tn index) - (inst fldx index nfp res)))))) - - -(define-vop (single-float-bits) - (:args (float :scs (single-reg) - :load-if (not (sc-is float single-stack)))) - (:results (bits :scs (signed-reg) - :load-if (or (not (sc-is bits signed-stack)) - (sc-is float single-stack)))) - (:arg-types single-float) - (:result-types signed-num) - (:translate single-float-bits) - (:policy :fast-safe) - (:vop-var vop) - (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp) - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:generator 2 - (let ((nfp (current-nfp-tn vop))) - (sc-case float - (single-reg - (sc-case bits - (signed-reg - (let ((offset (* (tn-offset temp) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst fsts float offset nfp)) - (t - (inst ldo offset zero-tn index) - (inst fstx float index nfp))) - (inst ldw offset nfp bits))) - (signed-stack - (let ((offset (* (tn-offset bits) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst fsts float offset nfp)) - (t - (inst ldo offset zero-tn index) - (inst fstx float index nfp))))))) - (single-stack - (sc-case bits - (signed-reg - (inst ldw (* (tn-offset float) word-bytes) nfp bits)))))))) - -(define-vop (double-float-high-bits) - (:args (float :scs (double-reg) - :load-if (not (sc-is float double-stack)))) - (:results (hi-bits :scs (signed-reg) - :load-if (or (not (sc-is hi-bits signed-stack)) - (sc-is float double-stack)))) - (:arg-types double-float) - (:result-types signed-num) - (:translate double-float-high-bits) - (:policy :fast-safe) - (:vop-var vop) - (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp) - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:generator 2 - (let ((nfp (current-nfp-tn vop))) - (sc-case float - (double-reg - (sc-case hi-bits - (signed-reg - (let ((offset (* (tn-offset temp) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst fsts float offset nfp :side 0)) - (t - (inst ldo offset zero-tn index) - (inst fstx float index nfp :side 0))) - (inst ldw offset nfp hi-bits))) - (signed-stack - (let ((offset (* (tn-offset hi-bits) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst fsts float offset nfp :side 0)) - (t - (inst ldo offset zero-tn index) - (inst fstx float index nfp :side 0))))))) - (double-stack - (sc-case hi-bits - (signed-reg - (let ((offset (* (tn-offset float) word-bytes))) - (inst ldw offset nfp hi-bits))))))))) - -(define-vop (double-float-low-bits) - (:args (float :scs (double-reg) - :load-if (not (sc-is float double-stack)))) - (:results (lo-bits :scs (unsigned-reg) - :load-if (or (not (sc-is lo-bits unsigned-stack)) - (sc-is float double-stack)))) - (:arg-types double-float) - (:result-types unsigned-num) - (:translate double-float-low-bits) - (:policy :fast-safe) - (:vop-var vop) - (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp) - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:generator 2 - (let ((nfp (current-nfp-tn vop))) - (sc-case float - (double-reg - (sc-case lo-bits - (unsigned-reg - (let ((offset (* (tn-offset temp) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst fsts float offset nfp :side 1)) - (t - (inst ldo offset zero-tn index) - (inst fstx float index nfp :side 1))) - (inst ldw offset nfp lo-bits))) - (unsigned-stack - (let ((offset (* (tn-offset lo-bits) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst fsts float offset nfp :side 1)) - (t - (inst ldo offset zero-tn index) - (inst fstx float index nfp :side 1))))))) - (double-stack - (sc-case lo-bits - (unsigned-reg - (let ((offset (* (1+ (tn-offset float)) word-bytes))) - (inst ldw offset nfp lo-bits))))))))) - - - -;;;; 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) - :load-if (not (sc-is res unsigned-stack)))) - (:result-types unsigned-num) - (:translate floating-point-modes) - (:policy :fast-safe) - (:temporary (:scs (unsigned-stack) :to (:result 0)) temp) - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:vop-var vop) - (:generator 3 - (let* ((nfp (current-nfp-tn vop)) - (stack-tn (sc-case res - (unsigned-stack res) - (unsigned-reg temp))) - (offset (* (tn-offset stack-tn) word-bytes))) - (cond ((< offset (ash 1 4)) - (inst fsts fp-single-zero-tn offset nfp)) - (t - (inst ldo offset zero-tn index) - (inst fstx fp-single-zero-tn index nfp))) - (unless (eq stack-tn res) - (inst ldw offset nfp res))))) - -(define-vop (set-floating-point-modes) - (:args (new :scs (unsigned-reg) - :load-if (not (sc-is new unsigned-stack)))) - (:results (res :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:result-types unsigned-num) - (:translate (setf floating-point-modes)) - (:policy :fast-safe) - (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp) - (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index) - (:vop-var vop) - (:generator 3 - (let* ((nfp (current-nfp-tn vop)) - (stack-tn (sc-case new - (unsigned-stack new) - (unsigned-reg temp))) - (offset (* (tn-offset stack-tn) word-bytes))) - (unless (eq new stack-tn) - (inst stw new offset nfp)) - (cond ((< offset (ash 1 4)) - (inst flds offset nfp fp-single-zero-tn)) - (t - (inst ldo offset zero-tn index) - (inst fldx index nfp fp-single-zero-tn))) - (inst ldw offset nfp res)))) diff --git a/compiler/hppa/insts.lisp b/compiler/hppa/insts.lisp deleted file mode 100644 index e27ec83097123dda14876a6313d6a11e0a7e4851..0000000000000000000000000000000000000000 --- a/compiler/hppa/insts.lisp +++ /dev/null @@ -1,1544 +0,0 @@ -;;; -*- Package: hppa -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/insts.lisp,v 1.4 1992/10/23 19:26:30 hallgren Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the instruction set definition for the HP-PA. -;;; -;;; Written by William Lott. -;;; - -(in-package :hppa) - -(use-package :new-assem) - -(def-assembler-params - :scheduler-p nil) - - -;;;; Utility functions. - -(defun reg-tn-encoding (tn) - (declare (type tn tn) - (values (unsigned-byte 5))) - (sc-case tn - (null null-offset) - (zero zero-offset) - (t - (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) - (tn-offset tn)))) - -(defun fp-reg-tn-encoding (tn) - (declare (type tn tn) - (values (unsigned-byte 5) (member t nil))) - (sc-case tn - (fp-single-zero (values 0 nil)) - (single-reg (values (tn-offset tn) nil)) - (fp-double-zero (values 0 t)) - (double-reg (values (tn-offset tn) t)))) - -(defconstant compare-conditions - '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev)) - -(deftype compare-condition () - `(member nil ,@compare-conditions)) - -(defun compare-condition (cond) - (declare (type compare-condition cond) - (values (unsigned-byte 3) (member t nil))) - (if cond - (let ((result (or (position cond compare-conditions :test #'eq) - (error "Bogus Compare/Subtract condition: ~S" cond)))) - (values (ldb (byte 3 0) result) - (logbitp 3 result))) - (values 0 nil))) - -(defconstant add-conditions - '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev)) - -(deftype add-condition () - `(member nil ,@add-conditions)) - -(defun add-condition (cond) - (declare (type add-condition cond) - (values (unsigned-byte 3) (member t nil))) - (if cond - (let ((result (or (position cond add-conditions :test #'eq) - (error "Bogus Add condition: ~S" cond)))) - (values (ldb (byte 3 0) result) - (logbitp 3 result))) - (values 0 nil))) - -(defconstant logical-conditions - '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev)) - -(deftype logical-condition () - `(member nil ,@(remove nil logical-conditions))) - -(defun logical-condition (cond) - (declare (type logical-condition cond) - (values (unsigned-byte 3) (member t nil))) - (if cond - (let ((result (or (position cond logical-conditions :test #'eq) - (error "Bogus Logical condition: ~S" cond)))) - (values (ldb (byte 3 0) result) - (logbitp 3 result))) - (values 0 nil))) - -(defconstant unit-conditions - '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc)) - -(deftype unit-condition () - `(member nil ,@(remove nil unit-conditions))) - -(defun unit-condition (cond) - (declare (type unit-condition cond) - (values (unsigned-byte 3) (member t nil))) - (if cond - (let ((result (or (position cond unit-conditions :test #'eq) - (error "Bogus Unit condition: ~S" cond)))) - (values (ldb (byte 3 0) result) - (logbitp 3 result))) - (values 0 nil))) - -(defconstant extract/deposit-conditions - '(:never := :< :od :tr :<> :>= :ev)) - -(deftype extract/deposit-condition () - `(member nil ,@extract/deposit-conditions)) - -(defun extract/deposit-condition (cond) - (declare (type extract/deposit-condition cond) - (values (unsigned-byte 3) (member t nil))) - (if cond - (or (position cond extract/deposit-conditions :test #'eq) - (error "Bogus Extract/Deposit condition: ~S" cond)) - 0)) - - -(defun space-encoding (space) - (declare (type (unsigned-byte 3) space) - (values (unsigned-byte 3))) - (dpb (ldb (byte 2 0) space) - (byte 2 1) - (ldb (byte 1 2) space))) - - -;;;; Initial disassembler setup. - -(disassem:set-disassem-params :instruction-alignment 32) - -(defvar *disassem-use-lisp-reg-names* t) - -(defparameter reg-symbols - (map 'vector - #'(lambda (name) - (cond ((null name) nil) - (t (make-symbol (concatenate 'string "$" name))))) - *register-names*)) - -(disassem:define-argument-type reg - :printer #'(lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref reg-symbols value))) - (princ regname stream) - (disassem:maybe-note-associated-storage-ref - value - 'registers - regname - dstate)))) - -(defparameter float-reg-symbols - (coerce - (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n))) - 'vector)) - -(disassem:define-argument-type fp-reg - :printer #'(lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref float-reg-symbols value))) - (princ regname stream) - (disassem:maybe-note-associated-storage-ref - value - 'float-registers - regname - dstate)))) - -(disassem:define-argument-type fp-fmt-0c - :printer #'(lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (ecase value - (0 (format stream "~A" '\,SGL)) - (1 (format stream "~A" '\,DBL)) - (3 (format stream "~A" '\,QUAD))))) - -(defun low-sign-extend (x n) - (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x)))) - (if (logbitp 0 x) - (logior (ash -1 (1- n)) normal) - normal))) - -(defun sign-extend (x n) - (if (logbitp (1- n) x) - (logior (ash -1 (1- n)) x) - x)) - -(defun assemble-bits (x list) - (let ((result 0) - (offset 0)) - (dolist (e (reverse list)) - (setf result (logior result (ash (ldb e x) offset))) - (incf offset (byte-size e))) - result)) - -(defmacro define-imx-decode (name bits) - `(disassem:define-argument-type ,name - :printer #'(lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" (low-sign-extend value ,bits))))) - -(define-imx-decode im5 5) -(define-imx-decode im11 11) -(define-imx-decode im14 14) - -(disassem:define-argument-type im3 - :printer #'(lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" (assemble-bits value `(,(byte 1 0) - ,(byte 2 1)))))) - -(disassem:define-argument-type im21 - :printer #'(lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" - (assemble-bits value `(,(byte 1 0) ,(byte 11 1) - ,(byte 2 14) ,(byte 5 16) - ,(byte 2 12)))))) - -(disassem:define-argument-type cp - :printer #'(lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" (- 31 value)))) - -(disassem:define-argument-type clen - :printer #'(lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" (- 32 value)))) - -(disassem:define-argument-type compare-condition - :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>= - \,> \,>>= \,>> \,NSV \,EV)) - -(disassem:define-argument-type compare-condition-false - :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV - "" \,= \,< \,<= \,<< \,<<= \,SV \,OD)) - -(disassem:define-argument-type add-condition - :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV - \,VNZ \,NSV \,EV)) - -(disassem:define-argument-type add-condition-false - :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV - "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD)) - -(disassem:define-argument-type logical-condition - :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV)) - -(disassem:define-argument-type unit-condition - :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC - \,NBC \,NHC)) - -(disassem:define-argument-type extract/deposit-condition - :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV)) - -(disassem:define-argument-type extract/deposit-condition-false - :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD)) - -(disassem:define-argument-type nullify - :printer #("" \,N)) - -(disassem:define-argument-type fcmp-cond - :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?< - \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>= - \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE)) - -(disassem:define-argument-type integer - :printer #'(lambda (value stream dstate) - (declare (ignore dstate) (stream stream) (fixnum value)) - (format stream "~S" value))) - -(disassem:define-argument-type space - :printer #("" |1,| |2,| |3,|)) - - -;;;; Define-instruction-formats for disassembler. - -(disassem:define-instruction-format - (load/store 32) - (op :field (byte 6 26)) - (b :field (byte 5 21) :type 'reg) - (t/r :field (byte 5 16) :type 'reg) - (s :field (byte 2 14) :type 'space) - (im14 :field (byte 14 0) :type 'im14)) - -(defconstant cmplt-index-print '((:cond ((u :constant 1) '\,S)) - (:cond ((m :constant 1) '\,M)))) - -(defconstant cmplt-disp-print '((:cond ((m :constant 1) - (:cond ((s :constant 0) '\,MA) - (t '\,MB)))))) - -(defconstant cmplt-store-print '((:cond ((s :constant 0) '\,B) - (t '\,E)) - (:cond ((m :constant 1) '\,M)))) - -(disassem:define-instruction-format - (extended-load/store 32) - (op1 :field (byte 6 26) :value 3) - (b :field (byte 5 21) :type 'reg) - (x/im5/r :field (byte 5 16) :type 'reg) - (s :field (byte 2 14) :type 'space) - (u :field (byte 1 13)) - (op2 :field (byte 3 10)) - (ext4/c :field (byte 4 6)) - (m :field (byte 1 5)) - (t/im5 :field (byte 5 0) :type 'reg)) - -(disassem:define-instruction-format - (ldil 32 :default-printer '(:name :tab im21 "," t)) - (op :field (byte 6 26)) - (t :field (byte 5 21) :type 'reg) - (im21 :field (byte 21 0) :type 'im21)) - -(disassem:define-instruction-format - (branch17 32) - (op1 :field (byte 6 26)) - (t :field (byte 5 21) :type 'reg) - (w :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0)) - :use-label - #'(lambda (value dstate) - (declare (type disassem:disassem-state dstate) (list value)) - (let ((x (logior (ash (first value) 12) (ash (second value) 1) - (third value)))) - (+ (ash (sign-extend - (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1) - ,(byte 10 2))) 17) 2) - (disassem:dstate-cur-addr dstate) 8)))) - (op2 :field (byte 3 13)) - (n :field (byte 1 1) :type 'nullify)) - -(disassem:define-instruction-format - (branch12 32) - (op1 :field (byte 6 26)) - (r2 :field (byte 5 21) :type 'reg) - (r1 :field (byte 5 16) :type 'reg) - (w :fields `(,(byte 11 2) ,(byte 1 0)) - :use-label - #'(lambda (value dstate) - (declare (type disassem:disassem-state dstate) (list value)) - (let ((x (logior (ash (first value) 1) (second value)))) - (+ (ash (sign-extend - (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2))) - 12) 2) - (disassem:dstate-cur-addr dstate) 8)))) - (c :field (byte 3 13)) - (n :field (byte 1 1) :type 'nullify)) - -(disassem:define-instruction-format - (branch 32) - (op1 :field (byte 6 26)) - (t :field (byte 5 21) :type 'reg) - (x :field (byte 5 16) :type 'reg) - (op2 :field (byte 3 13)) - (x1 :field (byte 11 2)) - (n :field (byte 1 1) :type 'nullify) - (x2 :field (byte 1 0))) - -(disassem:define-instruction-format - (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t)) - (r3 :field (byte 6 26) :value 2) - (r2 :field (byte 5 21) :type 'reg) - (r1 :field (byte 5 16) :type 'reg) - (c :field (byte 3 13)) - (f :field (byte 1 12)) - (op :field (byte 7 5)) - (t :field (byte 5 0) :type 'reg)) - -(disassem:define-instruction-format - (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t)) - (op :field (byte 6 26)) - (r :field (byte 5 21) :type 'reg) - (t :field (byte 5 16) :type 'reg) - (c :field (byte 3 13)) - (f :field (byte 1 12)) - (o :field (byte 1 11)) - (im11 :field (byte 11 0) :type 'im11)) - -(disassem:define-instruction-format - (extract/deposit-inst 32) - (op1 :field (byte 6 26)) - (r2 :field (byte 5 21) :type 'reg) - (r1 :field (byte 5 16) :type 'reg) - (c :field (byte 3 13) :type 'extract/deposit-condition) - (op2 :field (byte 3 10)) - (cp :field (byte 5 5) :type 'cp) - (t/clen :field (byte 5 0) :type 'clen)) - -(disassem:define-instruction-format - (break 32 :default-printer '(:name :tab im13 "," im5)) - (op1 :field (byte 6 26) :value 0) - (im13 :field (byte 13 13)) - (q2 :field (byte 8 5) :value 0) - (im5 :field (byte 5 0))) - -(defun snarf-error-junk (sap offset &optional length-only) - (let* ((length (system:sap-ref-8 sap offset)) - (vector (make-array length :element-type '(unsigned-byte 8)))) - (declare (type system:system-area-pointer sap) - (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) - (cond (length-only - (values 0 (1+ length) nil nil)) - (t - (kernel:copy-from-system-area sap (* hppa:byte-bits (1+ offset)) - vector (* hppa:word-bits - hppa:vector-data-offset) - (* length hppa:byte-bits)) - (collect ((sc-offsets) - (lengths)) - (lengths 1) ; the length byte - (let* ((index 0) - (error-number (c::read-var-integer vector index))) - (lengths index) - (loop - (when (>= index length) - (return)) - (let ((old-index index)) - (sc-offsets (c::read-var-integer vector index)) - (lengths (- index old-index)))) - (values error-number - (1+ length) - (sc-offsets) - (lengths)))))))) - -(defun break-control (chunk inst stream dstate) - (declare (ignore inst)) - (flet ((nt (x) (if stream (disassem:note x dstate)))) - (case (break-im5 chunk dstate) - (#.vm:error-trap - (nt "Error trap") - (disassem:handle-break-args #'snarf-error-junk stream dstate)) - (#.vm:cerror-trap - (nt "Cerror trap") - (disassem:handle-break-args #'snarf-error-junk stream dstate)) - (#.vm:breakpoint-trap - (nt "Breakpoint trap")) - (#.vm:pending-interrupt-trap - (nt "Pending interrupt trap")) - (#.vm:halt-trap - (nt "Halt trap")) - (#.vm:function-end-breakpoint-trap - (nt "Function end breakpoint trap")) - ))) - -(disassem:define-instruction-format - (system-inst 32) - (op1 :field (byte 6 26) :value 0) - (r1 :field (byte 5 21) :type 'reg) - (r2 :field (byte 5 16) :type 'reg) - (s :field (byte 3 13)) - (op2 :field (byte 8 5)) - (r3 :field (byte 5 0) :type 'reg)) - -(disassem:define-instruction-format - (fp-load/store 32) - (op :field (byte 6 26)) - (b :field (byte 5 21) :type 'reg) - (x :field (byte 5 16) :type 'reg) - (s :field (byte 2 14) :type 'space) - (u :field (byte 1 13)) - (x1 :field (byte 1 12)) - (x2 :field (byte 2 10)) - (x3 :field (byte 1 9)) - (x4 :field (byte 3 6)) - (m :field (byte 1 5)) - (t :field (byte 5 0) :type 'fp-reg)) - -(disassem:define-instruction-format - (fp-class-0-inst 32) - (op1 :field (byte 6 26)) - (r :field (byte 5 21) :type 'fp-reg) - (x1 :field (byte 5 16) :type 'fp-reg) - (op2 :field (byte 3 13)) - (fmt :field (byte 2 11) :type 'fp-fmt-0c) - (x2 :field (byte 2 9)) - (x3 :field (byte 3 6)) - (x4 :field (byte 1 5)) - (t :field (byte 5 0) :type 'fp-reg)) - -(disassem:define-instruction-format - (fp-class-1-inst 32) - (op1 :field (byte 6 26)) - (r :field (byte 5 21) :type 'fp-reg) - (x1 :field (byte 4 17) :value 0) - (x2 :field (byte 2 15)) - (df :field (byte 2 13) :type 'fp-fmt-0c) - (sf :field (byte 2 11) :type 'fp-fmt-0c) - (x3 :field (byte 2 9) :value 1) - (x4 :field (byte 3 6) :value 0) - (x5 :field (byte 1 5) :value 0) - (t :field (byte 5 0) :type 'fp-reg)) - - - -;;;; Load and Store stuff. - -(define-emitter emit-load/store 32 - (byte 6 26) - (byte 5 21) - (byte 5 16) - (byte 2 14) - (byte 14 0)) - - -(defun im14-encoding (segment disp) - (declare (type (or fixup (signed-byte 14)))) - (cond ((fixup-p disp) - (note-fixup segment :load disp) - (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp)))) - 0) - (t - (dpb (ldb (byte 13 0) disp) - (byte 13 1) - (ldb (byte 1 13) disp))))) - -(eval-when (compile eval) - (defmacro define-load-inst (name opcode) - `(define-instruction ,name (segment disp base reg) - (:declare (type tn reg base) - (type (or fixup (signed-byte 14)) disp)) - (:printer load/store ((op ,opcode) (s 0)) - '(:name :tab im14 "(" s b ")," t/r)) - (:emitter - (emit-load/store segment ,opcode - (reg-tn-encoding base) (reg-tn-encoding reg) 0 - (im14-encoding segment disp))))) - (defmacro define-store-inst (name opcode) - `(define-instruction ,name (segment reg disp base) - (:declare (type tn reg base) - (type (or fixup (signed-byte 14)) disp)) - (:printer load/store ((op ,opcode) (s 0)) - '(:name :tab t/r "," im14 "(" s b ")")) - (:emitter - (emit-load/store segment ,opcode - (reg-tn-encoding base) (reg-tn-encoding reg) 0 - (im14-encoding segment disp)))))) - -(define-load-inst ldw #x12) -(define-load-inst ldh #x11) -(define-load-inst ldb #x10) -(define-load-inst ldwm #x13) - -(define-store-inst stw #x1A) -(define-store-inst sth #x19) -(define-store-inst stb #x18) -(define-store-inst stwm #x1B) - -(define-emitter emit-extended-load/store 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) - (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0)) - -(eval-when (compile eval) - (defmacro define-load-indexed-inst (name opcode) - `(define-instruction ,name (segment index base reg &key modify scale) - (:declare (type tn reg base index) - (type (member t nil) modify scale)) - (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg) - (op2 0)) - `(:name ,@cmplt-index-print :tab x/im5/r - "(" s b ")" t/im5)) - (:emitter - (emit-extended-load/store - segment #x03 (reg-tn-encoding base) (reg-tn-encoding index) - 0 (if scale 1 0) 0 ,opcode (if modify 1 0) - (reg-tn-encoding reg)))))) - -(define-load-indexed-inst ldwx 2) -(define-load-indexed-inst ldhx 1) -(define-load-indexed-inst ldbx 0) -(define-load-indexed-inst ldcwx 7) - -(defun short-disp-encoding (segment disp) - (declare (type (or fixup (signed-byte 5)) disp) - (values (unsigned-byte 5))) - (cond ((fixup-p disp) - (note-fixup segment :load-short disp) - (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp)))) - 0) - (t - (dpb (ldb (byte 4 0) disp) - (byte 4 1) - (ldb (byte 1 4) disp))))) - -(eval-when (compile eval) - (defmacro define-load-short-inst (name opcode) - `(define-instruction ,name (segment base disp reg &key modify) - (:declare (type tn base reg) - (type (or fixup (signed-byte 5)) disp) - (type (member :before :after nil) modify)) - (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5) - (op2 4)) - `(:name ,@cmplt-disp-print :tab x/im5/r - "(" s b ")" t/im5)) - (:emitter - (multiple-value-bind - (m a) - (ecase modify - ((nil) (values 0 0)) - (:after (values 1 0)) - (:before (values 1 1))) - (emit-extended-load/store segment #x03 (reg-tn-encoding base) - (short-disp-encoding segment disp) - 0 a 4 ,opcode m - (reg-tn-encoding reg)))))) - (defmacro define-store-short-inst (name opcode) - `(define-instruction ,name (segment reg base disp &key modify) - (:declare (type tn reg base) - (type (or fixup (signed-byte 5)) disp) - (type (member :before :after nil) modify)) - (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5) - (op2 4)) - `(:name ,@cmplt-disp-print :tab x/im5/r - "," t/im5 "(" s b ")")) - (:emitter - (multiple-value-bind - (m a) - (ecase modify - ((nil) (values 0 0)) - (:after (values 1 0)) - (:before (values 1 1))) - (emit-extended-load/store segment #x03 (reg-tn-encoding base) - (short-disp-encoding segment disp) - 0 a 4 ,opcode m - (reg-tn-encoding reg))))))) - -(define-load-short-inst ldws 2) -(define-load-short-inst ldhs 1) -(define-load-short-inst ldbs 0) -(define-load-short-inst ldcws 7) - -(define-store-short-inst stws 10) -(define-store-short-inst sths 9) -(define-store-short-inst stbs 8) - -(define-instruction stbys (segment reg base disp where &key modify) - (:declare (type tn reg base) - (type (signed-byte 5) disp) - (type (member :begin :end) where) - (type (member t nil) modify)) - (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4)) - `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")")) - (:emitter - (emit-extended-load/store segment #x03 (reg-tn-encoding base) - (reg-tn-encoding reg) 0 - (ecase where (:begin 0) (:end 1)) - 4 #xC (if modify 1 0) - (short-disp-encoding segment disp)))) - - -;;;; Immediate Instructions. - -(define-load-inst ldo #x0D) - -(define-emitter emit-ldil 32 - (byte 6 26) - (byte 5 21) - (byte 21 0)) - -(defun immed-21-encoding (segment value) - (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value) - (values (unsigned-byte 21))) - (cond ((fixup-p value) - (note-fixup segment :hi value) - (assert (or (null (fixup-offset value)) (zerop (fixup-offset value)))) - 0) - (t - (logior (ash (ldb (byte 5 2) value) 16) - (ash (ldb (byte 2 7) value) 14) - (ash (ldb (byte 2 0) value) 12) - (ash (ldb (byte 11 9) value) 1) - (ldb (byte 1 20) value))))) - -(define-instruction ldil (segment value reg) - (:declare (type tn reg) - (type (or (signed-byte 21) (unsigned-byte 21) fixup) value)) - (:printer ldil ((op #x08))) - (:emitter - (emit-ldil segment #x08 (reg-tn-encoding reg) - (immed-21-encoding segment value)))) - -(define-instruction addil (segment value reg) - (:declare (type tn reg) - (type (or (signed-byte 21) (unsigned-byte 21) fixup) value)) - (:printer ldil ((op #x0A))) - (:emitter - (emit-ldil segment #x0A (reg-tn-encoding reg) - (immed-21-encoding segment value)))) - - -;;;; Branch instructions. - -(define-emitter emit-branch 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) - (byte 11 2) (byte 1 1) (byte 1 0)) - -(defun label-relative-displacement (label posn &optional delta-if-after) - (declare (type label label) (type index posn) - (values integer)) - (ash (- (if delta-if-after - (label-position label posn delta-if-after) - (label-position label)) - (+ posn 8)) -2)) - -(defun decompose-branch-disp (segment disp) - (declare (type (or fixup (signed-byte 17)) disp)) - (cond ((fixup-p disp) - (note-fixup segment :branch disp) - (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp)))) - (values 0 0 0)) - (t - (values (ldb (byte 5 11) disp) - (dpb (ldb (byte 10 0) disp) - (byte 10 1) - (ldb (byte 1 10) disp)) - (ldb (byte 1 16) disp))))) - -(defun emit-relative-branch (segment opcode link sub-opcode target nullify) - (declare (type (unsigned-byte 6) opcode) - (type (unsigned-byte 5) link) - (type (unsigned-byte 1) sub-opcode) - (type label target) - (type (member t nil) nullify)) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (let ((disp (label-relative-displacement target posn))) - (assert (<= (- (ash 1 16)) disp (1- (ash 1 16)))) - (multiple-value-bind - (w1 w2 w) - (decompose-branch-disp segment disp) - (emit-branch segment opcode link w1 sub-opcode w2 - (if nullify 1 0) w)))))) - -(define-instruction b (segment target &key nullify) - (:declare (type label target) (type (member t nil) nullify)) - (:emitter - (emit-relative-branch segment #x3A 0 0 target nullify))) - -(define-instruction bl (segment target reg &key nullify) - (:declare (type tn reg) (type label target) (type (member t nil) nullify)) - (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t)) - (:emitter - (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify))) - -(define-instruction gateway (segment target reg &key nullify) - (:declare (type tn reg) (type label target) (type (member t nil) nullify)) - (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t)) - (:emitter - (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify))) - -;;; BLR is useless because we have no way to generate the offset. - -(define-instruction bv (segment base &key nullify offset) - (:declare (type tn base) - (type (member t nil) nullify) - (type (or tn null) offset)) - (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")")) - (:emitter - (emit-branch segment #x3A (reg-tn-encoding base) - (if offset (reg-tn-encoding offset) 0) - 6 0 (if nullify 1 0) 0))) - -(define-instruction be (segment disp space base &key nullify) - (:declare (type (or fixup (signed-byte 17)) disp) - (type tn base) - (type (unsigned-byte 3) space) - (type (member t nil) nullify)) - (:printer branch17 ((op1 #x38) (op2 nil :type 'im3)) - '(:name n :tab w "(" op2 "," t ")")) - (:emitter - (multiple-value-bind - (w1 w2 w) - (decompose-branch-disp segment disp) - (emit-branch segment #x38 (reg-tn-encoding base) w1 - (space-encoding space) w2 (if nullify 1 0) w)))) - -(define-instruction ble (segment disp space base &key nullify) - (:declare (type (or fixup (signed-byte 17)) disp) - (type tn base) - (type (unsigned-byte 3) space) - (type (member t nil) nullify)) - (:printer branch17 ((op1 #x39) (op2 nil :type 'im3)) - '(:name n :tab w "(" op2 "," t ")")) - (:emitter - (multiple-value-bind - (w1 w2 w) - (decompose-branch-disp segment disp) - (emit-branch segment #x39 (reg-tn-encoding base) w1 - (space-encoding space) w2 (if nullify 1 0) w)))) - -(defun emit-conditional-branch (segment opcode r2 r1 cond target nullify) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (let ((disp (label-relative-displacement target posn))) - (assert (<= (- (ash 1 11)) disp (1- (ash 1 11)))) - (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1) - (ldb (byte 1 10) disp))) - (w (ldb (byte 1 11) disp))) - (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w)))))) - -(defun im5-encoding (value) - (declare (type (signed-byte 5) value) - (values (unsigned-byte 5))) - (dpb (ldb (byte 4 0) value) - (byte 4 1) - (ldb (byte 1 4) value))) - -(eval-when (compile eval) - (defmacro define-branch-inst (r-name r-opcode i-name i-opcode cond-kind) - (let* ((conditional (symbolicate cond-kind "-CONDITION")) - (false-conditional (symbolicate conditional "-FALSE"))) - `(progn - (define-instruction ,r-name (segment cond r1 r2 target &key nullify) - (:declare (type ,conditional cond) - (type tn r1 r2) - (type label target) - (type (member t nil) nullify)) - (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional)) - '(:name c n :tab r1 "," r2 "," w)) - ,@(unless (= r-opcode #x32) - `((:printer branch12 ((op1 ,(+ 2 r-opcode)) - (c nil :type ',false-conditional)) - '(:name c n :tab r1 "," r2 "," w)))) - (:emitter - (multiple-value-bind - (cond-encoding false) - (,conditional cond) - (emit-conditional-branch - segment (if false ,(+ r-opcode 2) ,r-opcode) - (reg-tn-encoding r2) (reg-tn-encoding r1) - cond-encoding target nullify)))) - (define-instruction ,i-name (segment cond imm reg target &key nullify) - (:declare (type ,conditional cond) - (type (signed-byte 5) imm) - (type tn reg) - (type (member t nil) nullify)) - (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5) - (c nil :type ',conditional)) - '(:name c n :tab r1 "," r2 w)) - ,@(unless (= r-opcode #x32) - `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5) - (c nil :type ',false-conditional)) - '(:name c n :tab r1 "," r2 "," w)))) - (:emitter - (multiple-value-bind - (cond-encoding false) - (,conditional cond) - (emit-conditional-branch - segment (if false (+ ,i-opcode 2) ,i-opcode) - (reg-tn-encoding reg) (im5-encoding imm) - cond-encoding target nullify)))))))) - -(define-branch-inst movb #x32 movib #x33 extract/deposit) -(define-branch-inst comb #x20 comib #x21 compare) -(define-branch-inst addb #x28 addib #x29 add) - -(define-instruction bb (segment cond reg posn target &key nullify) - (:declare (type (member t nil) cond nullify) - (type tn reg) - (type (or (member :variable) (unsigned-byte 5)) posn)) - (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition)) - '('BVB c n :tab r1 "," w)) - (:emitter - (multiple-value-bind - (opcode posn-encoding) - (if (eq posn :variable) - (values #x30 0) - (values #x31 posn)) - (emit-conditional-branch segment opcode posn-encoding - (reg-tn-encoding reg) - (if cond 2 6) target nullify)))) - - -;;;; Computation Instructions - -(define-emitter emit-r3-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) - (byte 1 12) (byte 7 5) (byte 5 0)) - -(eval-when (compile eval) - (defmacro define-r3-inst (name cond-kind opcode) - `(define-instruction ,name (segment r1 r2 res &optional cond) - (:declare (type tn res r1 r2)) - (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate - cond-kind - "-CONDITION")))) - ,@(when (= opcode #x12) - `((:printer r3-inst ((op ,opcode) (r2 0) - (c nil :type ',(symbolicate cond-kind - "-CONDITION"))) - `('COPY :tab r1 "," t)))) - (:emitter - (multiple-value-bind - (cond false) - (,(symbolicate cond-kind "-CONDITION") cond) - (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1) - cond (if false 1 0) ,opcode - (reg-tn-encoding res))))))) - -(define-r3-inst add add #x30) -(define-r3-inst addl add #x50) -(define-r3-inst addo add #x70) -(define-r3-inst addc add #x38) -(define-r3-inst addco add #x78) -(define-r3-inst sh1add add #x32) -(define-r3-inst sh1addl add #x52) -(define-r3-inst sh1addo add #x72) -(define-r3-inst sh2add add #x34) -(define-r3-inst sh2addl add #x54) -(define-r3-inst sh2addo add #x74) -(define-r3-inst sh3add add #x36) -(define-r3-inst sh3addl add #x56) -(define-r3-inst sh3addo add #x76) -(define-r3-inst sub compare #x20) -(define-r3-inst subo compare #x60) -(define-r3-inst subb compare #x28) -(define-r3-inst subbo compare #x68) -(define-r3-inst subt compare #x26) -(define-r3-inst subto compare #x66) -(define-r3-inst ds compare #x22) -(define-r3-inst comclr compare #x44) -(define-r3-inst or logical #x12) -(define-r3-inst xor logical #x14) -(define-r3-inst and logical #x10) -(define-r3-inst andcm logical #x00) -(define-r3-inst uxor unit #x1C) -(define-r3-inst uaddcm unit #x4C) -(define-r3-inst uaddcmt unit #x4E) -(define-r3-inst dcor unit #x5C) -(define-r3-inst idcor unit #x5E) - -(define-emitter emit-imm-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) - (byte 1 12) (byte 1 11) (byte 11 0)) - -(defun im11-encoding (value) - (declare (type (signed-byte 11) value) - (values (unsigned-byte 11))) - (dpb (ldb (byte 10 0) value) - (byte 10 1) - (ldb (byte 1 10) value))) - -(eval-when (compile eval) - (defmacro define-imm-inst (name cond-kind opcode subcode) - `(define-instruction ,name (segment imm src dst &optional cond) - (:declare (type tn dst src) - (type (signed-byte 11) imm)) - (:printer imm-inst ((op ,opcode) (o ,subcode) - (c nil :type - ',(symbolicate cond-kind "-CONDITION")))) - (:emitter - (multiple-value-bind - (cond false) - (,(symbolicate cond-kind "-CONDITION") cond) - (emit-imm-inst segment ,opcode (reg-tn-encoding src) - (reg-tn-encoding dst) cond - (if false 1 0) ,subcode - (im11-encoding imm))))))) - -(define-imm-inst addi add #x2D 0) -(define-imm-inst addio add #x2D 1) -(define-imm-inst addit add #x2C 0) -(define-imm-inst addito add #x2C 1) -(define-imm-inst subi compare #x25 0) -(define-imm-inst subio compare #x25 1) -(define-imm-inst comiclr compare #x24 0) - -(define-emitter emit-extract/deposit-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) - (byte 3 10) (byte 5 5) (byte 5 0)) - -(define-instruction shd (segment r1 r2 count res &optional cond) - (:declare (type tn res r1 r2) - (type (or (member :variable) (integer 0 31)) count)) - (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg)) - '(:name c :tab r1 "," r2 "," cp "," t/clen)) - (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg)) - '('VSHD c :tab r1 "," r2 "," t/clen)) - (:emitter - (etypecase count - ((member :variable) - (emit-extract/deposit-inst segment #x34 - (reg-tn-encoding r2) (reg-tn-encoding r1) - (extract/deposit-condition cond) - 0 0 (reg-tn-encoding res))) - ((integer 0 31) - (emit-extract/deposit-inst segment #x34 - (reg-tn-encoding r2) (reg-tn-encoding r1) - (extract/deposit-condition cond) - 2 (- 31 count) - (reg-tn-encoding res)))))) - -(eval-when (compile eval) - (defmacro define-extract-inst (name opcode) - `(define-instruction ,name (segment src posn len res &optional cond) - (:declare (type tn res src) - (type (or (member :variable) (integer 0 31)) posn) - (type (integer 1 32) len)) - (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer) - (op2 ,opcode)) - '(:name c :tab r2 "," cp "," t/clen "," r1)) - (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2))) - '('V :name c :tab r2 "," t/clen "," r1)) - (:emitter - (etypecase posn - ((member :variable) - (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src) - (reg-tn-encoding res) - (extract/deposit-condition cond) - ,(- opcode 2) 0 (- 32 len))) - ((integer 0 31) - (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src) - (reg-tn-encoding res) - (extract/deposit-condition cond) - ,opcode posn (- 32 len)))))))) - -(define-extract-inst extru 6) -(define-extract-inst extrs 7) - -(eval-when (compile eval) - (defmacro define-deposit-inst (name opcode) - `(define-instruction ,name (segment src posn len res &optional cond) - (:declare (type tn res) - (type (or tn (signed-byte 5)) src) - (type (or (member :variable) (integer 0 31)) posn) - (type (integer 1 32) len)) - (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode)) - ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2))) - (if (= opcode 0) (cons ''Z base) base))) - (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode))) - ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2))) - (if (= opcode 0) (cons ''Z base) base))) - (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5) - (op2 ,(+ 4 opcode))) - ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2))) - (if (= opcode 0) (cons ''Z base) base))) - (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5) - (op2 ,(+ 6 opcode))) - ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2))) - (if (= opcode 0) (cons ''Z base) base))) - (:emitter - (multiple-value-bind - (opcode src-encoding) - (etypecase src - (tn - (values ,opcode (reg-tn-encoding src))) - ((signed-byte 5) - (values ,(+ opcode 4) (im5-encoding src)))) - (multiple-value-bind - (opcode posn-encoding) - (etypecase posn - ((member :variable) - (values opcode 0)) - ((integer 0 31) - (values (+ opcode 2) (- 31 posn)))) - (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res) - src-encoding - (extract/deposit-condition cond) - opcode posn-encoding (- 32 len)))))))) - -(define-deposit-inst dep 1) -(define-deposit-inst zdep 0) - - - -;;;; System Control Instructions. - -(define-emitter emit-break 32 - (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0)) - -(define-instruction break (segment &optional (im5 0) (im13 0)) - (:declare (type (unsigned-byte 13) im13) - (type (unsigned-byte 5) im5)) - (:printer break () :default :control #'break-control) - (:emitter - (emit-break segment 0 im13 0 im5))) - -(define-emitter emit-system-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0)) - -(define-instruction ldsid (segment res base &optional (space 0)) - (:declare (type tn res base) - (type (integer 0 3) space)) - (:printer system-inst ((op2 #x85) (c nil :type 'space) - (s nil :printer #(0 0 1 1 2 2 3 3))) - `(:name :tab "(" s r1 ")," r3)) - (:emitter - (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85 - (reg-tn-encoding res)))) - -(define-instruction mtsp (segment reg space) - (:declare (type tn reg) (type (integer 0 7) space)) - (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s)) - (:emitter - (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space) - #xC1 0))) - -(define-instruction mfsp (segment space reg) - (:declare (type tn reg) (type (integer 0 7) space)) - (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3)) - (:emitter - (emit-system-inst segment 0 0 0 (space-encoding space) #x25 - (reg-tn-encoding reg)))) - -(deftype control-reg () - '(or (unsigned-byte 5) (member :sar))) - -(defun control-reg (reg) - (declare (type control-reg reg) - (values (unsigned-byte 32))) - (if (typep reg '(unsigned-byte 5)) - reg - (ecase reg - (:sar 11)))) - -(define-instruction mtctl (segment reg ctrl-reg) - (:declare (type tn reg) (type control-reg ctrl-reg)) - (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1)) - (:emitter - (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg) - 0 #xC2 0))) - -(define-instruction mfctl (segment ctrl-reg reg) - (:declare (type tn reg) (type control-reg ctrl-reg)) - (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3)) - (:emitter - (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45 - (reg-tn-encoding reg)))) - - - -;;;; Floating point instructions. - -(define-emitter emit-fp-load/store 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12) - (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0)) - -(define-instruction fldx (segment index base result &key modify scale side) - (:declare (type tn index base result) - (type (member t nil) modify scale) - (type (member nil 0 1) side)) - (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0)) - `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t)) - (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0)) - `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t)) - (:emitter - (multiple-value-bind - (result-encoding double-p) - (fp-reg-tn-encoding result) - (when side - (assert double-p) - (setf double-p nil)) - (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) - (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0 - (or side 0) (if modify 1 0) result-encoding)))) - -(define-instruction fstx (segment value index base &key modify scale side) - (:declare (type tn index base value) - (type (member t nil) modify scale) - (type (member nil 0 1) side)) - (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1)) - `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")")) - (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1)) - `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")")) - (:emitter - (multiple-value-bind - (value-encoding double-p) - (fp-reg-tn-encoding value) - (when side - (assert double-p) - (setf double-p nil)) - (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) - (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1 - (or side 0) (if modify 1 0) value-encoding)))) - -(define-instruction flds (segment disp base result &key modify side) - (:declare (type tn base result) - (type (signed-byte 5) disp) - (type (member :before :after nil) modify) - (type (member nil 0 1) side)) - (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0)) - `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t)) - (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0)) - `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t)) - (:emitter - (multiple-value-bind - (result-encoding double-p) - (fp-reg-tn-encoding result) - (when side - (assert double-p) - (setf double-p nil)) - (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) - (short-disp-encoding segment disp) 0 - (if (eq modify :before) 1 0) 1 0 0 - (or side 0) (if modify 1 0) result-encoding)))) - -(define-instruction fsts (segment value disp base &key modify side) - (:declare (type tn base value) - (type (signed-byte 5) disp) - (type (member :before :after nil) modify) - (type (member nil 0 1) side)) - (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1)) - `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")")) - (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1)) - `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")")) - (:emitter - (multiple-value-bind - (value-encoding double-p) - (fp-reg-tn-encoding value) - (when side - (assert double-p) - (setf double-p nil)) - (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base) - (short-disp-encoding segment disp) 0 - (if (eq modify :before) 1 0) 1 0 1 - (or side 0) (if modify 1 0) value-encoding)))) - - -(define-emitter emit-fp-class-0-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9) - (byte 3 6) (byte 1 5) (byte 5 0)) - -(define-emitter emit-fp-class-1-inst 32 - (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11) - (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0)) - -;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need -;;; seperate emitters. - -(defconstant funops '(:copy :abs :sqrt :rnd)) - -(deftype funop () - `(member ,@funops)) - -(define-instruction funop (segment op from to) - (:declare (type funop op) - (type tn from to)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0)) - '('FCPY fmt :tab r "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0)) - '('FABS fmt :tab r "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0)) - '('FSQRT fmt :tab r "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0)) - '('FRND fmt :tab r "," t)) - (:emitter - (multiple-value-bind - (from-encoding from-double-p) - (fp-reg-tn-encoding from) - (multiple-value-bind - (to-encoding to-double-p) - (fp-reg-tn-encoding to) - (assert (eq from-double-p to-double-p)) - (emit-fp-class-0-inst segment #x0C from-encoding 0 - (+ 2 (position op funops)) - (if to-double-p 1 0) 0 0 0 to-encoding))))) - -(eval-when (compile eval) - (defmacro define-class-1-fp-inst (name subcode) - `(define-instruction ,name (segment from to) - (:declare (type tn from to)) - (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode)) - '(:name sf df :tab r "," t)) - (:emitter - (multiple-value-bind - (from-encoding from-double-p) - (fp-reg-tn-encoding from) - (multiple-value-bind - (to-encoding to-double-p) - (fp-reg-tn-encoding to) - (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode - (if to-double-p 1 0) (if from-double-p 1 0) - 1 0 0 to-encoding))))))) - -(define-class-1-fp-inst fcnvff 0) -(define-class-1-fp-inst fcnvxf 1) -(define-class-1-fp-inst fcnvfx 2) -(define-class-1-fp-inst fcnvfxt 3) - -(define-instruction fcmp (segment cond r1 r2) - (:declare (type (unsigned-byte 5) cond) - (type tn r1 r2)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond)) - '(:name fmt t :tab r "," x1)) - (:emitter - (multiple-value-bind - (r1-encoding r1-double-p) - (fp-reg-tn-encoding r1) - (multiple-value-bind - (r2-encoding r2-double-p) - (fp-reg-tn-encoding r2) - (assert (eq r1-double-p r2-double-p)) - (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0 - (if r1-double-p 1 0) 2 0 0 cond))))) - -(define-instruction ftest (segment) - (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name)) - (:emitter - (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0))) - -(defconstant fbinops '(:add :sub :mpy :div)) - -(deftype fbinop () - `(member ,@fbinops)) - -(define-instruction fbinop (segment op r1 r2 result) - (:declare (type fbinop op) - (type tn r1 r2 result)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3)) - '('FADD fmt :tab r "," x1 "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3)) - '('FSUB fmt :tab r "," x1 "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3)) - '('FMPY fmt :tab r "," x1 "," t)) - (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3)) - '('FDIV fmt :tab r "," x1 "," t)) - (:emitter - (multiple-value-bind - (r1-encoding r1-double-p) - (fp-reg-tn-encoding r1) - (multiple-value-bind - (r2-encoding r2-double-p) - (fp-reg-tn-encoding r2) - (assert (eq r1-double-p r2-double-p)) - (multiple-value-bind - (result-encoding result-double-p) - (fp-reg-tn-encoding result) - (assert (eq r1-double-p result-double-p)) - (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding - (position op fbinops) - (if r1-double-p 1 0) 3 0 0 - result-encoding)))))) - - - -;;;; Instructions built out of other insts. - -(define-instruction-macro move (src dst &optional cond) - `(inst or ,src zero-tn ,dst ,cond)) - -(define-instruction-macro nop (&optional cond) - `(inst or zero-tn zero-tn zero-tn ,cond)) - -(define-instruction li (segment value reg) - (:declare (type tn reg) - (type (or fixup (signed-byte 32) (unsigned-byte 32)) value)) - (:vop-var vop) - (:emitter - (assemble (segment vop) - (etypecase value - (fixup - (inst ldil value reg) - (inst ldo value reg reg)) - ((signed-byte 14) - (inst ldo value zero-tn reg)) - ((or (signed-byte 32) (unsigned-byte 32)) - (let ((hi (ldb (byte 21 11) value)) - (lo (ldb (byte 11 0) value))) - (inst ldil hi reg) - (unless (zerop lo) - (inst ldo lo reg reg)))))))) - -(define-instruction-macro sll (src count result &optional cond) - (once-only ((result result) (src src) (count count) (cond cond)) - `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond))) - -(define-instruction-macro sra (src count result &optional cond) - (once-only ((result result) (src src) (count count) (cond cond)) - `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond))) - -(define-instruction-macro srl (src count result &optional cond) - (once-only ((result result) (src src) (count count) (cond cond)) - `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond))) - -(defun maybe-negate-cond (cond negate) - (if negate - (multiple-value-bind - (value negate) - (compare-condition cond) - (if negate - (nth value compare-conditions) - (nth (+ value 8) compare-conditions))) - cond)) - -(define-instruction bc (segment cond not-p r1 r2 target) - (:declare (type compare-condition cond) - (type (member t nil) not-p) - (type tn r1 r2) - (type label target)) - (:vop-var vop) - (:emitter - (emit-chooser segment 8 2 - #'(lambda (segment posn delta) - (let ((disp (label-relative-displacement target posn delta))) - (when (<= 0 disp (1- (ash 1 11))) - (assemble (segment vop) - (inst comb (maybe-negate-cond cond not-p) r1 r2 target - :nullify t)) - t))) - #'(lambda (segment posn) - (let ((disp (label-relative-displacement target posn))) - (assemble (segment vop) - (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11))) - (inst comb (maybe-negate-cond cond not-p) r1 r2 target) - (inst nop)) - (t - (inst comclr r1 r2 zero-tn - (maybe-negate-cond cond (not not-p))) - (inst b target :nullify t))))))))) - -(define-instruction bci (segment cond not-p imm reg target) - (:declare (type compare-condition cond) - (type (member t nil) not-p) - (type (signed-byte 11) imm) - (type tn reg) - (type label target)) - (:vop-var vop) - (:emitter - (emit-chooser segment 8 2 - #'(lambda (segment posn delta-if-after) - (let ((disp (label-relative-displacement target posn delta-if-after))) - (when (and (<= 0 disp (1- (ash 1 11))) - (<= (- (ash 1 4)) imm (1- (ash 1 4)))) - (assemble (segment vop) - (inst comib (maybe-negate-cond cond not-p) imm reg target - :nullify t)) - t))) - #'(lambda (segment posn) - (let ((disp (label-relative-displacement target posn))) - (assemble (segment vop) - (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11))) - (<= (- (ash 1 4)) imm (1- (ash 1 4)))) - (inst comib (maybe-negate-cond cond not-p) imm reg target) - (inst nop)) - (t - (inst comiclr imm reg zero-tn - (maybe-negate-cond cond (not not-p))) - (inst b target :nullify t))))))))) - - -;;;; Instructions to convert between code ptrs, functions, and lras. - -(defun emit-compute-inst (segment vop src label temp dst calc) - (emit-chooser - ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments. - segment 12 3 - #'(lambda (segment posn delta-if-after) - (let ((delta (funcall calc label posn delta-if-after))) - (when (<= (- (ash 1 10)) delta (1- (ash 1 10))) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (assemble (segment vop) - (inst addi (funcall calc label posn 0) src - dst)))) - t))) - #'(lambda (segment posn) - (let ((delta (funcall calc label posn 0))) - ;; Note: if we used addil/ldo to do this in 2 instructions then the - ;; intermediate value would be tagged but pointing into space. - (assemble (segment vop) - (inst ldil (ldb (byte 21 11) delta) temp) - (inst ldo (ldb (byte 11 0) delta) temp temp) - (inst add src temp dst)))))) - -;; code = fn - header - label-offset + other-pointer-tag -(define-instruction compute-code-from-fn (segment src label temp dst) - (:declare (type tn src dst temp) - (type label label)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop src label temp dst - #'(lambda (label posn delta-if-after) - (- other-pointer-type - (label-position label posn delta-if-after) - (component-header-length)))))) - -;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag -(define-instruction compute-code-from-lra (segment src label temp dst) - (:declare (type tn src dst temp) - (type label label)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop src label temp dst - #'(lambda (label posn delta-if-after) - (- (+ (label-position label posn delta-if-after) - (component-header-length))))))) - -;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag -(define-instruction compute-lra-from-code (segment src label temp dst) - (:declare (type tn src dst temp) - (type label label)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop src label temp dst - #'(lambda (label posn delta-if-after) - (+ (label-position label posn delta-if-after) - (component-header-length)))))) - - -;;;; Data instructions. - -(define-instruction byte (segment byte) - (:emitter - (emit-byte segment byte))) - -(define-emitter emit-halfword 16 - (byte 16 0)) - -(define-instruction halfword (segment halfword) - (:emitter - (emit-halfword segment halfword))) - -(define-emitter emit-word 32 - (byte 32 0)) - -(define-instruction word (segment word) - (:emitter - (emit-word segment word))) - -(define-instruction function-header-word (segment) - (:emitter - (emit-back-patch - segment 4 - #'(lambda (segment posn) - (emit-word segment - (logior function-header-type - (ash (+ posn (component-header-length)) - (- type-bits word-shift)))))))) - -(define-instruction lra-header-word (segment) - (:emitter - (emit-back-patch - segment 4 - #'(lambda (segment posn) - (emit-word segment - (logior return-pc-header-type - (ash (+ posn (component-header-length)) - (- type-bits word-shift)))))))) diff --git a/compiler/hppa/macros.lisp b/compiler/hppa/macros.lisp deleted file mode 100644 index ad0a2dfbb6e05cdcfa6582ac85467b38c0d9bdb7..0000000000000000000000000000000000000000 --- a/compiler/hppa/macros.lisp +++ /dev/null @@ -1,401 +0,0 @@ -;;; -*- Package: hppa -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/macros.lisp,v 1.2 1992/10/13 13:18:20 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains various useful macros for generating HP-PA code. -;;; -;;; Written by William Lott. -;;; - -(in-package :hppa) - - -;;; Instruction-like macros. - -(defmacro move (src dst) - "Move SRC into DST unless they are location=." - (once-only ((src src) (dst dst)) - `(unless (location= ,src ,dst) - (inst move ,src ,dst)))) - -(defmacro loadw (result base &optional (offset 0) (lowtag 0)) - (once-only ((result result) (base base)) - `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result))) - -(defmacro storew (value base &optional (offset 0) (lowtag 0)) - (once-only ((value value) (base base) (offset offset) (lowtag lowtag)) - `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base))) - -(defmacro load-symbol (reg symbol) - (once-only ((reg reg) (symbol symbol)) - `(inst addi (static-symbol-offset ,symbol) null-tn ,reg))) - -(defmacro load-symbol-value (reg symbol) - `(inst ldw - (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-type)) - null-tn - ,reg)) - -(defmacro store-symbol-value (reg symbol) - `(inst stw ,reg (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-type)) - null-tn)) - -(defmacro load-type (target source &optional (offset 0)) - "Loads the type bits of a pointer into target independent of - byte-ordering issues." - (ecase (backend-byte-order *target-backend*) - (:little-endian - `(inst ldb ,offset ,source ,target)) - (:big-endian - `(inst ldb (+ ,offset 3) ,source ,target)))) - -;;; Macros to handle the fact that we cannot use the machine native call and -;;; return instructions. - -(defmacro lisp-jump (function) - "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." - `(progn - (inst addi - (- (ash function-header-code-offset word-shift) - function-pointer-type) - ,function - lip-tn) - (inst bv lip-tn) - (move ,function code-tn))) - -(defmacro lisp-return (return-pc &key (offset 0) (frob-code t)) - "Return to RETURN-PC." - `(progn - (inst addi (- (* (1+ ,offset) word-bytes) other-pointer-type) - ,return-pc lip-tn) - (inst bv lip-tn ,@(unless frob-code '(:nullify t))) - ,@(when frob-code - `((move ,return-pc code-tn))))) - -(defmacro emit-return-pc (label) - "Emit a return-pc header word. LABEL is the label to use for this - return-pc." - `(progn - (align lowtag-bits) - (emit-label ,label) - (inst lra-header-word))) - - -;;;; Stack TN's - -;;; Load-Stack-TN, Store-Stack-TN -- Interface -;;; -;;; Move a stack TN to a register and vice-versa. -;;; -(defmacro load-stack-tn (reg stack) - `(let ((reg ,reg) - (stack ,stack)) - (let ((offset (tn-offset stack))) - (sc-case stack - ((control-stack) - (loadw reg cfp-tn offset)))))) - -(defmacro store-stack-tn (stack reg) - `(let ((stack ,stack) - (reg ,reg)) - (let ((offset (tn-offset stack))) - (sc-case stack - ((control-stack) - (storew reg cfp-tn offset)))))) - - -;;; MAYBE-LOAD-STACK-TN -- Interface -;;; -(defmacro maybe-load-stack-tn (reg reg-or-stack) - "Move the TN Reg-Or-Stack into Reg if it isn't already there." - (once-only ((n-reg reg) - (n-stack reg-or-stack)) - `(sc-case ,n-reg - ((any-reg descriptor-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg) - (move ,n-stack ,n-reg)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) - - -;;;; Storage allocation: - -(defmacro with-fixed-allocation ((result-tn temp-tn type-code size) - &body body) - "Do stuff to allocate an other-pointer object of fixed Size with a single - word header having the specified Type-Code. The result is placed in - Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used - by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably - initializes the object." - (once-only ((result-tn result-tn) (temp-tn temp-tn) - (type-code type-code) (size size)) - `(pseudo-atomic (:extra (pad-data-block ,size)) - (inst move alloc-tn ,result-tn) - (inst dep other-pointer-type 31 3 ,result-tn) - (inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn) - (storew ,temp-tn ,result-tn 0 other-pointer-type) - ,@body))) - - -;;;; Error Code - -(defvar *adjustable-vectors* nil) - -(defmacro with-adjustable-vector ((var) &rest body) - `(let ((,var (or (pop *adjustable-vectors*) - (make-array 16 - :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t)))) - (setf (fill-pointer ,var) 0) - (unwind-protect - (progn - ,@body) - (push ,var *adjustable-vectors*)))) - -(eval-when (compile load eval) - (defun emit-error-break (vop kind code values) - (let ((vector (gensym))) - `((let ((vop ,vop)) - (when vop - (note-this-location vop :internal-error))) - (inst break ,kind) - (with-adjustable-vector (,vector) - (write-var-integer (error-number-or-lose ',code) ,vector) - ,@(mapcar #'(lambda (tn) - `(let ((tn ,tn)) - (write-var-integer (make-sc-offset (sc-number - (tn-sc tn)) - (tn-offset tn)) - ,vector))) - values) - (inst byte (length ,vector)) - (dotimes (i (length ,vector)) - (inst byte (aref ,vector i)))) - (align word-shift))))) - -(defmacro error-call (vop error-code &rest values) - "Cause an error. ERROR-CODE is the error to cause." - (cons 'progn - (emit-error-break vop error-trap error-code values))) - - -(defmacro cerror-call (vop label error-code &rest values) - "Cause a continuable error. If the error is continued, execution resumes at - LABEL." - `(progn - (inst b ,label) - ,@(emit-error-break vop cerror-trap error-code values))) - -(defmacro generate-error-code (vop error-code &rest values) - "Generate-Error-Code Error-code Value* - Emit code for an error with the specified Error-Code and context Values." - `(assemble (*elsewhere*) - (let ((start-lab (gen-label))) - (emit-label start-lab) - (error-call ,vop ,error-code ,@values) - start-lab))) - -(defmacro generate-cerror-code (vop error-code &rest values) - "Generate-CError-Code Error-code Value* - Emit code for a continuable error with the specified Error-Code and - context Values. If the error is continued, execution resumes after - the GENERATE-CERROR-CODE form." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) - `(let ((,continue (gen-label))) - (emit-label ,continue) - (assemble (*elsewhere*) - (let ((,error (gen-label))) - (emit-label ,error) - (cerror-call ,vop ,continue ,error-code ,@values) - ,error))))) - - - -;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. -;;; -(defmacro pseudo-atomic ((&key (extra 0)) &rest forms) - (let ((n-extra (gensym))) - `(let ((,n-extra ,extra)) - (inst addi 4 alloc-tn alloc-tn) - ,@forms - (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od)))) - - - -;;;; Indexed references: - -(deftype load/store-index (scale lowtag min-offset - &optional (max-offset min-offset)) - `(integer ,(- (truncate (+ (ash 1 14) - (* min-offset word-bytes) - (- lowtag)) - scale)) - ,(truncate (- (+ (1- (ash 1 14)) lowtag) - (* max-offset word-bytes)) - scale))) - -(defmacro define-full-reffer (name type offset lowtag scs el-type - &optional translate) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (any-reg) :target temp)) - (:arg-types ,type tagged-num) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst addi (- (* ,offset word-bytes) ,lowtag) index temp) - (inst ldwx temp object value))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,word-bytes ,(eval lowtag) - ,(eval offset)))) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 4 - (inst ldw (- (* (+ ,offset index) word-bytes) ,lowtag) - object value))))) - -(defmacro define-full-setter (name type offset lowtag scs el-type - &optional translate) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs ,scs :target result)) - (:arg-types ,type tagged-num ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 2 - (inst add object index lip) - (inst stw value (- (* ,offset word-bytes) ,lowtag) lip) - (move value result))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs ,scs)) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,word-bytes ,(eval lowtag) - ,(eval offset))) - ,el-type) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 1 - (inst stw value (- (* (+ ,offset index) word-bytes) ,lowtag) object) - (move value result))))) - - -(defmacro define-partial-reffer (name type size signed offset lowtag scs - el-type &optional translate) - (let ((scale (ecase size (:byte 1) (:short 2)))) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:generator 5 - (inst ,(ecase size (:byte 'add) (:short 'sh1add)) - index object lip) - (inst ,(ecase size (:byte 'ldb) (:short 'ldh)) - (- (* ,offset word-bytes) ,lowtag) lip value) - ,@(when signed - `((inst extrs value 31 ,(* scale byte-bits) value))))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset)))) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst ,(ecase size (:byte 'ldb) (:short 'ldh)) - (- (+ (* ,offset word-bytes) (* index ,scale)) ,lowtag) - object value) - ,@(when signed - `((inst extrs value 31 ,(* scale byte-bits) value)))))))) - -(defmacro define-partial-setter (name type size offset lowtag scs el-type - &optional translate) - (let ((scale (ecase size (:byte 1) (:short 2)))) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg)) - (value :scs ,scs :target result)) - (:arg-types ,type positive-fixnum ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst ,(ecase size (:byte 'add) (:short 'sh1add)) - index object lip) - (inst ,(ecase size (:byte 'stb) (:short 'sth)) - value (- (* ,offset word-bytes) ,lowtag) lip) - (move value result))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs ,scs :target result)) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset))) - ,el-type) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst ,(ecase size (:byte 'stb) (:short 'sth)) - value - (- (+ (* ,offset word-bytes) (* index ,scale)) ,lowtag) - object) - (move value result)))))) - diff --git a/compiler/hppa/memory.lisp b/compiler/hppa/memory.lisp deleted file mode 100644 index de1eadf77b36762c2b91d7db60a8ca8c6be3d154..0000000000000000000000000000000000000000 --- a/compiler/hppa/memory.lisp +++ /dev/null @@ -1,106 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/memory.lisp,v 1.1 1992/07/13 03:48:26 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the HPPA definitions of some general purpose memory -;;; reference VOPs inherited by basic memory reference operations. -;;; -;;; Written by William Lott. -;;; - -(in-package "HPPA") - -;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to -;;; be read or written is a property of the VOP used. Cell-Setf is similar to -;;; Cell-Set, but delivers the new value as the result. Cell-Setf-Function -;;; takes its arguments as if it were a setf function (new value first, as -;;; apposed to a setf macro, which takes the new value last). -;;; -(define-vop (cell-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (loadw value object offset lowtag))) -;;; -(define-vop (cell-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 1 - (storew value object offset lowtag))) -;;; -(define-vop (cell-setf) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg) - :target result)) - (:results (result :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 1 - (storew value object offset lowtag) - (move value result))) -;;; -(define-vop (cell-setf-function) - (:args (value :scs (descriptor-reg any-reg) - :target result) - (object :scs (descriptor-reg))) - (:results (result :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 1 - (storew value object offset lowtag) - (move value result))) - -;;; Define-Cell-Accessors -- Interface -;;; -;;; Define accessor VOPs for some cells in an object. If the operation name -;;; is NIL, then that operation isn't defined. If the translate function is -;;; null, then we don't define a translation. -;;; -(defmacro define-cell-accessors (offset lowtag - ref-op ref-trans set-op set-trans) - `(progn - ,@(when ref-op - `((define-vop (,ref-op cell-ref) - (:variant ,offset ,lowtag) - ,@(when ref-trans - `((:translate ,ref-trans)))))) - ,@(when set-op - `((define-vop (,set-op cell-setf) - (:variant ,offset ,lowtag) - ,@(when set-trans - `((:translate ,set-trans)))))))) - - -;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the -;;; offset is constant at compile time, but varies for different uses. We add -;;; in the stardard g-vector overhead. -;;; -(define-vop (slot-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:variant-vars base lowtag) - (:info offset) - (:generator 4 - (loadw value object (+ base offset) lowtag))) -;;; -(define-vop (slot-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:variant-vars base lowtag) - (:info offset) - (:generator 1 - (storew value object (+ base offset) lowtag))) - diff --git a/compiler/hppa/move.lisp b/compiler/hppa/move.lisp deleted file mode 100644 index a6cb098f0f209e3dcda3ddae32f50c81a2372cd9..0000000000000000000000000000000000000000 --- a/compiler/hppa/move.lisp +++ /dev/null @@ -1,309 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/move.lisp,v 1.1 1992/07/13 03:48:27 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the HPPA VM definition of operand loading/saving and -;;; the Move VOP. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - - -(define-move-function (load-immediate 1) (vop x y) - ((null zero immediate) - (any-reg descriptor-reg)) - (let ((val (tn-value x))) - (etypecase val - (integer - (inst li (fixnum val) y)) - (null - (move null-tn y)) - (symbol - (load-symbol y val)) - (character - (inst li (logior (ash (char-code val) type-bits) - base-char-type) - y))))) - -(define-move-function (load-number 1) (vop x y) - ((immediate zero) - (signed-reg unsigned-reg)) - (let ((x (tn-value x))) - (inst li (if (>= x (ash 1 31)) (logior (ash -1 32) x) x) y))) - -(define-move-function (load-base-char 1) (vop x y) - ((immediate) (base-char-reg)) - (inst li (char-code (tn-value x)) y)) - -(define-move-function (load-system-area-pointer 1) (vop x y) - ((immediate) (sap-reg)) - (inst li (sap-int (tn-value x)) y)) - -(define-move-function (load-constant 5) (vop x y) - ((constant) (descriptor-reg)) - (loadw y code-tn (tn-offset x) other-pointer-type)) - -(define-move-function (load-stack 5) (vop x y) - ((control-stack) (any-reg descriptor-reg)) - (load-stack-tn y x)) - -(define-move-function (load-number-stack 5) (vop x y) - ((base-char-stack) (base-char-reg) - (sap-stack) (sap-reg) - (signed-stack) (signed-reg) - (unsigned-stack) (unsigned-reg)) - (let ((nfp (current-nfp-tn vop))) - (loadw y nfp (tn-offset x)))) - -(define-move-function (store-stack 5) (vop x y) - ((any-reg descriptor-reg) (control-stack)) - (store-stack-tn y x)) - -(define-move-function (store-number-stack 5) (vop x y) - ((base-char-reg) (base-char-stack) - (sap-reg) (sap-stack) - (signed-reg) (signed-stack) - (unsigned-reg) (unsigned-stack)) - (let ((nfp (current-nfp-tn vop))) - (storew x nfp (tn-offset y)))) - - -;;;; The Move VOP: -;;; -(define-vop (move) - (:args (x :target y - :scs (any-reg descriptor-reg) - :load-if (not (location= x y)))) - (:results (y :scs (any-reg descriptor-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move x y))) - -(define-move-vop move :move - (any-reg descriptor-reg) - (any-reg descriptor-reg)) - -;;; Make Move the check VOP for T so that type check generation doesn't think -;;; it is a hairy type. This also allows checking of a few of the values in a -;;; continuation to fall out. -;;; -(primitive-type-vop move (:check) t) - -;;; The Move-Argument VOP is used for moving descriptor values into another -;;; frame for argument or known value passing. -;;; -(define-vop (move-argument) - (:args (x :target y - :scs (any-reg descriptor-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y any-reg descriptor-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - ((any-reg descriptor-reg) - (move x y)) - (control-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-argument :move-argument - (any-reg descriptor-reg) - (any-reg descriptor-reg)) - - - -;;;; ILLEGAL-MOVE - -;;; This VOP exists just to begin the lifetime of a TN that couldn't be written -;;; legally due to a type error. An error is signalled before this VOP is -;;; so we don't need to do anything (not that there would be anything sensible -;;; to do anyway.) -;;; -(define-vop (illegal-move) - (:args (x) (type)) - (:results (y)) - (:ignore y) - (:vop-var vop) - (:save-p :compute-only) - (:generator 666 - (error-call vop object-not-type-error x type))) - - - -;;;; Moves and coercions: - -;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word -;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer -;;; to a tagged bignum or fixnum. - -;;; Arg is a fixnum, so just shift it. We need a type restriction because some -;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs. -;;; -(define-vop (move-to-word/fixnum) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:arg-types tagged-num) - (:note "fixnum untagging") - (:generator 1 - (inst sra x 2 y))) -;;; -(define-move-vop move-to-word/fixnum :move - (any-reg descriptor-reg) (signed-reg unsigned-reg)) - -;;; Arg is a non-immediate constant, load it. -(define-vop (move-to-word-c) - (:args (x :scs (constant))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "constant load") - (:generator 1 - (inst li (tn-value x) y))) -;;; -(define-move-vop move-to-word-c :move - (constant) (signed-reg unsigned-reg)) - -;;; Arg is a fixnum or bignum, figure out which and load if necessary. -(define-vop (move-to-word/integer) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "integer to untagged word coercion") - (:generator 3 - (inst extru x 31 2 zero-tn :<>) - (inst sra x 2 y :tr) - (loadw y x vm:bignum-digits-offset vm:other-pointer-type))) -;;; -(define-move-vop move-to-word/integer :move - (descriptor-reg) (signed-reg unsigned-reg)) - -;;; Result is a fixnum, so we can just shift. We need the result type -;;; restriction because of the control-stack ambiguity noted above. -;;; -(define-vop (move-from-word/fixnum) - (:args (x :scs (signed-reg unsigned-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "fixnum tagging") - (:generator 1 - (inst sll x 2 y))) -;;; -(define-move-vop move-from-word/fixnum :move - (signed-reg unsigned-reg) (any-reg descriptor-reg)) - -;;; Result may be a bignum, so we have to check. Use a worst-case cost to make -;;; sure people know they may be number consing. -;;; -(define-vop (move-from-signed) - (:args (x :scs (signed-reg unsigned-reg) :to (:eval 1))) - (:results (y :scs (any-reg descriptor-reg) :from (:eval 0))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:note "signed word to integer coercion") - (:generator 18 - ;; Extract the top three bits. - (inst extrs x 2 3 temp :=) - ;; Invert them (unless they are already zero). - (inst uaddcm zero-tn temp temp) - ;; If we are left with zero, it will fit in a fixnum. So branch around - ;; the bignum-construction, doing the shift in the delay slot. - (inst comb := temp zero-tn done) - (inst sll x 2 y) - ;; Make a single-digit bignum. - (with-fixed-allocation (y temp bignum-type (1+ bignum-digits-offset)) - (storew x y bignum-digits-offset other-pointer-type)) - DONE)) -;;; -(define-move-vop move-from-signed :move - (signed-reg) (descriptor-reg)) - - -;;; Check for fixnum, and possibly allocate one or two word bignum result. Use -;;; a worst-case cost to make sure people know they may be number consing. -;;; -(define-vop (move-from-unsigned) - (:args (x :scs (signed-reg unsigned-reg) :to (:eval 1))) - (:results (y :scs (any-reg descriptor-reg) :from (:eval 0))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:note "unsigned word to integer coercion") - (:generator 20 - ;; Grab the top three bits. - (inst extrs x 2 3 temp) - ;; If zero, it will fit as a fixnum. - (inst comib := 0 temp done) - (inst sll x 2 y) - ;; Make a bignum. - (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset))) - ;; Create the result pointer. - (inst move alloc-tn y) - (inst dep other-pointer-type 31 3 y) - ;; Check the high bit, and skip the next instruction it it's 0. - (inst comclr x zero-tn zero-tn :>=) - ;; The high bit is set, so allocate enough space for a two-word bignum. - ;; We always skip the following instruction, so it is only executed - ;; when we want one word. - (inst addi (pad-data-block 1) alloc-tn alloc-tn :tr) - ;; Set up the header for one word. Use addi instead of li so we can - ;; skip the next instruction. - (inst addi (logior (ash 1 type-bits) bignum-type) zero-tn temp :tr) - ;; Set up the header for two words. - (inst li (logior (ash 2 type-bits) bignum-type) temp) - ;; Store the header and the data. - (storew temp y 0 other-pointer-type) - (storew x y bignum-digits-offset other-pointer-type)) - DONE)) -;;; -(define-move-vop move-from-unsigned :move - (unsigned-reg) (descriptor-reg)) - - -;;; Move untagged numbers. -;;; -(define-vop (word-move) - (:args (x :target y - :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:results (y :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:note "word integer move") - (:generator 0 - (move x y))) -;;; -(define-move-vop word-move :move - (signed-reg unsigned-reg) (signed-reg unsigned-reg)) - - -;;; Move untagged number arguments/return-values. -;;; -(define-vop (move-word-argument) - (:args (x :target y - :scs (signed-reg unsigned-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (:note "word integer argument move") - (:generator 0 - (sc-case y - ((signed-reg unsigned-reg) - (move x y)) - ((signed-stack unsigned-stack) - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-word-argument :move-argument - (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a -;;; descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff --git a/compiler/hppa/nlx.lisp b/compiler/hppa/nlx.lisp deleted file mode 100644 index 608c0af637be377b5f68777a516a44182f539a71..0000000000000000000000000000000000000000 --- a/compiler/hppa/nlx.lisp +++ /dev/null @@ -1,273 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/nlx.lisp,v 1.2 1992/07/13 16:08:16 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the definitions of VOPs used for non-local exit -;;; (throw, lexical exit, etc.) -;;; -;;; Written by William Lott -;;; -(in-package "HPPA") - -;;; MAKE-NLX-SP-TN -- Interface -;;; -;;; Make an environment-live stack TN for saving the SP for NLX entry. -;;; -(def-vm-support-routine make-nlx-sp-tn (env) - (environment-live-tn - (make-representation-tn *fixnum-primitive-type* immediate-arg-scn) - env)) - - - -;;; Save and restore dynamic environment. -;;; -;;; These VOPs are used in the reentered function to restore the appropriate -;;; dynamic environment. Currently we only save the Current-Catch and binding -;;; stack pointer. We don't need to save/restore the current unwind-protect, -;;; since unwind-protects are implicitly processed during unwinding. If there -;;; were any additional stacks, then this would be the place to restore the top -;;; pointers. - - -;;; Make-Dynamic-State-TNs -- Interface -;;; -;;; Return a list of TNs that can be used to snapshot the dynamic state for -;;; use with the Save/Restore-Dynamic-Environment VOPs. -;;; -(def-vm-support-routine make-dynamic-state-tns () - (make-n-tns 4 *any-primitive-type*)) - -(define-vop (save-dynamic-state) - (:results (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg)) - (eval :scs (descriptor-reg))) - (:vop-var vop) - (:generator 13 - (load-symbol-value catch lisp::*current-catch-block*) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move cur-nfp nfp))) - (move nsp-tn nsp) - (load-symbol-value eval lisp::*eval-stack-top*))) - -(define-vop (restore-dynamic-state) - (:args (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg)) - (eval :scs (descriptor-reg))) - (:vop-var vop) - (:generator 10 - (store-symbol-value catch lisp::*current-catch-block*) - (store-symbol-value eval lisp::*eval-stack-top*) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move nfp cur-nfp))) - (move nsp nsp-tn))) - -(define-vop (current-stack-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move csp-tn res))) - -(define-vop (current-binding-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move bsp-tn res))) - - -;;;; Unwind block hackery: - -;;; Compute the address of the catch block from its TN, then store into the -;;; block the current Fp, Env, Unwind-Protect, and the entry PC. -;;; -(define-vop (make-unwind-block) - (:args (tn)) - (:info entry-label) - (:results (block :scs (any-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 22 - (inst addi (* (tn-offset tn) word-bytes) cfp-tn block) - (load-symbol-value temp lisp::*current-unwind-protect-block*) - (storew temp block unwind-block-current-uwp-slot) - (storew cfp-tn block unwind-block-current-cont-slot) - (storew code-tn block unwind-block-current-code-slot) - (inst compute-lra-from-code code-tn entry-label ndescr temp) - (storew temp block catch-block-entry-pc-slot))) - -;;; Like Make-Unwind-Block, except that we also store in the specified tag, and -;;; link the block into the Current-Catch list. -;;; -(define-vop (make-catch-block) - (:args (tn) - (tag :scs (descriptor-reg))) - (:info entry-label) - (:results (block :scs (any-reg) :from (:argument 0))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 44 - (inst addi (* (tn-offset tn) word-bytes) cfp-tn block) - (load-symbol-value temp lisp::*current-unwind-protect-block*) - (storew temp block catch-block-current-uwp-slot) - (storew cfp-tn block catch-block-current-cont-slot) - (storew code-tn block catch-block-current-code-slot) - (inst compute-lra-from-code code-tn entry-label ndescr temp) - (storew temp block catch-block-entry-pc-slot) - - (storew tag block catch-block-tag-slot) - (load-symbol-value temp lisp::*current-catch-block*) - (storew temp block catch-block-previous-catch-slot) - (store-symbol-value block lisp::*current-catch-block*))) - - -;;; Just set the current unwind-protect to TN's address. This instantiates an -;;; unwind block as an unwind-protect. -;;; -(define-vop (set-unwind-protect) - (:args (tn)) - (:temporary (:scs (descriptor-reg)) new-uwp) - (:generator 7 - (inst addi (* (tn-offset tn) word-bytes) cfp-tn new-uwp) - (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) - - -(define-vop (unlink-catch-block) - (:temporary (:scs (any-reg)) block) - (:policy :fast-safe) - (:translate %catch-breakup) - (:generator 17 - (load-symbol-value block lisp::*current-catch-block*) - (loadw block block catch-block-previous-catch-slot) - (store-symbol-value block lisp::*current-catch-block*))) - -(define-vop (unlink-unwind-protect) - (:temporary (:scs (any-reg)) block) - (:policy :fast-safe) - (:translate %unwind-protect-breakup) - (:generator 17 - (load-symbol-value block lisp::*current-unwind-protect-block*) - (loadw block block unwind-block-current-uwp-slot) - (store-symbol-value block lisp::*current-unwind-protect-block*))) - - -;;;; NLX entry VOPs: - - -(define-vop (nlx-entry) - (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops - ; would be inserted before the LRA. - (start) - (count)) - (:results (values :more t)) - (:temporary (:scs (descriptor-reg)) move-temp) - (:info label nvals) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (emit-return-pc label) - (note-this-location vop :non-local-entry) - (cond ((zerop nvals)) - ((= nvals 1) - (inst comclr count zero-tn zero-tn :<>) - (inst move null-tn (tn-ref-tn values) :tr) - (loadw (tn-ref-tn values) start)) - (t - (collect ((defaults)) - (do ((i 0 (1+ i)) - (tn-ref values (tn-ref-across tn-ref))) - ((null tn-ref)) - (let ((default-lab (gen-label)) - (tn (tn-ref-tn tn-ref))) - (defaults (cons default-lab tn)) - - (inst bci := nil (fixnum i) count default-lab) - (sc-case tn - ((descriptor-reg any-reg) - (loadw tn start i)) - (control-stack - (loadw move-temp start i) - (store-stack-tn tn move-temp))))) - - (let ((defaulting-done (gen-label))) - (emit-label defaulting-done) - - (assemble (*elsewhere*) - (do ((defs (defaults) (cdr defs))) - ((null defs)) - (let ((def (car defs))) - (emit-label (car def)) - (unless (cdr defs) - (inst b defaulting-done)) - (let ((tn (cdr def))) - (sc-case tn - ((descriptor-reg any-reg) - (move null-tn tn)) - (control-stack - (store-stack-tn tn null-tn))))))))))) - (load-stack-tn csp-tn sp))) - - -(define-vop (nlx-entry-multiple) - (:args (top :target dst) (start :target src) (count :target num)) - ;; Again, no SC restrictions for the args, 'cause the loading would - ;; happen before the entry label. - (:info label) - (:temporary (:scs (any-reg) :from (:argument 0)) dst) - (:temporary (:scs (any-reg) :from (:argument 1)) src) - (:temporary (:scs (any-reg) :from (:argument 2)) num) - (:temporary (:scs (descriptor-reg)) temp) - (:results (new-start) (new-count)) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (emit-return-pc label) - (note-this-location vop :non-local-entry) - - ;; Copy args. - (load-stack-tn dst top) - (move start src) - (move count num) - - ;; Establish results. - (sc-case new-start - (any-reg (move dst new-start)) - (control-stack (store-stack-tn new-start dst))) - (inst comb := num zero-tn done) - (sc-case new-count - (any-reg (inst move num new-count)) - (control-stack (store-stack-tn new-count num))) - ;; Load the first word. - (inst ldwm word-bytes src temp) - - ;; Copy stuff on stack. - LOOP - (inst stwm temp word-bytes dst) - (inst addib :<> (fixnum -1) num loop :nullify t) - (inst ldwm word-bytes src temp) - - DONE - (inst move dst csp-tn))) - - -;;; This VOP is just to force the TNs used in the cleanup onto the stack. -;;; -(define-vop (uwp-entry) - (:info label) - (:save-p :force-to-stack) - (:results (block) (start) (count)) - (:ignore block start count) - (:vop-var vop) - (:generator 0 - (emit-return-pc label) - (note-this-location vop :non-local-entry))) diff --git a/compiler/hppa/parms.lisp b/compiler/hppa/parms.lisp deleted file mode 100644 index 27c95b920c506fd42745c7366580630f60fd64ac..0000000000000000000000000000000000000000 --- a/compiler/hppa/parms.lisp +++ /dev/null @@ -1,213 +0,0 @@ -;;; -*- Package: hppa -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/parms.lisp,v 1.2 1992/10/13 13:17:01 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains some parameterizations of various VM -;;; attributes for the HP-PA. This file is separate from other stuff so -;;; that it can be compiled and loaded earlier. -;;; -;;; Written by William Lott. -;;; - -(in-package :hppa) -(use-package :c) - - -;;;; Compiler constants. - -(eval-when (compile eval load) - -(setf (backend-name *target-backend*) "HPPA") -(setf (backend-version *target-backend*) "HP-PA 1.1") -(setf (backend-fasl-file-type *target-backend*) "hpf") -(setf (backend-fasl-file-implementation *target-backend*) - hppa-fasl-file-implementation) -(setf (backend-fasl-file-version *target-backend*) 1) -(setf (backend-register-save-penalty *target-backend*) 3) -(setf (backend-byte-order *target-backend*) :big-endian) -(setf (backend-page-size *target-backend*) 4096) - -); eval-when - - -;;;; Machine Architecture parameters: - -(export '(word-bits byte-bits word-shift word-bytes float-sign-shift - - single-float-bias single-float-exponent-byte - single-float-significand-byte single-float-normal-exponent-min - single-float-normal-exponent-max single-float-hidden-bit - single-float-trapping-nan-bit single-float-digits - - double-float-bias double-float-exponent-byte - double-float-significand-byte double-float-normal-exponent-min - double-float-normal-exponent-max double-float-hidden-bit - double-float-trapping-nan-bit double-float-digits - - float-underflow-trap-bit float-overflow-trap-bit - float-imprecise-trap-bit float-invalid-trap-bit - float-divide-by-zero-trap-bit)) - - - -(eval-when (compile load eval) - -(defconstant word-bits 32 - "Number of bits per word where a word holds one lisp descriptor.") - -(defconstant byte-bits 8 - "Number of bits per byte where a byte is the smallest addressable object.") - -(defconstant word-shift (1- (integer-length (/ word-bits byte-bits))) - "Number of bits to shift between word addresses and byte addresses.") - -(defconstant word-bytes (/ word-bits byte-bits) - "Number of bytes in a word.") - -(defconstant float-sign-shift 31) - -(defconstant single-float-bias 126) -(defconstant single-float-exponent-byte (byte 8 23)) -(defconstant single-float-significand-byte (byte 23 0)) -(defconstant single-float-normal-exponent-min 1) -(defconstant single-float-normal-exponent-max 254) -(defconstant single-float-hidden-bit (ash 1 23)) -(defconstant single-float-trapping-nan-bit (ash 1 22)) - -(defconstant double-float-bias 1022) -(defconstant double-float-exponent-byte (byte 11 20)) -(defconstant double-float-significand-byte (byte 20 0)) -(defconstant double-float-normal-exponent-min 1) -(defconstant double-float-normal-exponent-max #x7FE) -(defconstant double-float-hidden-bit (ash 1 20)) -(defconstant double-float-trapping-nan-bit (ash 1 19)) - -(defconstant single-float-digits - (+ (byte-size single-float-significand-byte) 1)) - -(defconstant double-float-digits - (+ (byte-size double-float-significand-byte) word-bits 1)) - -(defconstant float-inexact-trap-bit (ash 1 0)) -(defconstant float-underflow-trap-bit (ash 1 1)) -(defconstant float-overflow-trap-bit (ash 1 2)) -(defconstant float-divide-by-zero-trap-bit (ash 1 3)) -(defconstant float-invalid-trap-bit (ash 1 4)) - -(defconstant float-round-to-nearest 0) -(defconstant float-round-to-zero 1) -(defconstant float-round-to-positive 2) -(defconstant float-round-to-negative 3) - -(defconstant float-rounding-mode (byte 2 7)) -(defconstant float-sticky-bits (byte 5 27)) -(defconstant float-traps-byte (byte 5 0)) -(defconstant float-exceptions-byte (byte 5 27)) -(defconstant float-condition-bit (ash 1 26)) -(defconstant float-fast-bit 0) ; No fast mode on HPPA. - -); eval-when - - - -;;;; Description of the target address space. - -(export '(target-read-only-space-start - target-static-space-start - target-dynamic-space-start)) - -;;; Where to put the different spaces. -;;; -(defparameter target-read-only-space-start #x20000000) -(defparameter target-static-space-start #x28000000) -(defparameter target-dynamic-space-start #x30000000) - -;; The space-register holding the lisp heap. -(defconstant lisp-heap-space 4) - -;; The space-register holding the C text segment. -(defconstant c-text-space 4) - - -;;;; Other random constants. - -(export '(halt-trap pending-interrupt-trap error-trap cerror-trap - breakpoint-trap function-end-breakpoint-trap single-step-breakpoint - trace-table-normal trace-table-call-site - trace-table-function-prologue trace-table-function-epilogue)) - -(defenum (:suffix -trap :start 8) - halt - pending-interrupt - error - cerror - breakpoint - function-end-breakpoint - single-step-breakpoint) - -(defenum (:prefix trace-table-) - normal - call-site - function-prologue - function-epilogue) - - - -;;;; Static symbols. - -(export '(static-symbols static-functions)) - -;;; These symbols are loaded into static space directly after NIL so -;;; that the system can compute their address by adding a constant -;;; amount to NIL. -;;; -;;; The fdefn objects for the static functions are loaded into static -;;; space directly after the static symbols. That way, the raw-addr -;;; can be loaded directly out of them by indirecting relative to NIL. -;;; -(defparameter static-symbols - '(t - - ;; The C startup code must fill these in. - lisp::lisp-environment-list - lisp::lisp-command-line-list - lisp::*initial-fdefn-objects* - - ;; Functions that the C code needs to call - lisp::%initial-function - lisp::maybe-gc - kernel::internal-error - di::handle-breakpoint - di::handle-function-end-breakpoint - lisp::fdefinition-object - - ;; Free Pointers. - lisp::*read-only-space-free-pointer* - lisp::*static-space-free-pointer* - lisp::*initial-dynamic-space-free-pointer* - - ;; Things needed for non-local-exit. - lisp::*current-catch-block* - lisp::*current-unwind-protect-block* - *eval-stack-top* - - ;; Interrupt Handling - lisp::*free-interrupt-context-index* - unix::*interrupts-enabled* - unix::*interrupt-pending* - )) - -(defparameter static-functions - '(length - two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql - %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm - )) diff --git a/compiler/hppa/pred.lisp b/compiler/hppa/pred.lisp deleted file mode 100644 index 8c87d7eebefc178de90ed3b6f1ae7c5125cce9bb..0000000000000000000000000000000000000000 --- a/compiler/hppa/pred.lisp +++ /dev/null @@ -1,43 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/pred.lisp,v 1.1 1992/07/13 03:48:30 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of predicate VOPs for the HPPA -;;; -;;; Written by William Lott. -;;; - -(in-package "HPPA") - - -;;;; The Branch VOP. - -;;; The unconditional branch, emitted when we can't drop through to the desired -;;; destination. Dest is the continuation we transfer control to. -;;; -(define-vop (branch) - (:info dest) - (:generator 5 - (inst b dest :nullify t))) - - -;;;; Conditional VOPs: - -(define-vop (if-eq) - (:args (x :scs (any-reg descriptor-reg zero null)) - (y :scs (any-reg descriptor-reg zero null))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:translate eq) - (:generator 3 - (inst bc := not-p x y target))) diff --git a/compiler/hppa/print.lisp b/compiler/hppa/print.lisp deleted file mode 100644 index 1701c8c5979eb1ea1f32661e638d98b25e127c96..0000000000000000000000000000000000000000 --- a/compiler/hppa/print.lisp +++ /dev/null @@ -1,48 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/print.lisp,v 1.1 1992/07/13 03:48:31 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains temporary printing utilities and similar noise. -;;; -;;; Written by William Lott. - -(in-package "HPPA") - - -(define-vop (print) - (:args (object :scs (descriptor-reg) :target arg)) - (:results (result :scs (descriptor-reg))) - (:save-p t) - (:temporary (:sc non-descriptor-reg :offset cfunc-offset) cfunc) - (:temporary (:sc non-descriptor-reg :offset nl0-offset :from (:argument 0)) - arg) - (:temporary (:sc non-descriptor-reg :offset nl4-offset :to (:result 0)) - res) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:generator 0 - (let ((cur-nfp (current-nfp-tn vop))) - (move object arg) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - ;; Allocate 64 bytes, the minimum stack size. - (inst addi 64 nsp-tn nsp-tn) - (inst li (make-fixup "debug_print" :foreign) cfunc) - (let ((fixup (make-fixup "call_into_c" :foreign))) - (inst ldil fixup temp) - (inst ble fixup c-text-space temp :nullify t) - (inst nop)) - (inst addi -64 nsp-tn nsp-tn) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - (move res result)))) diff --git a/compiler/hppa/sap.lisp b/compiler/hppa/sap.lisp deleted file mode 100644 index 07458041af5a37250c4b82a07591bc319e138aae..0000000000000000000000000000000000000000 --- a/compiler/hppa/sap.lisp +++ /dev/null @@ -1,286 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/sap.lisp,v 1.1 1992/07/13 03:48:33 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the HP-PA VM definition of SAP operations. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - - -;;;; Moves and coercions: - -;;; Move a tagged SAP to an untagged representation. -;;; -(define-vop (move-to-sap) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (sap-reg))) - (:note "system area pointer indirection") - (:generator 1 - (loadw y x sap-pointer-slot other-pointer-type))) - -;;; -(define-move-vop move-to-sap :move - (descriptor-reg) (sap-reg)) - - -;;; Move an untagged SAP to a tagged representation. -;;; -(define-vop (move-from-sap) - (:args (x :scs (sap-reg) :to (:eval 1))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (y :scs (descriptor-reg) :from (:eval 0))) - (:note "system area pointer allocation") - (:generator 20 - (with-fixed-allocation (y ndescr sap-type sap-size) - (storew x y sap-pointer-slot other-pointer-type)))) -;;; -(define-move-vop move-from-sap :move - (sap-reg) (descriptor-reg)) - - -;;; Move untagged sap values. -;;; -(define-vop (sap-move) - (:args (x :target y - :scs (sap-reg) - :load-if (not (location= x y)))) - (:results (y :scs (sap-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move x y))) -;;; -(define-move-vop sap-move :move - (sap-reg) (sap-reg)) - - -;;; Move untagged sap arguments/return-values. -;;; -(define-vop (move-sap-argument) - (:args (x :target y - :scs (sap-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (sap-reg - (move x y)) - (sap-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-sap-argument :move-argument - (descriptor-reg sap-reg) (sap-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a -;;; descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (sap-reg) (descriptor-reg)) - - - -;;;; SAP-INT and INT-SAP - -(define-vop (sap-int) - (:args (sap :scs (sap-reg) :target int)) - (:arg-types system-area-pointer) - (:results (int :scs (unsigned-reg))) - (:result-types unsigned-num) - (:translate sap-int) - (:policy :fast-safe) - (:generator 1 - (move sap int))) - -(define-vop (int-sap) - (:args (int :scs (unsigned-reg) :target sap)) - (:arg-types unsigned-num) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate int-sap) - (:policy :fast-safe) - (:generator 1 - (move int sap))) - - - -;;;; POINTER+ and POINTER- - -(define-vop (pointer+) - (:translate sap+) - (:args (ptr :scs (sap-reg) :target res) - (offset :scs (signed-reg))) - (:arg-types system-area-pointer signed-num) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:policy :fast-safe) - (:generator 1 - (inst add ptr offset res))) - -(define-vop (pointer+-c) - (:translate sap+) - (:args (ptr :scs (sap-reg))) - (:info offset) - (:arg-types system-area-pointer (:constant (signed-byte 11))) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:policy :fast-safe) - (:generator 1 - (inst addi offset ptr res))) - -(define-vop (pointer-) - (:translate sap-) - (:args (ptr1 :scs (sap-reg)) - (ptr2 :scs (sap-reg))) - (:arg-types system-area-pointer system-area-pointer) - (:policy :fast-safe) - (:results (res :scs (signed-reg))) - (:result-types signed-num) - (:generator 1 - (inst sub ptr1 ptr2 res))) - - - -;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET - -(eval-when (compile eval) - -(defmacro def-system-ref-and-set - (ref-name set-name sc type size &optional signed) - (let ((ref-name-c (symbolicate ref-name "-C")) - (set-name-c (symbolicate set-name "-C"))) - `(progn - (define-vop (,ref-name) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg)) - (offset :scs (unsigned-reg))) - (:arg-types system-area-pointer unsigned-num) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 5 - (inst ,(ecase size - (:byte 'ldbx) - (:short 'ldhx) - (:long 'ldwx) - (:float 'fldx)) - offset object result) - ,@(when (and signed (not (eq size :long))) - `((inst extrs result 31 ,(ecase size - (:byte 8) - (:short 16)) - result))))) - (define-vop (,ref-name-c) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg))) - (:arg-types system-area-pointer - (:constant ,(if (eq size :float) - '(signed-byte 5) - '(signed-byte 14)))) - (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 4 - (inst ,(ecase size - (:byte 'ldb) - (:short 'ldh) - (:long 'ldw) - (:float 'flds)) - offset object result) - ,@(when (and signed (not (eq size :long))) - `((inst extrs result 31 ,(ecase size - (:byte 8) - (:short 16)) - result))))) - (define-vop (,set-name) - (:translate ,set-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg) - ,@(unless (eq size :float) '(:target sap))) - (offset :scs (unsigned-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer unsigned-num ,type) - (:results (result :scs (,sc))) - (:result-types ,type) - ,@(unless (eq size :float) - '((:temporary (:scs (sap-reg) :from (:argument 0)) sap))) - (:generator 5 - ,@(if (eq size :float) - `((inst fstx value offset object) - (unless (location= value result) - (inst funop :copy value result))) - `((inst add object offset sap) - (inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw)) - value 0 sap) - (move value result))))) - (define-vop (,set-name-c) - (:translate ,set-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer - (:constant ,(if (eq size :float) - '(signed-byte 5) - '(signed-byte 14))) - ,type) - (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 5 - ,@(if (eq size :float) - `((inst fsts value offset object) - (unless (location= value result) - (inst funop :copy value result))) - `((inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw)) - value offset object) - (move value result)))))))) - -); eval-when (compile eval) - -(def-system-ref-and-set sap-ref-8 %set-sap-ref-8 - unsigned-reg positive-fixnum :byte nil) -(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 - signed-reg tagged-num :byte t) -(def-system-ref-and-set sap-ref-16 %set-sap-ref-16 - unsigned-reg positive-fixnum :short nil) -(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 - signed-reg tagged-num :short t) -(def-system-ref-and-set sap-ref-32 %set-sap-ref-32 - unsigned-reg unsigned-num :long nil) -(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 - signed-reg signed-num :long t) -(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap - sap-reg system-area-pointer :long) -(def-system-ref-and-set sap-ref-single %set-sap-ref-single - single-reg single-float :float) -(def-system-ref-and-set sap-ref-double %set-sap-ref-double - double-reg double-float :float) - - -;;; Noise to convert normal lisp data objects into SAPs. - -(define-vop (vector-sap) - (:translate vector-sap) - (:policy :fast-safe) - (:args (vector :scs (descriptor-reg))) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst addi - (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type) - vector - sap))) diff --git a/compiler/hppa/static-fn.lisp b/compiler/hppa/static-fn.lisp deleted file mode 100644 index 0d2d1cc386c985661b70046f62e0b810af7737dd..0000000000000000000000000000000000000000 --- a/compiler/hppa/static-fn.lisp +++ /dev/null @@ -1,144 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/static-fn.lisp,v 1.1 1992/07/13 03:48:35 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VOPs and macro magic necessary to call static -;;; functions. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - - -(define-vop (static-function-template) - (:save-p t) - (:policy :safe) - (:variant-vars symbol) - (:vop-var vop) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg)) move-temp) - (:temporary (:sc descriptor-reg :offset lra-offset) lra) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) old-fp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) - - -(eval-when (compile load eval) - -(defun static-function-template-name (num-args num-results) - (intern (format nil "~:@(~R-arg-~R-result-static-function~)" - num-args num-results))) - - -(defun moves (src dst) - (collect ((moves)) - (do ((src src (cdr src)) - (dst dst (cdr dst))) - ((or (null src) (null dst))) - (moves `(move ,(car src) ,(car dst)))) - (moves))) - -(defun static-function-template-vop (num-args num-results) - (assert (and (<= num-args register-arg-count) - (<= num-results register-arg-count)) - (num-args num-results) - "Either too many args (~D) or too many results (~D). Max = ~D" - num-args num-results register-arg-count) - (let ((num-temps (max num-args num-results))) - (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) - (dotimes (i num-results) - (let ((result-name (intern (format nil "RESULT-~D" i)))) - (result-names result-name) - (results `(,result-name :scs (any-reg descriptor-reg))))) - (dotimes (i num-temps) - (let ((temp-name (intern (format nil "TEMP-~D" i)))) - (temp-names temp-name) - (temps `(:temporary (:sc descriptor-reg - :offset ,(nth i register-arg-offsets) - ,@(when (< i num-args) - `(:from (:argument ,i))) - ,@(when (< i num-results) - `(:to (:result ,i) - :target ,(nth i (result-names))))) - ,temp-name)))) - (dotimes (i num-args) - (let ((arg-name (intern (format nil "ARG-~D" i)))) - (arg-names arg-name) - (args `(,arg-name - :scs (any-reg descriptor-reg) - :target ,(nth i (temp-names)))))) - `(define-vop (,(static-function-template-name num-args num-results) - static-function-template) - (:args ,@(args)) - ,@(temps) - (:results ,@(results)) - (:generator ,(+ 50 num-args num-results) - (let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - ,@(moves (arg-names) (temp-names)) - (inst li (fixnum ,num-args) nargs) - (inst ldw (static-function-offset symbol) null-tn lip) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (inst move cfp-tn old-fp) - (inst compute-lra-from-code code-tn lra-label temp lra) - (note-this-location vop :call-site) - (inst bv lip) - (inst move csp-tn cfp-tn) - (emit-return-pc lra-label) - ,(collect ((bindings) (links)) - (do ((temp (temp-names) (cdr temp)) - (name 'values (gensym)) - (prev nil name) - (i 0 (1+ i))) - ((= i num-results)) - (bindings `(,name - (make-tn-ref ,(car temp) nil))) - (when prev - (links `(setf (tn-ref-across ,prev) ,name)))) - `(let ,(bindings) - ,@(links) - (default-unknown-values vop - ,(if (zerop num-results) nil 'values) - ,num-results move-temp temp lra-label))) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - ,@(moves (temp-names) (result-names)))))))) - -) ; eval-when (compile load eval) - -(macrolet - ((foo () - (collect ((templates (list 'progn))) - (dotimes (i register-arg-count) - (templates (static-function-template-vop i 1))) - (templates)))) - (foo)) - -(defmacro define-static-function (name args &key (results '(x)) translate - policy cost arg-types result-types) - `(define-vop (,name - ,(static-function-template-name (length args) - (length results))) - (:variant ',name) - (:note ,(format nil "static-function ~@(~S~)" name)) - ,@(when translate - `((:translate ,translate))) - ,@(when policy - `((:policy ,policy))) - ,@(when cost - `((:generator-cost ,cost))) - ,@(when arg-types - `((:arg-types ,@arg-types))) - ,@(when result-types - `((:result-types ,@result-types))))) diff --git a/compiler/hppa/subprim.lisp b/compiler/hppa/subprim.lisp deleted file mode 100644 index 09379f233604d8bfcdd11f52755738c813309706..0000000000000000000000000000000000000000 --- a/compiler/hppa/subprim.lisp +++ /dev/null @@ -1,58 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/subprim.lisp,v 1.1 1992/07/13 03:48:35 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Linkage information for standard static functions, and random vops. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - - - -;;;; Length - -(define-vop (length/list) - (:translate length) - (:args (object :scs (descriptor-reg) :target ptr)) - (:arg-types list) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) - (:temporary (:scs (non-descriptor-reg) :type random) temp) - (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result) - count) - (:results (result :scs (any-reg descriptor-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:generator 50 - (move object ptr) - (inst comb := ptr null-tn done) - (inst li 0 count) - - (inst extru ptr 31 3 temp) - (inst comib :<> list-pointer-type temp loose :nullify t) - (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) - - LOOP - (inst addi (fixnum 1) count count) - (inst comb := ptr null-tn done :nullify t) - (inst extru ptr 31 3 temp) - (inst comib := list-pointer-type temp loop :nullify t) - (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) - - LOOSE - (cerror-call vop done object-not-list-error ptr) - - DONE - (move count result))) - -(define-static-function length (object) :translate length) diff --git a/compiler/hppa/system.lisp b/compiler/hppa/system.lisp deleted file mode 100644 index 1f3fb929eaa0e9e36ea774e76c616635a5dcc7b6..0000000000000000000000000000000000000000 --- a/compiler/hppa/system.lisp +++ /dev/null @@ -1,230 +0,0 @@ -;;; -*- Package: hppa -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/system.lisp,v 1.1 1992/07/13 03:48:36 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; HPPA VM definitions of various system hacking operations. -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - - -;;;; Type frobbing VOPs - -(define-vop (get-lowtag) - (:translate get-lowtag) - (:policy :fast-safe) - (:args (object :scs (any-reg descriptor-reg) :target result)) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 1 - (inst extru object 31 3 result))) - -(define-vop (get-type) - (:translate get-type) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 1))) - (:results (result :scs (unsigned-reg) :from (:eval 0))) - (:result-types positive-fixnum) - (:generator 6 - (inst extru object 31 3 result) - (inst comib := other-pointer-type result other-ptr :nullify t) - (inst comib := function-pointer-type result function-ptr :nullify t) - (inst bb t object 31 done :nullify t) - (inst extru object 31 2 result :<>) - (inst extru object 31 8 result) - (inst nop :tr) - - FUNCTION-PTR - (load-type result object (- function-pointer-type)) - (inst nop :tr) - - OTHER-PTR - (load-type result object (- other-pointer-type)) - - DONE)) - -(define-vop (function-subtype) - (:translate function-subtype) - (:policy :fast-safe) - (:args (function :scs (descriptor-reg))) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (load-type result function (- function-pointer-type)))) - -(define-vop (set-function-subtype) - (:translate (setf function-subtype)) - (:policy :fast-safe) - (:args (type :scs (unsigned-reg) :target result) - (function :scs (descriptor-reg))) - (:arg-types positive-fixnum *) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (inst stb type (- 3 function-pointer-type) function) - (move type result))) - -(define-vop (get-header-data) - (:translate get-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (loadw res x 0 other-pointer-type) - (inst srl res 8 res))) - -(define-vop (get-closure-length) - (:translate get-closure-length) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (loadw res x 0 function-pointer-type) - (inst srl res 8 res))) - -(define-vop (set-header-data) - (:translate set-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg) :target res) - (data :scs (unsigned-reg))) - (:arg-types * positive-fixnum) - (:results (res :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 6 - (loadw temp x 0 vm:other-pointer-type) - (inst dep data 23 24 temp) - (storew temp x 0 vm:other-pointer-type) - (move x res))) - -(define-vop (set-header-data-c) - (:translate set-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg) :target res)) - (:arg-types * (:constant (signed-byte 5))) - (:info data) - (:results (res :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 5 - (loadw temp x 0 vm:other-pointer-type) - (inst dep data 23 24 temp) - (storew temp x 0 vm:other-pointer-type) - (move x res))) - -(define-vop (c::make-fixnum) - (:args (ptr :scs (any-reg descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - ;; - ;; Some code (the hash table code) depends on this returning a - ;; positive number so make sure it does. - (inst zdep ptr 29 29 res))) - -(define-vop (c::make-other-immediate-type) - (:args (val :scs (any-reg descriptor-reg)) - (type :scs (any-reg descriptor-reg) :target temp)) - (:results (res :scs (any-reg descriptor-reg) :from (:argument 0))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 2 - (inst sll val (- type-bits 2) res) - (inst sra type 2 temp) - (inst or res temp res))) - - -;;;; Allocation - -(define-vop (dynamic-space-free-pointer) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate dynamic-space-free-pointer) - (:policy :fast-safe) - (:generator 1 - (move alloc-tn int))) - -(define-vop (binding-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate binding-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move bsp-tn int))) - -(define-vop (control-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate control-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move csp-tn int))) - - -;;;; Code object frobbing. - -(define-vop (code-instructions) - (:translate code-instructions) - (:policy :fast-safe) - (:args (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 10 - (loadw ndescr code 0 other-pointer-type) - (inst srl ndescr 8 ndescr) - (inst sll ndescr 2 ndescr) - (inst addi (- other-pointer-type) ndescr ndescr) - (inst add code ndescr sap))) - -(define-vop (compute-function) - (:args (code :scs (descriptor-reg)) - (offset :scs (signed-reg unsigned-reg))) - (:arg-types * positive-fixnum) - (:results (func :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 10 - (loadw ndescr code 0 vm:other-pointer-type) - (inst srl ndescr 8 ndescr) - (inst sll ndescr 2 ndescr) - (inst add ndescr offset ndescr) - (inst addi (- function-pointer-type other-pointer-type) ndescr ndescr) - (inst add ndescr code func))) - - -;;;; Other random VOPs. - - -(defknown unix::do-pending-interrupt () (values)) -(define-vop (unix::do-pending-interrupt) - (:policy :fast-safe) - (:translate unix::do-pending-interrupt) - (:generator 1 - (inst break pending-interrupt-trap))) - - -(define-vop (halt) - (:generator 1 - (inst break halt-trap))) - - -;;;; Dynamic vop count collection support - -(define-vop (count-me) - (:args (count-vector :scs (descriptor-reg))) - (:info index) - (:temporary (:scs (non-descriptor-reg)) count) - (:generator 1 - (let ((offset - (- (* (+ index vector-data-offset) word-bytes) other-pointer-type))) - (inst ldw offset count-vector count) - (inst addi 1 count count) - (inst stw count offset count-vector)))) diff --git a/compiler/hppa/type-vops.lisp b/compiler/hppa/type-vops.lisp deleted file mode 100644 index 2cd18272a2ee6fe1534275887a6129f7b874e854..0000000000000000000000000000000000000000 --- a/compiler/hppa/type-vops.lisp +++ /dev/null @@ -1,492 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/type-vops.lisp,v 1.2 1992/10/28 16:13:11 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of type testing and checking VOPs -;;; for the HPPA -;;; -;;; Written by William Lott. -;;; -(in-package "HPPA") - - - -;;;; Test generation utilities. - -(eval-when (compile eval) - -(defparameter immediate-types - (list unbound-marker-type base-char-type)) - -(defparameter function-header-types - (list funcallable-instance-header-type closure-header-type - byte-code-function-type byte-code-closure-type - function-header-type closure-function-header-type)) - -(defun canonicalize-headers (headers) - (collect ((results)) - (let ((start nil) - (prev nil) - (delta (- other-immediate-1-type other-immediate-0-type))) - (flet ((emit-test () - (results (if (= start prev) - start - (cons start prev))))) - (dolist (header (sort headers #'<)) - (cond ((null start) - (setf start header) - (setf prev header)) - ((= header (+ prev delta)) - (setf prev header)) - (t - (emit-test) - (setf start header) - (setf prev header)))) - (emit-test))) - (results))) - -(defmacro test-type (value temp target not-p &rest type-codes) - ;; Determine what interesting combinations we need to test for. - (let* ((type-codes (mapcar #'eval type-codes)) - (fixnump (and (member even-fixnum-type type-codes) - (member odd-fixnum-type type-codes) - t)) - (lowtags (remove lowtag-limit type-codes :test #'<)) - (extended (remove lowtag-limit type-codes :test #'>)) - (immediates (intersection extended immediate-types :test #'eql)) - (headers (set-difference extended immediate-types :test #'eql)) - (function-p (if (intersection headers function-header-types) - (if (subsetp headers function-header-types) - t - (error "Can't test for mix of function subtypes ~ - and normal header types.")) - nil))) - (unless type-codes - (error "Must supply at least on type for test-type.")) - (cond - (fixnump - (when (remove-if #'(lambda (x) - (or (= x even-fixnum-type) - (= x odd-fixnum-type))) - lowtags) - (error "Can't mix fixnum testing with other lowtags.")) - (when function-p - (error "Can't mix fixnum testing with function subtype testing.")) - (when immediates - (error "Can't mix fixnum testing with other immediates.")) - (if headers - `(%test-fixnum-and-headers ,value ,temp ,target ,not-p - ',(canonicalize-headers headers)) - `(%test-fixnum ,value ,temp ,target ,not-p))) - (immediates - (when headers - (error "Can't mix testing of immediates with testing of headers.")) - (when lowtags - (error "Can't mix testing of immediates with testing of lowtags.")) - (when (cdr immediates) - (error "Can't test multiple immediates at the same time.")) - `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates))) - (lowtags - (when (cdr lowtags) - (error "Can't test multiple lowtags at the same time.")) - (if headers - `(%test-lowtag-and-headers - ,value ,temp ,target ,not-p ,(car lowtags) - ,function-p ',(canonicalize-headers headers)) - `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags)))) - (headers - `(%test-headers ,value ,temp ,target ,not-p ,function-p - ',(canonicalize-headers headers))) - (t - (error "Nothing to test?"))))) - -); eval-when (compile eval) - -(defun %test-fixnum (value temp target not-p) - (declare (ignore temp)) - (assemble () - (inst extru value 31 2 zero-tn (if not-p := :<>)) - (inst b target :nullify t))) - -(defun %test-fixnum-and-headers (value temp target not-p headers) - (let ((drop-through (gen-label))) - (assemble () - (inst extru value 31 2 zero-tn :<>) - (inst b (if not-p drop-through target) :nullify t)) - (%test-headers value temp target not-p nil headers drop-through))) - -(defun %test-immediate (value temp target not-p immediate) - (assemble () - (inst extru value 31 8 temp) - (inst bci := not-p immediate temp target))) - -(defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded) - (assemble () - (unless temp-loaded - (inst extru value 31 3 temp)) - (inst bci := not-p lowtag temp target))) - -(defun %test-lowtag-and-headers (value temp target not-p lowtag - function-p headers) - (let ((drop-through (gen-label))) - (%test-lowtag value temp (if not-p drop-through target) nil lowtag) - (%test-headers value temp target not-p function-p headers drop-through t))) - -(defun %test-headers (value temp target not-p function-p headers - &optional (drop-through (gen-label)) temp-loaded) - (let ((lowtag (if function-p function-pointer-type other-pointer-type))) - (multiple-value-bind - (equal greater-or-equal when-true when-false) - ;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to - ;; TARGET. WHEN-TRUE and WHEN-FALSE are the labels to branch to when - ;; we know it's true and when we know it's false respectively. - (if not-p - (values :<> :< drop-through target) - (values := :>= target drop-through)) - (assemble () - (%test-lowtag value temp when-false t lowtag temp-loaded) - (inst ldb (- 3 lowtag) value temp) - (do ((remaining headers (cdr remaining))) - ((null remaining)) - (let ((header (car remaining)) - (last (null (cdr remaining)))) - (cond - ((atom header) - (if last - (inst bci equal nil header temp target) - (inst bci := nil header temp when-true))) - (t - (let ((start (car header)) - (end (cdr header))) - (unless (= start bignum-type) - (inst bci :> nil start temp when-false)) - (if last - (inst bci greater-or-equal nil end temp target) - (inst bci :>= nil end temp when-true))))))) - (emit-label drop-through))))) - - -;;;; Type checking and testing: - -(define-vop (check-type) - (:args (value :target result :scs (any-reg descriptor-reg))) - (:results (result :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp) - (:vop-var vop) - (:save-p :compute-only)) - -(define-vop (type-predicate) - (:args (value :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:conditional) - (:info target not-p) - (:policy :fast-safe)) - -(eval-when (compile eval) - -(defun cost-to-test-types (type-codes) - (+ (* 2 (length type-codes)) - (if (> (apply #'max type-codes) lowtag-limit) 7 2))) - -(defmacro def-type-vops (pred-name check-name ptype error-code - &rest type-codes) - (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) - `(progn - ,@(when pred-name - `((define-vop (,pred-name type-predicate) - (:translate ,pred-name) - (:generator ,cost - (test-type value temp target not-p ,@type-codes))))) - ,@(when check-name - `((define-vop (,check-name check-type) - (:generator ,cost - (let ((err-lab - (generate-error-code vop ,error-code value))) - (test-type value temp err-lab t ,@type-codes) - (move value result)))))) - ,@(when ptype - `((primitive-type-vop ,check-name (:check) ,ptype)))))) - -); eval-when (compile eval) - -(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error - even-fixnum-type odd-fixnum-type) - -(def-type-vops functionp check-function function - object-not-function-error function-pointer-type) - -(def-type-vops listp check-list list object-not-list-error - list-pointer-type) - -(def-type-vops structurep check-structure structure object-not-structure-error - structure-pointer-type) - -(def-type-vops bignump check-bigunm bignum - object-not-bignum-error bignum-type) - -(def-type-vops ratiop check-ratio ratio - object-not-ratio-error ratio-type) - -(def-type-vops complexp check-complex complex - object-not-complex-error complex-type) - -(def-type-vops single-float-p check-single-float single-float - object-not-single-float-error single-float-type) - -(def-type-vops double-float-p check-double-float double-float - object-not-double-float-error double-float-type) - -(def-type-vops simple-string-p check-simple-string simple-string - object-not-simple-string-error simple-string-type) - -(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector - object-not-simple-bit-vector-error simple-bit-vector-type) - -(def-type-vops simple-vector-p check-simple-vector simple-vector - object-not-simple-vector-error simple-vector-type) - -(def-type-vops simple-array-unsigned-byte-2-p - check-simple-array-unsigned-byte-2 - simple-array-unsigned-byte-2 - object-not-simple-array-unsigned-byte-2-error - simple-array-unsigned-byte-2-type) - -(def-type-vops simple-array-unsigned-byte-4-p - check-simple-array-unsigned-byte-4 - simple-array-unsigned-byte-4 - object-not-simple-array-unsigned-byte-4-error - simple-array-unsigned-byte-4-type) - -(def-type-vops simple-array-unsigned-byte-8-p - check-simple-array-unsigned-byte-8 - simple-array-unsigned-byte-8 - object-not-simple-array-unsigned-byte-8-error - simple-array-unsigned-byte-8-type) - -(def-type-vops simple-array-unsigned-byte-16-p - check-simple-array-unsigned-byte-16 - simple-array-unsigned-byte-16 - object-not-simple-array-unsigned-byte-16-error - simple-array-unsigned-byte-16-type) - -(def-type-vops simple-array-unsigned-byte-32-p - check-simple-array-unsigned-byte-32 - simple-array-unsigned-byte-32 - object-not-simple-array-unsigned-byte-32-error - simple-array-unsigned-byte-32-type) - -(def-type-vops simple-array-single-float-p check-simple-array-single-float - simple-array-single-float object-not-simple-array-single-float-error - simple-array-single-float-type) - -(def-type-vops simple-array-double-float-p check-simple-array-double-float - simple-array-double-float object-not-simple-array-double-float-error - simple-array-double-float-type) - -(def-type-vops base-char-p check-base-char base-char - object-not-base-char-error base-char-type) - -(def-type-vops system-area-pointer-p check-system-area-pointer - system-area-pointer object-not-sap-error sap-type) - -(def-type-vops weak-pointer-p check-weak-pointer weak-pointer - object-not-weak-pointer-error weak-pointer-type) - -(def-type-vops scavenger-hook-p nil nil nil - 0) - -(def-type-vops code-component-p nil nil nil - code-header-type) - -(def-type-vops lra-p nil nil nil - return-pc-header-type) - -(def-type-vops fdefn-p nil nil nil - fdefn-type) - -(def-type-vops funcallable-instance-p nil nil nil - funcallable-instance-header-type) - -(def-type-vops array-header-p nil nil nil - simple-array-type complex-string-type complex-bit-vector-type - complex-vector-type complex-array-type) - -(def-type-vops nil check-function-or-symbol nil - object-not-function-or-symbol-error - function-pointer-type symbol-header-type) - -(def-type-vops stringp check-string nil object-not-string-error - simple-string-type complex-string-type) - -(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error - simple-bit-vector-type complex-bit-vector-type) - -(def-type-vops vectorp check-vector nil object-not-vector-error - simple-string-type simple-bit-vector-type simple-vector-type - simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type - simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type - simple-array-unsigned-byte-32-type simple-array-single-float-type - simple-array-double-float-type complex-string-type - complex-bit-vector-type complex-vector-type) - -(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error - simple-array-type simple-string-type simple-bit-vector-type - simple-vector-type simple-array-unsigned-byte-2-type - simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type - simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type - simple-array-single-float-type simple-array-double-float-type) - -(def-type-vops arrayp check-array nil object-not-array-error - simple-array-type simple-string-type simple-bit-vector-type - simple-vector-type simple-array-unsigned-byte-2-type - simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type - simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type - simple-array-single-float-type simple-array-double-float-type - complex-string-type complex-bit-vector-type complex-vector-type - complex-array-type) - -(def-type-vops numberp check-number nil object-not-number-error - even-fixnum-type odd-fixnum-type bignum-type ratio-type - single-float-type double-float-type complex-type) - -(def-type-vops rationalp check-rational nil object-not-rational-error - even-fixnum-type odd-fixnum-type ratio-type bignum-type) - -(def-type-vops integerp check-integer nil object-not-integer-error - even-fixnum-type odd-fixnum-type bignum-type) - -(def-type-vops floatp check-float nil object-not-float-error - single-float-type double-float-type) - -(def-type-vops realp check-real nil object-not-real-error - even-fixnum-type odd-fixnum-type ratio-type bignum-type - single-float-type double-float-type) - - -;;;; Other integer ranges. - -;;; A (signed-byte 32) can be represented with either fixnum or a bignum with -;;; exactly one digit. - -(defun signed-byte-32-test (value temp not-p target not-target) - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - (assemble () - (inst extru value 31 2 zero-tn :<>) - (inst b yep :nullify t) - (inst extru value 31 3 temp) - (inst bci :<> nil other-pointer-type temp nope) - (loadw temp value 0 other-pointer-type) - (inst bci := not-p (+ (ash 1 type-bits) bignum-type) temp target))) - (undefined-value)) - -(define-vop (signed-byte-32-p type-predicate) - (:translate signed-byte-32-p) - (:generator 45 - (signed-byte-32-test value temp not-p target not-target) - NOT-TARGET)) - -(define-vop (check-signed-byte-32 check-type) - (:generator 45 - (let ((loose (generate-error-code vop object-not-signed-byte-32-error - value))) - (signed-byte-32-test value temp t loose okay)) - OKAY - (move value result))) - -;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a -;;; bignum with exactly one positive digit, or a bignum with exactly two digits -;;; and the second digit all zeros. - -(defun unsigned-byte-32-test (value temp not-p target not-target) - (let ((nope (if not-p target not-target))) - (assemble () - ;; Is it a fixnum? - (inst extru value 31 2 zero-tn :<>) - (inst b fixnum) - (inst move value temp) - - ;; If not, is it an other pointer? - (inst extru value 31 3 temp) - (inst bci :<> nil other-pointer-type temp nope) - ;; Get the header. - (loadw temp value 0 other-pointer-type) - ;; Is it one? - (inst bci := nil (+ (ash 1 type-bits) bignum-type) temp single-word) - ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst bci :<> nil (+ (ash 2 type-bits) bignum-type) temp nope) - ;; Get the second digit. - (loadw temp value (1+ bignum-digits-offset) other-pointer-type) - ;; All zeros, its an (unsigned-byte 32). - (inst comb (if not-p := :<>) temp zero-tn not-target :nullify t) - (inst b target :nullify t) - - SINGLE-WORD - ;; Get the single digit. - (loadw temp value bignum-digits-offset other-pointer-type) - - ;; positive implies (unsigned-byte 32). - FIXNUM - (inst bc :>= not-p temp zero-tn target))) - (undefined-value)) - -(define-vop (unsigned-byte-32-p type-predicate) - (:translate unsigned-byte-32-p) - (:generator 45 - (unsigned-byte-32-test value temp not-p target not-target) - NOT-TARGET)) - -(define-vop (check-unsigned-byte-32 check-type) - (:generator 45 - (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error - value))) - (unsigned-byte-32-test value temp t loose okay)) - OKAY - (move value result))) - - -;;;; List/symbol types: -;;; -;;; symbolp (or symbol (eq nil)) -;;; consp (and list (not (eq nil))) - -(define-vop (symbolp type-predicate) - (:translate symbolp) - (:generator 12 - (inst bc := nil value null-tn (if not-p drop-thru target)) - (test-type value temp target not-p symbol-header-type) - DROP-THRU)) - -(define-vop (check-symbol check-type) - (:generator 12 - (inst comb := value null-tn drop-thru) - (let ((error (generate-error-code vop object-not-symbol-error value))) - (test-type value temp error t symbol-header-type)) - DROP-THRU - (move value result))) - -(define-vop (consp type-predicate) - (:translate consp) - (:generator 8 - (inst bc := nil value null-tn (if not-p target drop-thru)) - (test-type value temp target not-p list-pointer-type) - DROP-THRU)) - -(define-vop (check-cons check-type) - (:generator 8 - (let ((error (generate-error-code vop object-not-cons-error value))) - (inst bc := nil value null-tn error) - (test-type value temp error t list-pointer-type)) - (move value result))) diff --git a/compiler/hppa/values.lisp b/compiler/hppa/values.lisp deleted file mode 100644 index 76ff19a0804f1109737a462af46e457f8ee3d6c5..0000000000000000000000000000000000000000 --- a/compiler/hppa/values.lisp +++ /dev/null @@ -1,89 +0,0 @@ -;;; -*- Package: HPPA -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/values.lisp,v 1.1 1992/07/13 03:48:39 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the implementation of unknown-values VOPs. -;;; -;;; Written by William Lott. -;;; - -(in-package "HPPA") - -(define-vop (reset-stack-pointer) - (:args (ptr :scs (any-reg))) - (:generator 1 - (move ptr csp-tn))) - - -;;; Push some values onto the stack, returning the start and number of values -;;; pushed as results. It is assumed that the Vals are wired to the standard -;;; argument locations. Nvals is the number of values to push. -;;; -;;; The generator cost is pseudo-random. We could get it right by defining a -;;; bogus SC that reflects the costs of the memory-to-memory moves for each -;;; operand, but this seems unworthwhile. -;;; -(define-vop (push-values) - (:args - (vals :more t)) - (:results (start :scs (any-reg) :from :load) - (count :scs (any-reg))) - (:info nvals) - (:temporary (:scs (descriptor-reg)) temp) - (:generator 20 - (move csp-tn start) - (inst addi (* nvals word-bytes) csp-tn csp-tn) - (do ((val vals (tn-ref-across val)) - (i 0 (1+ i))) - ((null val)) - (let ((tn (tn-ref-tn val))) - (sc-case tn - (descriptor-reg - (storew tn start i)) - (control-stack - (load-stack-tn temp tn) - (storew temp start i))))) - (inst li (fixnum nvals) count))) - - -;;; Push a list of values on the stack, returning Start and Count as used in -;;; unknown values continuations. -;;; -(define-vop (values-list) - (:args (arg :scs (descriptor-reg) :target list)) - (:arg-types list) - (:policy :fast-safe) - (:results (start :scs (any-reg)) - (count :scs (any-reg))) - (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (move arg list) - (inst comb := list null-tn done) - (move csp-tn start) - - LOOP - (loadw temp list cons-car-slot list-pointer-type) - (loadw list list cons-cdr-slot list-pointer-type) - (inst addi word-bytes csp-tn csp-tn) - (storew temp csp-tn -1) - (inst extru list 31 lowtag-bits ndescr) - (inst comib := list-pointer-type ndescr loop) - (inst comb := list null-tn done :nullify t) - (error-call vop bogus-argument-to-values-list-error list) - - DONE - (inst sub csp-tn start count))) - diff --git a/compiler/hppa/vm.lisp b/compiler/hppa/vm.lisp deleted file mode 100644 index 96ceb958cfbd827f8c39a10d86cd14083ab7e931..0000000000000000000000000000000000000000 --- a/compiler/hppa/vm.lisp +++ /dev/null @@ -1,359 +0,0 @@ -;;; -*- Package: hppa -*- -;;; -;;; ********************************************************************** -;;; 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/hppa/vm.lisp,v 1.1 1992/07/13 03:48:39 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition for the HP-PA. -;;; -;;; Written by William Lott. -;;; - -(in-package "HPPA") - - -;;;; Define the registers - -(eval-when (compile eval) - -(defmacro defreg (name offset) - (let ((offset-sym (symbolicate name "-OFFSET"))) - `(eval-when (compile eval load) - (defconstant ,offset-sym ,offset) - (setf (svref *register-names* ,offset-sym) ,(symbol-name name))))) - -(defmacro defregset (name &rest regs) - `(eval-when (compile eval load) - (defconstant ,name - (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))) - -); eval-when (compile eval) - - -(eval-when (compile load eval) - -(defvar *register-names* (make-array 32 :initial-element nil)) - -); eval-when (compile load eval) - - -;; Wired-zero -(defreg zero 0) -;; This gets trashed by the C call convention. -(defreg nfp 1) -(defreg cfunc 2) -;; These are the callee saves, so these registers are stay live -;; over call-out. -(defreg csp 3) -(defreg cfp 4) -(defreg bsp 5) -(defreg null 6) -(defreg alloc 7) -(defreg code 8) -(defreg fdefn 9) -(defreg lexenv 10) -(defreg nargs 11) -(defreg ocfp 12) -(defreg lra 13) -(defreg a0 14) -(defreg a1 15) -(defreg a2 16) -(defreg a3 17) -(defreg a4 18) -;; This is where the caller-saves registers start, but we don't really care -;; because we need to clear the above after call-out to make sure no pointers -;; into oldspace are kept around. -(defreg a5 19) -(defreg l0 20) -(defreg l1 21) -(defreg l2 22) -;; These are the 4 C argument registers. -(defreg nl3 23) -(defreg nl2 24) -(defreg nl1 25) -(defreg nl0 26) -;; The global Data Pointer. We just leave it alone, because we don't need it. -(defreg dp 27) -;; These two are use for C return values. -(defreg nl4 28) -(defreg nl5 29) -(defreg nsp 30) -(defreg lip 31) - -(defregset non-descriptor-regs - nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc) - -(defregset descriptor-regs - fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2) - -(defregset register-arg-offsets - a0 a1 a2 a3 a4 a5) - - -(define-storage-base registers :finite :size 32) -(define-storage-base float-registers :finite :size 64) -(define-storage-base control-stack :unbounded :size 8) -(define-storage-base non-descriptor-stack :unbounded :size 0) -(define-storage-base constant :non-packed) -(define-storage-base immediate-constant :non-packed) - -;;; -;;; Handy macro so we don't have to keep changing all the numbers whenever -;;; we insert a new storage class. -;;; -(defmacro define-storage-classes (&rest classes) - (do ((forms (list 'progn) - (let* ((class (car classes)) - (sc-name (car class)) - (constant-name (intern (concatenate 'simple-string - (string sc-name) - "-SC-NUMBER")))) - (list* `(define-storage-class ,sc-name ,index - ,@(cdr class)) - `(defconstant ,constant-name ,index) - `(export ',constant-name) - forms))) - (index 0 (1+ index)) - (classes classes (cdr classes))) - ((null classes) - (nreverse forms)))) - -(define-storage-classes - - ;; Non-immediate contstants in the constant pool - (constant constant) - - ;; ZERO and NULL are in registers. - (zero immediate-constant) - (null immediate-constant) - (fp-single-zero immediate-constant) - (fp-double-zero immediate-constant) - - ;; Anything else that can be an immediate. - (immediate immediate-constant) - - - ;; **** The stacks. - - ;; The control stack. (Scanned by GC) - (control-stack control-stack) - - ;; The non-descriptor stacks. - (signed-stack non-descriptor-stack) ; (signed-byte 32) - (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) - (base-char-stack non-descriptor-stack) ; non-descriptor characters. - (sap-stack non-descriptor-stack) ; System area pointers. - (single-stack non-descriptor-stack) ; single-floats - (double-stack non-descriptor-stack - :element-size 2 :alignment 2) ; double floats. - - - ;; **** Things that can go in the integer registers. - - ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing - ;; bad will happen if they are. (fixnums, characters, header values, etc). - (any-reg - registers - :locations #.(append non-descriptor-regs descriptor-regs) - :constant-scs (zero immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; Pointer descriptor objects. Must be seen by GC. - (descriptor-reg registers - :locations #.descriptor-regs - :constant-scs (constant null immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; Non-Descriptor characters - (base-char-reg registers - :locations #.non-descriptor-regs - :constant-scs (immediate) - :save-p t - :alternate-scs (base-char-stack)) - - ;; Non-Descriptor SAP's (arbitrary pointers into address space) - (sap-reg registers - :locations #.non-descriptor-regs - :constant-scs (immediate) - :save-p t - :alternate-scs (sap-stack)) - - ;; Non-Descriptor (signed or unsigned) numbers. - (signed-reg registers - :locations #.non-descriptor-regs - :constant-scs (zero immediate) - :save-p t - :alternate-scs (signed-stack)) - (unsigned-reg registers - :locations #.non-descriptor-regs - :constant-scs (zero immediate) - :save-p t - :alternate-scs (unsigned-stack)) - - ;; Random objects that must not be seen by GC. Used only as temporaries. - (non-descriptor-reg registers - :locations #.non-descriptor-regs) - - ;; Pointers to the interior of objects. Used only as an temporary. - (interior-reg registers - :locations (#.lip-offset)) - - - ;; **** Things that can go in the floating point registers. - - ;; Non-Descriptor single-floats. - (single-reg float-registers - :locations #.(loop for i from 4 to 31 collect i) - :constant-scs (fp-single-zero) - :save-p t - :alternate-scs (single-stack)) - - ;; Non-Descriptor double-floats. - (double-reg float-registers - :locations #.(loop for i from 4 to 31 collect i) - :constant-scs (fp-double-zero) - :save-p t - :alternate-scs (double-stack)) - - ;; A catch or unwind block. - (catch-block control-stack :element-size vm:catch-block-size)) - - -;;;; Make some random tns for important registers. - -(eval-when (compile eval) - -(defmacro defregtn (name sc) - (let ((offset-sym (symbolicate name "-OFFSET")) - (tn-sym (symbolicate name "-TN"))) - `(defparameter ,tn-sym - (make-random-tn :kind :normal - :sc (sc-or-lose ',sc) - :offset ,offset-sym)))) - -); eval-when (compile eval) - -;; These, we access by foo-TN only - -(defregtn zero any-reg) -(defregtn null descriptor-reg) -(defregtn code descriptor-reg) -(defregtn alloc any-reg) -(defregtn bsp any-reg) -(defregtn csp any-reg) -(defregtn cfp any-reg) -(defregtn nsp any-reg) - -;; These alias regular locations, so we have to make sure we don't bypass -;; the register allocator when using them. -(defregtn nargs any-reg) -(defregtn ocfp any-reg) -(defregtn lip interior-reg) - -;; And some floating point values. -(defparameter fp-single-zero-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'single-reg) - :offset 0)) -(defparameter fp-double-zero-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset 0)) - - -;;; Immediate-Constant-SC -- Interface -;;; -;;; If value can be represented as an immediate constant, then return the -;;; appropriate SC number, otherwise return NIL. -;;; -(def-vm-support-routine immediate-constant-sc (value) - (typecase value - ((integer 0 0) - (sc-number-or-lose 'zero *backend*)) - (null - (sc-number-or-lose 'null *backend*)) - ((or fixnum system-area-pointer character) - (sc-number-or-lose 'immediate *backend*)) - (symbol - (if (static-symbol-p value) - (sc-number-or-lose 'immediate *backend*) - nil)) - (single-float - (if (zerop value) - (sc-number-or-lose 'fp-single-zero) - nil)) - (double-float - (if (zerop value) - (sc-number-or-lose 'fp-double-zero) - nil)))) - - -;;;; Function Call Parameters - -;;; The SC numbers for register and stack arguments/return values. -;;; -(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) -(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) -(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) - -(eval-when (compile load eval) - -;;; Offsets of special stack frame locations -(defconstant ocfp-save-offset 0) -(defconstant lra-save-offset 1) -(defconstant nfp-save-offset 2) - -;;; The number of arguments/return values passed in registers. -;;; -(defconstant register-arg-count 6) - -;;; Names to use for the argument registers. -;;; -(defconstant register-arg-names '(a0 a1 a2 a3 a4 a5)) - -); Eval-When (Compile Load Eval) - - -;;; A list of TN's describing the register arguments. -;;; -(defparameter register-arg-tns - (mapcar #'(lambda (n) - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset n)) - register-arg-offsets)) - -;;; SINGLE-VALUE-RETURN-BYTE-OFFSET -;;; -;;; This is used by the debugger. -;;; -(export 'single-value-return-byte-offset) -(defconstant single-value-return-byte-offset 4) - - -;;; LOCATION-PRINT-NAME -- Interface -;;; -;;; This function is called by debug output routines that want a pretty name -;;; for a TN's location. It returns a thing that can be printed with PRINC. -;;; -(def-vm-support-routine location-print-name (tn) - (declare (type tn tn)) - (let ((sb (sb-name (sc-sb (tn-sc tn)))) - (offset (tn-offset tn))) - (ecase sb - (registers (or (svref *register-names* offset) - (format nil "R~D" offset))) - (float-registers (format nil "F~D" offset)) - (control-stack (format nil "CS~D" offset)) - (non-descriptor-stack (format nil "NS~D" offset)) - (constant (format nil "Const~D" offset)) - (immediate-constant "Immed")))) diff --git a/compiler/ir1final.lisp b/compiler/ir1final.lisp deleted file mode 100644 index 93a5d1d3fe87de5a117b22dfaf889872e88991fc..0000000000000000000000000000000000000000 --- a/compiler/ir1final.lisp +++ /dev/null @@ -1,139 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/ir1final.lisp,v 1.17 1992/12/09 00:10:25 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file implements the IR1 finalize phase, which checks for various -;;; semantic errors. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") - - -;;; Note-Failed-Optimization -- Internal -;;; -;;; Give the user grief about optimizations that we weren't able to do. It -;;; is assumed that they want to hear, or there wouldn't be any entries in the -;;; table. If the node has been deleted or is no longer a known call, then do -;;; nothing; some other optimization must have gotten to it. -;;; -(defun note-failed-optimization (node failures) - (declare (type combination node) (list failures)) - (unless (or (node-deleted node) - (not (function-info-p (combination-kind node)))) - (let ((*compiler-error-context* node)) - (dolist (failure failures) - (let ((what (cdr failure)) - (note (transform-note (car failure)))) - (cond - ((consp what) - (compiler-note "Unable to ~A because:~%~6T~?" - note (first what) (rest what))) - ((valid-function-use node what - :argument-test #'types-intersect - :result-test #'values-types-intersect) - (collect ((messages)) - (flet ((frob (string &rest stuff) - (messages string) - (messages stuff))) - (valid-function-use node what - :warning-function #'frob - :error-function #'frob)) - - (compiler-note "Unable to ~A due to type uncertainty:~@ - ~{~6T~?~^~&~}" - note (messages)))))))))) - - -;;; FINALIZE-XEP-DEFINITION -- Internal -;;; -;;; For each named function with an XEP, note the definition of that name, and -;;; add derived type information to the info environment. We also delete the -;;; FUNCTIONAL from *FREE-FUNCTIONS* to eliminate the possibility that new -;;; references might be converted to it. -;;; -(defun finalize-xep-definition (fun) - (let* ((leaf (functional-entry-function fun)) - (name (leaf-name leaf)) - (dtype (definition-type leaf))) - (setf (leaf-type leaf) dtype) - (when (or (and name (symbolp name)) - (and (consp name) (eq (car name) 'setf))) - (let* ((where (info function where-from name)) - (*compiler-error-context* (lambda-bind (main-entry leaf))) - (global-def (gethash name *free-functions*)) - (global-p - (and (defined-function-p global-def) - (eq (defined-function-functional global-def) leaf)))) - (note-name-defined name :function) - (when global-p - (remhash name *free-functions*)) - (ecase where - (:assumed - (let ((approx-type (info function assumed-type name))) - (when (and approx-type (function-type-p dtype)) - (valid-approximate-type approx-type dtype)) - (setf (info function type name) dtype) - (setf (info function assumed-type name) nil)) - (setf (info function where-from name) :defined)) - (:declared); Just keep declared type. - (:defined - (when global-p - (setf (info function type name) dtype))))))) - (undefined-value)) - - -;;; NOTE-ASSUMED-TYPES -- Internal -;;; -;;; Find all calls in Component to assumed functions and update the assumed -;;; type information. This is delayed until now so that we have the best -;;; possible information about the actual argument types. -;;; -(defun note-assumed-types (component name var) - (when (eq (leaf-where-from var) :assumed) - (assert (and (eq (info function where-from name) :assumed) - (eq (info function kind name) :function))) - (let ((atype (info function assumed-type name))) - (dolist (ref (leaf-refs var)) - (let ((dest (continuation-dest (node-cont ref)))) - (when (and (eq (block-component (node-block ref)) component) - (combination-p dest) - (eq (continuation-use (basic-combination-fun dest)) ref)) - (setq atype (note-function-use dest atype))))) - (setf (info function assumed-type name) atype)))) - - -;;; IR1-FINALIZE -- Interface -;;; -;;; Do miscellaneous things that we want to do once all optimization has -;;; been done: -;;; -- Record the derived result type before the back-end trashes the -;;; flow graph. -;;; -- Note definition of any entry points. -;;; -- Note any failed optimizations. -;;; -(defun ir1-finalize (component) - (declare (type component component)) - (dolist (fun (component-lambdas component)) - (case (functional-kind fun) - (:external - (finalize-xep-definition fun)) - ((nil) - (setf (leaf-type fun) (definition-type fun))))) - - (maphash #'note-failed-optimization - (component-failed-optimizations component)) - - (maphash #'(lambda (k v) - (note-assumed-types component k v)) - *free-functions*) - (undefined-value)) diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp deleted file mode 100644 index 7ecabf4b53e02e5f69a5b6730ab6e742683c3550..0000000000000000000000000000000000000000 --- a/compiler/ir1opt.lisp +++ /dev/null @@ -1,1658 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/ir1opt.lisp,v 1.56 1992/11/03 07:04:29 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file implements the IR1 optimization phase of the compiler. IR1 -;;; optimization is a grab-bag of optimizations that don't make major changes -;;; to the block-level control flow and don't use flow analysis. These -;;; optimizations can mostly be classified as "meta-evaluation", but there is a -;;; sizable top-down component as well. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package :c) - - -;;;; Interface for obtaining results of constant folding: - -;;; Constant-Continuation-P -- Interface -;;; -;;; Return true if the sole use of Cont is a reference to a constant leaf. -;;; -(proclaim '(function constant-continuation-p (continuation) boolean)) -(defun constant-continuation-p (cont) - (let ((use (continuation-use cont))) - (and (ref-p use) - (constant-p (ref-leaf use))))) - - -;;; Continuation-Value -- Interface -;;; -;;; Return the constant value for a continuation whose only use is a -;;; constant node. -;;; -(proclaim '(function continuation-value (continuation) t)) -(defun continuation-value (cont) - (assert (constant-continuation-p cont)) - (constant-value (ref-leaf (continuation-use cont)))) - - -;;;; Interface for obtaining results of type inference: - -;;; CONTINUATION-PROVEN-TYPE -- Interface -;;; -;;; Return a (possibly values) type that describes what we have proven about -;;; the type of Cont without taking any type assertions into consideration. -;;; This is just the union of the NODE-DERIVED-TYPE of all the uses. Most -;;; often people use CONTINUATION-DERIVED-TYPE or CONTINUATION-TYPE instead of -;;; using this function directly. -;;; -(defun continuation-proven-type (cont) - (declare (type continuation cont)) - (ecase (continuation-kind cont) - ((:block-start :deleted-block-start) - (let ((uses (block-start-uses (continuation-block cont)))) - (if uses - (do ((res (node-derived-type (first uses)) - (values-type-union (node-derived-type (first current)) - res)) - (current (rest uses) (rest current))) - ((null current) res)) - *empty-type*))) - (:inside-block - (node-derived-type (continuation-use cont))))) - - -;;; Continuation-Derived-Type -- Interface -;;; -;;; Our best guess for the type of this continuation's value. Note that -;;; this may be Values or Function type, which cannot be passed as an argument -;;; to the normal type operations. See Continuation-Type. This may be called -;;; on deleted continuations, always returning *. -;;; -;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the result -;;; is a subtype of the assertion. If so, return the proven type and set -;;; TYPE-CHECK to nil. Otherwise, return the intersection of the asserted and -;;; proven types, and set TYPE-CHECK T. If TYPE-CHECK already has a non-null -;;; value, then preserve it. Only in the somewhat unusual circumstance of -;;; a newly discovered assertion will we change TYPE-CHECK from NIL to T. -;;; -;;; The result value is cached in the Continuation-%Derived-Type. If the -;;; slot is true, just return that value, otherwise recompute and stash the -;;; value there. -;;; -(proclaim '(inline continuation-derived-type)) -(defun continuation-derived-type (cont) - (declare (type continuation cont)) - (or (continuation-%derived-type cont) - (%continuation-derived-type cont))) -;;; -(defun %continuation-derived-type (cont) - (declare (type continuation cont)) - (let ((proven (continuation-proven-type cont)) - (asserted (continuation-asserted-type cont))) - (cond ((values-subtypep proven asserted) - (setf (continuation-%type-check cont) nil) - (setf (continuation-%derived-type cont) proven)) - (t - (unless (or (continuation-%type-check cont) - (not (continuation-dest cont)) - (eq asserted *universal-type*)) - (setf (continuation-%type-check cont) t)) - - (setf (continuation-%derived-type cont) - (values-type-intersection asserted proven)))))) - - -;;; CONTINUATION-TYPE-CHECK -- Interface -;;; -;;; Call CONTINUATION-DERIVED-TYPE to make sure the slot is up to date, then -;;; return it. -;;; -(proclaim '(inline continuation-type-check)) -(defun continuation-type-check (cont) - (declare (type continuation cont)) - (continuation-derived-type cont) - (continuation-%type-check cont)) - - -;;; Continuation-Type -- Interface -;;; -;;; Return the derived type for Cont's first value. This is guaranteed not -;;; to be a Values or Function type. -;;; -(proclaim '(function continuation-type (continuation) ctype)) -(defun continuation-type (cont) - (single-value-type (continuation-derived-type cont))) - - -;;;; Interface routines used by optimizers: - -;;; Reoptimize-Continuation -- Interface -;;; -;;; This function is called by optimizers to indicate that something -;;; interesting has happened to the value of Cont. Optimizers must make sure -;;; that they don't call for reoptimization when nothing has happened, since -;;; optimization will fail to terminate. -;;; -;;; We clear any cached type for the continuation and set the reoptimize -;;; flags on everything in sight, unless the continuation is deleted (in which -;;; case we do nothing.) -;;; -;;; Since this can get called curing IR1 conversion, we have to be careful -;;; not to fly into space when the Dest's Prev is missing. -;;; -(defun reoptimize-continuation (cont) - (declare (type continuation cont)) - (unless (member (continuation-kind cont) '(:deleted :unused)) - (setf (continuation-%derived-type cont) nil) - (let ((dest (continuation-dest cont))) - (when dest - (setf (continuation-reoptimize cont) t) - (setf (node-reoptimize dest) t) - (let ((prev (node-prev dest))) - (when prev - (let* ((block (continuation-block prev)) - (component (block-component block))) - (when (typep dest 'cif) - (setf (block-test-modified block) t)) - (setf (block-reoptimize block) t) - (setf (component-reoptimize component) t)))))) - (do-uses (node cont) - (setf (block-type-check (node-block node)) t))) - (undefined-value)) - - -;;; Derive-Node-Type -- Interface -;;; -;;; Annotate Node to indicate that its result has been proven to be typep to -;;; RType. After IR1 conversion has happened, this is the only correct way to -;;; supply information discovered about a node's type. If you fuck with the -;;; Node-Derived-Type directly, then information may be lost and reoptimization -;;; may not happen. -;;; -;;; What we do is intersect Rtype with Node's Derived-Type. If the -;;; intersection is different from the old type, then we do a -;;; Reoptimize-Continuation on the Node-Cont. -;;; -(defun derive-node-type (node rtype) - (declare (type node node) (type ctype rtype)) - (let ((node-type (node-derived-type node))) - (unless (eq node-type rtype) - (let ((int (values-type-intersection node-type rtype))) - (when (type/= node-type int) - (when (and *check-consistency* - (eq int *empty-type*) - (not (eq rtype *empty-type*))) - (let ((*compiler-error-context* node)) - (compiler-warning - "New inferred type ~S conflicts with old type:~ - ~% ~S~%*** Bug?" - (type-specifier rtype) (type-specifier node-type)))) - (setf (node-derived-type node) int) - (reoptimize-continuation (node-cont node)))))) - (undefined-value)) - -(declaim (start-block assert-continuation-type assert-call-type)) - -;;; Assert-Continuation-Type -- Interface -;;; -;;; Similar to Derive-Node-Type, but asserts that it is an error for Cont's -;;; value not to be typep to Type. If we improve the assertion, we set -;;; TYPE-CHECK and TYPE-ASSERTED to guarantee that the new assertion will be -;;; checked. -;;; -(defun assert-continuation-type (cont type) - (declare (type continuation cont) (type ctype type)) - (let ((cont-type (continuation-asserted-type cont))) - (unless (eq cont-type type) - (let ((int (values-type-intersection cont-type type))) - (when (type/= cont-type int) - (setf (continuation-asserted-type cont) int) - (do-uses (node cont) - (setf (block-attributep (block-flags (node-block node)) - type-check type-asserted) - t)) - (reoptimize-continuation cont))))) - (undefined-value)) - - -;;; Assert-Call-Type -- Interface -;;; -;;; Assert that Call is to a function of the specified Type. It is assumed -;;; that the call is legal and has only constants in the keyword positions. -;;; -(defun assert-call-type (call type) - (declare (type combination call) (type function-type type)) - (derive-node-type call (function-type-returns type)) - (let ((args (combination-args call))) - (dolist (req (function-type-required type)) - (when (null args) (return-from assert-call-type)) - (let ((arg (pop args))) - (assert-continuation-type arg req))) - (dolist (opt (function-type-optional type)) - (when (null args) (return-from assert-call-type)) - (let ((arg (pop args))) - (assert-continuation-type arg opt))) - - (let ((rest (function-type-rest type))) - (when rest - (dolist (arg args) - (assert-continuation-type arg rest)))) - - (dolist (key (function-type-keywords type)) - (let ((name (key-info-name key))) - (do ((arg args (cddr arg))) - ((null arg)) - (when (eq (continuation-value (first arg)) name) - (assert-continuation-type - (second arg) (key-info-type key))))))) - (undefined-value)) - - -;;;; IR1-OPTIMIZE: - -(declaim (start-block ir1-optimize)) - -;;; IR1-Optimize -- Interface -;;; -;;; Do one forward pass over Component, deleting unreachable blocks and -;;; doing IR1 optimizations. We can ignore all blocks that don't have the -;;; Reoptimize flag set. If Component-Reoptimize is true when we are done, -;;; then another iteration would be beneficial. -;;; -;;; We delete blocks when there is either no predecessor or the block is in -;;; a lambda that has been deleted. These blocks would eventually be deleted -;;; by DFO recomputation, but doing it here immediately makes the effect -;;; avaliable to IR1 optimization. -;;; -(defun ir1-optimize (component) - (declare (type component component)) - (setf (component-reoptimize component) nil) - (do-blocks (block component) - (cond - ((or (block-delete-p block) - (null (block-pred block)) - (eq (functional-kind (block-home-lambda block)) :deleted)) - (delete-block block)) - (t - (loop - (let ((succ (block-succ block))) - (unless (and succ (null (rest succ))) - (return))) - - (let ((last (block-last block))) - (typecase last - (cif - (flush-dest (if-test last)) - (when (unlink-node last) (return))) - (exit - (when (maybe-delete-exit last) (return))))) - - (unless (join-successor-if-possible block) - (return))) - - (when (and (block-reoptimize block) (block-component block)) - (assert (not (block-delete-p block))) - (ir1-optimize-block block)) - - (when (and (block-flush-p block) (block-component block)) - (assert (not (block-delete-p block))) - (flush-dead-code block))))) - - (undefined-value)) - - -;;; IR1-Optimize-Block -- Internal -;;; -;;; Loop over the nodes in Block, looking for stuff that needs to be -;;; optimized. We dispatch off of the type of each node with its reoptimize -;;; flag set: -;;; -- With a combination, we call Propagate-Function-Change whenever the -;;; function changes, and call IR1-Optimize-Combination if any argument -;;; changes. -;;; -- With an Exit, we derive the node's type from the Value's type. We don't -;;; propagate Cont's assertion to the Value, since if we did, this would -;;; move the checking of Cont's assertion to the exit. This wouldn't work -;;; with Catch and UWP, where the Exit node is just a placeholder for the -;;; actual unknown exit. -;;; -;;; Note that we clear the node & block reoptimize flags *before* doing the -;;; optimization. This ensures that the node or block will be reoptimized if -;;; necessary. We leave the NODE-OPTIMIZE flag set going into -;;; IR1-OPTIMIZE-RETURN, since it wants to clear the flag itself. -;;; -(defun ir1-optimize-block (block) - (declare (type cblock block)) - (setf (block-reoptimize block) nil) - (do-nodes (node cont block :restart-p t) - (when (node-reoptimize node) - (setf (node-reoptimize node) nil) - (typecase node - (ref) - (combination - (ir1-optimize-combination node)) - (cif - (ir1-optimize-if node)) - (creturn - (setf (node-reoptimize node) t) - (ir1-optimize-return node)) - (mv-combination - (ir1-optimize-mv-combination node)) - (exit - (let ((value (exit-value node))) - (when value - (derive-node-type node (continuation-derived-type value))))) - (cset - (ir1-optimize-set node))))) - (undefined-value)) - - -;;; Join-Successor-If-Possible -- Internal -;;; -;;; We cannot combine with a successor block if: -;;; 1] The successor has more than one predecessor. -;;; 2] The last node's Cont is also used somewhere else. -;;; 3] The successor is the current block (infinite loop). -;;; 4] The next block has a different cleanup, and thus we may want to insert -;;; cleanup code between the two blocks at some point. -;;; 5] The next block has a different home lambda, and thus the control -;;; transfer is a non-local exit. -;;; -;;; If we succeed, we return true, otherwise false. -;;; -;;; Joining is easy when the successor's Start continuation is the same from -;;; our Last's Cont. If they differ, then we can still join when the last -;;; continuation has no next and the next continuation has no uses. In this -;;; case, we replace the next continuation with the last before joining the -;;; blocks. -;;; -(defun join-successor-if-possible (block) - (declare (type cblock block)) - (let ((next (first (block-succ block)))) - (when (block-start next) - (let* ((last (block-last block)) - (last-cont (node-cont last)) - (next-cont (block-start next))) - (cond ((or (rest (block-pred next)) - (not (eq (continuation-use last-cont) last)) - (eq next block) - (not (eq (block-end-cleanup block) - (block-start-cleanup next))) - (not (eq (block-home-lambda block) - (block-home-lambda next)))) - nil) - ((eq last-cont next-cont) - (join-blocks block next) - t) - ((and (null (block-start-uses next)) - (eq (continuation-kind last-cont) :inside-block)) - (let ((next-node (continuation-next next-cont))) - ;; - ;; If next-cont does have a dest, it must be unreachable, - ;; since there are no uses. DELETE-CONTINUATION will mark the - ;; dest block as delete-p [and also this block, unless it is - ;; no longer backward reachable from the dest block.] - (delete-continuation next-cont) - (setf (node-prev next-node) last-cont) - (setf (continuation-next last-cont) next-node) - (setf (block-start next) last-cont) - (join-blocks block next)) - t) - (t - nil)))))) - - -;;; Join-Blocks -- Internal -;;; -;;; Join together two blocks which have the same ending/starting -;;; continuation. The code in Block2 is moved into Block1 and Block2 is -;;; deleted from the DFO. We combine the optimize flags for the two blocks so -;;; that any indicated optimization gets done. -;;; -(defun join-blocks (block1 block2) - (declare (type cblock block1 block2)) - (let* ((last (block-last block2)) - (last-cont (node-cont last)) - (succ (block-succ block2)) - (start2 (block-start block2))) - (do ((cont start2 (node-cont (continuation-next cont)))) - ((eq cont last-cont) - (when (eq (continuation-kind last-cont) :inside-block) - (setf (continuation-block last-cont) block1))) - (setf (continuation-block cont) block1)) - - (unlink-blocks block1 block2) - (dolist (block succ) - (unlink-blocks block2 block) - (link-blocks block1 block)) - - (setf (block-last block1) last) - (setf (continuation-kind start2) :inside-block)) - - (setf (block-flags block1) - (attributes-union (block-flags block1) - (block-flags block2) - (block-attributes type-asserted test-modified))) - - (let ((next (block-next block2)) - (prev (block-prev block2))) - (setf (block-next prev) next) - (setf (block-prev next) prev)) - - (undefined-value)) - -;;; Flush-Dead-Code -- Internal -;;; -;;; Delete any nodes in Block whose value is unused and have no -;;; side-effects. We can delete sets of lexical variables when the set -;;; variable has no references. -;;; -;;; [### For now, don't delete potentially flushable calls when they have the -;;; Call attribute. Someday we should look at the funcitonal args to determine -;;; if they have any side-effects.] -;;; -(defun flush-dead-code (block) - (declare (type cblock block)) - (do-nodes-backwards (node cont block) - (unless (continuation-dest cont) - (typecase node - (ref - (delete-ref node) - (unlink-node node)) - (combination - (let ((info (combination-kind node))) - (when (function-info-p info) - (let ((attr (function-info-attributes info))) - (when (and (ir1-attributep attr flushable) - (not (ir1-attributep attr call))) - (flush-dest (combination-fun node)) - (dolist (arg (combination-args node)) - (flush-dest arg)) - (unlink-node node)))))) - (mv-combination - (when (eq (basic-combination-kind node) :local) - (let ((fun (combination-lambda node))) - (when (dolist (var (lambda-vars fun) t) - (when (or (leaf-refs var) - (lambda-var-sets var)) - (return nil))) - (flush-dest (first (basic-combination-args node))) - (delete-let fun))))) - (exit - (let ((value (exit-value node))) - (when value - (flush-dest value) - (setf (exit-value node) nil)))) - (cset - (let ((var (set-var node))) - (when (and (lambda-var-p var) - (null (leaf-refs var))) - (flush-dest (set-value node)) - (setf (basic-var-sets var) - (delete node (basic-var-sets var))) - (unlink-node node))))))) - - (setf (block-flush-p block) nil) - (undefined-value)) - -(declaim (end-block)) - - -;;;; Local call return type propagation: - -;;; Find-Result-Type -- Internal -;;; -;;; This function is called on RETURN nodes that have their REOPTIMIZE flag -;;; set. It iterates over the uses of the RESULT, looking for interesting -;;; stuff to update the TAIL-SET. If a use isn't a local call, then we union -;;; its type together with the types of other such uses. We assign to the -;;; RETURN-RESULT-TYPE the intersection of this type with the RESULT's asserted -;;; type. We can make this intersection now (potentially before type checking) -;;; because this assertion on the result will eventually be checked (if -;;; appropriate.) -;;; -;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV combination, -;;; which may change the succesor of the call to be the called function, and if -;;; so, checks if the call can become an assignment. If we convert to an -;;; assignment, we abort, since the RETURN has been deleted. -;;; -(defun find-result-type (node) - (declare (type creturn node)) - (let ((result (return-result node))) - (collect ((use-union *empty-type* values-type-union)) - (do-uses (use result) - (cond ((and (basic-combination-p use) - (eq (basic-combination-kind use) :local)) - (assert (eq (lambda-tail-set (node-home-lambda use)) - (lambda-tail-set (combination-lambda use)))) - (when (combination-p use) - (when (nth-value 1 (maybe-convert-tail-local-call use)) - (return-from find-result-type (undefined-value))))) - (t - (use-union (node-derived-type use))))) - (let ((int (values-type-intersection - (continuation-asserted-type result) - (use-union)))) - (setf (return-result-type node) int)))) - (undefined-value)) - - -;;; IR1-Optimize-Return -- Internal -;;; -;;; Do stuff to realize that something has changed about the value delivered -;;; to a return node. Since we consider the return values of all functions in -;;; the tail set to be equivalent, this amounts to bringing the entire tail set -;;; up to date. We iterate over the returns for all the functions in the tail -;;; set, reanalyzing them all (not treating Node specially.) -;;; -;;; When we are done, we check if the new type is different from the old -;;; TAIL-SET-TYPE. If so, we set the type and also reoptimize all the -;;; continuations for references to functions in the tail set. This will -;;; cause IR1-OPTIMIZE-COMBINATION to derive the new type as the results of the -;;; calls. -;;; -(defun ir1-optimize-return (node) - (declare (type creturn node)) - (let* ((tails (lambda-tail-set (return-lambda node))) - (funs (tail-set-functions tails))) - (collect ((res *empty-type* values-type-union)) - (dolist (fun funs) - (let ((return (lambda-return fun))) - (when return - (when (node-reoptimize return) - (setf (node-reoptimize node) nil) - (find-result-type return)) - (res (return-result-type return))))) - - (when (type/= (res) (tail-set-type tails)) - (setf (tail-set-type tails) (res)) - (dolist (fun (tail-set-functions tails)) - (dolist (ref (leaf-refs fun)) - (reoptimize-continuation (node-cont ref))))))) - - (undefined-value)) - - -;;; IF optimization: - -(declaim (start-block ir1-optimize-if)) - -;;; IR1-Optimize-If -- Internal -;;; -;;; If the test has multiple uses, replicate the node when possible. Also -;;; check if the predicate is known to be true or false, deleting the IF node -;;; in favor of the appropriate branch when this is the case. -;;; -(defun ir1-optimize-if (node) - (declare (type cif node)) - (let ((test (if-test node)) - (block (node-block node))) - - (when (and (eq (block-start block) test) - (eq (continuation-next test) node) - (rest (block-start-uses block))) - (do-uses (use test) - (when (immediately-used-p test use) - (convert-if-if use node) - (when (continuation-use test) (return))))) - - (let* ((type (continuation-type test)) - (victim - (cond ((constant-continuation-p test) - (if (continuation-value test) - (if-alternative node) - (if-consequent node))) - ((not (types-intersect type *null-type*)) - (if-alternative node)) - ((type= type *null-type*) - (if-consequent node))))) - (when victim - (flush-dest test) - (when (rest (block-succ block)) - (unlink-blocks block victim)) - (setf (component-reanalyze (block-component (node-block node))) t) - (unlink-node node)))) - (undefined-value)) - - -;;; Convert-If-If -- Internal -;;; -;;; Create a new copy of an IF Node that tests the value of the node Use. -;;; The test must have >1 use, and must be immediately used by Use. Node must -;;; be the only node in its block (implying that block-start = if-test). -;;; -;;; This optimization has an effect semantically similar to the -;;; source-to-source transformation: -;;; (IF (IF A B C) D E) ==> -;;; (IF A (IF B D E) (IF C D E)) -;;; -;;; We clobber the NODE-SOURCE-PATH of both the original and the new node so -;;; that dead code deletion notes will definitely not consider either node to -;;; be part of the original source. One node might become unreachable, -;;; resulting in a spurious note. -;;; -(defun convert-if-if (use node) - (declare (type node use) (type cif node)) - (with-ir1-environment node - (let* ((block (node-block node)) - (test (if-test node)) - (cblock (if-consequent node)) - (ablock (if-alternative node)) - (use-block (node-block use)) - (dummy-cont (make-continuation)) - (new-cont (make-continuation)) - (new-node (make-if :test new-cont - :consequent cblock :alternative ablock)) - (new-block (continuation-starts-block new-cont))) - (prev-link new-node new-cont) - (setf (continuation-dest new-cont) new-node) - (add-continuation-use new-node dummy-cont) - (setf (block-last new-block) new-node) - - (unlink-blocks use-block block) - (delete-continuation-use use) - (add-continuation-use use new-cont) - (link-blocks use-block new-block) - - (link-blocks new-block cblock) - (link-blocks new-block ablock) - - (push "<IF Duplication>" (node-source-path node)) - (push "<IF Duplication>" (node-source-path new-node)) - - (reoptimize-continuation test) - (reoptimize-continuation new-cont) - (setf (component-reanalyze *current-component*) t))) - (undefined-value)) - -(declaim (end-block)) - - -;;;; Exit IR1 optimization: - -;;; Maybe-Delete-Exit -- Interface -;;; -;;; This function attempts to delete an exit node, returning true if it -;;; deletes the block as a consequence: -;;; -- If the exit is degenerate (has no Entry), then we don't do anything, -;;; since there is nothing to be done. -;;; -- If the exit node and its Entry have the same home lambda then we know -;;; the exit is local, and can delete the exit. We change uses of the -;;; Exit-Value to be uses of the original continuation, then unlink the -;;; node. If the exit is to a TR context, then we must do MERGE-TAIL-SETS -;;; on any local calls which delivered their value to this exit. -;;; -- If there is no value (as in a GO), then we skip the value semantics. -;;; -;;; This function is also called by environment analysis, since it wants all -;;; exits to be optimized even if normal optimization was omitted. -;;; -(defun maybe-delete-exit (node) - (declare (type exit node)) - (let ((value (exit-value node)) - (entry (exit-entry node)) - (cont (node-cont node))) - (when (and entry - (eq (node-home-lambda node) (node-home-lambda entry))) - (setf (entry-exits entry) (delete node (entry-exits entry))) - (prog1 - (unlink-node node) - (when value - (collect ((merges)) - (when (return-p (continuation-dest cont)) - (do-uses (use value) - (when (and (basic-combination-p use) - (eq (basic-combination-kind use) :local)) - (merges use)))) - (substitute-continuation-uses cont value) - (dolist (merge (merges)) - (merge-tail-sets merge)))))))) - - -;;;; Combination IR1 optimization: - -(declaim (start-block ir1-optimize-combination maybe-terminate-block - validate-call-type)) - -;;; Ir1-Optimize-Combination -- Internal -;;; -;;; Do IR1 optimizations on a Combination node. -;;; -(proclaim '(function ir1-optimize-combination (combination) void)) -(defun ir1-optimize-combination (node) - (when (continuation-reoptimize (basic-combination-fun node)) - (propagate-function-change node)) - (let ((args (basic-combination-args node)) - (kind (basic-combination-kind node))) - (case kind - (:local - (let ((fun (combination-lambda node))) - (if (eq (functional-kind fun) :let) - (propagate-let-args node fun) - (propagate-local-call-args node fun)))) - ((:full :error) - (dolist (arg args) - (when arg - (setf (continuation-reoptimize arg) nil)))) - (t - (dolist (arg args) - (when arg - (setf (continuation-reoptimize arg) nil))) - - (let ((attr (function-info-attributes kind))) - (when (and (ir1-attributep attr foldable) - (not (ir1-attributep attr call)) - (every #'constant-continuation-p args) - (continuation-dest (node-cont node))) - (constant-fold-call node) - (return-from ir1-optimize-combination))) - - (let ((fun (function-info-derive-type kind))) - (when fun - (let ((res (funcall fun node))) - (when res - (derive-node-type node res) - (maybe-terminate-block node nil))))) - - (let ((fun (function-info-optimizer kind))) - (unless (and fun (funcall fun node)) - (dolist (x (function-info-transforms kind)) - (unless (ir1-transform node x) - (return)))))))) - - (undefined-value)) - - -;;; MAYBE-TERMINATE-BLOCK -- Interface -;;; -;;; If Call is to a function that doesn't return (type NIL), then terminate -;;; the block there, and link it to the component tail. We also change the -;;; call's CONT to be a dummy continuation to prevent the use from confusing -;;; things. -;;; -;;; Except when called during IR1, we delete the continuation if it has no -;;; other uses. (If it does have other uses, we reoptimize.) -;;; -;;; Termination on the basis of a continuation type assertion is inhibited -;;; when: -;;; -- The continuation is deleted (hence the assertion is spurious), or -;;; -- We are in IR1 conversion (where THE assertions are subject to -;;; weakening.) -;;; -(defun maybe-terminate-block (call ir1-p) - (declare (type basic-combination call)) - (let* ((block (node-block call)) - (cont (node-cont call)) - (tail (component-tail (block-component block))) - (succ (first (block-succ block)))) - (unless (or (and (eq call (block-last block)) (eq succ tail)) - (block-delete-p block) - *converting-for-interpreter*) - (when (or (and (eq (continuation-asserted-type cont) *empty-type*) - (not (or ir1-p (eq (continuation-kind cont) :deleted)))) - (eq (node-derived-type call) *empty-type*)) - (cond (ir1-p - (delete-continuation-use call) - (cond - ((block-last block) - (assert (and (eq (block-last block) call) - (eq (continuation-kind cont) :block-start)))) - (t - (setf (block-last block) call) - (link-blocks block (continuation-starts-block cont))))) - (t - (node-ends-block call) - (delete-continuation-use call) - (if (eq (continuation-kind cont) :unused) - (delete-continuation cont) - (reoptimize-continuation cont)))) - - (unlink-blocks block (first (block-succ block))) - (setf (component-reanalyze (block-component block)) t) - (assert (not (block-succ block))) - (link-blocks block tail) - (add-continuation-use call (make-continuation)) - t)))) - - -;;; Recognize-Known-Call -- Interface -;;; -;;; Called both by IR1 conversion and IR1 optimization when they have -;;; verified the type signature for the call, and are wondering if something -;;; should be done to special-case the call. If Call is a call to a global -;;; function, then see if it defined or known: -;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert the -;;; expansion and change the call to call it. Expansion is enabled if -;;; :INLINE or if space=0. If the FUNCTIONAL slot is true, we never expand, -;;; since this function has already been converted. Local call analysis -;;; will duplicate the definition if necessary. We claim that the parent -;;; form is LABELS for context declarations, since we don't want it to be -;;; considered a real global function. -;;; -- In addition to a direct check for the function name in the table, we -;;; also must check for slot accessors. If the function is a slot accessor, -;;; then we set the combination kind to the function info of %Slot-Setter or -;;; %Slot-Accessor, as appropriate. -;;; -- If it is a known function, mark it as such by setting the Kind. -;;; -;;; We return the leaf referenced (NIL if not a leaf) and the function-info -;;; assigned. -;;; -(defun recognize-known-call (call ir1-p) - (declare (type combination call)) - (let* ((ref (continuation-use (basic-combination-fun call))) - (leaf (when (ref-p ref) (ref-leaf ref))) - (inlinep (if (defined-function-p leaf) - (defined-function-inlinep leaf) - :no-chance))) - (cond - ((eq inlinep :notinline) (values nil nil)) - ((not (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function))) - (values leaf nil)) - ((and (ecase inlinep - (:inline t) - (:no-chance nil) - ((nil :maybe-inline) (policy call (zerop space)))) - (defined-function-inline-expansion leaf) - (let ((fun (defined-function-functional leaf))) - (or (not fun) - (and (eq inlinep :inline) (functional-kind fun)))) - (inline-expansion-ok call)) - (flet ((frob () - (let ((res (ir1-convert-lambda-for-defun - (defined-function-inline-expansion leaf) - leaf t - #'ir1-convert-inline-lambda - 'labels))) - (setf (defined-function-functional leaf) res) - (change-ref-leaf ref res)))) - (if ir1-p - (frob) - (with-ir1-environment call - (frob) - (local-call-analyze *current-component*)))) - - (values (ref-leaf (continuation-use (basic-combination-fun call))) - nil)) - (t - (let* ((name (leaf-name leaf)) - (info (info function info - (if (slot-accessor-p leaf) - (if (consp name) '%slot-setter '%slot-accessor) - name)))) - (if info - (values leaf (setf (basic-combination-kind call) info)) - (values leaf nil))))))) - - -;;; VALIDATE-CALL-TYPE -- Internal -;;; -;;; Check if Call satisfies Type. If so, apply the type to the call, and do -;;; MAYBE-TERMINATE-BLOCK and return the values of RECOGNIZE-KNOWN-CALL. If an -;;; error, set the combination kind and return NIL, NIL. -;;; -(defun validate-call-type (call type ir1-p) - (declare (type combination call) (type ctype type)) - (cond ((not (function-type-p type)) (values nil nil)) - ((valid-function-use call type - :argument-test #'always-subtypep - :result-test #'always-subtypep - :error-function #'compiler-warning - :warning-function #'compiler-note) - (assert-call-type call type) - (maybe-terminate-block call ir1-p) - (recognize-known-call call ir1-p)) - (t - (setf (combination-kind call) :error) - (values nil nil)))) - - -;;; Propagate-Function-Change -- Internal -;;; -;;; Called by Ir1-Optimize when the function for a call has changed. -;;; If the call is local, we try to let-convert it, and derive the result type. -;;; If it is a :FULL call, we validate it against the type, which recognizes -;;; known calls, does inline expansion, etc. If a call to a predicate in a -;;; non-conditional position or to a function with a source transform, then we -;;; reconvert the form to give IR1 another chance. -;;; -(defun propagate-function-change (call) - (declare (type combination call)) - (let ((*compiler-error-context* call) - (fun-cont (basic-combination-fun call))) - (setf (continuation-reoptimize fun-cont) nil) - (case (combination-kind call) - (:local - (let ((fun (combination-lambda call))) - (maybe-let-convert fun) - (unless (member (functional-kind fun) '(:let :assignment :deleted)) - (derive-node-type call (tail-set-type (lambda-tail-set fun)))))) - (:full - (multiple-value-bind - (leaf info) - (validate-call-type call (continuation-derived-type fun-cont) nil) - (cond ((functional-p leaf) - (convert-call-if-possible - (continuation-use (basic-combination-fun call)) - call)) - ((not leaf)) - ((or (info function source-transform (leaf-name leaf)) - (and info - (ir1-attributep (function-info-attributes info) - predicate) - (let ((dest (continuation-dest (node-cont call)))) - (and dest (not (if-p dest)))))) - (let ((name (leaf-name leaf))) - (when (symbolp name) - (let ((dums (loop repeat (length (combination-args call)) - collect (gensym)))) - (transform-call call - `(lambda ,dums - (,name ,@dums)))))))))))) - (undefined-value)) - - -;;;; Known function optimization: - - -;;; RECORD-OPTIMIZATION-FAILURE -- Internal -;;; -;;; Add a failed optimization note to FAILED-OPTIMZATIONS for Node, Fun -;;; and Args. If there is already a note for Node and Transform, replace it, -;;; otherwise add a new one. -;;; -(defun record-optimization-failure (node transform args) - (declare (type combination node) (type transform transform) - (type (or function-type list) args)) - (let* ((table (component-failed-optimizations *compile-component*)) - (found (assoc transform (gethash node table)))) - (if found - (setf (cdr found) args) - (push (cons transform args) (gethash node table)))) - (undefined-value)) - - -;;; IR1-Transform -- Internal -;;; -;;; Attempt to transform Node using Function, subject to the call type -;;; constraint Type. If we are inhibited from doing the transform for some -;;; reason and Flame is true, then we make a note of the message in -;;; FAILED-OPTIMIZATIONS for IR1 finalize to pick up. We return true if -;;; the transform failed, and thus further transformation should be -;;; attempted. We return false if either the transform suceeded or was -;;; aborted. -;;; -(defun ir1-transform (node transform) - (declare (type combination node) (type transform transform)) - (let* ((type (transform-type transform)) - (fun (transform-function transform)) - (constrained (function-type-p type)) - (table (component-failed-optimizations *compile-component*)) - (flame - (if (transform-important transform) - (policy node (>= speed brevity)) - (policy node (> speed brevity)))) - (*compiler-error-context* node)) - (cond ((or (not constrained) - (valid-function-use node type :strict-result t)) - (multiple-value-bind - (severity args) - (catch 'give-up - (transform-call node (funcall fun node)) - (values :none nil)) - (ecase severity - (:none - (remhash node table) - nil) - (:aborted - (setf (combination-kind node) :error) - (when args - (apply #'compiler-warning args)) - (remhash node table) - nil) - (:failure - (if args - (when flame - (record-optimization-failure node transform args)) - (setf (gethash node table) - (remove transform (gethash node table) :key #'car))) - t)))) - ((and flame - (valid-function-use node type - :argument-test #'types-intersect - :result-test #'values-types-intersect)) - (record-optimization-failure node transform type) - t) - (t - t)))) - -(declaim (end-block)) - -;;; GIVE-UP, ABORT-TRANSFORM -- Interface -;;; -;;; Just throw the severity and args... -;;; -(proclaim '(function give-up (&rest t) nil)) -(defun give-up (&rest args) - "This function is used to throw out of an IR1 transform, aborting this - attempt to transform the call, but admitting the possibility that this or - some other transform will later suceed. If arguments are supplied, they are - format arguments for an efficiency note." - (throw 'give-up (values :failure args))) -;;; -(defun abort-transform (&rest args) - "This function is used to throw out of an IR1 transform and force a normal - call to the function at run time. No further optimizations will be - attempted." - (throw 'give-up (values :aborted args))) - - -;;; Transform-Call -- Internal -;;; -;;; Take the lambda-expression Res, IR1 convert it in the proper -;;; environment, and then install it as the function for the call Node. We do -;;; local call analysis so that the new function is integrated into the control -;;; flow. -;;; -(defun transform-call (node res) - (declare (type combination node) (list res)) - (with-ir1-environment node - (let ((new-fun (ir1-convert-inline-lambda res)) - (ref (continuation-use (combination-fun node)))) - (change-ref-leaf ref new-fun) - (setf (combination-kind node) :full) - (local-call-analyze *current-component*))) - (undefined-value)) - - -;;; Constant-Fold-Call -- Internal -;;; -;;; Replace a call to a foldable function of constant arguments with the -;;; result of evaluating the form. We insert the resulting constant node after -;;; the call, stealing the call's continuation. We give the call a -;;; continuation with no Dest, which should cause it and its arguments to go -;;; away. If there is an error during the evaluation, we give a warning and -;;; leave the call alone, making the call a :ERROR call. -;;; -;;; If there is more than one value, then we transform the call into a -;;; values form. -;;; -(defun constant-fold-call (call) - (declare (type combination call)) - (let* ((args (mapcar #'continuation-value (combination-args call))) - (ref (continuation-use (combination-fun call))) - (fun (leaf-name (ref-leaf ref)))) - - (multiple-value-bind (values win) - (careful-call fun args call "constant folding") - (cond - ((not win) - (setf (combination-kind call) :error)) - ((= (length values) 1) - (with-ir1-environment call - (when (producing-fasl-file) - (maybe-emit-make-load-forms (first values))) - (let* ((leaf (find-constant (first values))) - (node (make-ref (leaf-type leaf) leaf)) - (dummy (make-continuation)) - (cont (node-cont call)) - (block (node-block call)) - (next (continuation-next cont))) - (push node (leaf-refs leaf)) - (setf (leaf-ever-used leaf) t) - - (delete-continuation-use call) - (add-continuation-use call dummy) - (prev-link node dummy) - (add-continuation-use node cont) - (setf (continuation-next cont) next) - (when (eq call (block-last block)) - (setf (block-last block) node)) - (reoptimize-continuation cont)))) - (t - (let ((dummies (loop repeat (length args) - collect (gensym)))) - (transform-call - call - `(lambda ,dummies - (declare (ignore ,@dummies)) - (values ,@(mapcar #'(lambda (x) `',x) values))))))))) - - (undefined-value)) - - -;;;; Local call optimization: - -(declaim (start-block ir1-optimize-set constant-reference-p delete-let - propagate-let-args propagate-local-call-args - propagate-to-refs propagate-from-sets - ir1-optimize-mv-combination)) - -;;; Propagate-To-Refs -- Internal -;;; -;;; Propagate Type to Leaf and its Refs, marking things changed. If the -;;; leaf type is a function type, then just leave it alone, since TYPE is never -;;; going to be more specific than that (and TYPE-INTERSECTION would choke.) -;;; -(defun propagate-to-refs (leaf type) - (declare (type leaf leaf) (type ctype type)) - (let ((var-type (leaf-type leaf))) - (unless (function-type-p var-type) - (let ((int (type-intersection var-type type))) - (when (type/= int var-type) - (setf (leaf-type leaf) int) - (dolist (ref (leaf-refs leaf)) - (derive-node-type ref int)))) - (undefined-value)))) - - -;;; PROPAGATE-FROM-SETS -- Internal -;;; -;;; Figure out the type of a LET variable that has sets. We compute the -;;; union of the initial value Type and the types of all the set values and to -;;; a PROPAGATE-TO-REFS with this type. -;;; -(defun propagate-from-sets (var type) - (collect ((res type type-union)) - (dolist (set (basic-var-sets var)) - (res (continuation-type (set-value set))) - (setf (node-reoptimize set) nil)) - (propagate-to-refs var (res))) - (undefined-value)) - - -;;; IR1-OPTIMIZE-SET -- Internal -;;; -;;; If a let variable, find the initial value's type and do -;;; PROPAGATE-FROM-SETS. We also derive the VALUE's type as the node's type. -;;; -(defun ir1-optimize-set (node) - (declare (type cset node)) - (let ((var (set-var node))) - (when (and (lambda-var-p var) (leaf-refs var)) - (let ((home (lambda-var-home var))) - (when (eq (functional-kind home) :let) - (let ((iv (let-var-initial-value var))) - (setf (continuation-reoptimize iv) nil) - (propagate-from-sets var (continuation-type iv))))))) - - (derive-node-type node (continuation-type (set-value node))) - (undefined-value)) - - -;;; CONSTANT-REFERENCE-P -- Interface -;;; -;;; Return true if the value of Ref will always be the same (and is thus -;;; legal to substitute.) -;;; -(defun constant-reference-p (ref) - (declare (type ref ref)) - (let ((leaf (ref-leaf ref))) - (typecase leaf - ((or constant functional) t) - (lambda-var - (null (lambda-var-sets leaf))) - (defined-function - (not (eq (defined-function-inlinep leaf) :notinline))) - (global-var - (case (global-var-kind leaf) - (:global-function t) - (:constant t)))))) - - -;;; SUBSTITUTE-SINGLE-USE-CONTINUATION -- Internal -;;; -;;; If we have a non-set let var with a single use, then (if possible) -;;; replace the variable reference's CONT with the arg continuation. This is -;;; inhibited when: -;;; -- CONT has other uses, or -;;; -- CONT receives multiple values, or -;;; -- the reference is in a different environment from the variable, or -;;; -- either continuation has a funky TYPE-CHECK annotation. -;;; -- the continuations have incompatible assertions, so the new asserted type -;;; would be NIL. -;;; -- the var's DEST has a different policy than the ARG's (think safety). -;;; -;;; We change the Ref to be a reference to NIL with unused value, and let it -;;; be flushed as dead code. A side-effect of this substitution is to delete -;;; the variable. -;;; -(defun substitute-single-use-continuation (arg var) - (declare (type continuation arg) (type lambda-var var)) - (let* ((ref (first (leaf-refs var))) - (cont (node-cont ref)) - (cont-atype (continuation-asserted-type cont)) - (dest (continuation-dest cont))) - (when (and (eq (continuation-use cont) ref) - dest - (not (typep dest '(or creturn exit mv-combination))) - (eq (node-home-lambda ref) - (lambda-home (lambda-var-home var))) - (member (continuation-type-check arg) '(t nil)) - (member (continuation-type-check cont) '(t nil)) - (not (eq (values-type-intersection - cont-atype - (continuation-asserted-type arg)) - *empty-type*)) - (eq (lexenv-cookie (node-lexenv dest)) - (lexenv-cookie (node-lexenv (continuation-dest arg))))) - (assert (member (continuation-kind arg) - '(:block-start :deleted-block-start :inside-block))) - (assert-continuation-type arg cont-atype) - (setf (node-derived-type ref) *wild-type*) - (change-ref-leaf ref (find-constant nil)) - (substitute-continuation arg cont) - (reoptimize-continuation arg) - t))) - - -;;; DELETE-LET -- Interface -;;; -;;; Delete a Let, removing the call and bind nodes, and warning about any -;;; unreferenced variables. Note that FLUSH-DEAD-CODE will come along right -;;; away and delete the REF and then the lambda, since we flush the FUN -;;; continuation. -;;; -(defun delete-let (fun) - (declare (type clambda fun)) - (assert (member (functional-kind fun) '(:let :mv-let))) - (note-unreferenced-vars fun) - (let ((call (let-combination fun))) - (flush-dest (basic-combination-fun call)) - (unlink-node call) - (unlink-node (lambda-bind fun)) - (setf (lambda-bind fun) nil)) - (undefined-value)) - - -;;; Propagate-Let-Args -- Internal -;;; -;;; This function is called when one of the arguments to a LET changes. We -;;; look at each changed argument. If the corresponding variable is set, then -;;; we call PROPAGATE-FROM-SETS. Otherwise, we consider substituting for the -;;; variable, and also propagate derived-type information for the arg to all -;;; the Var's refs. -;;; -;;; Substitution is inhibited when the arg leaf's derived type isn't a -;;; subtype of the argument's asserted type. This prevents type checking from -;;; being defeated, and also ensures that the best representation for the -;;; variable can be used. -;;; -;;; Substitution of individual references is inhibited if the reference is -;;; in a different component from the home. This can only happen with closures -;;; over top-level lambda vars. In such cases, the references may have already -;;; been compiled, and thus can't be retroactively modified. -;;; -;;; If all of the variables are deleted (have no references) when we are -;;; done, then we delete the let. -;;; -;;; Note that we are responsible for clearing the Continuation-Reoptimize -;;; flags. -;;; -(defun propagate-let-args (call fun) - (declare (type combination call) (type clambda fun)) - (loop for arg in (combination-args call) - and var in (lambda-vars fun) do - (when (and arg (continuation-reoptimize arg)) - (setf (continuation-reoptimize arg) nil) - (cond - ((lambda-var-sets var) - (propagate-from-sets var (continuation-type arg))) - ((let ((use (continuation-use arg))) - (when (ref-p use) - (let ((leaf (ref-leaf use))) - (when (and (constant-reference-p use) - (values-subtypep (leaf-type leaf) - (continuation-asserted-type arg))) - (propagate-to-refs var (continuation-type arg)) - (let ((this-comp (block-component (node-block use)))) - (substitute-leaf-if - #'(lambda (ref) - (cond ((eq (block-component (node-block ref)) - this-comp) - t) - (t - (assert (eq (functional-kind (lambda-home fun)) - :top-level)) - nil))) - leaf var)) - t))))) - ((and (null (rest (leaf-refs var))) - (not *byte-compiling*) - (substitute-single-use-continuation arg var))) - (t - (propagate-to-refs var (continuation-type arg)))))) - - (when (every #'null (combination-args call)) - (delete-let fun)) - - (undefined-value)) - - -;;; Propagate-Local-Call-Args -- Internal -;;; -;;; This function is called when one of the args to a non-let local call -;;; changes. For each changed argument corresponding to an unset variable, we -;;; compute the union of the types across all calls and propagate this type -;;; information to the var's refs. -;;; -;;; If the function has an XEP, then we don't do anything, since we won't -;;; discover anything. -;;; -;;; We can clear the Continuation-Reoptimize flags for arguments in all calls -;;; corresponding to changed arguments in Call, since the only use in IR1 -;;; optimization of the Reoptimize flag for local call args is right here. -;;; -(defun propagate-local-call-args (call fun) - (declare (type combination call) (type clambda fun)) - - (unless (functional-entry-function fun) - (let* ((vars (lambda-vars fun)) - (union (mapcar #'(lambda (arg var) - (when (and arg - (continuation-reoptimize arg) - (null (basic-var-sets var))) - (continuation-type arg))) - (basic-combination-args call) - vars)) - (this-ref (continuation-use (basic-combination-fun call)))) - - (dolist (arg (basic-combination-args call)) - (when arg - (setf (continuation-reoptimize arg) nil))) - - (dolist (ref (leaf-refs fun)) - (unless (eq ref this-ref) - (setq union - (mapcar #'(lambda (this-arg old) - (when old - (setf (continuation-reoptimize this-arg) nil) - (type-union (continuation-type this-arg) old))) - (basic-combination-args - (continuation-dest (node-cont ref))) - union)))) - - (mapc #'(lambda (var type) - (when type - (propagate-to-refs var type))) - vars union))) - - (undefined-value)) - -(declaim (end-block)) - - -;;;; Multiple values optimization: - -;;; IR1-OPTIMIZE-MV-COMBINATION -- Internal -;;; -;;; Do stuff to notice a change to a MV combination node. There are two -;;; main branches here: -;;; -- If the call is local, then it is already a MV let, or should become one. -;;; Note that although all :LOCAL MV calls must eventually be converted to -;;; :MV-LETs, there can be a window when the call is local, but has not -;;; been let converted yet. This is because the entry-point lambdas may -;;; have stray references (in other entry points) that have not been -;;; deleted yet. -;;; -- The call is full. This case is somewhat similar to the non-MV -;;; combination optimization: we propagate return type information and -;;; notice non-returning calls. We also have an optimization -;;; which tries to convert MV-CALLs into MV-binds. -;;; -(defun ir1-optimize-mv-combination (node) - (ecase (basic-combination-kind node) - (:local - (let ((fun-cont (basic-combination-fun node))) - (when (continuation-reoptimize fun-cont) - (setf (continuation-reoptimize fun-cont) nil) - (maybe-let-convert (combination-lambda node)))) - (setf (continuation-reoptimize (first (basic-combination-args node))) nil) - (when (eq (functional-kind (combination-lambda node)) :mv-let) - (unless (convert-mv-bind-to-let node) - (ir1-optimize-mv-bind node)))) - (:full - (let* ((fun (basic-combination-fun node)) - (fun-changed (continuation-reoptimize fun)) - (args (basic-combination-args node))) - (when fun-changed - (setf (continuation-reoptimize fun) nil) - (let ((type (continuation-type fun))) - (when (function-type-p type) - (derive-node-type node (function-type-returns type)))) - (maybe-terminate-block node nil) - (let ((use (continuation-use fun))) - (when (and (ref-p use) (functional-p (ref-leaf use))) - (convert-call-if-possible use node) - (when (eq (basic-combination-kind node) :local) - (maybe-let-convert (ref-leaf use)))))) - (unless (or (eq (basic-combination-kind node) :local) - (eq (continuation-function-name fun) '%throw)) - (ir1-optimize-mv-call node)) - (dolist (arg args) - (setf (continuation-reoptimize arg) nil)))) - (:error)) - (undefined-value)) - - -;;; IR1-OPTIMIZE-MV-BIND -- Internal -;;; -;;; Propagate derived type info from the values continuation to the vars. -;;; -(defun ir1-optimize-mv-bind (node) - (declare (type mv-combination node)) - (let ((arg (first (basic-combination-args node))) - (vars (lambda-vars (combination-lambda node)))) - (multiple-value-bind (types nvals) - (values-types (continuation-derived-type arg)) - (unless (eq nvals :unknown) - (mapc #'(lambda (var type) - (if (basic-var-sets var) - (propagate-from-sets var type) - (propagate-to-refs var type))) - vars - (append types - (make-list (max (- (length vars) nvals) 0) - :initial-element *null-type*))))) - - (setf (continuation-reoptimize arg) nil)) - (undefined-value)) - - -;;; IR1-OPTIMIZE-MV-CALL -- Internal -;;; -;;; If possible, convert a general MV call to an MV-BIND. We can do this -;;; if: -;;; -- The call has only one argument, and -;;; -- The function has a known fixed number of arguments, or -;;; -- The argument yields a known fixed number of values. -;;; -;;; What we do is change the function in the MV-CALL to be a lambda that "looks -;;; like an MV bind", which allows IR1-OPTIMIZE-MV-COMBINATION to notice that -;;; this call can be converted (the next time around.) This new lambda just -;;; calls the actual function with the MV-BIND variables as arguments. Note -;;; that this new MV bind is not let-converted immediately, as there are going -;;; to be stray references from the entry-point functions until they get -;;; deleted. -;;; -;;; In order to avoid loss of argument count checking, we only do the -;;; transformation according to a known number of expected argument if safety -;;; is unimportant. We can always convert if we know the number of actual -;;; values, since the normal call that we build will still do any appropriate -;;; argument count checking. -;;; -;;; We only attempt the transformation if the called function is a constant -;;; reference. This allows us to just splice the leaf into the new function, -;;; instead of trying to somehow bind the function expression. The leaf must -;;; be constant because we are evaluating it again in a different place. This -;;; also has the effect of squelching multiple warnings when there is an -;;; argument count error. -;;; -(defun ir1-optimize-mv-call (node) - (let ((fun (basic-combination-fun node)) - (*compiler-error-context* node) - (ref (continuation-use (basic-combination-fun node))) - (args (basic-combination-args node))) - - (unless (and (ref-p ref) (constant-reference-p ref) - args (null (rest args))) - (return-from ir1-optimize-mv-call)) - - (multiple-value-bind (min max) - (function-type-nargs (continuation-type fun)) - (let ((total-nvals - (multiple-value-bind - (types nvals) - (values-types (continuation-derived-type (first args))) - (declare (ignore types)) - (if (eq nvals :unknown) nil nvals)))) - - (when total-nvals - (when (and min (< total-nvals min)) - (compiler-warning - "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ - at least ~R." - total-nvals min) - (setf (basic-combination-kind node) :error) - (return-from ir1-optimize-mv-call)) - (when (and max (> total-nvals max)) - (compiler-warning - "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ - at most ~R." - total-nvals max) - (setf (basic-combination-kind node) :error) - (return-from ir1-optimize-mv-call))) - - (let ((count (cond (total-nvals) - ((and (policy node (zerop safety)) (eql min max)) - min) - (t nil)))) - (when count - (with-ir1-environment node - (let* ((dums (loop repeat count collect (gensym))) - (ignore (gensym)) - (fun (ir1-convert-lambda - `(lambda (&optional ,@dums &rest ,ignore) - (declare (ignore ,ignore)) - (funcall ,(ref-leaf ref) ,@dums))))) - (change-ref-leaf ref fun) - (assert (eq (basic-combination-kind node) :full)) - (local-call-analyze *current-component*) - (assert (eq (basic-combination-kind node) :local))))))))) - (undefined-value)) - - -;;; CONVERT-MV-BIND-TO-LET -- Internal -;;; -;;; If we see: -;;; (multiple-value-bind (x y) -;;; (values xx yy) -;;; ...) -;;; Convert to: -;;; (let ((x xx) -;;; (y yy)) -;;; ...) -;;; -;;; What we actually do is convert the VALUES combination into a normal let -;;; combination calling the original :MV-LET lambda. If there are extra args to -;;; VALUES, discard the corresponding continuations. If there are insufficient -;;; args, insert references to NIL. -;;; -(defun convert-mv-bind-to-let (call) - (declare (type mv-combination call)) - (let* ((arg (first (basic-combination-args call))) - (use (continuation-use arg))) - (when (and (combination-p use) - (eq (continuation-function-name (combination-fun use)) - 'values)) - (let* ((fun (combination-lambda call)) - (vars (lambda-vars fun)) - (vals (combination-args use)) - (nvars (length vars)) - (nvals (length vals))) - (cond ((> nvals nvars) - (mapc #'flush-dest (subseq vals nvars)) - (setq vals (subseq vals 0 nvars))) - ((< nvals nvars) - (with-ir1-environment use - (let ((node-prev (node-prev use))) - (setf (node-prev use) nil) - (setf (continuation-next node-prev) nil) - (collect ((res vals)) - (loop as cont = (make-continuation use) - and prev = node-prev then cont - repeat (- nvars nvals) - do (reference-constant prev cont nil) - (res cont)) - (setq vals (res))) - (prev-link use (car (last vals))))))) - (setf (combination-args use) vals) - (flush-dest (combination-fun use)) - (let ((fun-cont (basic-combination-fun call))) - (setf (continuation-dest fun-cont) use) - (setf (combination-fun use) fun-cont)) - (setf (combination-kind use) :local) - (setf (functional-kind fun) :let) - (flush-dest (first (basic-combination-args call))) - (unlink-node call) - (when vals - (reoptimize-continuation (first vals))) - (propagate-to-args use fun)) - t))) - - -;;; VALUES-LIST IR1 optimizer -- Internal -;;; -;;; If we see: -;;; (values-list (list x y z)) -;;; -;;; Convert to: -;;; (values x y z) -;;; -;;; In implementation, this is somewhat similar to CONVERT-MV-BIND-TO-LET. We -;;; grab the args of LIST and make them args of the VALUES-LIST call, flushing -;;; the old argument continuation (allowing the LIST to be flushed.) -;;; -(defoptimizer (values-list optimizer) ((list) node) - (let ((use (continuation-use list))) - (when (and (combination-p use) - (eq (continuation-function-name (combination-fun use)) - 'list)) - (change-ref-leaf (continuation-use (combination-fun node)) - (find-free-function 'values "in a strange place")) - (setf (combination-kind node) :full) - (let ((args (combination-args use))) - (dolist (arg args) - (setf (continuation-dest arg) node)) - (setf (combination-args use) nil) - (flush-dest list) - (setf (combination-args node) args)) - t))) - - -;;; VALUES IR1 transform -- Internal -;;; -;;; If VALUES appears in a non-MV context, then effectively convert it to a -;;; PROG1. This allows the computation of the additional values to become dead -;;; code. -;;; -(deftransform values ((&rest vals) * * :node node) - (when (typep (continuation-dest (node-cont node)) - '(or creturn exit mv-combination)) - (give-up)) - (setf (node-derived-type node) *wild-type*) - (if vals - (let ((dummies (loop repeat (1- (length vals)) - collect (gensym)))) - `(lambda (val ,@dummies) - (declare (ignore ,@dummies)) - val)) - 'nil)) diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp deleted file mode 100644 index 759a5502b18e2fc51589625d71dd273347fd8635..0000000000000000000000000000000000000000 --- a/compiler/ir1util.lisp +++ /dev/null @@ -1,2145 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/ir1util.lisp,v 1.60 1992/09/22 00:05:23 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains random utilities used for manipulating the IR1 -;;; representation. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") -(export '(*compiler-notification-function*)) -(in-package "EXTENSIONS") -(export '(*error-print-level* *error-print-length* *error-print-lines* - def-source-context *undefined-warning-limit* - *enclosing-source-cutoff* *inline-expansion-limit*)) - -(in-package "C") - - -;;;; Cleanup hackery: - - -;;; Node-Enclosing-Cleanup -- Interface -;;; -;;; Return the innermost cleanup enclosing Node, or NIL if there is none in -;;; its function. If Node has no cleanup, but is in a let, then we must still -;;; check the environment that the call is in. -;;; -(defun node-enclosing-cleanup (node) - (declare (type node node)) - (do ((lexenv (node-lexenv node) - (lambda-call-lexenv (lexenv-lambda lexenv)))) - ((null lexenv) nil) - (let ((cup (lexenv-cleanup lexenv))) - (when cup (return cup))))) - - -;;; Insert-Cleanup-Code -- Interface -;;; -;;; Convert the Form in a block inserted between Block1 and Block2 as an -;;; implicit MV-Prog1. The inserted block is returned. Node is used for IR1 -;;; context when converting the form. Note that the block is not assigned a -;;; number, and is linked into the DFO at the beginning. We indicate that we -;;; have trashed the DFO by setting Component-Reanalyze. If Cleanup is -;;; supplied, then convert with that cleanup. -;;; -(defun insert-cleanup-code (block1 block2 node form &optional cleanup) - (declare (type cblock block1 block2) (type node node) - (type (or cleanup null) cleanup)) - (setf (component-reanalyze (block-component block1)) t) - (with-ir1-environment node - (let* ((start (make-continuation)) - (block (continuation-starts-block start)) - (cont (make-continuation)) - (*lexical-environment* - (if cleanup - (make-lexenv :cleanup cleanup) - *lexical-environment*))) - (change-block-successor block1 block2 block) - (link-blocks block block2) - (ir1-convert start cont form) - (setf (block-last block) (continuation-use cont)) - block))) - - -;;;; Continuation use hacking: - -;;; Find-Uses -- Interface -;;; -;;; Return a list of all the nodes which use Cont. -;;; -(proclaim '(function find-uses (continuation) list)) -(defun find-uses (cont) - (ecase (continuation-kind cont) - ((:block-start :deleted-block-start) - (block-start-uses (continuation-block cont))) - (:inside-block (list (continuation-use cont))) - (:unused nil))) - - -;;; Delete-Continuation-Use -- Interface -;;; -;;; Update continuation use information so that Node is no longer a use of -;;; its Cont. If the old continuation doesn't start its block, then we don't -;;; update the Block-Start-Uses, since it will be deleted when we are done. -;;; -;;; Note: if you call this function, you may have to do a -;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something has -;;; changed. -;;; -(proclaim '(function delete-continuation-use (node) void)) -(defun delete-continuation-use (node) - (let* ((cont (node-cont node)) - (block (continuation-block cont))) - (ecase (continuation-kind cont) - (:deleted) - ((:block-start :deleted-block-start) - (let ((uses (delete node (block-start-uses block)))) - (setf (block-start-uses block) uses) - (setf (continuation-use cont) - (if (cdr uses) nil (car uses))))) - (:inside-block - (setf (continuation-kind cont) :unused) - (setf (continuation-block cont) nil) - (setf (continuation-use cont) nil) - (setf (continuation-next cont) nil))) - (setf (node-cont node) nil))) - - -;;; Add-Continuation-Use -- Interface -;;; -;;; Update continuation use information so that Node uses Cont. If Cont is -;;; :Unused, then we set its block to Node's Node-Block (which must be set.) -;;; -;;; Note: if you call this function, you may have to do a -;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something has -;;; changed. -;;; -(proclaim '(function add-continuation-use (node continuation) void)) -(defun add-continuation-use (node cont) - (assert (not (node-cont node))) - (let ((block (continuation-block cont))) - (ecase (continuation-kind cont) - (:deleted) - (:unused - (assert (not block)) - (let ((block (node-block node))) - (assert block) - (setf (continuation-block cont) block)) - (setf (continuation-kind cont) :inside-block) - (setf (continuation-use cont) node)) - ((:block-start :deleted-block-start) - (let ((uses (cons node (block-start-uses block)))) - (setf (block-start-uses block) uses) - (setf (continuation-use cont) - (if (cdr uses) nil (car uses))))))) - (setf (node-cont node) cont)) - - -;;; Immediately-Used-P -- Interface -;;; -;;; Return true if Cont is the Node-Cont for Node and Cont is transferred to -;;; immediately after the evaluation of Node. -;;; -(defun immediately-used-p (cont node) - (declare (type continuation cont) (type node node)) - (and (eq (node-cont node) cont) - (not (eq (continuation-kind cont) :deleted)) - (let ((cblock (continuation-block cont)) - (nblock (node-block node))) - (or (eq cblock nblock) - (let ((succ (block-succ nblock))) - (and (= (length succ) 1) - (eq (first succ) cblock))))))) - - -;;;; Continuation substitution: - -;;; Substitute-Continuation -- Interface -;;; -;;; In Old's Dest, replace Old with New. New's Dest must initially be NIL. -;;; When we are done, we call Flush-Dest on Old to clear its Dest and to note -;;; potential optimization opportunities. -;;; -(defun substitute-continuation (new old) - (declare (type continuation old new)) - (assert (not (continuation-dest new))) - (let ((dest (continuation-dest old))) - (etypecase dest - ((or ref bind)) - (cif (setf (if-test dest) new)) - (cset (setf (set-value dest) new)) - (creturn (setf (return-result dest) new)) - (exit (setf (exit-value dest) new)) - (basic-combination - (if (eq old (basic-combination-fun dest)) - (setf (basic-combination-fun dest) new) - (setf (basic-combination-args dest) - (nsubst new old (basic-combination-args dest)))))) - - (flush-dest old) - (setf (continuation-dest new) dest)) - (undefined-value)) - -;;; Substitute-Continuation-Uses -- Interface -;;; -;;; Replace all uses of Old with uses of New, where New has an arbitary -;;; number of uses. If New will end up with more than one use, then we must -;;; arrange for it to start a block if it doesn't already. -;;; -(defun substitute-continuation-uses (new old) - (declare (type continuation old new)) - (unless (and (eq (continuation-kind new) :unused) - (eq (continuation-kind old) :inside-block)) - (ensure-block-start new)) - - (do-uses (node old) - (delete-continuation-use node) - (add-continuation-use node new)) - - (reoptimize-continuation new) - (undefined-value)) - - -;;;; Block starting/creation: - -;;; Continuation-Starts-Block -- Interface -;;; -;;; Return the block that Continuation is the start of, making a block if -;;; necessary. This function is called by IR1 translators which may cause a -;;; continuation to be used more than once. Every continuation which may be -;;; used more than once must start a block by the time that anyone does a -;;; Use-Continuation on it. -;;; -;;; We also throw the block into the next/prev list for the -;;; *current-component* so that we keep track of which blocks we have made. -;;; -(defun continuation-starts-block (cont) - (declare (type continuation cont)) - (ecase (continuation-kind cont) - (:unused - (assert (not (continuation-block cont))) - (let* ((head (component-head *current-component*)) - (next (block-next head)) - (new-block (make-block cont))) - (setf (block-next new-block) next) - (setf (block-prev new-block) head) - (setf (block-prev next) new-block) - (setf (block-next head) new-block) - (setf (continuation-block cont) new-block) - (setf (continuation-use cont) nil) - (setf (continuation-kind cont) :block-start) - new-block)) - (:block-start - (continuation-block cont)))) - -;;; Ensure-Block-Start -- Interface -;;; -;;; Ensure that Cont is the start of a block (or deleted) so that the use -;;; set can be freely manipulated. -;;; -- If the continuation is :Unused or is :Inside-Block and the Cont of Last -;;; in its block, then we make it the start of a new deleted block. -;;; -- If the continuation is :Inside-Block inside a block, then we split the -;;; block using Node-Ends-Block, which makes the continuation be a -;;; :Block-Start. -;;; -(defun ensure-block-start (cont) - (declare (type continuation cont)) - (let ((kind (continuation-kind cont))) - (ecase kind - ((:deleted :block-start :deleted-block-start)) - ((:unused :inside-block) - (let ((block (continuation-block cont))) - (cond ((or (eq kind :unused) - (eq (node-cont (block-last block)) cont)) - (setf (continuation-block cont) - (make-block-key :start cont :component nil - :start-uses (find-uses cont))) - (setf (continuation-kind cont) :deleted-block-start)) - (t - (node-ends-block (continuation-use cont)))))))) - (undefined-value)) - - -;;;; Misc shortand functions: - -;;; NODE-HOME-LAMBDA -- Interface -;;; -;;; Return the home (i.e. enclosing non-let) lambda for Node. Since the -;;; LEXENV-LAMBDA may be deleted, we must chain up the LAMBDA-CALL-LEXENV -;;; thread until we find a lambda that isn't deleted, and then return its home. -;;; -(declaim (maybe-inline node-home-lambda)) -(defun node-home-lambda (node) - (declare (type node node)) - (do ((fun (lexenv-lambda (node-lexenv node)) - (lexenv-lambda (lambda-call-lexenv fun)))) - ((not (eq (functional-kind fun) :deleted)) - (lambda-home fun)) - (when (eq (lambda-home fun) fun) - (return fun)))) - -;;; NODE-xxx -- Interface -;;; -(declaim (inline node-block node-tlf-number)) -(declaim (maybe-inline node-environment)) -(defun node-block (node) - (declare (type node node)) - (the cblock (continuation-block (node-prev node)))) -;;; -(defun node-environment (node) - (declare (type node node) (inline node-home-lambda)) - (the environment (lambda-environment (node-home-lambda node)))) - - -;;; BLOCK-xxx-CLEANUP -- Interface -;;; -;;; Return the enclosing cleanup for environment of the first or last node -;;; in Block. -;;; -(defun block-start-cleanup (block) - (declare (type cblock block)) - (node-enclosing-cleanup (continuation-next (block-start block)))) -;;; -(defun block-end-cleanup (block) - (declare (type cblock block)) - (node-enclosing-cleanup (block-last block))) - - -;;; BLOCK-HOME-LAMBDA -- Interface -;;; -;;; Return the non-let lambda that holds Block's code. -;;; -(defun block-home-lambda (block) - (declare (type cblock block) (inline node-home-lambda)) - (node-home-lambda (block-last block))) - - -;;; BLOCK-ENVIRONMENT -- Interface -;;; -;;; Return the IR1 environment for Block. -;;; -(defun block-environment (block) - (declare (type cblock block) (inline node-home-lambda)) - (lambda-environment (node-home-lambda (block-last block)))) - - -;;; SOURCE-PATH-TLF-NUMBER -- Interface -;;; -;;; Return the Top Level Form number of path, i.e. the ordinal number of -;;; its orignal source's top-level form in its compilation unit. -;;; -(defun source-path-tlf-number (path) - (declare (list path)) - (car (last path))) - - -;;; SOURCE-PATH-ORIGINAL-SOURCE -- Interface -;;; -;;; Return the (reversed) list for the path in the orignal source (with the -;;; TLF number last.) -;;; -(defun source-path-original-source (path) - (declare (list path) (inline member)) - (cddr (member 'original-source-start path :test #'eq))) - - -;;; SOURCE-PATH-FORM-NUMBER -- Interface -;;; -;;; Return the Form Number of Path's orignal source inside the Top Level -;;; Form that contains it. This is determined by the order that we walk the -;;; subforms of the top level source form. -;;; -(defun source-path-form-number (path) - (declare (list path) (inline member)) - (cadr (member 'original-source-start path :test #'eq))) - - -;;; SOURCE-PATH-FORMS -- Interface -;;; -;;; Return a list of all the enclosing forms not in the original source that -;;; converted to get to this form, with the immediate source for node at the -;;; start of the list. -;;; -(defun source-path-forms (path) - (subseq path 0 (position 'original-source-start path))) - - -;;; NODE-SOURCE-FORM -- Interface -;;; -;;; Return the innermost source form for Node. -;;; -(defun node-source-form (node) - (declare (type node node)) - (let* ((path (node-source-path node)) - (forms (source-path-forms path))) - (if forms - (first forms) - (values (find-original-source path))))) - - -;;; CONTINUATION-SOURCE-FORM -- Interface -;;; -;;; Return NODE-SOURCE-FORM, T if continuation has a single use, otherwise -;;; NIL, NIL. -;;; -(defun continuation-source (cont) - (let ((use (continuation-use cont))) - (if use - (values (node-source-form use) t) - (values nil nil)))) - - -;;; MAKE-LEXENV -- Interface -;;; -;;; Return a new LEXENV just like Default except for the specified slot -;;; values. Values for the alist slots are NCONC'ed to the beginning of the -;;; current value, rather than replacing it entirely. -;;; -(defun make-lexenv (&key (default *lexical-environment*) - functions variables blocks tags type-restrictions - options - (lambda (lexenv-lambda default)) - (cleanup (lexenv-cleanup default)) - (cookie (lexenv-cookie default)) - (interface-cookie (lexenv-interface-cookie default))) - (macrolet ((frob (var slot) - `(let ((old (,slot default))) - (if ,var - (nconc ,var old) - old)))) - (internal-make-lexenv - (frob functions lexenv-functions) - (frob variables lexenv-variables) - (frob blocks lexenv-blocks) - (frob tags lexenv-tags) - (frob type-restrictions lexenv-type-restrictions) - lambda cleanup cookie interface-cookie - (frob options lexenv-options)))) - - -;;; MAKE-INTERFACE-COOKIE -- Interface -;;; -;;; Return a cookie that defaults any unsupplied optimize qualities in the -;;; Interface-Cookie with the corresponding ones from the Cookie. -;;; -(defun make-interface-cookie (lexenv) - (declare (type lexenv lexenv)) - (let ((icookie (lexenv-interface-cookie lexenv)) - (cookie (lexenv-cookie lexenv))) - (make-cookie - :speed (or (cookie-speed icookie) (cookie-speed cookie)) - :space (or (cookie-space icookie) (cookie-space cookie)) - :safety (or (cookie-safety icookie) (cookie-safety cookie)) - :cspeed (or (cookie-cspeed icookie) (cookie-cspeed cookie)) - :brevity (or (cookie-brevity icookie) (cookie-brevity cookie)) - :debug (or (cookie-debug icookie) (cookie-debug cookie))))) - - -;;;; Flow/DFO/Component hackery: - -;;; Link-Blocks -- Interface -;;; -;;; Join Block1 and Block2. -;;; -(declaim (inline link-blocks)) -(defun link-blocks (block1 block2) - (declare (type cblock block1 block2)) - (setf (block-succ block1) - (if (block-succ block1) - (%link-blocks block1 block2) - (list block2))) - (push block1 (block-pred block2)) - (undefined-value)) -;;; -(defun %link-blocks (block1 block2) - (declare (type cblock block1 block2) (inline member)) - (let ((succ1 (block-succ block1))) - (assert (not (member block2 succ1 :test #'eq))) - (cons block2 succ1))) - - -;;; UNLINK-BLOCKS -- Interface -;;; -;;; Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If this leaves a -;;; successor with a single predecessor that ends in an IF, then set -;;; BLOCK-TEST-MODIFIED so that any test constraint will now be able to be -;;; propagated to the successor. -;;; -(defun unlink-blocks (block1 block2) - (declare (type cblock block1 block2)) - (let ((succ1 (block-succ block1))) - (if (eq block2 (car succ1)) - (setf (block-succ block1) (cdr succ1)) - (do ((succ (cdr succ1) (cdr succ)) - (prev succ1 succ)) - ((eq (car succ) block2) - (setf (cdr prev) (cdr succ))) - (assert succ)))) - - (let ((new-pred (delq block1 (block-pred block2)))) - (setf (block-pred block2) new-pred) - (when (and new-pred (null (rest new-pred))) - (let ((pred-block (first new-pred))) - (when (if-p (block-last pred-block)) - (setf (block-test-modified pred-block) t))))) - (undefined-value)) - - -;;; Change-Block-Successor -- Internal -;;; -;;; Swing the succ/pred link between Block and Old to be between Block and -;;; New. If Block ends in an IF, then we have to fix up the -;;; consequent/alternative blocks to point to New. We also set -;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to the new -;;; successor. -;;; -(defun change-block-successor (block old new) - (declare (type cblock new old block) (inline member)) - (unlink-blocks block old) - (setf (component-reanalyze (block-component block)) t) - (unless (member new (block-succ block) :test #'eq) - (link-blocks block new)) - - (let ((last (block-last block))) - (when (if-p last) - (setf (block-test-modified block) t) - (macrolet ((frob (slot) - `(when (eq (,slot last) old) - (setf (,slot last) new)))) - (frob if-consequent) - (frob if-alternative)))) - - (undefined-value)) - - -;;; Remove-From-DFO -- Interface -;;; -;;; Unlink a block from the next/prev chain. We also null out the -;;; Component. -;;; -(proclaim '(function remove-from-dfo (cblock) void)) -(declaim (inline remove-from-dfo)) -(defun remove-from-dfo (block) - (let ((next (block-next block)) - (prev (block-prev block))) - (setf (block-component block) nil) - (setf (block-next prev) next) - (setf (block-prev next) prev))) - -;;; Add-To-DFO -- Interface -;;; -;;; Add Block to the next/prev chain following After. We also set the -;;; Component to be the same as for After. -;;; -(declaim (inline add-to-dfo)) -(defun add-to-dfo (block after) - (declare (type cblock block after)) - (let ((next (block-next after)) - (comp (block-component after))) - (assert (not (eq (component-kind comp) :deleted))) - (setf (block-component block) comp) - (setf (block-next after) block) - (setf (block-prev block) after) - (setf (block-next block) next) - (setf (block-prev next) block)) - (undefined-value)) - - -;;; Clear-Flags -- Interface -;;; -;;; Set the Flag for all the blocks in Component to NIL, except for the head -;;; and tail which are set to T. -;;; -(proclaim '(function clear-flags (component) void)) -(defun clear-flags (component) - (let ((head (component-head component)) - (tail (component-tail component))) - (setf (block-flag head) t) - (setf (block-flag tail) t) - (do-blocks (block component) - (setf (block-flag block) nil)))) - - -;;; Make-Empty-Component -- Interface -;;; -;;; Make a component with no blocks in it. The Block-Flag is initially true -;;; in the head and tail blocks. -;;; -(proclaim '(function make-empty-component () component)) -(defun make-empty-component () - (let* ((head (make-block-key :start nil :component nil)) - (tail (make-block-key :start nil :component nil)) - (res (make-component :head head :tail tail))) - (setf (block-flag head) t) - (setf (block-flag tail) t) - (setf (block-component head) res) - (setf (block-component tail) res) - (setf (block-next head) tail) - (setf (block-prev tail) head) - res)) - - -;;; Node-Ends-Block -- Interface -;;; -;;; Makes Node the Last node in its block, splitting the block if necessary. -;;; The new block is added to the DFO immediately following Node's block. -;;; -(defun node-ends-block (node) - (declare (type node node)) - (let* ((block (node-block node)) - (start (node-cont node)) - (last (block-last block)) - (last-cont (node-cont last))) - (unless (eq last node) - (assert (and (eq (continuation-kind start) :inside-block) - (not (block-delete-p block)))) - (let* ((succ (block-succ block)) - (new-block - (make-block-key :start start - :component (block-component block) - :start-uses (list (continuation-use start)) - :succ succ :last last))) - (setf (continuation-kind start) :block-start) - (dolist (b succ) - (setf (block-pred b) - (cons new-block (remove block (block-pred b))))) - (setf (block-succ block) ()) - (setf (block-last block) node) - (link-blocks block new-block) - (add-to-dfo new-block block) - (setf (component-reanalyze (block-component block)) t) - - (do ((cont start (node-cont (continuation-next cont)))) - ((eq cont last-cont) - (when (eq (continuation-kind last-cont) :inside-block) - (setf (continuation-block last-cont) new-block))) - (setf (continuation-block cont) new-block)) - - (setf (block-type-asserted block) t) - (setf (block-test-modified block) t)))) - - (undefined-value)) - - -;;;; Deleting stuff: - -(declaim (start-block delete-ref delete-functional flush-dest - delete-continuation delete-block)) - -;;; Delete-Lambda-Var -- Internal -;;; -;;; Deal with deleting the last (read) reference to a lambda-var. We -;;; iterate over all local calls flushing the corresponding argument, allowing -;;; the computation of the argument to be deleted. We also mark the let for -;;; reoptimization, since it may be that we have deleted the last variable. -;;; -;;; The lambda-var may still have some sets, but this doesn't cause too much -;;; difficulty, since we can efficiently implement write-only variables. We -;;; iterate over the sets, marking their blocks for dead code flushing, since -;;; we can delete sets whose value is unused. -;;; -(defun delete-lambda-var (leaf) - (declare (type lambda-var leaf)) - (let* ((fun (lambda-var-home leaf)) - (n (position leaf (lambda-vars fun)))) - (dolist (ref (leaf-refs fun)) - (let* ((cont (node-cont ref)) - (dest (continuation-dest cont))) - (when (and (combination-p dest) - (eq (basic-combination-fun dest) cont) - (eq (basic-combination-kind dest) :local)) - (let* ((args (basic-combination-args dest)) - (arg (elt args n))) - (reoptimize-continuation arg) - (flush-dest arg) - (setf (elt args n) nil)))))) - - (dolist (set (lambda-var-sets leaf)) - (setf (block-flush-p (node-block set)) t)) - - (undefined-value)) - - -;;; REOPTIMIZE-LAMBDA-VAR -- Internal -;;; -;;; Note that something interesting has happened to Var. We only deal with -;;; LET variables, marking the corresponding initial value arg as needing to be -;;; reoptimized. -;;; -(defun reoptimize-lambda-var (var) - (declare (type lambda-var var)) - (let ((fun (lambda-var-home var))) - (when (and (eq (functional-kind fun) :let) - (leaf-refs var)) - (reoptimize-continuation - (elt (basic-combination-args - (continuation-dest - (node-cont - (first (leaf-refs fun))))) - (position var (lambda-vars fun)))))) - (undefined-value)) - - -;;; DELETE-FUNCTIONAL -- Interface -;;; -;;; This function deletes functions that have no references. This need only -;;; be called on functions that never had any references, since otherwise -;;; DELETE-REF will handle the deletion. -;;; -(defun delete-functional (fun) - (assert (and (null (leaf-refs fun)) - (not (functional-entry-function fun)))) - (etypecase fun - (optional-dispatch (delete-optional-dispatch fun)) - (clambda (delete-lambda fun))) - (undefined-value)) - - -;;; Delete-Lambda -- Internal -;;; -;;; Deal with deleting the last reference to a lambda. Since there is only -;;; one way into a lambda, deleting the last reference to a lambda ensures that -;;; there is no way to reach any of the code in it. So we just set the -;;; Functional-Kind for Fun and its Lets to :Deleted, causing IR1 optimization -;;; to delete blocks in that lambda. -;;; -;;; If the function isn't a Let, we unlink the function head and tail from -;;; the component head and tail to indicate that the code is unreachable. We -;;; also delete the function from Component-Lambdas (it won't be there before -;;; local call analysis, but no matter.) If the lambda was never referenced, -;;; we give a note. -;;; -;;; If the lambda is an XEP, then we null out the Entry-Function in its -;;; Entry-Function so that people will know that it is not an entry point -;;; anymore. -;;; -(defun delete-lambda (leaf) - (declare (type clambda leaf)) - (let ((kind (functional-kind leaf)) - (bind (lambda-bind leaf))) - (assert (not (member kind '(:deleted :optional :top-level)))) - (setf (functional-kind leaf) :deleted) - (setf (lambda-bind leaf) nil) - (dolist (let (lambda-lets leaf)) - (setf (lambda-bind let) nil) - (setf (functional-kind let) :deleted)) - - (if (member kind '(:let :mv-let :assignment)) - (let ((home (lambda-home leaf))) - (setf (lambda-lets home) (delete leaf (lambda-lets home)))) - (let* ((bind-block (node-block bind)) - (component (block-component bind-block)) - (return (lambda-return leaf))) - (assert (null (leaf-refs leaf))) - (unless (leaf-ever-used leaf) - (let ((*compiler-error-context* bind)) - (compiler-note "Deleting unused function~:[.~;~:*~% ~S~]" - (leaf-name leaf)))) - (unlink-blocks (component-head component) bind-block) - (when return - (unlink-blocks (node-block return) (component-tail component))) - (setf (component-reanalyze component) t) - (let ((tails (lambda-tail-set leaf))) - (setf (tail-set-functions tails) - (delete leaf (tail-set-functions tails))) - (setf (lambda-tail-set leaf) nil)) - (setf (component-lambdas component) - (delete leaf (component-lambdas component))))) - - (when (eq kind :external) - (let ((fun (functional-entry-function leaf))) - (setf (functional-entry-function fun) nil) - (when (optional-dispatch-p fun) - (delete-optional-dispatch fun))))) - - (undefined-value)) - - -;;; Delete-Optional-Dispatch -- Internal -;;; -;;; Deal with deleting the last reference to an Optional-Dispatch. We have -;;; to be a bit more careful than with lambdas, since Delete-Ref is used both -;;; before and after local call analysis. Afterward, all references to -;;; still-existing optional-dispatches have been moved to the XEP, leaving it -;;; with no references at all. So we look at the XEP to see if an -;;; optional-dispatch is still really being used. But before local call -;;; analysis, there are no XEPs, and all references are direct. -;;; -;;; When we do delete the optional-dispatch, we grovel all of its -;;; entry-points, making them be normal lambdas, and then deleting the ones -;;; with no references. This deletes any e-p lambdas that were either never -;;; referenced, or couldn't be deleted when the last deference was deleted (due -;;; to their :Optional kind.) -;;; -;;; Note that the last optional ep may alias the main entry, so when we process -;;; the main entry, its kind may have been changed to NIL or even converted to -;;; a let. -;;; -(defun delete-optional-dispatch (leaf) - (declare (type optional-dispatch leaf)) - (let ((entry (functional-entry-function leaf))) - (unless (and entry (leaf-refs entry)) - (assert (or (not entry) (eq (functional-kind entry) :deleted))) - (setf (functional-kind leaf) :deleted) - - (flet ((frob (fun) - (unless (eq (functional-kind fun) :deleted) - (assert (eq (functional-kind fun) :optional)) - (setf (functional-kind fun) nil) - (let ((refs (leaf-refs fun))) - (cond ((null refs) - (delete-lambda fun)) - ((null (rest refs)) - (or (maybe-let-convert fun) - (maybe-convert-to-assignment fun))) - (t - (maybe-convert-to-assignment fun))))))) - - (dolist (ep (optional-dispatch-entry-points leaf)) - (frob ep)) - (when (optional-dispatch-more-entry leaf) - (frob (optional-dispatch-more-entry leaf))) - (let ((main (optional-dispatch-main-entry leaf))) - (when (eq (functional-kind main) :optional) - (frob main)))))) - - (undefined-value)) - - -;;; Delete-Ref -- Interface -;;; -;;; Do stuff to delete the semantic attachments of a Ref node. When this -;;; leaves zero or one reference, we do a type dispatch off of the leaf to -;;; determine if a special action is appropriate. -;;; -(defun delete-ref (ref) - (declare (type ref ref)) - (let* ((leaf (ref-leaf ref)) - (refs (delete ref (leaf-refs leaf)))) - (setf (leaf-refs leaf) refs) - - (cond ((null refs) - (typecase leaf - (lambda-var (delete-lambda-var leaf)) - (clambda - (ecase (functional-kind leaf) - ((nil :let :mv-let :assignment :escape :cleanup) - (assert (not (functional-entry-function leaf))) - (delete-lambda leaf)) - (:external - (delete-lambda leaf)) - ((:deleted :optional)))) - (optional-dispatch - (unless (eq (functional-kind leaf) :deleted) - (delete-optional-dispatch leaf))))) - ((null (rest refs)) - (typecase leaf - (clambda (or (maybe-let-convert leaf) - (maybe-convert-to-assignment leaf))) - (lambda-var (reoptimize-lambda-var leaf)))) - (t - (typecase leaf - (clambda (maybe-convert-to-assignment leaf)))))) - - (undefined-value)) - - - - -;;; Flush-Dest -- Interface -;;; -;;; This function is called by people who delete nodes; it provides a way to -;;; indicate that the value of a continuation is no longer used. We null out -;;; the Continuation-Dest, set Flush-P in the blocks containing uses of Cont -;;; and set Component-Reoptimize. If the Prev of the use is deleted, then we -;;; blow off reoptimization. -;;; -;;; If the continuation is :Deleted, then we don't do anything, since all -;;; semantics have already been flushed. :Deleted-Block-Start start -;;; continuations are treated just like :Block-Start; it is possible that the -;;; continuation may be given a new dest (e.g. by SUBSTITUTE-CONTINUATION), so -;;; we don't want to delete it. -;;; -(defun flush-dest (cont) - (declare (type continuation cont)) - - (unless (eq (continuation-kind cont) :deleted) - (assert (continuation-dest cont)) - (setf (continuation-dest cont) nil) - (do-uses (use cont) - (let ((prev (node-prev use))) - (unless (eq (continuation-kind prev) :deleted) - (let ((block (continuation-block prev))) - (setf (component-reoptimize (block-component block)) t) - (setf (block-attributep (block-flags block) flush-p type-asserted) - t)))))) - - (setf (continuation-%type-check cont) nil) - - (undefined-value)) - - -;;; MARK-FOR-DELETION -- Internal -;;; -;;; Do a graph walk backward from Block, marking all predecessor blocks with -;;; the DELETE-P flag. -;;; -(defun mark-for-deletion (block) - (declare (type cblock block)) - (unless (block-delete-p block) - (setf (block-delete-p block) t) - (setf (component-reanalyze (block-component block)) t) - (dolist (pred (block-pred block)) - (mark-for-deletion pred))) - (undefined-value)) - - -;;; DELETE-CONTINUATION -- Interface -;;; -;;; Delete Cont, eliminating both control and value semantics. We set -;;; FLUSH-P and COMPONENT-REOPTIMIZE similarly to in FLUSH-DEST. Here we must -;;; get the component from the use block, since the continuation may be a -;;; :DELETED-BLOCK-START. -;;; -;;; If Cont has DEST, then it must be the case that the DEST is unreachable, -;;; since we can't compute the value desired. In this case, we call -;;; MARK-FOR-DELETION to cause the DEST block and its predecessors to tell -;;; people to ignore them, and to cause them to be deleted eventually. -;;; -(defun delete-continuation (cont) - (declare (type continuation cont)) - (assert (not (eq (continuation-kind cont) :deleted))) - - (do-uses (use cont) - (let ((prev (node-prev use))) - (unless (eq (continuation-kind prev) :deleted) - (let ((block (continuation-block prev))) - (setf (block-attributep (block-flags block) flush-p type-asserted) t) - (setf (component-reoptimize (block-component block)) t))))) - - (let ((dest (continuation-dest cont))) - (when dest - (let ((prev (node-prev dest))) - (when (and prev - (not (eq (continuation-kind prev) :deleted))) - (let ((block (continuation-block prev))) - (unless (block-delete-p block) - (mark-for-deletion block))))))) - - (setf (continuation-kind cont) :deleted) - (setf (continuation-dest cont) nil) - (setf (continuation-next cont) nil) - (setf (continuation-asserted-type cont) *empty-type*) - (setf (continuation-%derived-type cont) *empty-type*) - (setf (continuation-use cont) nil) - (setf (continuation-block cont) nil) - (setf (continuation-reoptimize cont) nil) - (setf (continuation-%type-check cont) nil) - (setf (continuation-info cont) nil) - - (undefined-value)) - - -;;; Delete-Block -- Interface -;;; -;;; This function does what is necessary to eliminate the code in it from -;;; the IR1 representation. This involves unlinking it from its predecessors -;;; and successors and deleting various node-specific semantic information. -;;; -;;; We mark the Start as has having no next and remove the last node from -;;; its Cont's uses. We also flush the DEST for all continuations whose values -;;; are received by nodes in the block. -;;; -(defun delete-block (block) - (declare (type cblock block)) - (assert (block-component block) () "Block is already deleted.") - (note-block-deletion block) - (setf (block-delete-p block) t) - - (let* ((last (block-last block)) - (cont (node-cont last))) - (delete-continuation-use last) - (if (eq (continuation-kind cont) :unused) - (delete-continuation cont) - (reoptimize-continuation cont))) - - (dolist (b (block-pred block)) - (unlink-blocks b block)) - (dolist (b (block-succ block)) - (unlink-blocks block b)) - - (do-nodes (node cont block) - (typecase node - (ref (delete-ref node)) - (cif - (flush-dest (if-test node))) - ;; - ;; The next two cases serve to maintain the invariant that a LET always - ;; has a well-formed COMBINATION, REF and BIND. We delete the lambda - ;; whenever we delete any of these, but we must be careful that this LET - ;; has not already been partially deleted. - (basic-combination - (when (and (eq (basic-combination-kind node) :local) - ;; Guards COMBINATION-LAMBDA agains the REF being deleted. - (continuation-use (basic-combination-fun node))) - (let ((fun (combination-lambda node))) - ;; If our REF was the 2'nd to last ref, and has been deleted, then - ;; Fun may be a LET for some other combination. - (when (and (member (functional-kind fun) '(:let :mv-let)) - (eq (let-combination fun) node)) - (delete-lambda fun)))) - (flush-dest (basic-combination-fun node)) - (dolist (arg (basic-combination-args node)) - (when arg (flush-dest arg)))) - (bind - (let ((lambda (bind-lambda node))) - (unless (eq (functional-kind lambda) :deleted) - (assert (member (functional-kind lambda) - '(:let :mv-let :assignment))) - (delete-lambda lambda)))) - (exit - (let ((value (exit-value node)) - (entry (exit-entry node))) - (when value - (flush-dest value)) - (when entry - (setf (entry-exits entry) - (delete node (entry-exits entry)))))) - (creturn - (flush-dest (return-result node)) - (delete-return node)) - (cset - (flush-dest (set-value node)) - (let ((var (set-var node))) - (setf (basic-var-sets var) - (delete node (basic-var-sets var)))))) - - (delete-continuation (node-prev node))) - - (remove-from-dfo block) - (undefined-value)) - -(declaim (end-block)) - - -;;; Delete-Return -- Interface -;;; -;;; Do stuff to indicate that the return node Node is being deleted. We set -;;; the RETURN to NIL. -;;; -(defun delete-return (node) - (declare (type creturn node)) - (let ((fun (return-lambda node))) - (assert (lambda-return fun)) - (setf (lambda-return fun) nil)) - (undefined-value)) - - -;;; NOTE-UNREFERENCED-VARS -- Interface -;;; -;;; If any of the Vars in fun were never referenced and was not declared -;;; IGNORE, then complain. -;;; -(defun note-unreferenced-vars (fun) - (declare (type clambda fun)) - (dolist (var (lambda-vars fun)) - (unless (or (leaf-ever-used var) - (lambda-var-ignorep var)) - (let ((*compiler-error-context* (lambda-bind fun))) - (unless (policy *compiler-error-context* (= brevity 3)) - (compiler-warning "Variable ~S defined but never used." - (leaf-name var))) - (setf (leaf-ever-used var) t)))) - (undefined-value)) - - -(defvar *deletion-ignored-objects* '(t nil)) - -;;; PRESENT-IN-FORM -- Internal -;;; -;;; Return true if we can find Obj in Form, NIL otherwise. We bound our -;;; recursion so that we don't get lost in circular structures. We ignore the -;;; car of forms if they are a symbol (to prevent confusing function -;;; referencess with variables), and we also ignore anything inside ' or #'. -;;; -(defun present-in-form (obj form depth) - (declare (type (integer 0 20) depth)) - (cond ((= depth 20) nil) - ((eq obj form) t) - ((atom form) nil) - (t - (let ((first (car form)) - (depth (1+ depth))) - (if (member first '(quote function)) - nil - (or (and (not (symbolp first)) - (present-in-form obj first depth)) - (do ((l (cdr form) (cdr l)) - (n 0 (1+ n))) - ((or (atom l) (> n 100)) - nil) - (declare (fixnum n)) - (when (present-in-form obj (car l) depth) - (return t))))))))) - - -;;; NOTE-BLOCK-DELETION -- Internal -;;; -;;; This function is called on a block immediately before we delete it. We -;;; check to see if any of the code about to die appeared in the original -;;; source, and emit a note if so. -;;; -;;; If the block was in a lambda is now deleted, then we ignore the whole -;;; block, since this case is picked off in DELETE-LAMBDA. We also ignore -;;; the deletion of CRETURN nodes, since it is somewhat reasonable for a -;;; function to not return, and there is a different note for that case anyway. -;;; -;;; If the actual source is an atom, then we use a bunch of heuristics to -;;; guess whether this reference really appeared in the original source: -;;; -- If a symbol, it must be interned and not a keyword. -;;; -- It must not be an easily introduced constant (T or NIL, a fixnum or a -;;; character.) -;;; -- The atom must be "present" in the original source form, and present in -;;; all intervening actual source forms. -;;; -(defun note-block-deletion (block) - (let ((home (block-home-lambda block))) - (unless (eq (functional-kind home) :deleted) - (do-nodes (node cont block) - (let* ((path (node-source-path node)) - (first (first path))) - (when (or (eq first 'original-source-start) - (and (atom first) - (or (not (symbolp first)) - (let ((pkg (symbol-package first))) - (and pkg - (not (eq pkg (symbol-package :end)))))) - (not (member first *deletion-ignored-objects*)) - (not (typep first '(or fixnum character))) - (every #'(lambda (x) - (present-in-form first x 0)) - (source-path-forms path)) - (present-in-form first (find-original-source path) - 0))) - (unless (return-p node) - (let ((*compiler-error-context* node)) - (compiler-note "Deleting unreachable code."))) - (return)))))) - (undefined-value)) - - -;;; Unlink-Node -- Interface -;;; -;;; Delete a node from a block, deleting the block if there are no nodes -;;; left. We remove the node from the uses of its CONT, but we don't deal with -;;; cleaning up any type-specific semantic attachments. If the CONT is :UNUSED -;;; after deleting this use, then we delete CONT. (Note :UNUSED is not the -;;; same as no uses. A continuation will only become :UNUSED if it was -;;; :INSIDE-BLOCK before.) -;;; -;;; If the node is the last node, there must be exactly one successor. We -;;; link all of our precedessors to the successor and unlink the block. In -;;; this case, we return T, otherwise NIL. If no nodes are left, and the block -;;; is a successor of itself, then we replace the only node with a degenerate -;;; exit node. This provides a way to represent the bodyless infinite loop, -;;; given the prohibition on empty blocks in IR1. -;;; -(defun unlink-node (node) - (declare (type node node)) - (let* ((cont (node-cont node)) - (next (continuation-next cont)) - (prev (node-prev node)) - (block (continuation-block prev)) - (prev-kind (continuation-kind prev)) - (last (block-last block))) - - (unless (eq (continuation-kind cont) :deleted) - (delete-continuation-use node) - (when (eq (continuation-kind cont) :unused) - (assert (not (continuation-dest cont))) - (delete-continuation cont))) - - (setf (block-type-asserted block) t) - (setf (block-test-modified block) t) - - (cond ((or (eq prev-kind :inside-block) - (and (eq prev-kind :block-start) - (not (eq node last)))) - (cond ((eq node last) - (setf (block-last block) (continuation-use prev)) - (setf (continuation-next prev) nil)) - (t - (setf (continuation-next prev) next) - (setf (node-prev next) prev))) - (setf (node-prev node) nil) - nil) - (t - (assert (eq prev-kind :block-start)) - (assert (eq node last)) - (let* ((succ (block-succ block)) - (next (first succ))) - (assert (and succ (null (cdr succ)))) - (cond - ((member block succ) - (with-ir1-environment node - (let ((exit (make-exit)) - (dummy (make-continuation))) - (setf (continuation-next prev) nil) - (prev-link exit prev) - (add-continuation-use exit dummy) - (setf (block-last block) exit))) - (setf (node-prev node) nil) - nil) - (t - (assert (eq (block-start-cleanup block) - (block-end-cleanup block))) - (unlink-blocks block next) - (dolist (pred (block-pred block)) - (change-block-successor pred block next)) - (remove-from-dfo block) - (cond ((continuation-dest prev) - (setf (continuation-next prev) nil) - (setf (continuation-kind prev) :deleted-block-start)) - (t - (delete-continuation prev))) - (setf (node-prev node) nil) - t))))))) - - -;;; NODE-DELETED -- Interface -;;; -;;; Return true if NODE has been deleted, false if it is still a valid part -;;; of IR1. -;;; -(defun node-deleted (node) - (declare (type node node)) - (let ((prev (node-prev node))) - (not (and prev - (not (eq (continuation-kind prev) :deleted)) - (let ((block (continuation-block prev))) - (and (block-component block) - (not (block-delete-p block)))))))) - - -;;; DELETE-COMPONENT -- Interface -;;; -;;; Delete all the blocks and functions in Component. We scan first marking -;;; the blocks as delete-p to prevent weird stuff from being triggered by -;;; deletion. -;;; -(defun delete-component (component) - (declare (type component component)) - (assert (null (component-new-functions component))) - (setf (component-kind component) :deleted) - (do-blocks (block component) - (setf (block-delete-p block) t)) - (dolist (fun (component-lambdas component)) - (setf (functional-kind fun) nil) - (setf (leaf-refs fun) nil) - (delete-functional fun)) - (do-blocks (block component) - (delete-block block)) - (undefined-value)) - - -;;; EXTRACT-FUNCTION-ARGS -- interface -;;; -;;; Convert code of the form (foo ... (fun ...) ...) to (foo ... ... ...). -;;; In other words, replace the function combination fun by it's arguments. -;;; If there are any problems with doing this, use GIVE-UP to blow out of -;;; whatever transform called this. Note, as the number of arguments changes, -;;; the transform must be prepared to return a lambda with a new lambda-list -;;; with the correct number of arguments. -;;; -(defun extract-function-args (cont fun num-args) - "If CONT is a call to FUN with NUM-ARGS args, change those arguments - to feed directly to the continuation-dest of CONT, which must be - a combination." - (declare (type continuation cont) - (type symbol fun) - (type index num-args)) - (let ((outside (continuation-dest cont)) - (inside (continuation-use cont))) - (assert (combination-p outside)) - (unless (combination-p inside) - (give-up)) - (let ((inside-fun (combination-fun inside))) - (unless (eq (continuation-function-name inside-fun) fun) - (give-up)) - (let ((inside-args (combination-args inside))) - (unless (= (length inside-args) num-args) - (give-up)) - (let* ((outside-args (combination-args outside)) - (arg-position (position cont outside-args)) - (before-args (subseq outside-args 0 arg-position)) - (after-args (subseq outside-args (1+ arg-position)))) - (dolist (arg inside-args) - (setf (continuation-dest arg) outside)) - (setf (combination-args inside) nil) - (setf (combination-args outside) - (append before-args inside-args after-args)) - (change-ref-leaf (continuation-use inside-fun) - (find-free-function 'list "???")) - (setf (combination-kind inside) :full) - (setf (node-derived-type inside) *wild-type*) - (flush-dest cont) - (setf (continuation-asserted-type cont) *wild-type*) - (undefined-value)))))) - - - -;;;; Leaf hackery: - -;;; Change-Ref-Leaf -- Interface -;;; -;;; Change the Leaf that a Ref refers to. -;;; -(defun change-ref-leaf (ref leaf) - (declare (type ref ref) (type leaf leaf)) - (unless (eq (ref-leaf ref) leaf) - (push ref (leaf-refs leaf)) - (delete-ref ref) - (setf (ref-leaf ref) leaf) - (let ((ltype (leaf-type leaf))) - (if (function-type-p ltype) - (setf (node-derived-type ref) ltype) - (derive-node-type ref ltype))) - (reoptimize-continuation (node-cont ref))) - (undefined-value)) - - -;;; Substitute-Leaf -- Interface -;;; -;;; Change all Refs for Old-Leaf to New-Leaf. -;;; -(defun substitute-leaf (new-leaf old-leaf) - (declare (type leaf new-leaf old-leaf)) - (dolist (ref (leaf-refs old-leaf)) - (change-ref-leaf ref new-leaf)) - (undefined-value)) - -;;; SUBSTITUTE-LEAF-IF -- Interface -;;; -;;; Like SUBSITIUTE-LEAF, only there is a predicate on the Ref to tell -;;; whether to substitute. -;;; -(defun substitute-leaf-if (test new-leaf old-leaf) - (declare (type leaf new-leaf old-leaf) (type function test)) - (dolist (ref (leaf-refs old-leaf)) - (when (funcall test ref) - (change-ref-leaf ref new-leaf))) - (undefined-value)) - -;;; Find-Constant -- Interface -;;; -;;; Return a Leaf which represents the specified constant object. If the -;;; object is not in *constants*, then we create a new constant Leaf and -;;; enter it. -;;; -(declaim (maybe-inline find-constant)) -(defun find-constant (object) - (or (gethash object *constants*) - (setf (gethash object *constants*) - (make-constant :value object :name nil - :type (ctype-of object) - :where-from :defined)))) - - -;;;; Find-NLX-Info -- Interface -;;; -;;; If there is a non-local exit noted in Entry's environment that exits to -;;; Cont in that entry, then return it, otherwise return NIL. -;;; -(defun find-nlx-info (entry cont) - (declare (type entry entry) (type continuation cont)) - (let ((entry-cleanup (entry-cleanup entry))) - (dolist (nlx (environment-nlx-info (node-environment entry)) nil) - (when (and (eq (nlx-info-continuation nlx) cont) - (eq (nlx-info-cleanup nlx) entry-cleanup)) - (return nlx))))) - - -;;;; Functional hackery: - -;;; Main-Entry -- Interface -;;; -;;; If Functional is a Lambda, just return it; if it is an -;;; optional-dispatch, return the main-entry. -;;; -(proclaim '(function main-entry (functional) clambda)) -(defun main-entry (functional) - (if (lambda-p functional) - functional - (optional-dispatch-main-entry functional))) - -;;; Looks-Like-An-MV-Bind -- Interface -;;; -;;; Returns true if Functional is a thing that can be treated like MV-Bind -;;; when it appears in an MV-Call. All fixed arguments must be optional with -;;; null default and no supplied-p. There must be a rest arg with no -;;; references. -;;; -(proclaim '(function looks-like-an-mv-bind (functional) boolean)) -(defun looks-like-an-mv-bind (functional) - (and (optional-dispatch-p functional) - (do ((arg (optional-dispatch-arglist functional) (cdr arg))) - ((null arg) nil) - (let ((info (lambda-var-arg-info (car arg)))) - (unless info (return nil)) - (case (arg-info-kind info) - (:optional - (when (or (arg-info-supplied-p info) (arg-info-default info)) - (return nil))) - (:rest - (return (and (null (cdr arg)) (null (leaf-refs (car arg)))))) - (t - (return nil))))))) - -;;; External-Entry-Point-P -- Interface -;;; -;;; Return true if function is an XEP. This is true of normal XEPs -;;; (:External kind) and top-level lambdas (:Top-Level kind.) -;;; -(declaim (inline external-entry-point-p)) -(defun external-entry-point-p (fun) - (declare (type functional fun)) - (not (null (member (functional-kind fun) '(:external :top-level))))) - - -;;; Continuation-Function-Name -- Interface -;;; -;;; If Cont's only use is a non-notinline global function reference, then -;;; return the referenced symbol, otherwise NIL. If Notinline-OK is true, then -;;; we don't care if the leaf is notinline. -;;; -(defun continuation-function-name (cont &optional notinline-ok) - (declare (type continuation cont)) - (let ((use (continuation-use cont))) - (if (ref-p use) - (let ((leaf (ref-leaf use))) - (if (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function) - (or (not (defined-function-p leaf)) - (not (eq (defined-function-inlinep leaf) :notinline)) - notinline-ok)) - (leaf-name leaf) - nil)) - nil))) - - -;;; LET-COMBINATION -- Interface -;;; -;;; Return the COMBINATION node that is the call to the let Fun. -;;; -(defun let-combination (fun) - (declare (type clambda fun)) - (assert (member (functional-kind fun) '(:let :mv-let))) - (continuation-dest (node-cont (first (leaf-refs fun))))) - - -;;; LET-VAR-INITIAL-VALUE -- Interface -;;; -;;; Return the initial value continuation for a let variable or NIL if none. -;;; -(defun let-var-initial-value (var) - (declare (type lambda-var var)) - (let ((fun (lambda-var-home var))) - (elt (combination-args (let-combination fun)) - (position var (lambda-vars fun))))) - - -;;; COMBINATION-LAMBDA -- Interface -;;; -;;; Return the LAMBDA that is called by the local Call. -;;; -(declaim (inline combination-lambda)) -(defun combination-lambda (call) - (declare (type basic-combination call)) - (assert (eq (basic-combination-kind call) :local)) - (ref-leaf (continuation-use (basic-combination-fun call)))) - - -(defvar *inline-expansion-limit* 50 - "An upper limit on the number of inline function calls that will be expanded - in any given code object (single function or block compilation.)") - - -;;; INLINE-EXPANSION-OK -- Interface -;;; -;;; Check if Node's component has exceeded its inline expansion limit, and -;;; warn if so, returning NIL. -;;; -(defun inline-expansion-ok (node) - (let ((expanded (incf (component-inline-expansions - (block-component - (node-block node)))))) - (cond ((> expanded *inline-expansion-limit*) nil) - ((= expanded *inline-expansion-limit*) - (let ((*compiler-error-context* node)) - (compiler-warning "*Inline-Expansion-Limit* (~D) exceeded, ~ - probably trying to~% ~ - inline a recursive function." - *inline-expansion-limit*)) - nil) - (t t)))) - - -;;;; Compiler error context determination: - -(proclaim '(special *current-path*)) - - -;;; We bind print level and length when printing out messages so that we don't -;;; dump huge amounts of garbage. -;;; -(proclaim '(type (or unsigned-byte null) *error-print-level* - *error-print-length* *error-print-lines*)) - -(defvar *error-print-level* 3 - "The value for *Print-Level* when printing compiler error messages.") -(defvar *error-print-length* 5 - "The value for *Print-Length* when printing compiler error messages.") -(defvar *error-print-lines* 5 - "The value for *Print-Lines* when printing compiler error messages.") - -(defvar *enclosing-source-cutoff* 1 - "The maximum number of enclosing non-original source forms (i.e. from - macroexpansion) that we print in full. For additional enclosing forms, we - print only the CAR.") -(proclaim '(type unsigned-byte *enclosing-source-cutoff*)) - - -;;; We separate the determination of compiler error contexts from the actual -;;; signalling of those errors by objectifying the error context. This allows -;;; postponement of the determination of how (and if) to signal the error. -;;; -;;; We take care not to reference any of the IR1 so that pending potential -;;; error messages won't prevent the IR1 from being GC'd. To this end, we -;;; convert source forms to strings so that source forms that contain IR1 -;;; references (e.g. %DEFUN) don't hold onto the IR. -;;; -(defstruct (compiler-error-context - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (format stream "#<Compiler-Error-Context>")))) - ;; - ;; A list of the stringified CARs of the enclosing non-original source forms - ;; exceeding the *enclosing-source-cutoff*. - (enclosing-source nil :type list) - ;; - ;; A list of stringified enclosing non-original source forms. - (source nil :type list) - ;; - ;; The stringified form in the original source that expanded into Source. - (original-source (required-argument) :type simple-string) - ;; - ;; A list of prefixes of "interesting" forms that enclose original-source. - (context nil :type list) - ;; - ;; The FILE-INFO-NAME for the relevant FILE-INFO. - (file-name (required-argument) - :type (or simple-string (member :lisp :stream))) - ;; - ;; The file position at which the top-level form starts, if applicable. - (file-position nil :type (or index null)) - ;; - ;; The original source part of the source path. - (original-source-path nil :type list)) - - -;;; If true, this is the node which is used as context in compiler warning -;;; messages. -;;; -(proclaim '(type (or null compiler-error-context node) - *compiler-error-context*)) -(defvar *compiler-error-context* nil) - - -;;; Hashtable mapping macro names to source context parsers. Each parser -;;; function returns the source-context list for that form. -;;; -(defvar *source-context-methods* (make-hash-table)) - -;;; DEF-SOURCE-CONTEXT -- Public -;;; -(defmacro def-source-context (name ll &body body) - "DEF-SOURCE-CONTEXT Name Lambda-List Form* - This macro defines how to extract an abbreviated source context from the - Named form when it appears in the compiler input. Lambda-List is a DEFMACRO - style lambda-list used to parse the arguments. The Body should return a - list of subforms suitable for a \"~{~S ~}\" format string." - (let ((n-whole (gensym))) - `(setf (gethash ',name *source-context-methods*) - #'(lambda (,n-whole) - (destructuring-bind ,ll ,n-whole ,@body))))) - -(def-source-context defstruct (name-or-options &rest slots) - (declare (ignore slots)) - `(defstruct ,(if (consp name-or-options) - (car name-or-options) - name-or-options))) - -(def-source-context function (thing) - (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing))) - `(lambda ,(second thing)) - `(function ,thing))) - -#+pcl -(def-source-context pcl::defmethod (name &rest stuff) - (let ((arg-pos (position-if #'listp stuff))) - (if arg-pos - `(pcl::defmethod ,name ,@(subseq stuff 0 arg-pos) - ,@(nth-value 2 (pcl::parse-specialized-lambda-list - (elt stuff arg-pos)))) - `(pcl::defmethod ,name "<illegal syntax>")))) - - -;;; SOURCE-FORM-CONTEXT -- Internal -;;; -;;; Return the first two elements of Form if Form is a list. Take the car -;;; of the second form if appropriate. -;;; -(defun source-form-context (form) - (cond ((atom form) nil) - ((>= (length form) 2) - (funcall (gethash (first form) *source-context-methods* - #'(lambda (x) - (declare (ignore x)) - (list (first form) (second form)))) - (rest form))) - (t - form))) - - -;;; Find-Original-Source -- Internal -;;; -;;; Given a source path, return the original source form and a description -;;; of the interesting aspects of the context in which it appeared. The -;;; context is a list of lists, one sublist per context form. The sublist is a -;;; list of some of the initial subforms of the context form. -;;; -;;; For now, we use the first two subforms of each interesting form. A form is -;;; interesting if the first element is a symbol beginning with "DEF" and it is -;;; not the source form. If there is no DEF-mumble, then we use the outermost -;;; containing form. If the second subform is a list, then in some cases we -;;; return the car of that form rather than the whole form (i.e. don't show -;;; defstruct options, etc.) -;;; -(defun find-original-source (path) - (declare (list path)) - (let* ((rpath (reverse (source-path-original-source path))) - (tlf (first rpath)) - (root (find-source-root tlf *source-info*))) - (collect ((context)) - (let ((form root) - (current (rest rpath))) - (loop - (when (atom form) - (assert (null current)) - (return)) - (let ((head (first form))) - (when (symbolp head) - (let ((name (symbol-name head))) - (when (and (>= (length name) 3) (string= name "DEF" :end1 3)) - (context (source-form-context form)))))) - (when (null current) (return)) - (setq form (nth (pop current) form))) - - (cond ((context) - (values form (context))) - ((and path root) - (let ((c (source-form-context root))) - (values form (if c (list c) nil)))) - (t - (values '(unable to locate source) - '((some strange place))))))))) - - -;;; STRINGIFY-FORM -- Internal -;;; -;;; Convert a source form to a string, formatted suitably for use in -;;; compiler warnings. -;;; -(defun stringify-form (form &optional (pretty t)) - (let ((*print-level* (or *error-print-level* *print-level*)) - (*print-length* (or *error-print-length* *print-length*)) - (*print-lines* (or *error-print-lines* *print-lines*)) - (*print-pretty* pretty)) - (if pretty - (format nil " ~S~%" form) - (prin1-to-string form)))) - - -;;; FIND-ERROR-CONTEXT -- Interface -;;; -;;; Return a COMPILER-ERROR-CONTEXT structure describing the current error -;;; context, or NIL if we can't figure anything out. Args is a list of things -;;; that are going to be printed out in the error message, and can thus be -;;; blown off when they appear in the source context. -;;; -(defun find-error-context (args) - (let ((context *compiler-error-context*)) - (if (compiler-error-context-p context) - context - (let ((path (or *current-path* - (if context - (node-source-path context) - nil)))) - (when (and *source-info* path) - (multiple-value-bind (form src-context) - (find-original-source path) - (collect ((full nil cons) - (short nil cons)) - (let ((forms (source-path-forms path)) - (n 0)) - (dolist (src (if (member (first forms) args) - (rest forms) - forms)) - (if (>= n *enclosing-source-cutoff*) - (short (stringify-form (if (consp src) - (car src) - src) - nil)) - (full (stringify-form src))) - (incf n))) - - (let* ((tlf (source-path-tlf-number path)) - (file (find-file-info tlf *source-info*))) - (make-compiler-error-context - :enclosing-source (short) - :source (full) - :original-source (stringify-form form) - :context src-context - :file-name (file-info-name file) - :file-position - (multiple-value-bind (ignore pos) - (find-source-root tlf *source-info*) - (declare (ignore ignore)) - pos) - :original-source-path - (source-path-original-source path)))))))))) - - -;;;; Printing error messages: - -;;; A function that is called to unwind out of Compiler-Error. -;;; -(proclaim '(type (function () nil) *compiler-error-bailout*)) -(defvar *compiler-error-bailout* - #'(lambda () (error "Compiler-Error with no bailout."))) - -;;; The stream that compiler error output is directed to. -;;; -(defvar *compiler-error-output* (make-synonym-stream '*error-output*)) -(proclaim '(type stream *compiler-error-output*)) - -;;; We save the context information that we printed out most recently so that -;;; we don't print it out redundantly. - -;;; The last COMPILER-ERROR-CONTEXT that we printed. -;;; -(defvar *last-error-context* nil) -(proclaim '(type (or compiler-error-context null) *last-error-context*)) - -;;; The format string and args for the last error we printed. -;;; -(defvar *last-format-string* nil) -(defvar *last-format-args* nil) -(proclaim '(type (or string null) *last-format-string*)) -(proclaim '(type list *last-format-args*)) - -;;; The number of times that the last error message has been emitted, so that -;;; we can compress duplicate error messages. -(defvar *last-message-count* 0) -(proclaim '(type index *last-message-count*)) - -(defvar *compiler-notification-function* nil - "This is the function called by the compiler to specially note a warning, - comment, or error. The function must take four arguments, the severity - a string for context, the file namestring, and the file position. The - severity is one of :note, :warning, or :error. Except for the severity, all - of these can be NIL if unavailable or inapplicable.") - - -;;; COMPILER-NOTIFICATION -- Internal -;;; -;;; Call any defined notification function. -;;; -(defun compiler-notification (severity context) - (declare (type (member :note :warning :error) severity) - (type (or compiler-error-context null) context)) - (when *compiler-notification-function* - (if context - (let ((*print-level* 2) - (*print-pretty* nil) - (name (compiler-error-context-file-name context))) - (funcall *compiler-notification-function* severity - (format nil "~{~{~S~^ ~}~^ => ~}" - (compiler-error-context-context context)) - (when (stringp name) name) - (compiler-error-context-file-position context))) - (funcall *compiler-notification-function* severity nil nil nil))) - (undefined-value)) - - -;;; Note-Message-Repeats -- Internal -;;; -;;; If the last message was given more than once, then print out an -;;; indication of how many times it was repeated. We reset the message count -;;; when we are done. -;;; -(defun note-message-repeats (&optional (terpri t)) - (cond ((= *last-message-count* 1) - (when terpri (terpri *compiler-error-output*))) - ((> *last-message-count* 1) - (format *compiler-error-output* "[Last message occurs ~D times]~2%" - *last-message-count*))) - (setq *last-message-count* 0)) - - -;;; Print-Error-Message -- Internal -;;; -;;; Print out the message, with appropriate context if we can find it. If -;;; If the context is different from the context of the last message we -;;; printed, then we print the context. If the original source is different -;;; from the source we are working on, then we print the current source in -;;; addition to the original source. -;;; -;;; We suppress printing of messages identical to the previous, but record -;;; the number of times that the message is repeated. -;;; -(defun print-error-message (what format-string format-args) - (declare (type (member :error :warning :note) what) (string format-string) - (list format-args)) - (let* ((*print-level* (or *error-print-level* *print-level*)) - (*print-length* (or *error-print-length* *print-length*)) - (*print-lines* (or *error-print-lines* *print-lines*)) - (stream *compiler-error-output*) - (context (find-error-context format-args))) - (cond - (context - (let ((file (compiler-error-context-file-name context)) - (in (compiler-error-context-context context)) - (form (compiler-error-context-original-source context)) - (enclosing (compiler-error-context-enclosing-source context)) - (source (compiler-error-context-source context)) - (last *last-error-context*)) - (compiler-notification what context) - - (unless (and last - (equal file (compiler-error-context-file-name last))) - (when (stringp file) - (note-message-repeats) - (setq last nil) - (format stream "~2&File: ~A~%" file))) - - (unless (and last - (equal in (compiler-error-context-context last))) - (note-message-repeats) - (setq last nil) - (format stream "~2&In:~{~<~% ~4:;~{ ~S~}~>~^ =>~}~%" in)) - - (unless (and last - (string= form - (compiler-error-context-original-source last))) - (note-message-repeats) - (setq last nil) - (write-string form stream)) - - (unless (and last - (equal enclosing - (compiler-error-context-enclosing-source last))) - (when enclosing - (note-message-repeats) - (setq last nil) - (format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing))) - - (unless (and last - (equal source (compiler-error-context-source last))) - (setq *last-format-string* nil) - (when source - (note-message-repeats) - (dolist (src source) - (write-line "==>" stream) - (write-string src stream)))))) - (t - (compiler-notification what nil) - (note-message-repeats) - (setq *last-format-string* nil) - (format stream "~2&"))) - - (setq *last-error-context* context) - - (unless (and (equal format-string *last-format-string*) - (tree-equal format-args *last-format-args*)) - (note-message-repeats nil) - (setq *last-format-string* format-string) - (setq *last-format-args* format-args) - (format stream "~&~:(~A~): ~?~&" what format-string format-args))) - - (incf *last-message-count*) - (undefined-value)) - - -;;; Keep track of how many times each kind of warning happens. -;;; -(proclaim '(type index *compiler-error-count* *compiler-warning-count* - *compiler-note-count*)) -(defvar *compiler-error-count* 0) -(defvar *compiler-warning-count* 0) -(defvar *compiler-note-count* 0) - - -;;; Compiler-Error, ... -- Interface -;;; -;;; Increment the count and print the message. Compiler-Note never prints -;;; anything when Brevity is 3. Compiler-Error calls the bailout function -;;; so that it never returns. Compiler-Error-Message returns like -;;; Compiler-Warning, but prints a message like Compiler-Error. -;;; -(proclaim '(ftype (function (string &rest t) void) - compiler-error compiler-warning compiler-note)) -;;; -(defun compiler-error (format-string &rest format-args) - (incf *compiler-error-count*) - (print-error-message :error format-string format-args) - (funcall *compiler-error-bailout*) - (error "*Compiler-Error-Bailout* returned?")) -;;; -(defun compiler-error-message (format-string &rest format-args) - (incf *compiler-error-count*) - (print-error-message :error format-string format-args)) -;;; -(defun compiler-warning (format-string &rest format-args) - (incf *compiler-warning-count*) - (print-error-message :warning format-string format-args)) -;;; -(defun compiler-note (format-string &rest format-args) - (unless (if *compiler-error-context* - (policy *compiler-error-context* (= brevity 3)) - (policy nil (= brevity 3))) - (incf *compiler-note-count*) - (print-error-message :note format-string format-args))) - - -;;; Compiler-Mumble -- Interface -;;; -;;; The politically correct way to print out random progress messages and -;;; such like. We clear the current error context so that we know that it -;;; needs to be reprinted, and we also Force-Output so that the message gets -;;; seen right away. -;;; -(proclaim '(function compiler-mumble (string &rest t) void)) -(defun compiler-mumble (format-string &rest format-args) - (note-message-repeats) - (setq *last-error-context* nil) - (apply #'format *compiler-error-output* format-string format-args) - (force-output *compiler-error-output*)) - - -;;; Find-Component-Name -- Interface -;;; -;;; Return a string that somehow names the code in Component. We use the -;;; source path for the bind node for an arbitrary entry point to find the -;;; source context, then return that as a string. -;;; -(proclaim '(function find-component-name (component) simple-string)) -(defun find-component-name (component) - (let ((ep (first (block-succ (component-head component))))) - (assert ep () "No entry points?") - (multiple-value-bind - (form context) - (find-original-source - (node-source-path (continuation-next (block-start ep)))) - (declare (ignore form)) - (let ((*print-level* 2) - (*print-pretty* nil)) - (format nil "~{~{~S~^ ~}~^ => ~}" context))))) - - -;;;; Undefined warnings: - - -(defvar *undefined-warning-limit* 3 - "If non-null, then an upper limit on the number of unknown function or type - warnings that the compiler will print for any given name in a single - compilation. This prevents excessive amounts of output when there really is - a missing definition (as opposed to a typo in the use.)") - - -;;; NOTE-UNDEFINED-REFERENCE -- Interface -;;; -;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference to Name -;;; of the specified Kind. If we have exceeded the warning limit, then just -;;; increment the count, otherwise note the current error context. -;;; -(defun note-undefined-reference (name kind) - (unless (policy nil (= brevity 3)) - (let* ((found (dolist (warn *undefined-warnings* nil) - (when (and (equal (undefined-warning-name warn) name) - (eq (undefined-warning-kind warn) kind)) - (return warn)))) - (res (or found - (make-undefined-warning :name name :kind kind)))) - (unless found (push res *undefined-warnings*)) - (when (or (not *undefined-warning-limit*) - (< (undefined-warning-count res) *undefined-warning-limit*)) - (push (find-error-context (list name)) - (undefined-warning-warnings res))) - (incf (undefined-warning-count res)))) - (undefined-value)) - - -;;;; Careful call: - -;;; Careful-Call -- Interface -;;; -;;; Apply a function to some arguments, returning a list of the values -;;; resulting of the evaulation. If an error is signalled during the -;;; application, then we print a warning message and return NIL as our second -;;; value to indicate this. Node is used as the error context for any error -;;; message, and Context is a string that is spliced into the warning. -;;; -(proclaim '(function careful-call ((or symbol function) list node string) - (values list boolean))) -(defun careful-call (function args node context) - (values - (multiple-value-list - (handler-case (apply function args) - (error (condition) - (let ((*compiler-error-context* node)) - (compiler-warning "Lisp error during ~A:~%~A" context condition) - (return-from careful-call (values nil nil)))))) - t)) - - -;;;; Generic list (?) functions: - -(proclaim '(inline find-in position-in map-in)) - -;;; Find-In -- Interface -;;; -(defun find-in (next element list &key (key #'identity) - (test #'eql test-p) (test-not nil not-p)) - "Find Element in a null-terminated List linked by the accessor function - Next. Key, Test and Test-Not are the same as for generic sequence - functions." - (when (and test-p not-p) - (error "Silly to supply both :Test and :Test-Not.")) - (if not-p - (do ((current list (funcall next current))) - ((null current) nil) - (unless (funcall test-not (funcall key current) element) - (return current))) - (do ((current list (funcall next current))) - ((null current) nil) - (when (funcall test (funcall key current) element) - (return current))))) - -;;; Position-In -- Interface -;;; -(defun position-in (next element list &key (key #'identity) - (test #'eql test-p) (test-not nil not-p)) - "Return the position of Element (or NIL if absent) in a null-terminated List - linked by the accessor function Next. Key, Test and Test-Not are the same as - for generic sequence functions." - (when (and test-p not-p) - (error "Silly to supply both :Test and :Test-Not.")) - (if not-p - (do ((current list (funcall next current)) - (i 0 (1+ i))) - ((null current) nil) - (unless (funcall test-not (funcall key current) element) - (return i))) - (do ((current list (funcall next current)) - (i 0 (1+ i))) - ((null current) nil) - (when (funcall test (funcall key current) element) - (return i))))) - - -;;; Map-In -- Interface -;;; -(defun map-in (next function list) - "Map Function over the elements in a null-terminated List linked by the - accessor function Next, returning a list of the results." - (collect ((res)) - (do ((current list (funcall next current))) - ((null current)) - (res (funcall function current))) - (res))) - - -;;; Deletef-In -- Interface -;;; -(defmacro deletef-in (next place item &environment env) - "Deletef-In Next Place Item - Delete Item from a null-terminated list linked by the accessor function Next - that is stored in Place. Item must appear exactly once in the list." - (multiple-value-bind - (temps vals stores store access) - (get-setf-method place env) - (let ((n-item (gensym)) - (n-place (gensym)) - (n-current (gensym)) - (n-prev (gensym))) - `(let* (,@(mapcar #'list temps vals) - (,n-place ,access) - (,n-item ,item)) - (if (eq ,n-place ,n-item) - (let ((,(first stores) (,next ,n-place))) - ,store) - (do ((,n-prev ,n-place ,n-current) - (,n-current (,next ,n-place) - (,next ,n-current))) - ((eq ,n-current ,n-item) - (setf (,next ,n-prev) - (,next ,n-current))))) - (undefined-value))))) - - -;;; Push-In -- Interface -;;; -(defmacro push-in (next item place &environment env) - "Push Item onto a list linked by the accessor function Next that is stored in - Place." - (multiple-value-bind - (temps vals stores store access) - (get-setf-method place env) - `(let (,@(mapcar #'list temps vals) - (,(first stores) ,item)) - (setf (,next ,(first stores)) ,access) - ,store - (undefined-value)))) - - -;;; Compiler-Constantp -- Interface -;;; -;;; We don't want to assume that a variable is a constant just because it is -;;; in the current lisp environment. -;;; -;;; ### For now, just use CONSTANTP to avoid bootstrapping problems with having -;;; to have the INFO database available at meta-compile time. -;;; -(proclaim '(function compiler-constantp (t) boolean)) -(defun compiler-constantp (exp) - "Like constantp, only uses the compilation environment rather than the - current Lisp environment." -#| - (if (symbolp exp) - (eq (info variable kind exp) :constant) - (constantp exp)) -|# - (constantp exp)) diff --git a/compiler/life.lisp b/compiler/life.lisp deleted file mode 100644 index 9ad097ccfd7397642918ef3a91bf27244592d394..0000000000000000000000000000000000000000 --- a/compiler/life.lisp +++ /dev/null @@ -1,1132 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/life.lisp,v 1.21 1992/08/14 15:20:19 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the lifetime analysis phase in the compiler. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; Utilities: - -;;; Add-Global-Conflict -- Internal -;;; -;;; Link in a global-conflicts structure for TN in Block with Number as the -;;; LTN number. The conflict is inserted in the per-TN Global-Conflicts thread -;;; after the TN's Current-Conflict. We change the Current-Conflict to point -;;; to the new conflict. Since we scan the blocks in reverse DFO, this list is -;;; automatically built in order. We have to actually scan the current -;;; Global-TNs for the block in order to keep that thread sorted. -;;; -(defun add-global-conflict (kind tn block number) - (declare (type (member :read :write :read-only :live) kind) - (type tn tn) (type ir2-block block) - (type (or local-tn-number null) number)) - (let ((new (make-global-conflicts kind tn block number))) - (let ((last (tn-current-conflict tn))) - (if last - (shiftf (global-conflicts-tn-next new) - (global-conflicts-tn-next last) - new) - (shiftf (global-conflicts-tn-next new) - (tn-global-conflicts tn) - new))) - (setf (tn-current-conflict tn) new) - - (insert-block-global-conflict new block)) - (undefined-value)) - - -;;; INSERT-BLOCK-GLOBAL-CONFLICT -- Internal -;;; -;;; Do the actual insertion of the conflict New into Block's global -;;; conflicts. -;;; -(defun insert-block-global-conflict (new block) - (let ((global-num (tn-number (global-conflicts-tn new)))) - (do ((prev nil conf) - (conf (ir2-block-global-tns block) - (global-conflicts-next conf))) - ((or (null conf) - (> (tn-number (global-conflicts-tn conf)) global-num)) - (if prev - (setf (global-conflicts-next prev) new) - (setf (ir2-block-global-tns block) new)) - (setf (global-conflicts-next new) conf)))) - (undefined-value)) - - -;;; Reset-Current-Conflict -- Internal -;;; -;;; Reset the Current-Conflict slot in all packed TNs to point to the head -;;; of the Global-Conflicts thread. -;;; -(defun reset-current-conflict (component) - (do-packed-tns (tn component) - (setf (tn-current-conflict tn) (tn-global-conflicts tn)))) - - -;;;; Pre-pass: - -;;; Convert-To-Global -- Internal -;;; -;;; Convert TN (currently local) to be a global TN, since we discovered that -;;; it is referenced in more than one block. We just add a global-conflicts -;;; structure with a kind derived from the Kill and Live sets. -;;; -(defun convert-to-global (tn) - (declare (type tn tn)) - (let ((block (tn-local tn)) - (num (tn-local-number tn))) - (add-global-conflict - (if (zerop (sbit (ir2-block-written block) num)) - :read-only - (if (zerop (sbit (ir2-block-live-out block) num)) - :write - :read)) - tn block num)) - (undefined-value)) - - -;;; Find-Local-References -- Internal -;;; -;;; Scan all references to packed TNs in block. We assign LTN numbers to -;;; each referenced TN, and also build the Kill and Live sets that summarize -;;; the references to each TN for purposes of lifetime analysis. -;;; -;;; It is possible that we will run out of LTN numbers. If this happens, -;;; then we return the VOP that we were processing at the time we ran out, -;;; otherwise we return NIL. -;;; -;;; If a TN is referenced in more than one block, then we must represent -;;; references using Global-Conflicts structures. When we first see a TN, we -;;; assume it will be local. If we see a reference later on in a different -;;; block, then we go back and fix the TN to global. -;;; -;;; We must globalize TNs that have a block other than the current one in -;;; their Local slot and have no Global-Conflicts. The latter condition is -;;; necessary because we always set Local and Local-Number when we process a -;;; reference to a TN, even when the TN is already known to be global. -;;; -;;; When we see reference to global TNs during the scan, we add the -;;; global-conflict as :Read-Only, since we don't know the corrent kind until -;;; we are done scanning the block. -;;; -(defun find-local-references (block) - (declare (type ir2-block block)) - (let ((kill (ir2-block-written block)) - (live (ir2-block-live-out block)) - (tns (ir2-block-local-tns block))) - (let ((ltn-num (ir2-block-local-tn-count block))) - (do ((vop (ir2-block-last-vop block) - (vop-prev vop))) - ((null vop)) - (do ((ref (vop-refs vop) (tn-ref-next-ref ref))) - ((null ref)) - (let* ((tn (tn-ref-tn ref)) - (local (tn-local tn)) - (kind (tn-kind tn))) - (unless (member kind '(:component :environment :constant)) - (unless (eq local block) - (when (= ltn-num local-tn-limit) - (return-from find-local-references vop)) - (when local - (unless (tn-global-conflicts tn) - (convert-to-global tn)) - (add-global-conflict :read-only tn block ltn-num)) - - (setf (tn-local tn) block) - (setf (tn-local-number tn) ltn-num) - (setf (svref tns ltn-num) tn) - (incf ltn-num)) - - (let ((num (tn-local-number tn))) - (if (tn-ref-write-p ref) - (setf (sbit kill num) 1 (sbit live num) 0) - (setf (sbit live num) 1))))))) - - (setf (ir2-block-local-tn-count block) ltn-num))) - nil) - - -;;; Init-Global-Conflict-Kind -- Internal -;;; -;;; Finish up the global conflicts for TNs referenced in Block according to -;;; the local Kill and Live sets. -;;; -;;; We set the kind for TNs already in the global-TNs. If not written at -;;; all, then is :Read-Only, the default. Must have been referenced somehow, -;;; or we wouldn't have conflicts for it. -;;; -;;; We also iterate over all the local TNs, looking for TNs local to this -;;; block that are still live at the block beginning, and thus must be global. -;;; This case is only important when a TN is read in a block but not written in -;;; any other, since otherwise the write would promote the TN to global. But -;;; this does happen with various passing-location TNs that are magically -;;; written. This also serves to propagate the lives of erroneously -;;; uninitialized TNs so that consistency checks can detect them. -;;; -(defun init-global-conflict-kind (block) - (declare (type ir2-block block)) - (let ((live (ir2-block-live-out block))) - (let ((kill (ir2-block-written block))) - (do ((conf (ir2-block-global-tns block) - (global-conflicts-next conf))) - ((null conf)) - (let ((num (global-conflicts-number conf))) - (unless (zerop (sbit kill num)) - (setf (global-conflicts-kind conf) - (if (zerop (sbit live num)) - :write - :read)))))) - - (let ((ltns (ir2-block-local-tns block))) - (dotimes (i (ir2-block-local-tn-count block)) - (let ((tn (svref ltns i))) - (unless (or (eq tn :more) - (tn-global-conflicts tn) - (zerop (sbit live i))) - (convert-to-global tn)))))) - - (undefined-value)) - - -(defevent split-ir2-block "Split an IR2 block to meet Local-TN-Limit.") - -;;; Split-IR2-Blocks -- Internal -;;; -;;; Move the code after the VOP Lose in 2block into its own block. The -;;; block is linked into the emit order following 2block. Number is the block -;;; number assigned to the new block. We return the new block. -;;; -(defun split-ir2-blocks (2block lose number) - (declare (type ir2-block 2block) (type vop lose) - (type unsigned-byte number)) - (event split-ir2-block (vop-node lose)) - (let ((new (make-ir2-block (ir2-block-block 2block))) - (new-start (vop-next lose))) - (setf (ir2-block-number new) number) - (add-to-emit-order new 2block) - - (do ((vop new-start (vop-next vop))) - ((null vop)) - (setf (vop-block vop) new)) - - (setf (ir2-block-start-vop new) new-start) - (shiftf (ir2-block-last-vop new) (ir2-block-last-vop 2block) lose) - - (setf (vop-next lose) nil) - (setf (vop-prev new-start) nil) - - new)) - - -;;; Clear-Lifetime-Info -- Internal -;;; -;;; Clear the global and local conflict info in Block so that we can -;;; recompute it without any old cruft being retained. It is assumed that all -;;; LTN numbers are in use. -;;; -;;; First we delete all the global conflicts. The conflict we are deleting -;;; must be the last in the TN's global-conflicts, but we must scan for it in -;;; order to find the previous conflict. -;;; -;;; Next, we scan the local TNs, nulling out the Local slot in all TNs with -;;; no global conflicts. This allows these TNs to be treated as local when we -;;; scan the block again. -;;; -;;; If there are conflicts, then we set Local to one of the conflicting -;;; blocks. This ensures that Local doesn't hold over Block as its value, -;;; causing the subsequent reanalysis to think that the TN has already been -;;; seen in that block. -;;; -;;; This function must not be called on blocks that have :More TNs. -;;; -(defun clear-lifetime-info (block) - (declare (type ir2-block block)) - (setf (ir2-block-local-tn-count block) 0) - - (do ((conf (ir2-block-global-tns block) - (global-conflicts-next conf))) - ((null conf) - (setf (ir2-block-global-tns block) nil)) - (let ((tn (global-conflicts-tn conf))) - (assert (eq (tn-current-conflict tn) conf)) - (assert (null (global-conflicts-tn-next conf))) - (do ((current (tn-global-conflicts tn) - (global-conflicts-tn-next current)) - (prev nil current)) - ((eq current conf) - (if prev - (setf (global-conflicts-tn-next prev) nil) - (setf (tn-global-conflicts tn) nil)) - (setf (tn-current-conflict tn) prev))))) - - (fill (ir2-block-written block) 0) - (let ((ltns (ir2-block-local-tns block))) - (dotimes (i local-tn-limit) - (let ((tn (svref ltns i))) - (assert (not (eq tn :more))) - (let ((conf (tn-global-conflicts tn))) - (setf (tn-local tn) - (if conf - (global-conflicts-block conf) - nil)))))) - - (undefined-value)) - - -;;; Coalesce-More-LTN-Numbers -- Internal -;;; -;;; This provides a panic mode for assigning LTN numbers when there is a VOP -;;; with so many more operands that they can't all be assigned distinct -;;; numbers. When this happens, we recover by assigning all the more operands -;;; the same LTN number. We can get away with this, since all more args (and -;;; results) are referenced simultaneously as far as conflict analysis is -;;; concerned. -;;; -;;; Block is the IR2-Block that the more VOP is at the end of. Ops is the -;;; full argument or result TN-Ref list. Fixed is the types of the fixed -;;; operands (used only to skip those operands.) -;;; -;;; What we do is grab a LTN number, then make a :Read-Only global conflict -;;; for each more operand TN. We require that there be no existing global -;;; conflict in Block for any of the operands. Since conflicts must be cleared -;;; before the first call, this only prohibits the same TN being used both as a -;;; more operand and as any other operand to the same VOP. -;;; -;;; We don't have to worry about getting the correct conflict kind, since -;;; Init-Global-Conflict-Kind will fix things up. Similarly, -;;; FIND-LOCAL-REFERENCES will set the local conflict bit corresponding to this -;;; call. -;;; -;;; We also set the Local and Local-Number slots in each TN. It is -;;; possible that there are no operands in any given call to this function, but -;;; there had better be either some more args or more results. -;;; -(defun coalesce-more-ltn-numbers (block ops fixed) - (declare (type ir2-block block) (type (or tn-ref null) ops) (list fixed)) - (let ((num (ir2-block-local-tn-count block))) - (assert (< num local-tn-limit)) - (incf (ir2-block-local-tn-count block)) - (setf (svref (ir2-block-local-tns block) num) :more) - - (do ((op (do ((op ops (tn-ref-across op)) - (i 0 (1+ i))) - ((= i (length fixed)) op) - (declare (type index i))) - (tn-ref-across op))) - ((null op)) - (let ((tn (tn-ref-tn op))) - (assert - (flet ((frob (refs) - (do ((ref refs (tn-ref-next ref))) - ((null ref) t) - (when (and (eq (vop-block (tn-ref-vop ref)) block) - (not (eq ref op))) - (return nil))))) - (and (frob (tn-reads tn)) (frob (tn-writes tn)))) - () "More operand ~S used more than once in its VOP." op) - (assert (not (find-in #'global-conflicts-next tn - (ir2-block-global-tns block) - :key #'global-conflicts-tn))) - - (add-global-conflict :read-only tn block num) - (setf (tn-local tn) block) - (setf (tn-local-number tn) num)))) - (undefined-value)) - - -(defevent coalesce-more-ltn-numbers - "Coalesced LTN numbers for a more operand to meet Local-TN-Limit.") - -;;; Lifetime-Pre-Pass -- Internal -;;; -;;; Loop over the blocks in Component, assigning LTN numbers and recording -;;; TN birth and death. The only interesting action is when we run out of -;;; local TN numbers while finding local references. -;;; -;;; If we run out of LTN numbers while processing a VOP within the block, -;;; then we just split off the VOPs we have successfully processed into their -;;; own block. -;;; -;;; If we run out of LTN numbers while processing the our first VOP (the -;;; last in the block), then it must be the case that this VOP has large more -;;; operands. We split the VOP into its own block, and then call -;;; Coalesce-More-Ltn-Numbers to assign all the more args/results the same LTN -;;; number(s). -;;; -;;; In either case, we clear the lifetime information that we computed so -;;; far, recomputing it after taking corrective action. -;;; -;;; Whenever we split a block, we finish the pre-pass on the split-off block -;;; by doing Find-Local-References and Init-Global-Conflict-Kind. This can't -;;; run out of LTN numbers. -;;; -(defun lifetime-pre-pass (component) - (declare (type component component)) - (let ((counter -1)) - (declare (type fixnum counter)) - (do-blocks-backwards (block component) - (let ((2block (block-info block))) - (do ((lose (find-local-references 2block) - (find-local-references 2block)) - (last-lose nil lose) - (coalesced nil)) - ((not lose) - (init-global-conflict-kind 2block) - (setf (ir2-block-number 2block) (incf counter))) - - (clear-lifetime-info 2block) - - (cond - ((vop-next lose) - (assert (not (eq last-lose lose))) - (let ((new (split-ir2-blocks 2block lose (incf counter)))) - (assert (not (find-local-references new))) - (init-global-conflict-kind new))) - (t - (assert (not (eq lose coalesced))) - (setq coalesced lose) - (event coalesce-more-ltn-numbers (vop-node lose)) - (let ((info (vop-info lose)) - (new (if (vop-prev lose) - (split-ir2-blocks 2block (vop-prev lose) - (incf counter)) - 2block))) - (coalesce-more-ltn-numbers new (vop-args lose) - (vop-info-arg-types info)) - (coalesce-more-ltn-numbers new (vop-results lose) - (vop-info-result-types info)) - (let ((lose (find-local-references new))) - (assert (not lose))) - (init-global-conflict-kind new)))))))) - - (undefined-value)) - - -;;;; Environment TN stuff: - - -;;; SETUP-ENVIRONMENT-TN-CONFLICT -- Internal -;;; -;;; Add a :LIVE global conflict for TN in 2block if there is none present. -;;; If Debug-P is false (a :ENVIRONMENT TN), then modify any existing conflict -;;; to be :LIVE. -;;; -(defun setup-environment-tn-conflict (tn 2block debug-p) - (declare (type tn tn) (type ir2-block 2block)) - (let ((block-num (ir2-block-number 2block))) - (do ((conf (tn-current-conflict tn) (global-conflicts-tn-next conf)) - (prev nil conf)) - ((or (null conf) - (> (ir2-block-number (global-conflicts-block conf)) block-num)) - (setf (tn-current-conflict tn) prev) - (add-global-conflict :live tn 2block nil)) - (when (eq (global-conflicts-block conf) 2block) - (unless (or debug-p - (eq (global-conflicts-kind conf) :live)) - (setf (global-conflicts-kind conf) :live) - (setf (svref (ir2-block-local-tns 2block) - (global-conflicts-number conf)) - nil) - (setf (global-conflicts-number conf) nil)) - (setf (tn-current-conflict tn) conf) - (return)))) - (undefined-value)) - - -;;; SETUP-ENVIRONMENT-TN-CONFLICTS -- Internal -;;; -;;; Iterate over all the blocks in Env, setting up :LIVE conflicts for TN. -;;; We make the TN global if it isn't already. The TN must have at least one -;;; reference. -;;; -(defun setup-environment-tn-conflicts (component tn env debug-p) - (declare (type component component) (type tn tn) (type environment env)) - (when (and debug-p - (not (tn-global-conflicts tn)) - (tn-local tn)) - (convert-to-global tn)) - (setf (tn-current-conflict tn) (tn-global-conflicts tn)) - (do-blocks-backwards (block component) - (when (eq (block-environment block) env) - (let* ((2block (block-info block)) - (last (do ((b (ir2-block-next 2block) (ir2-block-next b)) - (prev 2block b)) - ((not (eq (ir2-block-block b) block)) - prev)))) - (do ((b last (ir2-block-prev b))) - ((not (eq (ir2-block-block b) block))) - (setup-environment-tn-conflict tn b debug-p))))) - (undefined-value)) - - -;;; SETUP-ENVIRONMENT-LIVE-CONFLICTS -- Internal -;;; -;;; Iterate over all the environment TNs, adding always-live conflicts as -;;; appropriate. -;;; -(defun setup-environment-live-conflicts (component) - (declare (type component component)) - (dolist (fun (component-lambdas component)) - (let* ((env (lambda-environment fun)) - (2env (environment-info env))) - (dolist (tn (ir2-environment-live-tns 2env)) - (setup-environment-tn-conflicts component tn env nil)) - (dolist (tn (ir2-environment-debug-live-tns 2env)) - (setup-environment-tn-conflicts component tn env t)))) - (undefined-value)) - - -;;; Convert-To-Environment-TN -- Internal -;;; -;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN. This -;;; requires adding :LIVE conflicts to all blocks in TN-ENV. -;;; -(defun convert-to-environment-tn (tn tn-env) - (declare (type tn tn) (type environment tn-env)) - (assert (member (tn-kind tn) '(:normal :debug-environment))) - (when (eq (tn-kind tn) :debug-environment) - (assert (eq (tn-environment tn) tn-env)) - (let ((2env (environment-info tn-env))) - (setf (ir2-environment-debug-live-tns 2env) - (delete tn (ir2-environment-debug-live-tns 2env))))) - (setup-environment-tn-conflicts *compile-component* tn tn-env nil) - (setf (tn-local tn) nil) - (setf (tn-local-number tn) nil) - (setf (tn-kind tn) :environment) - (setf (tn-environment tn) tn-env) - (push tn (ir2-environment-live-tns (environment-info tn-env))) - (undefined-value)) - - -;;;; Flow analysis: - -;;; Propagate-Live-TNs -- Internal -;;; -;;; For each Global-TN in Block2 that is :Live, :Read or :Read-Only, ensure -;;; that there is a corresponding Global-Conflict in Block1. If there is none, -;;; make a :Live Global-Conflict. If there is a :Read-Only conflict, promote -;;; it to :Live. -;;; -;;; If we did added a new conflict, return true, otherwise false. We don't -;;; need to return true when we promote a :Read-Only conflict, since it doesn't -;;; reveal any new information to predecessors of Block1. -;;; -;;; We use the Tn-Current-Conflict to walk through the global -;;; conflicts. Since the global conflicts for a TN are ordered by block, we -;;; can be sure that the Current-Conflict always points at or before the block -;;; that we are looking at. This allows us to quickly determine if there is a -;;; global conflict for a given TN in Block1. -;;; -;;; When we scan down the conflicts, we know that there must be at least one -;;; conflict for TN, since we got our hands on TN by picking it out of a -;;; conflict in Block2. -;;; -;;; We leave the Current-Conflict pointing to the conflict for Block1. The -;;; Current-Conflict must be initialized to the head of the Global-Conflicts -;;; for the TN between each flow analysis iteration. -;;; -(defun propagate-live-tns (block1 block2) - (declare (type ir2-block block1 block2)) - (let ((live-in (ir2-block-live-in block1)) - (did-something nil)) - (do ((conf2 (ir2-block-global-tns block2) - (global-conflicts-next conf2))) - ((null conf2)) - (ecase (global-conflicts-kind conf2) - ((:live :read :read-only) - (let* ((tn (global-conflicts-tn conf2)) - (tn-conflicts (tn-current-conflict tn)) - (number1 (ir2-block-number block1))) - (assert tn-conflicts) - (do ((current tn-conflicts (global-conflicts-tn-next current)) - (prev nil current)) - ((or (null current) - (> (ir2-block-number (global-conflicts-block current)) - number1)) - (setf (tn-current-conflict tn) prev) - (add-global-conflict :live tn block1 nil) - (setq did-something t)) - (when (eq (global-conflicts-block current) block1) - (case (global-conflicts-kind current) - (:live) - (:read-only - (setf (global-conflicts-kind current) :live) - (setf (svref (ir2-block-local-tns block1) - (global-conflicts-number current)) - nil) - (setf (global-conflicts-number current) nil) - (setf (tn-current-conflict tn) current)) - (t - (setf (sbit live-in (global-conflicts-number current)) 1))) - (return))))) - (:write))) - did-something)) - - -;;; Lifetime-Flow-Analysis -- Internal -;;; -;;; Do backward global flow analysis to find all TNs live at each block -;;; boundary. -;;; -(defun lifetime-flow-analysis (component) - (loop - (reset-current-conflict component) - (let ((did-something nil)) - (do-blocks-backwards (block component) - (let* ((2block (block-info block)) - (last (do ((b (ir2-block-next 2block) (ir2-block-next b)) - (prev 2block b)) - ((not (eq (ir2-block-block b) block)) - prev)))) - - (dolist (b (block-succ block)) - (when (and (block-start b) - (propagate-live-tns last (block-info b))) - (setq did-something t))) - - (do ((b (ir2-block-prev last) (ir2-block-prev b)) - (prev last b)) - ((not (eq (ir2-block-block b) block))) - (when (propagate-live-tns b prev) - (setq did-something t))))) - - (unless did-something (return)))) - - (undefined-value)) - - -;;;; Post-pass: - -;;; Note-Conflicts -- Internal -;;; -;;; Note that TN conflicts with all current live TNs. Num is TN's LTN -;;; number. We bit-ior Live-Bits with TN's Local-Conflicts, and set TN's -;;; number in the conflicts of all TNs in Live-List. -;;; -(defun note-conflicts (live-bits live-list tn num) - (declare (type tn tn) (type (or tn null) live-list) - (type local-tn-bit-vector live-bits) - (type local-tn-number num)) - (let ((lconf (tn-local-conflicts tn))) - (bit-ior live-bits lconf lconf)) - (do ((live live-list (tn-next* live))) - ((null live)) - (setf (sbit (tn-local-conflicts live) num) 1)) - (undefined-value)) - - -;;; Compute-Save-Set -- Internal -;;; -;;; Compute a bit vector of the TNs live after VOP that aren't results. -;;; -(defun compute-save-set (vop live-bits) - (declare (type vop vop) (type local-tn-bit-vector live-bits)) - (let ((live (bit-vector-copy live-bits))) - (do ((r (vop-results vop) (tn-ref-across r))) - ((null r)) - (let ((tn (tn-ref-tn r))) - (ecase (tn-kind tn) - ((:normal :debug-environment) - (setf (sbit live (tn-local-number tn)) 0)) - (:environment :component)))) - live)) - - -;;; SAVED-AFTER-READ -- Internal -;;; -;;; Used to determine whether a :DEBUG-ENVIRONMENT TN should be considered -;;; live at block end. We return true if a VOP with non-null SAVE-P appears -;;; before the first read of TN (hence is seen first in our backward scan.) -;;; -(defun saved-after-read (tn block) - (do ((vop (ir2-block-last-vop block) (vop-prev vop))) - ((null vop) t) - (when (vop-info-save-p (vop-info vop)) (return t)) - (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn) - (return nil)))) - -;;; MAKE-DEBUG-ENVIRONMENT-TNS-LIVE -- Internal -;;; -;;; If the block has no successors, or its successor is the component tail, -;;; then all :DEBUG-ENVIRONMENT TNs are always added, regardless of whether -;;; they appeared to be live. This ensures that these TNs are considered to be -;;; live throughout blocks that read them, but don't have any interesting -;;; successors (such as a return or tail call.) In this case, we set the -;;; corresponding bit in LIVE-IN as well. -;;; -(defun make-debug-environment-tns-live (block live-bits live-list) - (let* ((1block (ir2-block-block block)) - (live-in (ir2-block-live-in block)) - (succ (block-succ 1block)) - (next (ir2-block-next block))) - (when (and next - (not (eq (ir2-block-block next) 1block)) - (or (null succ) - (eq (first succ) - (component-tail (block-component 1block))))) - (do ((conf (ir2-block-global-tns block) - (global-conflicts-next conf))) - ((null conf)) - (let* ((tn (global-conflicts-tn conf)) - (num (global-conflicts-number conf))) - (when (and num (zerop (sbit live-bits num)) - (eq (tn-kind tn) :debug-environment) - (eq (tn-environment tn) (block-environment 1block)) - (saved-after-read tn block)) - (note-conflicts live-bits live-list tn num) - (setf (sbit live-bits num) 1) - (push-in tn-next* tn live-list) - (setf (sbit live-in num) 1)))))) - - (values live-bits live-list)) - - -;;; Compute-Initial-Conflicts -- Internal -;;; -;;; Return as values, a LTN bit-vector and a list (threaded by TN-Next*) -;;; representing the TNs live at the end of Block (exclusive of :Live TNs). -;;; -;;; We iterate over the TNs in the global conflicts that are live at the block -;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the -;;; TN to the live list. -;;; -;;; If a :MORE result is not live, we effectively fake a read to it. This is -;;; part of the action described in ENSURE-RESULTS-LIVE. -;;; -;;; At the end, we call MAKE-DEBUG-ENVIRONEMNT-TNS-LIVE to make debug -;;; environment TNs appear live when appropriate, even when they aren't. -;;; -;;; ### Note: we alias the global-conflicts-conflicts here as the -;;; tn-local-conflicts. -;;; -(defun compute-initial-conflicts (block) - (declare (type ir2-block block)) - (let* ((live-in (ir2-block-live-in block)) - (ltns (ir2-block-local-tns block)) - (live-bits (bit-vector-copy live-in)) - (live-list nil)) - - (do ((conf (ir2-block-global-tns block) - (global-conflicts-next conf))) - ((null conf)) - (let ((bits (global-conflicts-conflicts conf)) - (tn (global-conflicts-tn conf)) - (num (global-conflicts-number conf)) - (kind (global-conflicts-kind conf))) - (setf (tn-local-number tn) num) - (unless (eq kind :live) - (cond ((not (zerop (sbit live-bits num))) - (bit-vector-replace bits live-bits) - (setf (sbit bits num) 0) - (push-in tn-next* tn live-list)) - ((and (eq (svref ltns num) :more) - (eq kind :write)) - (note-conflicts live-bits live-list tn num) - (setf (sbit live-bits num) 1) - (push-in tn-next* tn live-list) - (setf (sbit live-in num) 1))) - - (setf (tn-local-conflicts tn) bits)))) - - (make-debug-environment-tns-live block live-bits live-list))) - - -;;; DO-SAVE-P-STUFF -- Internal -;;; -;;; A function called in Conflict-Analyze-1-Block when we have a VOP with -;;; SAVE-P true. We compute the save-set, and if :FORCE-TO-STACK, force all -;;; the live TNs to be stack environment TNs. -;;; -(defun do-save-p-stuff (vop block live-bits) - (declare (type vop vop) (type ir2-block block) - (type local-tn-bit-vector live-bits)) - (let ((ss (compute-save-set vop live-bits))) - (setf (vop-save-set vop) ss) - (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack) - (do-live-tns (tn ss block) - (unless (eq (tn-kind tn) :component) - (force-tn-to-stack tn) - (unless (eq (tn-kind tn) :environment) - (convert-to-environment-tn - tn - (block-environment (ir2-block-block block)))))))) - (undefined-value)) - - -(eval-when (compile eval) - -;;; Frob-More-TNs -- Internal -;;; -;;; Used in SCAN-VOP-REFS to simultaneously do something to all of the TNs -;;; referenced by a big more arg. We have to treat these TNs specially, since -;;; when we set or clear the bit in the live TNs, the represents a change in -;;; the liveness of all the more TNs. If we iterated as normal, the next more -;;; ref would be thought to be not live when it was, etc. We update Ref to be -;;; the last :more ref we scanned, so that the main loop will step to the next -;;; non-more ref. -;;; -(defmacro frob-more-tns (action) - `(when (eq (svref ltns num) :more) - (let ((prev ref)) - (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref))) - ((null mref)) - (let ((mtn (tn-ref-tn mref))) - (unless (eql (tn-local-number mtn) num) - (return)) - ,action) - (setq prev mref)) - (setq ref prev)))) - - -;;; SCAN-VOP-REFS -- Internal -;;; -;;; Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs for the -;;; current VOP. This macro shamelessly references free variables in C-A-1-B. -;;; -(defmacro scan-vop-refs () - '(do ((ref (vop-refs vop) (tn-ref-next-ref ref))) - ((null ref)) - (let* ((tn (tn-ref-tn ref)) - (num (tn-local-number tn))) - (cond - ((not num)) - ((not (zerop (sbit live-bits num))) - (when (tn-ref-write-p ref) - (setf (sbit live-bits num) 0) - (deletef-in tn-next* live-list tn) - (frob-more-tns (deletef-in tn-next* live-list mtn)))) - (t - (assert (not (tn-ref-write-p ref))) - (note-conflicts live-bits live-list tn num) - (frob-more-tns (note-conflicts live-bits live-list mtn num)) - (setf (sbit live-bits num) 1) - (push-in tn-next* tn live-list) - (frob-more-tns (push-in tn-next* mtn live-list))))))) - - -;;; ENSURE-RESULTS-LIVE -- Internal -;;; -;;; This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the current -;;; VOP's results, and make any dead ones live. This is necessary, since even -;;; though a result is dead after the VOP, it may be in use for an extended -;;; period within the VOP (especially if it has :FROM specified.) During this -;;; interval, temporaries must be noted to conflict with the result. More -;;; results are finessed in COMPUTE-INITIAL-CONFLICTS, so we ignore them here. -;;; -(defmacro ensure-results-live () - '(do ((res (vop-results vop) (tn-ref-across res))) - ((null res)) - (let* ((tn (tn-ref-tn res)) - (num (tn-local-number tn))) - (when (and num (zerop (sbit live-bits num))) - (unless (eq (svref ltns num) :more) - (note-conflicts live-bits live-list tn num) - (setf (sbit live-bits num) 1) - (push-in tn-next* tn live-list)))))) - -); Eval-When (Compile Eval) - - -;;; Conflict-Analyze-1-Block -- Internal -;;; -;;; Compute the block-local conflict information for Block. We iterate over -;;; all the TN-Refs in a block in reference order, maintaining the set of live -;;; TNs in both a list and a bit-vector representation. -;;; -(defun conflict-analyze-1-block (block) - (declare (type ir2-block block)) - (multiple-value-bind - (live-bits live-list) - (compute-initial-conflicts block) - (let ((ltns (ir2-block-local-tns block))) - (do ((vop (ir2-block-last-vop block) - (vop-prev vop))) - ((null vop)) - (when (vop-info-save-p (vop-info vop)) - (do-save-p-stuff vop block live-bits)) - (ensure-results-live) - (scan-vop-refs))))) - - -;;; Lifetime-Post-Pass -- Internal -;;; -;;; Conflict analyze each block, and also add it -(defun lifetime-post-pass (component) - (declare (type component component)) - (do-ir2-blocks (block component) - (conflict-analyze-1-block block))) - - -;;;; Alias TN stuff: - -;;; MERGE-ALIAS-BLOCK-CONFLICTS -- Internal -;;; -;;; Destructively modify Oconf to include the conflict information in Conf. -;;; -(defun merge-alias-block-conflicts (conf oconf) - (declare (type global-conflicts conf oconf)) - (let* ((kind (global-conflicts-kind conf)) - (num (global-conflicts-number conf)) - (okind (global-conflicts-kind oconf)) - (onum (global-conflicts-number oconf)) - (block (global-conflicts-block oconf)) - (ltns (ir2-block-local-tns block))) - (cond - ((eq okind :live)) - ((eq kind :live) - (setf (global-conflicts-kind oconf) :live) - (setf (svref ltns onum) nil) - (setf (global-conflicts-number oconf) nil)) - (t - (unless (eq kind okind) - (setf (global-conflicts-kind oconf) :read)) - ;; - ;; Make original conflict with all the local TNs the alias conflicted - ;; with. - (bit-ior (global-conflicts-conflicts oconf) - (global-conflicts-conflicts conf) - t) - (flet ((frob (x) - (unless (zerop (sbit x num)) - (setf (sbit x onum) 1)))) - ;; - ;; Make all the local TNs that conflicted with the alias conflict - ;; with the original. - (dotimes (i (ir2-block-local-tn-count block)) - (let ((tn (svref ltns i))) - (when (and tn (not (eq tn :more)) - (null (tn-global-conflicts tn))) - (frob (tn-local-conflicts tn))))) - ;; - ;; Same for global TNs... - (do ((current (ir2-block-global-tns block) - (global-conflicts-next current))) - ((null current)) - (unless (eq (global-conflicts-kind current) :live) - (frob (global-conflicts-conflicts current)))) - ;; - ;; Make the original TN live everywhere that the alias was live. - (frob (ir2-block-written block)) - (frob (ir2-block-live-in block)) - (frob (ir2-block-live-out block)) - (do ((vop (ir2-block-start-vop block) - (vop-next vop))) - ((null vop)) - (let ((sset (vop-save-set vop))) - (when sset (frob sset))))))) - ;; - ;; Delete the alias's conflict info. - (when num - (setf (svref ltns num) nil)) - (deletef-in global-conflicts-next (ir2-block-global-tns block) conf)) - - (undefined-value)) - - -;;; CHANGE-GLOBAL-CONFLICTS-TN -- Internal -;;; -;;; Co-opt Conf to be a conflict for TN. -;;; -(defun change-global-conflicts-tn (conf new) - (declare (type global-conflicts conf) (type tn new)) - (setf (global-conflicts-tn conf) new) - (let ((ltn-num (global-conflicts-number conf)) - (block (global-conflicts-block conf))) - (deletef-in global-conflicts-next (ir2-block-global-tns block) conf) - (setf (global-conflicts-next conf) nil) - (insert-block-global-conflict conf block) - (when ltn-num - (setf (svref (ir2-block-local-tns block) ltn-num) new))) - (undefined-value)) - - -;;; ENSURE-GLOBAL-TN -- Internal -;;; -;;; Do CONVERT-TO-GLOBAL on TN if it has no global conflicts. Copy the -;;; local conflicts into the global bit vector. -;;; -(defun ensure-global-tn (tn) - (declare (type tn tn)) - (cond ((tn-global-conflicts tn)) - ((tn-local tn) - (convert-to-global tn) - (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn)) - (tn-local-conflicts tn) - t)) - (t - (assert (and (null (tn-reads tn)) (null (tn-writes tn)))))) - (undefined-value)) - - -;;; MERGE-ALIAS-CONFLICTS -- Internal -;;; -;;; For each :ALIAS TN, destructively merge the conflict info into the -;;; original TN and replace the uses of the alias. -;;; -;;; For any block that uses only the alias TN, just insert that conflict into -;;; the conflicts for the original TN, changing the LTN map to refer to the -;;; original TN. This gives a result indistinguishable from the what there -;;; would have been if the original TN had always been referenced. This leaves -;;; no sign that an alias TN was ever involved. -;;; -;;; If a block has references to both the alias and the original TN, then we -;;; call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts into the original -;;; conflict. -;;; -(defun merge-alias-conflicts (component) - (declare (type component component)) - (do ((tn (ir2-component-alias-tns (component-info component)) - (tn-next tn))) - ((null tn)) - (let ((original (tn-save-tn tn))) - (ensure-global-tn tn) - (ensure-global-tn original) - (let ((conf (tn-global-conflicts tn)) - (oconf (tn-global-conflicts original)) - (oprev nil)) - (loop - (unless oconf - (if oprev - (setf (global-conflicts-tn-next oprev) conf) - (setf (tn-global-conflicts original) conf)) - (do ((current conf (global-conflicts-tn-next current))) - ((null current)) - (change-global-conflicts-tn current original)) - (return)) - (let* ((block (global-conflicts-block conf)) - (num (ir2-block-number block)) - (onum (ir2-block-number (global-conflicts-block oconf)))) - - (cond ((< onum num) - (shiftf oprev oconf (global-conflicts-tn-next oconf))) - ((> onum num) - (if oprev - (setf (global-conflicts-tn-next oprev) conf) - (setf (tn-global-conflicts original) conf)) - (change-global-conflicts-tn conf original) - (shiftf oprev conf (global-conflicts-tn-next conf) oconf)) - (t - (merge-alias-block-conflicts conf oconf) - (shiftf oprev oconf (global-conflicts-tn-next oconf)) - (setf conf (global-conflicts-tn-next conf))))) - (unless conf (return)))) - - (flet ((frob (refs) - (let ((ref refs) - (next nil)) - (loop - (unless ref (return)) - (setq next (tn-ref-next ref)) - (change-tn-ref-tn ref original) - (setq ref next))))) - (frob (tn-reads tn)) - (frob (tn-writes tn))) - (setf (tn-global-conflicts tn) nil))) - - (undefined-value)) - - -;;; Lifetime-Analyze -- Interface -;;; -;;; -(defun lifetime-analyze (component) - (lifetime-pre-pass component) - (setup-environment-live-conflicts component) - (lifetime-flow-analysis component) - (lifetime-post-pass component) - (merge-alias-conflicts component)) - - -;;;; Conflict testing: - -;;; TNs-Conflict-Local-Global -- Internal -;;; -;;; Test for a conflict between the local TN X and the global TN Y. We just -;;; look for a global conflict of Y in X's block, and then test for conflict in -;;; that block. -;;; [### Might be more efficient to scan Y's global conflicts. This depends on -;;; whether there are more global TNs than blocks.] -;;; -(defun tns-conflict-local-global (x y) - (let ((block (tn-local x))) - (do ((conf (ir2-block-global-tns block) - (global-conflicts-next conf))) - ((null conf) nil) - (when (eq (global-conflicts-tn conf) y) - (let ((num (global-conflicts-number conf))) - (return (or (not num) - (not (zerop (sbit (tn-local-conflicts x) - num)))))))))) - - -;;; TNs-Conflict-Global-Global -- Internal -;;; -;;; Test for conflict between two global TNs X and Y. -;;; -(defun tns-conflict-global-global (x y) - (declare (type tn x y)) - (let* ((x-conf (tn-global-conflicts x)) - (x-num (ir2-block-number (global-conflicts-block x-conf))) - (y-conf (tn-global-conflicts y)) - (y-num (ir2-block-number (global-conflicts-block y-conf)))) - - (macrolet ((advance (n c) - `(progn - (setq ,c (global-conflicts-tn-next ,c)) - (unless ,c (return-from tns-conflict-global-global nil)) - (setq ,n (ir2-block-number (global-conflicts-block ,c))))) - (scan (g l lc) - `(do () - ((>= ,g ,l)) - (advance ,l ,lc)))) - - (loop - ;; x-conf, y-conf true, x-num, y-num corresponding block numbers. - (scan x-num y-num y-conf) - (scan y-num x-num x-conf) - (when (= x-num y-num) - (let ((ltn-num-x (global-conflicts-number x-conf))) - (unless (and ltn-num-x - (global-conflicts-number y-conf) - (zerop (sbit (global-conflicts-conflicts y-conf) - ltn-num-x))) - (return t)) - (advance x-num x-conf) - (advance y-num y-conf))))))) - - -;;; TNs-Conflict -- Interface -;;; -;;; Return true if X and Y are distinct and the lifetimes of X and Y overlap -;;; at any point. -;;; -(defun tns-conflict (x y) - (declare (type tn x y)) - (let ((x-kind (tn-kind x)) - (y-kind (tn-kind y))) - (cond ((eq x y) nil) - ((or (eq x-kind :component) (eq y-kind :component)) t) - ((tn-global-conflicts x) - (if (tn-global-conflicts y) - (tns-conflict-global-global x y) - (tns-conflict-local-global y x))) - ((tn-global-conflicts y) - (tns-conflict-local-global x y)) - (t - (and (eq (tn-local x) (tn-local y)) - (not (zerop (sbit (tn-local-conflicts x) - (tn-local-number y))))))))) diff --git a/compiler/loadbackend.lisp b/compiler/loadbackend.lisp deleted file mode 100644 index 72d777fca1c4751b0cd9b05883db54d0a9864dc4..0000000000000000000000000000000000000000 --- a/compiler/loadbackend.lisp +++ /dev/null @@ -1,70 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/loadbackend.lisp,v 1.7 1992/06/08 21:09:18 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Load the backend of the compiler. -;;; - -(in-package "C") - -(load "vm:vm-macs") -(if (target-featurep :rt) - (load "vm:params") - (load "vm:parms")) -(load "vm:objdef") -(load "vm:interr") -(load "assem:support") -(load "vm:macros") -(when (target-featurep :gengc) - (load "vm:vm-utils")) -(load "vm:utils") - -(load "vm:vm") -(load "vm:insts") -(unless (target-featurep :rt) - (load "vm:primtype")) -(load "vm:move") -(load "vm:sap") -(load "vm:system") -(load "vm:char") -(if (target-featurep :rt) - (if (target-featurep :afpa) - (load "vm:afpa") - (load "vm:mc68881")) - (load "vm:float")) - -(load "vm:memory") -(load "vm:static-fn") -(load "vm:arith") -(load "vm:cell") -(load "vm:subprim") -(load "vm:debug") -(load "vm:c-call") -(load "vm:print") -(load "vm:alloc") -(load "vm:call") -(load "vm:nlx") -(load "vm:values") -(load "vm:array") -(load "vm:pred") -(load "vm:type-vops") - -(load "assem:assem-rtns") - -(load "assem:array") -(load "assem:arith") -(unless (target-featurep :gengc) - (load "assem:alloc")) - -(load "c:pseudo-vops") - -(check-move-function-consistency) diff --git a/compiler/loadcom.lisp b/compiler/loadcom.lisp deleted file mode 100644 index a159615385b62a6ecbd8f2d44779ae2753135e02..0000000000000000000000000000000000000000 --- a/compiler/loadcom.lisp +++ /dev/null @@ -1,78 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/loadcom.lisp,v 1.44 1992/12/13 15:29:59 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Load up the compiler. -;;; -(in-package "C") - -(load "c:backend") -(load "c:macros") -(load "c:sset") -(load "c:node") -(load "c:alloc") -(load "c:ctype") -(load "c:knownfun") -(load "c:fndb") -(load "vm:vm-fndb") -(load "c:ir1util") -(load "c:ir1tran") -(load "c:ir1final") -(load "c:srctran") -(load "c:array-tran") -(load "c:seqtran") -(load "c:typetran") -(load "vm:vm-typetran") -(load "vm:vm-tran") -(load "c:float-tran") -(load "c:saptran") -(load "c:locall") -(load "c:dfo") -(load "c:ir1opt") -;(load "c:loop") -(load "c:checkgen") -(load "c:constraint") -(load "c:envanal") -(load "c:vop") -(load "c:tn") -(load "c:bit-util") -(load "c:life") -(load "c:vmdef") -(load "c:meta-vmdef") -(load "c:gtn") -(load "c:ltn") -(load "c:stack") -(load "c:control") -(load "c:entry") -(load "c:ir2tran") -(load "vm:vm-ir2tran") -(load "c:pack") -(load "c:dyncount") -(load "c:statcount") -(load "c:codegen") -(load "c:main") -(load "c:disassem") -(load "c:new-assem") -(load "assem:assemfile") -(load "c:aliencomp") -(load "c:ltv") -(load "c:debug-dump") - -(load "c:dump") -(load "c:debug") -(load "c:copyprop") -(load "c:represent") - -(load "c:eval-comp") -(load "c:eval") - -(load "vm:core") diff --git a/compiler/locall.lisp b/compiler/locall.lisp deleted file mode 100644 index 56b2f5ed392c353abe997733d34408413d16c217..0000000000000000000000000000000000000000 --- a/compiler/locall.lisp +++ /dev/null @@ -1,1058 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/locall.lisp,v 1.39 1992/11/03 07:06:03 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file implements local call analysis. A local call is a function -;;; call between functions being compiled at the same time. If we can tell at -;;; compile time that such a call is legal, then we change the combination -;;; to call the correct lambda, mark it as local, and add this link to our call -;;; graph. Once a call is local, it is then eligible for let conversion, which -;;; places the body of the function inline. -;;; -;;; We cannot always do a local call even when we do have the function being -;;; called. Calls that cannot be shown to have legal arg counts are not -;;; converted. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package :c) - - -;;; Propagate-To-Args -- Interface -;;; -;;; This function propagates information from the variables in the function -;;; Fun to the actual arguments in Call. This is also called by the VALUES IR1 -;;; optimizer when it sleazily converts MV-BINDs to LETs. -;;; -;;; We flush all arguments to Call that correspond to unreferenced variables -;;; in Fun. We leave NILs in the Combination-Args so that the remaining args -;;; still match up with their vars. -;;; -;;; We also apply the declared variable type assertion to the argument -;;; continuations. -;;; -(defun propagate-to-args (call fun) - (declare (type combination call) (type clambda fun)) - (do ((args (basic-combination-args call) (cdr args)) - (vars (lambda-vars fun) (cdr vars))) - ((null args)) - (let ((arg (car args)) - (var (car vars))) - (cond ((leaf-refs var) - (assert-continuation-type arg (leaf-type var))) - (t - (flush-dest arg) - (setf (car args) nil))))) - - (undefined-value)) - - -;;; Merge-Tail-Sets -- Interface -;;; -;;; This function handles merging the tail sets if Call is potentially -;;; tail-recursive, and is a call to a function with a different TAIL-SET than -;;; Call's Fun. This must be called whenever we alter IR1 so as to place a -;;; local call in what might be a TR context. Note that any call which returns -;;; its value to a RETURN is considered potentially TR, since any implicit -;;; MV-PROG1 might be optimized away. -;;; -;;; We destructively modify the set for the calling function to represent both, -;;; and then change all the functions in callee's set to reference the first. -;;; If we do merge, we reoptimize the RETURN-RESULT continuation to cause -;;; IR1-OPTIMIZE-RETURN to recompute the tail set type. -;;; -(defun merge-tail-sets (call &optional (new-fun (combination-lambda call))) - (declare (type basic-combination call) (type clambda new-fun)) - (let ((return (continuation-dest (node-cont call)))) - (when (return-p return) - (let ((call-set (lambda-tail-set (node-home-lambda call))) - (fun-set (lambda-tail-set new-fun))) - (unless (eq call-set fun-set) - (let ((funs (tail-set-functions fun-set))) - (dolist (fun funs) - (setf (lambda-tail-set fun) call-set)) - (setf (tail-set-functions call-set) - (nconc (tail-set-functions call-set) funs))) - (reoptimize-continuation (return-result return)) - t))))) - - -;;; Convert-Call -- Internal -;;; -;;; Convert a combination into a local call. We PROPAGATE-TO-ARGS, set the -;;; combination kind to :Local, add Fun to the Calls of the function that the -;;; call is in, call MERGE-TAIL-SETS, then replace the function in the Ref node -;;; with the new function. -;;; -;;; We change the Ref last, since changing the reference can trigger let -;;; conversion of the new function, but will only do so if the call is local. -;;; Note that the replacement may trigger let conversion or other changes in -;;; IR1. We must call MERGE-TAIL-SETS with NEW-FUN before the substitution, -;;; since after the substitution (and let conversion), the call may no longer -;;; be recognizable as tail-recursive. -;;; -(defun convert-call (ref call fun) - (declare (type ref ref) (type combination call) (type clambda fun)) - (propagate-to-args call fun) - (setf (basic-combination-kind call) :local) - (pushnew fun (lambda-calls (node-home-lambda call))) - (merge-tail-sets call fun) - (change-ref-leaf ref fun) - (undefined-value)) - - -;;;; External entry point creation: - -;;; Make-XEP-Lambda -- Internal -;;; -;;; Return a Lambda form that can be used as the definition of the XEP for -;;; Fun. -;;; -;;; If Fun is a lambda, then we check the number of arguments (conditional -;;; on policy) and call Fun with all the arguments. -;;; -;;; If Fun is an Optional-Dispatch, then we dispatch off of the number of -;;; supplied arguments by doing do an = test for each entry-point, calling the -;;; entry with the appropriate prefix of the passed arguments. -;;; -;;; If there is a more arg, then there are a couple of optimizations that we -;;; make (more for space than anything else): -;;; -- If Min-Args is 0, then we make the more entry a T clause, since no -;;; argument count error is possible. -;;; -- We can omit the = clause for the last entry-point, allowing the case of -;;; 0 more args to fall through to the more entry. -;;; -;;; We don't bother to policy conditionalize wrong arg errors in optional -;;; dispatches, since the additional overhead is negligible compared to the -;;; other hair going down. -;;; -;;; Note that if policy indicates it, argument type declarations in Fun will -;;; be verified. Since nothing is known about the type of the XEP arg vars, -;;; type checks will be emitted when the XEP's arg vars are passed to the -;;; actual function. -;;; -(defun make-xep-lambda (fun) - (declare (type functional fun)) - (etypecase fun - (clambda - (let ((nargs (length (lambda-vars fun))) - (n-supplied (gensym))) - (collect ((temps)) - (dotimes (i nargs) - (temps (gensym))) - `(lambda (,n-supplied ,@(temps)) - (declare (fixnum ,n-supplied)) - ,(if (policy nil (zerop safety)) - `(declare (ignore ,n-supplied)) - `(%verify-argument-count ,n-supplied ,nargs)) - (%funcall ,fun ,@(temps)))))) - (optional-dispatch - (let* ((min (optional-dispatch-min-args fun)) - (max (optional-dispatch-max-args fun)) - (more (optional-dispatch-more-entry fun)) - (n-supplied (gensym))) - (collect ((temps) - (entries)) - (dotimes (i max) - (temps (gensym))) - - (do ((eps (optional-dispatch-entry-points fun) (rest eps)) - (n min (1+ n))) - ((null eps)) - (entries `((= ,n-supplied ,n) - (%funcall ,(first eps) ,@(subseq (temps) 0 n))))) - - `(lambda (,n-supplied ,@(temps)) - (declare (fixnum ,n-supplied)) - (cond - ,@(if more (butlast (entries)) (entries)) - ,@(when more - `((,(if (zerop min) 't `(>= ,n-supplied ,max)) - ,(let ((n-context (gensym)) - (n-count (gensym))) - `(multiple-value-bind - (,n-context ,n-count) - (%more-arg-context ,n-supplied ,max) - (%funcall ,more ,@(temps) ,n-context ,n-count)))))) - (t - (%argument-count-error ,n-supplied))))))))) - - -;;; Make-External-Entry-Point -- Internal -;;; -;;; Make an external entry point (XEP) for Fun and return it. We convert -;;; the result of Make-XEP-Lambda in the correct environment, then associate -;;; this lambda with Fun as its XEP. After the conversion, we iterate over the -;;; function's associated lambdas, redoing local call analysis so that the XEP -;;; calls will get converted. We also bind *lexical-environment* to change the -;;; compilation policy over to the interface policy. -;;; -;;; We set Reanalyze and Reoptimize in the component, just in case we -;;; discover an XEP after the initial local call analyze pass. -;;; -(defun make-external-entry-point (fun) - (declare (type functional fun)) - (assert (not (functional-entry-function fun))) - (with-ir1-environment (lambda-bind (main-entry fun)) - (let* ((*lexical-environment* - (make-lexenv :cookie - (make-interface-cookie *lexical-environment*))) - (res (ir1-convert-lambda (make-xep-lambda fun)))) - (setf (functional-kind res) :external) - (setf (leaf-ever-used res) t) - (setf (functional-entry-function res) fun) - (setf (functional-entry-function fun) res) - (setf (component-reanalyze *current-component*) t) - (setf (component-reoptimize *current-component*) t) - (etypecase fun - (clambda (local-call-analyze-1 fun)) - (optional-dispatch - (dolist (ep (optional-dispatch-entry-points fun)) - (local-call-analyze-1 ep)) - (when (optional-dispatch-more-entry fun) - (local-call-analyze-1 (optional-dispatch-more-entry fun))))) - res))) - - -;;; Reference-Entry-Point -- Internal -;;; -;;; Notice a Ref that is not in a local-call context. If the Ref is already -;;; to an XEP, then do nothing, otherwise change it to the XEP, making an XEP -;;; if necessary. -;;; -;;; If Ref is to a special :Cleanup or :Escape function, then we treat it as -;;; though it was not an XEP reference (i.e. leave it alone.) -;;; -(defun reference-entry-point (ref) - (declare (type ref ref)) - (let ((fun (ref-leaf ref))) - (unless (or (external-entry-point-p fun) - (member (functional-kind fun) '(:escape :cleanup))) - (change-ref-leaf ref (or (functional-entry-function fun) - (make-external-entry-point fun)))))) - - - -;;; Local-Call-Analyze-1 -- Interface -;;; -;;; Attempt to convert all references to Fun to local calls. The reference -;;; must be the function for a call, and the function continuation must be used -;;; only once, since otherwise we cannot be sure what function is to be called. -;;; The call continuation would be multiply used if there is hairy stuff such -;;; as conditionals in the expression that computes the function. -;;; -;;; If we cannot convert a reference, then we mark the referenced function -;;; as an entry-point, creating a new XEP if necessary. We don't try to -;;; convert calls that are in error (:ERROR kind.) -;;; -;;; This is broken off from Local-Call-Analyze so that people can force -;;; analysis of newly introduced calls. Note that we don't do let conversion -;;; here. -;;; -(defun local-call-analyze-1 (fun) - (declare (type functional fun)) - (let ((refs (leaf-refs fun)) - (first-time t)) - (dolist (ref refs) - (let* ((cont (node-cont ref)) - (dest (continuation-dest cont))) - (cond ((and (basic-combination-p dest) - (eq (basic-combination-fun dest) cont) - (eq (continuation-use cont) ref)) - - (convert-call-if-possible ref dest) - - (unless (eq (basic-combination-kind dest) :local) - (reference-entry-point ref))) - (t - (reference-entry-point ref)))) - (setq first-time nil))) - - (undefined-value)) - - -;;; Local-Call-Analyze -- Interface -;;; -;;; We examine all New-Functions in component, attempting to convert calls -;;; into local calls when it is legal. We also attempt to convert each lambda -;;; to a let. Let conversion is also triggered by deletion of a function -;;; reference, but functions that start out eligible for conversion must be -;;; noticed sometime. -;;; -;;; Note that there is a lot of action going on behind the scenes here, -;;; triggered by reference deletion. In particular, the Component-Lambdas are -;;; being hacked to remove newly deleted and let converted lambdas, so it is -;;; important that the lambda is added to the Component-Lambdas when it is. -;;; Also, the COMPONENT-NEW-FUNCTIONS may contain all sorts of drivel, since it -;;; is not updated when we delete functions, etc. Only COMPONENT-LAMBDAS is -;;; updated. -;;; -;;; COMPONENT-REANALYZE-FUNCTIONS is treated similarly to NEW-FUNCTIONS, but we -;;; don't add lambdas to the LAMBDAS. -;;; -(defun local-call-analyze (component) - (declare (type component component)) - (loop - (let* ((new (pop (component-new-functions component))) - (fun (or new (pop (component-reanalyze-functions component))))) - (unless fun (return)) - (let ((kind (functional-kind fun))) - (cond ((member kind '(:deleted :let :mv-let :assignment))) - ((and (null (leaf-refs fun)) (eq kind nil) - (not (functional-entry-function fun))) - (delete-functional fun)) - (t - (when (and new (lambda-p fun)) - (push fun (component-lambdas component))) - (local-call-analyze-1 fun) - (when (lambda-p fun) - (maybe-let-convert fun))))))) - - (undefined-value)) - - -;;; MAYBE-EXPAND-LOCAL-INLINE -- Internal -;;; -;;; If policy is auspicious, Call is not in an XEP, and we don't seem to be -;;; in an infinite recursive loop, then change the reference to reference a -;;; fresh copy. We return whichever function we decide to reference. -;;; -(defun maybe-expand-local-inline (fun ref call) - (if (and (policy call (>= speed space) (>= speed cspeed)) - (not (eq (functional-kind (node-home-lambda call)) :external)) - (inline-expansion-ok call)) - (with-ir1-environment call - (let* ((*lexical-environment* (functional-lexenv fun)) - (won nil) - (res (catch 'local-call-lossage - (prog1 - (ir1-convert-lambda (functional-inline-expansion fun)) - (setq won t))))) - (cond (won - (change-ref-leaf ref res) - res) - (t - (let ((*compiler-error-context* call)) - (compiler-note "Couldn't inline expand because expansion ~ - calls this let-converted local function:~ - ~% ~S" - (leaf-name res))) - fun)))) - fun)) - - -;;; Convert-Call-If-Possible -- Interface -;;; -;;; Dispatch to the appropriate function to attempt to convert a call. This -;;; is called in IR1 optimize as well as in local call analysis. If the call -;;; is is already :Local, we do nothing. If the call is already scheduled for -;;; deletion, also do nothing (in addition to saving time, this also avoids -;;; some problems with optimizing collections of functions that are partially -;;; deleted.) -;;; -;;; This is called both before and after FIND-INITIAL-DFO runs. When called -;;; on a :INITIAL component, we don't care whether the caller and callee are in -;;; the same component. Afterward, we must stick with whatever component -;;; division we have chosen. -;;; -;;; Before attempting to convert a call, we see if the function is supposed -;;; to be inline expanded. Call conversion proceeds as before after any -;;; expansion. -;;; -;;; We bind *Compiler-Error-Context* to the node for the call so that -;;; warnings will get the right context. -;;; -;;; -(defun convert-call-if-possible (ref call) - (declare (type ref ref) (type basic-combination call)) - (let* ((block (node-block call)) - (component (block-component block)) - (original-fun (ref-leaf ref))) - (unless (or (member (basic-combination-kind call) '(:local :error)) - (block-delete-p block) - (eq (functional-kind (block-home-lambda block)) :deleted) - (not (or (eq (component-kind component) :initial) - (eq (block-component - (node-block - (lambda-bind (main-entry original-fun)))) - component)))) - (let ((fun (if (external-entry-point-p original-fun) - (functional-entry-function original-fun) - original-fun)) - (*compiler-error-context* call)) - - (when (and (eq (functional-inlinep fun) :inline) - (rest (leaf-refs original-fun))) - (setq fun (maybe-expand-local-inline fun ref call))) - - (assert (member (functional-kind fun) - '(nil :escape :cleanup :optional))) - (cond ((mv-combination-p call) - (convert-mv-call ref call fun)) - ((lambda-p fun) - (convert-lambda-call ref call fun)) - (t - (convert-hairy-call ref call fun)))))) - - (undefined-value)) - - -;;; Convert-MV-Call -- Internal -;;; -;;; Attempt to convert a multiple-value call. The only interesting case is -;;; a call to a function that Looks-Like-An-MV-Bind, has exactly one reference -;;; and no XEP, and is called with one values continuation. -;;; -;;; We change the call to be to the last optional entry point and change the -;;; call to be local. Due to our preconditions, the call should eventually be -;;; converted to a let, but we can't do that now, since there may be stray -;;; references to the e-p lambda due to optional defaulting code. -;;; -;;; We also use variable types for the called function to construct an -;;; assertion for the values continuation. -;;; -;;; See CONVERT-CALL for additional notes on MERGE-TAIL-SETS, etc. -;;; -(defun convert-mv-call (ref call fun) - (declare (type ref ref) (type mv-combination call) (type functional fun)) - (when (and (looks-like-an-mv-bind fun) - (not (functional-entry-function fun)) - (= (length (leaf-refs fun)) 1) - (= (length (basic-combination-args call)) 1)) - (let ((ep (car (last (optional-dispatch-entry-points fun))))) - (setf (basic-combination-kind call) :local) - (pushnew ep (lambda-calls (node-home-lambda call))) - (merge-tail-sets call ep) - (change-ref-leaf ref ep) - - (assert-continuation-type - (first (basic-combination-args call)) - (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep)) - :rest *universal-type*)))) - (undefined-value)) - - -;;; Convert-Lambda-Call -- Internal -;;; -;;; Attempt to convert a call to a lambda. If the number of args is wrong, -;;; we give a warning and mark the call as :ERROR to remove it from future -;;; consideration. If the argcount is O.K. then we just convert it. -;;; -(defun convert-lambda-call (ref call fun) - (declare (type ref ref) (type combination call) (type clambda fun)) - (let ((nargs (length (lambda-vars fun))) - (call-args (length (combination-args call)))) - (cond ((= call-args nargs) - (convert-call ref call fun)) - (t - (compiler-warning - "Function called with ~R argument~:P, but wants exactly ~R." - call-args nargs) - (setf (basic-combination-kind call) :error))))) - - - -;;;; Optional, more and keyword calls: - -;;; Convert-Hairy-Call -- Internal -;;; -;;; Similar to Convert-Lambda-Call, but deals with Optional-Dispatches. If -;;; only fixed args are supplied, then convert a call to the correct entry -;;; point. If keyword args are supplied, then dispatch to a subfunction. We -;;; don't convert calls to functions that have a more (or rest) arg. -;;; -(defun convert-hairy-call (ref call fun) - (declare (type ref ref) (type combination call) - (type optional-dispatch fun)) - (let ((min-args (optional-dispatch-min-args fun)) - (max-args (optional-dispatch-max-args fun)) - (call-args (length (combination-args call)))) - (cond ((< call-args min-args) - (compiler-warning "Function called with ~R argument~:P, but wants at least ~R." - call-args min-args) - (setf (basic-combination-kind call) :error)) - ((<= call-args max-args) - (convert-call ref call - (elt (optional-dispatch-entry-points fun) - (- call-args min-args)))) - ((optional-dispatch-more-entry fun) - (convert-more-call ref call fun)) - (t - (compiler-warning "Function called with ~R argument~:P, but wants at most ~R." - call-args max-args) - (setf (basic-combination-kind call) :error)))) - (undefined-value)) - - -;;; Convert-Hairy-Fun-Entry -- Internal -;;; -;;; This function is used to convert a call to an entry point when complex -;;; transformations need to be done on the original arguments. Entry is the -;;; entry point function that we are calling. Vars is a list of variable names -;;; which are bound to the oringinal call arguments. Ignores is the subset of -;;; Vars which are ignored. Args is the list of arguments to the entry point -;;; function. -;;; -;;; In order to avoid gruesome graph grovelling, we introduce a new function -;;; that rearranges the arguments and calls the entry point. We analyze the -;;; new function and the entry point immediately so that everything gets -;;; converted during the single pass. -;;; -(defun convert-hairy-fun-entry (ref call entry vars ignores args) - (declare (list vars ignores args) (type ref ref) (type combination call) - (type clambda entry)) - (let ((new-fun - (with-ir1-environment call - (ir1-convert-lambda - `(lambda ,vars - (declare (ignorable . ,ignores)) - (%funcall ,entry . ,args)))))) - (convert-call ref call new-fun) - (dolist (ref (leaf-refs entry)) - (convert-call-if-possible ref (continuation-dest (node-cont ref)))))) - - -;;; Convert-More-Call -- Internal -;;; -;;; Use Convert-Hairy-Fun-Entry to convert a more-arg call to a known -;;; function into a local call to the Main-Entry. -;;; -;;; First we verify that all keywords are constant and legal. If there -;;; aren't, then we warn the user and don't attempt to convert the call. -;;; -;;; We massage the supplied keyword arguments into the order expected by the -;;; main entry. This is done by binding all the arguments to the keyword call -;;; to variables in the introduced lambda, then passing these values variables -;;; in the correct order when calling the main entry. Unused arguments -;;; (such as the keywords themselves) are discarded simply by not passing them -;;; along. -;;; -;;; If there is a rest arg, then we bundle up the args and pass them to -;;; LIST. -;;; -(defun convert-more-call (ref call fun) - (declare (type ref ref) (type combination call) (type optional-dispatch fun)) - (let* ((max (optional-dispatch-max-args fun)) - (arglist (optional-dispatch-arglist fun)) - (args (combination-args call)) - (more (nthcdr max args)) - (flame (policy call (or (> speed brevity) (> space brevity)))) - (loser nil)) - (collect ((temps) - (more-temps) - (ignores) - (supplied) - (key-vars)) - - (dolist (var arglist) - (let ((info (lambda-var-arg-info var))) - (when info - (ecase (arg-info-kind info) - (:keyword - (key-vars var)) - ((:rest :optional)))))) - - (dotimes (i max) - (temps (gensym "FIXED-ARG-TEMP-"))) - - (dotimes (i (length more)) - (more-temps (gensym "MORE-ARG-TEMP-"))) - - (when (optional-dispatch-keyp fun) - (when (oddp (length more)) - (compiler-warning "Function called with odd number of ~ - arguments in keyword portion.") - - (setf (basic-combination-kind call) :error) - (return-from convert-more-call)) - - (do ((key more (cddr key)) - (temp (more-temps) (cddr temp))) - ((null key)) - (let ((cont (first key))) - (unless (constant-continuation-p cont) - (when flame - (compiler-note "Non-constant keyword in keyword call.")) - (setf (basic-combination-kind call) :error) - (return-from convert-more-call)) - - (let ((name (continuation-value cont)) - (dummy (first temp)) - (val (second temp))) - (dolist (var (key-vars) - (progn - (ignores dummy val) - (setq loser name))) - (let ((info (lambda-var-arg-info var))) - (when (eq (arg-info-keyword info) name) - (ignores dummy) - (supplied (cons var val)) - (return))))))) - - (when (and loser (not (optional-dispatch-allowp fun))) - (compiler-warning "Function called with unknown argument keyword ~S." - loser) - (setf (basic-combination-kind call) :error) - (return-from convert-more-call))) - - (collect ((call-args)) - (do ((var arglist (cdr var)) - (temp (temps) (cdr temp))) - (()) - (let ((info (lambda-var-arg-info (car var)))) - (if info - (ecase (arg-info-kind info) - (:optional - (call-args (car temp)) - (when (arg-info-supplied-p info) - (call-args t))) - (:rest - (call-args `(list ,@(more-temps))) - (return)) - (:keyword - (return))) - (call-args (car temp))))) - - (dolist (var (key-vars)) - (let ((info (lambda-var-arg-info var)) - (temp (cdr (assoc var (supplied))))) - (if temp - (call-args temp) - (call-args (arg-info-default info))) - (when (arg-info-supplied-p info) - (call-args (not (null temp)))))) - - (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun) - (append (temps) (more-temps)) - (ignores) (call-args))))) - - (undefined-value)) - - -;;;; Let conversion: -;;; -;;; Converting to a let has differing significance to various parts of the -;;; compiler: -;;; -- The body of a Let is spliced in immediately after the the corresponding -;;; combination node, making the control transfer explicit and allowing lets -;;; to mashed together into a single block. The value of the let is -;;; delivered directly to the original continuation for the call, -;;; eliminating the need to propagate information from the dummy result -;;; continuation. -;;; -- As far as IR1 optimization is concerned, it is interesting in that there -;;; is only one expression that the variable can be bound to, and this is -;;; easily substitited for. -;;; -- Lets are interesting to environment analysis and the back end because in -;;; most ways a let can be considered to be "the same function" as its home -;;; function. -;;; -- Let conversion has dynamic scope implications, since control transfers -;;; within the same environment are local. In a local control transfer, -;;; cleanup code must be emitted to remove dynamic bindings that are no -;;; longer in effect. - - -;;; Insert-Let-Body -- Internal -;;; -;;; Set up the control transfer to the called lambda. We split the call -;;; block immediately after the call, and link the head of Fun to the call -;;; block. The successor block after splitting (where we return to) is -;;; returned. -;;; -;;; If the lambda is is a different component than the call, then we call -;;; JOIN-COMPONENTS. This only happens in block compilation before -;;; FIND-INITIAL-DFO. -;;; -(defun insert-let-body (fun call) - (declare (type clambda fun) (type basic-combination call)) - (let* ((call-block (node-block call)) - (bind-block (node-block (lambda-bind fun))) - (component (block-component call-block))) - (let ((fun-component (block-component bind-block))) - (unless (eq fun-component component) - (assert (eq (component-kind component) :initial)) - (join-components component fun-component))) - - (let ((*current-component* component)) - (node-ends-block call)) - (assert (= (length (block-succ call-block)) 1)) - (let ((next-block (first (block-succ call-block)))) - (unlink-blocks call-block next-block) - (link-blocks call-block bind-block) - next-block))) - - -;;; Merge-Lets -- Internal -;;; -;;; Handle the environment semantics of let conversion. We add the lambda -;;; and its lets to lets for the Call's home function. We merge the calls for -;;; Fun with the calls for the home function, removing Fun in the process. We -;;; also merge the Entries. -;;; -;;; We also unlink the function head from the component head and set -;;; Component-Reanalyze to true to indicate that the DFO should be recomputed. -;;; -(defun merge-lets (fun call) - (declare (type clambda fun) (type basic-combination call)) - (let ((component (block-component (node-block call)))) - (unlink-blocks (component-head component) (node-block (lambda-bind fun))) - (setf (component-lambdas component) - (delete fun (component-lambdas component))) - (setf (component-reanalyze component) t)) - (setf (lambda-call-lexenv fun) (node-lexenv call)) - (let ((tails (lambda-tail-set fun))) - (setf (tail-set-functions tails) - (delete fun (tail-set-functions tails)))) - (setf (lambda-tail-set fun) nil) - (let* ((home (node-home-lambda call)) - (home-env (lambda-environment home))) - (push fun (lambda-lets home)) - (setf (lambda-home fun) home) - (setf (lambda-environment fun) home-env) - - (let ((lets (lambda-lets fun))) - (dolist (let lets) - (setf (lambda-home let) home) - (setf (lambda-environment let) home-env)) - - (setf (lambda-lets home) (nconc lets (lambda-lets home))) - (setf (lambda-lets fun) ())) - - (setf (lambda-calls home) - (nunion (lambda-calls fun) - (delete fun (lambda-calls home)))) - (setf (lambda-calls fun) ()) - - (setf (lambda-entries home) - (nconc (lambda-entries fun) (lambda-entries home))) - (setf (lambda-entries fun) ())) - (undefined-value)) - - -;;; Move-Return-Uses -- Internal -;;; -;;; Handle the value semantics of let conversion. Delete Fun's return node, -;;; and change the control flow to transfer to Next-Block instead. Move all -;;; the uses of the result continuation to Call's Cont. -;;; -;;; If the actual continuation is only used by the let call, then we -;;; intersect the type assertion on the dummy continuation with the assertion -;;; for the actual continuation; in all other cases assertions on the dummy -;;; continuation are lost. -;;; -;;; We also intersect the derived type of the call with the derived type of -;;; all the dummy continuation's uses. This serves mainly to propagate -;;; TRULY-THE through lets. -;;; -(defun move-return-uses (fun call next-block) - (declare (type clambda fun) (type basic-combination call) - (type cblock next-block)) - (let* ((return (lambda-return fun)) - (return-block (node-block return))) - (unlink-blocks return-block - (component-tail (block-component return-block))) - (link-blocks return-block next-block) - (unlink-node return) - (delete-return return) - (let ((result (return-result return)) - (cont (node-cont call)) - (call-type (node-derived-type call))) - (when (eq (continuation-use cont) call) - (assert-continuation-type cont (continuation-asserted-type result))) - (unless (eq call-type *wild-type*) - (do-uses (use result) - (derive-node-type use call-type))) - (substitute-continuation-uses cont result))) - (undefined-value)) - - - -;;; MOVE-LET-CALL-CONT -- Internal -;;; -;;; Change all Cont for all the calls to Fun to be the start continuation -;;; for the bind node. This allows the blocks to be joined if the caller count -;;; ever goes to one. -;;; -(defun move-let-call-cont (fun) - (declare (type clambda fun)) - (let ((new-cont (node-prev (lambda-bind fun)))) - (dolist (ref (leaf-refs fun)) - (let ((dest (continuation-dest (node-cont ref)))) - (delete-continuation-use dest) - (add-continuation-use dest new-cont)))) - (undefined-value)) - - -;;; Unconvert-Tail-Calls -- Internal -;;; -;;; We are converting Fun to be a let when the call is in a non-tail -;;; position. Any previously tail calls in Fun are no longer tail calls, and -;;; must be restored to normal calls which transfer to Next-Block (Fun's -;;; return point.) We can't do this by DO-USES on the RETURN-RESULT, because -;;; the return might have been deleted (if all calls were TR.) -;;; -;;; The called function might be an assignment in the case where we are -;;; currently converting that function. In steady-state, assignments never -;;; appear in the lambda-calls. -;;; -(defun unconvert-tail-calls (fun call next-block) - (dolist (called (lambda-calls fun)) - (dolist (ref (leaf-refs called)) - (let ((this-call (continuation-dest (node-cont ref)))) - (when (and (node-tail-p this-call) - (eq (node-home-lambda this-call) fun)) - (setf (node-tail-p this-call) nil) - (ecase (functional-kind called) - ((nil :cleanup :optional) - (let ((block (node-block this-call))) - (unlink-blocks block (first (block-succ block))) - (link-blocks block next-block) - (delete-continuation-use this-call) - (add-continuation-use this-call (node-cont call)))) - (:assignment - (assert (eq called fun)))))))) - (undefined-value)) - - -;;; MOVE-RETURN-STUFF -- Internal -;;; -;;; Deal with returning from a let or assignment that we are converting. -;;; FUN is the function we are calling, CALL is a call to FUN, and NEXT-BLOCK -;;; is the return point for a non-tail call, or NULL if call is a tail call. -;;; -;;; If the call is not a tail call, then we must do UNCONVERT-TAIL-CALLS, since -;;; a tail call is a call which returns its value out of the enclosing non-let -;;; function. When call is non-TR, we must convert it back to an ordinary -;;; local call, since the value must be delivered to the receiver of CALL's -;;; value. -;;; -;;; We do different things depending on whether the caller and callee have -;;; returns left: -;;; -- If the callee has no return we just do MOVE-LET-CALL-CONT. Either the -;;; function doesn't return, or all returns are via tail-recursive local -;;; calls. -;;; -- If CALL is a non-tail call, or if both have returns, then we -;;; delete the callee's return, move its uses to the call's result -;;; continuation, and transfer control to the appropriate return point. -;;; -- If the callee has a return, but the caller doesn't, then we move the -;;; return to the caller. -;;; -(defun move-return-stuff (fun call next-block) - (declare (type clambda fun) (type basic-combination call) - (type (or cblock null) next-block)) - (when next-block - (unconvert-tail-calls fun call next-block)) - (let* ((return (lambda-return fun)) - (call-fun (node-home-lambda call)) - (call-return (lambda-return call-fun))) - (cond ((not return)) - ((or next-block call-return) - (unless (block-delete-p (node-block return)) - (move-return-uses fun call - (or next-block (node-block call-return))))) - (t - (assert (node-tail-p call)) - (setf (lambda-return call-fun) return) - (setf (return-lambda return) call-fun)))) - (move-let-call-cont fun) - (undefined-value)) - - -;;; Let-Convert -- Internal -;;; -;;; Actually do let conversion. We call subfunctions to do most of the -;;; work. We change the Call's cont to be the continuation heading the bind -;;; block, and also do Reoptimize-Continuation on the args and Cont so that -;;; let-specific IR1 optimizations get a chance. We blow away any entry for -;;; the function in *free-functions* so that nobody will create new reference -;;; to it. -;;; -(defun let-convert (fun call) - (declare (type clambda fun) (type basic-combination call)) - (let ((next-block (if (node-tail-p call) - nil - (insert-let-body fun call)))) - (move-return-stuff fun call next-block) - (merge-lets fun call))) - - -;;; REOPTIMIZE-CALL -- Internal -;;; -;;; Reoptimize all of Call's args and its result. -;;; -(defun reoptimize-call (call) - (declare (type basic-combination call)) - (dolist (arg (basic-combination-args call)) - (when arg - (reoptimize-continuation arg))) - (reoptimize-continuation (node-cont call)) - (undefined-value)) - -;;; OK-INITIAL-CONVERT-P -- Internal -;;; -;;; We also don't convert calls to named functions which appear in the initial -;;; component, delaying this until optimization. This minimizes the likelyhood -;;; that we well let-convert a function which may have references added due to -;;; later local inline expansion -;;; -(defun ok-initial-convert-p (fun) - (not (and (leaf-name fun) - (eq (component-kind - (block-component - (node-block (lambda-bind fun)))) - :initial)))) - - -;;; Maybe-Let-Convert -- Interface -;;; -;;; This function is called when there is some reason to believe that -;;; the lambda Fun might be converted into a let. This is done after local -;;; call analysis, and also when a reference is deleted. We only convert to a -;;; let when the function is a normal local function, has no XEP, and is -;;; referenced in exactly one local call. Conversion is also inhibited if the -;;; only reference is in a block about to be deleted. We return true if we -;;; converted. -;;; -;;; These rules may seem unnecessarily restrictive, since there are some -;;; cases where we could do the return with a jump that don't satisfy these -;;; requirements. The reason for doing things this way is that it makes the -;;; concept of a let much more useful at the level of IR1 semantics. The -;;; :ASSIGNMENT function kind provides another way to optimize calls to -;;; single-return/multiple call functions. -;;; -;;; We don't attempt to convert calls to functions that have an XEP, since -;;; we might be embarrassed later when we want to convert a newly discovered -;;; local call. Also, see OK-INITIAL-CONVERT-P. -;;; -(defun maybe-let-convert (fun) - (declare (type clambda fun)) - (let ((refs (leaf-refs fun))) - (when (and refs (null (rest refs)) - (member (functional-kind fun) '(nil :assignment)) - (not (functional-entry-function fun))) - (let* ((ref-cont (node-cont (first refs))) - (dest (continuation-dest ref-cont))) - (when (and (basic-combination-p dest) - (eq (basic-combination-fun dest) ref-cont) - (eq (basic-combination-kind dest) :local) - (not (block-delete-p (node-block dest))) - (cond ((ok-initial-convert-p fun) t) - (t - (reoptimize-continuation ref-cont) - nil))) - (unless (eq (functional-kind fun) :assignment) - (let-convert fun dest)) - (reoptimize-call dest) - (setf (functional-kind fun) - (if (mv-combination-p dest) :mv-let :let)))) - t))) - - -;;;; Tail local calls and assignments: - -;;; ONLY-HARMLESS-CLEANUPS -- Internal -;;; -;;; Return T if there are no cleanups between Block1 and Block2, or if they -;;; definitely won't generate any cleanup code. Currently we recognize lexical -;;; entry points that are only used locally (if at all). -;;; -(defun only-harmless-cleanups (block1 block2) - (declare (type cblock block1 block2)) - (or (eq block1 block2) - (let ((cleanup2 (block-start-cleanup block2))) - (do ((cleanup (block-end-cleanup block1) - (node-enclosing-cleanup (cleanup-mess-up cleanup)))) - ((eq cleanup cleanup2) t) - (case (cleanup-kind cleanup) - ((:block :tagbody) - (unless (null (entry-exits (cleanup-mess-up cleanup))) - (return nil))) - (t (return nil))))))) - - -;;; MAYBE-CONVERT-TAIL-LOCAL-CALL -- Interface -;;; -;;; If a potentially TR local call really is TR, then convert it to jump -;;; directly to the called function. We also call MAYBE-CONVERT-TO-ASSIGNMENT. -;;; The first value is true if we tail-convert. The second is the value of -;;; M-C-T-A. We can switch the succesor (potentially deleting the RETURN node) -;;; unless: -;;; -- The call has already been converted. -;;; -- The call isn't TR (random implicit MV PROG1.) -;;; -- The call is in an XEP (thus we might decide to make it non-tail so that -;;; we can use known return inside the component.) -;;; -- There is a change in the cleanup between the call in the return, so we -;;; might need to introduce cleanup code. -;;; -(defun maybe-convert-tail-local-call (call) - (declare (type combination call)) - (let ((return (continuation-dest (node-cont call)))) - (assert (return-p return)) - (when (and (not (node-tail-p call)) - (immediately-used-p (return-result return) call) - (not (eq (functional-kind (node-home-lambda call)) - :external)) - (only-harmless-cleanups (node-block call) - (node-block return))) - (node-ends-block call) - (let ((block (node-block call)) - (fun (combination-lambda call))) - (setf (node-tail-p call) t) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (node-block (lambda-bind fun))) - (values t (maybe-convert-to-assignment fun)))))) - - -;;; MAYBE-CONVERT-TO-ASSIGNMENT -- Interface -;;; -;;; Called when we believe it might make sense to convert Fun to an -;;; assignment. All this function really does is determine when a function -;;; with more than one call can still be combined with the calling function's -;;; environment. We can convert when: -;;; -- The function is a normal, non-entry function, and -;;; -- Except for one call, all calls must be tail recursive calls in the -;;; called function (i.e. are self-recursive tail calls) -;;; -- OK-INITIAL-CONVERT-P is true. -;;; -;;; There may be one outside call, and it need not be tail-recursive. Since -;;; all tail local calls have already been converted to direct transfers, the -;;; only control semantics needed are to splice in the body at the non-tail -;;; call. If there is no non-tail call, then we need only merge the -;;; environments. Both cases are handled by LET-CONVERT. -;;; -;;; ### It would actually be possible to allow any number of outside calls as -;;; long as they all return to the same place (i.e. have the same conceptual -;;; continuation.) A special case of this would be when all of the outside -;;; calls are tail recursive. -;;; -(defun maybe-convert-to-assignment (fun) - (declare (type clambda fun)) - (when (and (not (functional-kind fun)) - (not (functional-entry-function fun))) - (let ((non-tail nil) - (call-fun nil)) - (when (and (dolist (ref (leaf-refs fun) t) - (let ((dest (continuation-dest (node-cont ref)))) - (when (block-delete-p (node-block dest)) (return nil)) - (let ((home (node-home-lambda ref))) - (unless (eq home fun) - (when call-fun (return nil)) - (setq call-fun home)) - (unless (node-tail-p dest) - (when (or non-tail (eq home fun)) (return nil)) - (setq non-tail dest))))) - (ok-initial-convert-p fun)) - (setf (functional-kind fun) :assignment) - (let-convert fun (or non-tail - (continuation-dest - (node-cont (first (leaf-refs fun)))))) - (when non-tail (reoptimize-call non-tail)) - t)))) diff --git a/compiler/ltn.lisp b/compiler/ltn.lisp deleted file mode 100644 index 2515ab672f4367177182412fb1904f7f0b8b0376..0000000000000000000000000000000000000000 --- a/compiler/ltn.lisp +++ /dev/null @@ -1,1105 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/ltn.lisp,v 1.34 1992/12/16 13:32:33 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the LTN pass in the compiler. LTN allocates -;;; expression evaluation TNs, makes nearly all the implementation policy -;;; decisions, and also does a few other random things. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") -(in-package "EXTENSIONS") -(export '(*efficiency-note-limit* *efficiency-note-cost-threshold*)) -(in-package "C") - - -;;;; Utilities: - -;;; Translation-Policy -- Internal -;;; -;;; Return the policies keyword indicated by the node policy. -;;; -(defun translation-policy (node) - (declare (type node node)) - (let* ((cookie (lexenv-cookie (node-lexenv node))) - (safety (cookie-safety cookie)) - (space (max (cookie-space cookie) - (cookie-cspeed cookie))) - (speed (cookie-speed cookie))) - (if (zerop safety) - (if (>= speed space) :fast :small) - (if (>= speed space) :fast-safe :safe)))) - - -;;; Policy-Safe-P -- Interface -;;; -;;; Return true if Policy is a safe policy. -;;; -(proclaim '(inline policy-safe-p)) -(defun policy-safe-p (policy) - (declare (type policies policy)) - (or (eq policy :safe) (eq policy :fast-safe))) - - -;;; FLUSH-TYPE-CHECK -- Internal -;;; -;;; Called when an unsafe policy indicates that no type check should be done -;;; on CONT. We delete the type check unless it is :ERROR (indicating a -;;; compile-time type error.) -;;; -(proclaim '(inline flush-type-check)) -(defun flush-type-check (cont) - (declare (type continuation cont)) - (when (member (continuation-type-check cont) '(t :no-check)) - (setf (continuation-%type-check cont) :deleted)) - (undefined-value)) - - -;;; Continuation-PType -- Internal -;;; -;;; A annotated continuation's primitive-type. -;;; -(proclaim '(inline continuation-ptype)) -(defun continuation-ptype (cont) - (declare (type continuation cont)) - (ir2-continuation-primitive-type (continuation-info cont))) - - -;;; LEGAL-IMMEDIATE-CONSTANT-P -- Interface -;;; -;;; Return true if a constant Leaf is of a type which we can legally -;;; directly reference in code. Named constants with arbitrary pointer values -;;; cannot, since we must preserve EQLness. -;;; -(defun legal-immediate-constant-p (leaf) - (declare (type constant leaf)) - (or (null (leaf-name leaf)) - (typecase (constant-value leaf) - ((or number character) t) - (symbol (symbol-package (constant-value leaf))) - (t nil)))) - - -;;; Continuation-Delayed-Leaf -- Internal -;;; -;;; If Cont is used only by a Ref to a leaf that can be delayed, then return -;;; the leaf, otherwise return NIL. -;;; -(defun continuation-delayed-leaf (cont) - (declare (type continuation cont)) - (let ((use (continuation-use cont))) - (and (ref-p use) - (let ((leaf (ref-leaf use))) - (etypecase leaf - (lambda-var (if (null (lambda-var-sets leaf)) leaf nil)) - (constant (if (legal-immediate-constant-p leaf) leaf nil)) - ((or functional global-var) nil)))))) - - -;;; Annotate-1-Value-Continuation -- Internal -;;; -;;; Annotate a normal single-value continuation. If its only use is a ref -;;; that we are allowed to delay the evaluation of, then we mark the -;;; continuation for delayed evaluation, otherwise we assign a TN to hold the -;;; continuation's value. If the continuation has a type check, we make the TN -;;; according to the proven type to ensure that the possibly erroneous value -;;; can be represented. -;;; -(defun annotate-1-value-continuation (cont) - (declare (type continuation cont)) - (let ((info (continuation-info cont))) - (assert (eq (ir2-continuation-kind info) :fixed)) - (cond - ((continuation-delayed-leaf cont) - (setf (ir2-continuation-kind info) :delayed)) - ((member (continuation-type-check cont) '(:deleted nil)) - (setf (ir2-continuation-locs info) - (list (make-normal-tn (ir2-continuation-primitive-type info))))) - (t - (setf (ir2-continuation-locs info) - (list (make-normal-tn - (primitive-type - (single-value-type (continuation-proven-type cont))))))))) - (undefined-value)) - - -;;; Annotate-Ordinary-Continuation -- Internal -;;; -;;; Make an IR2-Continuation corresponding to the continuation type and then -;;; do Annotate-1-Value-Continuation. If Policy isn't a safe policy, then we -;;; clear the type-check flag. -;;; -(defun annotate-ordinary-continuation (cont policy) - (declare (type continuation cont) - (type policies policy)) - (let ((info (make-ir2-continuation - (primitive-type (continuation-type cont))))) - (setf (continuation-info cont) info) - (unless (policy-safe-p policy) (flush-type-check cont)) - (annotate-1-value-continuation cont)) - (undefined-value)) - - -;;; Annotate-Function-Continuation -- Internal -;;; -;;; Annotate the function continuation for a full call. If the only -;;; reference is to a global function and Delay is true, then we delay -;;; the reference, otherwise we annotate for a single value. -;;; -;;; Unlike for an argument, we only clear the type check flag when the policy -;;; is unsafe, since the check for a valid function object must be done before -;;; the call. -;;; -(defun annotate-function-continuation (cont policy &optional (delay t)) - (declare (type continuation cont) (type policies policy)) - (unless (policy-safe-p policy) (flush-type-check cont)) - (let* ((ptype (primitive-type (continuation-type cont))) - (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil)) - ptype - (primitive-type - (single-value-type - (continuation-proven-type cont))))) - (info (make-ir2-continuation ptype))) - (setf (continuation-info cont) info) - (let ((name (continuation-function-name cont t))) - (if (and delay name) - (setf (ir2-continuation-kind info) :delayed) - (setf (ir2-continuation-locs info) - (list (make-normal-tn tn-ptype)))))) - (undefined-value)) - - -;;; FLUSH-FULL-CALL-TAIL-TRANSFER -- Internal -;;; -;;; If TAIL-P is true, then we check to see if the call can really be a tail -;;; call by seeing if this function's return convention is :UNKNOWN. If so, we -;;; move the call block succssor link from the return block to the component -;;; tail (after ensuring that they are in separate blocks.) This allows the -;;; return to be deleted when there are no non-tail uses. -;;; -(defun flush-full-call-tail-transfer (call) - (declare (type basic-combination call)) - (let ((tails (and (node-tail-p call) - (lambda-tail-set (node-home-lambda call))))) - (when tails - (cond ((eq (return-info-kind (tail-set-info tails)) :unknown) - (node-ends-block call) - (let ((block (node-block call))) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (component-tail (block-component block))))) - (t - (setf (node-tail-p call) nil))))) - (undefined-value)) - - -;;; LTN-Default-Call -- Internal -;;; -;;; Set up stuff to do a full call for Call. We always flush arg type -;;; checks, but do it after annotation when the policy is safe, since we don't -;;; want to choose the TNs according to a type assertions that may not hold. -;;; -;;; We set the kind to :FULL or :FUNNY, depending on whether there is an -;;; IR2-CONVERT method. If a funny function, then we inhibit tail recursion, -;;; since the IR2 convert method is going to want to deliver values normally. -;;; -(defun ltn-default-call (call policy) - (declare (type combination call) (type policies policy)) - (annotate-function-continuation (basic-combination-fun call) policy) - - (let ((safe-p (policy-safe-p policy))) - (dolist (arg (basic-combination-args call)) - (unless safe-p (flush-type-check arg)) - (unless (continuation-info arg) - (setf (continuation-info arg) - (make-ir2-continuation - (primitive-type - (continuation-type arg))))) - (annotate-1-value-continuation arg) - (when safe-p (flush-type-check arg)))) - - (let ((kind (basic-combination-kind call))) - (cond ((and (function-info-p kind) - (function-info-ir2-convert kind)) - (setf (basic-combination-info call) :funny) - (setf (node-tail-p call) nil)) - (t - (when (eq kind :error) - (setf (basic-combination-kind call) :full)) - (setf (basic-combination-info call) :full) - (flush-full-call-tail-transfer call)))) - - (undefined-value)) - -;;; Annotate-Funny-Call -- Internal. -;;; -;;; Annotate the call as ``funny.'' In other words, mark it as funny, -;;; flush tail-call-ness, and mark all arg continuations as ordinary. -;;; -(defun annotate-funny-call (call policy) - (setf (basic-combination-info call) :funny) - (setf (node-tail-p call) nil) - (dolist (arg (basic-combination-args call)) - (annotate-ordinary-continuation arg policy))) - -;;; Annotate-Unknown-Values-Continuation -- Internal -;;; -;;; Annotate a continuation for unknown multiple values: -;;; -- Delete any type check, regardless of policy, since we IR2 conversion -;;; isn't prepared to check unknown-values continuations. If we delete a -;;; type check when the policy is safe, then we emit a warning. -;;; -- Add the continuation to the IR2-Block-Popped if it is used across a -;;; block boundry. -;;; -- Assign a :Unknown IR2-Continuation. -;;; -;;; Note: it is critical that this be called only during LTN analysis of Cont's -;;; DEST, and called in the order that the continuations are received. -;;; Otherwise the IR2-Block-Popped and IR2-Component-Values-XXX will get all -;;; messed up. -;;; -(defun annotate-unknown-values-continuation (cont policy) - (declare (type continuation cont) (type policies policy)) - (when (eq (continuation-type-check cont) t) - (let* ((dest (continuation-dest cont)) - (*compiler-error-context* dest)) - (when (and (policy-safe-p policy) - (policy dest (>= safety brevity))) - (compiler-note "Unable to check type assertion in unknown-values ~ - context:~% ~S" - (continuation-asserted-type cont)))) - (setf (continuation-%type-check cont) :deleted)) - - (let* ((block (node-block (continuation-dest cont))) - (use (continuation-use cont)) - (2block (block-info block))) - (unless (and use (eq (node-block use) block)) - (setf (ir2-block-popped 2block) - (nconc (ir2-block-popped 2block) (list cont))))) - - (let ((2cont (make-ir2-continuation nil))) - (setf (ir2-continuation-kind 2cont) :unknown) - (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations)) - (setf (continuation-info cont) 2cont)) - - (undefined-value)) - - -;;; Annotate-Fixed-Values-Continuation -- Internal -;;; -;;; Annotate Cont for a fixed, but arbitrary number of values, of the -;;; specified primitive Types. If the continuation has a type check, we -;;; annotate for the number of values indicated by Types, but only use proven -;;; type information. -;;; -(defun annotate-fixed-values-continuation (cont policy types) - (declare (type continuation cont) (type policies policy) (list types)) - (unless (policy-safe-p policy) (flush-type-check cont)) - - (let ((res (make-ir2-continuation nil))) - (if (member (continuation-type-check cont) '(:deleted nil)) - (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types)) - (let* ((proven (mapcar #'(lambda (x) - (make-normal-tn (primitive-type x))) - (values-types - (continuation-proven-type cont)))) - (num-proven (length proven)) - (num-types (length types))) - (setf (ir2-continuation-locs res) - (cond - ((< num-proven num-types) - (append proven - (make-n-tns (- num-types num-proven) - (backend-any-primitive-type *backend*)))) - ((> num-proven num-types) - (subseq proven 0 num-types)) - (t - proven))))) - (setf (continuation-info cont) res)) - - (undefined-value)) - - -;;;; Node-specific analysis functions: - -;;; LTN-Analyze-Return -- Internal -;;; -;;; Annotate the result continuation for a function. We use the Return-Info -;;; computed by GTN to determine how to represent the return values within the -;;; function: -;;; -- If the tail-set has a fixed values count, then use that many values. -;;; -- If the actual uses of the result continuation in this function have a -;;; fixed number of values (after intersection with the assertion), then use -;;; that number. We throw out TAIL-P :FULL and :LOCAL calls, since we know -;;; they will truly end up as TR calls. We can use the -;;; BASIC-COMBINATION-INFO even though it is assigned by this phase, since -;;; the initial value NIL doesn't look like a TR call. -;;; -;;; If there are *no* non-tail-call uses, then it falls out that we annotate -;;; for one value (type is NIL), but the return will end up being deleted. -;;; -;;; In non-perverse code, the DFO walk will reach all uses of the result -;;; continuation before it reaches the RETURN. In perverse code, we may -;;; annotate for unknown values when we didn't have to. -;;; -- Otherwise, we must annotate the continuation for unknown values. -;;; -(defun ltn-analyze-return (node policy) - (declare (type creturn node) (type policies policy)) - (let* ((cont (return-result node)) - (fun (return-lambda node)) - (returns (tail-set-info (lambda-tail-set fun))) - (types (return-info-types returns))) - (if (eq (return-info-count returns) :unknown) - (collect ((res *empty-type* values-type-union)) - (do-uses (use (return-result node)) - (unless (and (node-tail-p use) - (basic-combination-p use) - (member (basic-combination-info use) '(:local :full))) - (res (node-derived-type use)))) - - (let ((int (values-type-intersection - (res) - (continuation-asserted-type cont)))) - (multiple-value-bind - (types kind) - (values-types (if (eq int *empty-type*) (res) int)) - (if (eq kind :unknown) - (annotate-unknown-values-continuation cont policy) - (annotate-fixed-values-continuation - cont policy - (mapcar #'primitive-type types)))))) - (annotate-fixed-values-continuation cont policy types))) - - (undefined-value)) - - -;;; LTN-Analyze-MV-Bind -- Internal -;;; -;;; Annotate the single argument continuation as a fixed-values -;;; continuation. We look at the called lambda to determine number and type of -;;; return values desired. It is assumed that only a function that -;;; Looks-Like-An-MV-Bind will be converted to a local call. -;;; -(defun ltn-analyze-mv-bind (call policy) - (declare (type mv-combination call) - (type policies policy)) - (setf (basic-combination-kind call) :local) - (setf (node-tail-p call) nil) - (annotate-fixed-values-continuation - (first (basic-combination-args call)) policy - (mapcar #'(lambda (var) - (primitive-type (basic-var-type var))) - (lambda-vars - (ref-leaf - (continuation-use - (basic-combination-fun call)))))) - (undefined-value)) - - -;;; LTN-Analyze-MV-Call -- Internal -;;; -;;; We force all the argument continuations to use the unknown values -;;; convention. The continuations are annotated in reverse order, since the -;;; last argument is on top, thus must be popped first. We disallow delayed -;;; evaluation of the function continuation to simplify IR2 conversion of MV -;;; call. -;;; -;;; We could be cleverer when we know the number of values returned by the -;;; continuations, but optimizations of MV-Call are probably unworthwhile. -;;; -;;; We are also responsible for handling THROW, which is represented in IR1 -;;; as an mv-call to the %THROW funny function. We annotate the tag -;;; continuation for a single value and the values continuation for unknown -;;; values. -;;; -(defun ltn-analyze-mv-call (call policy) - (declare (type mv-combination call)) - (let ((fun (basic-combination-fun call)) - (args (basic-combination-args call))) - (cond ((eq (continuation-function-name fun) '%throw) - (setf (basic-combination-info call) :funny) - (annotate-ordinary-continuation (first args) policy) - (annotate-unknown-values-continuation (second args) policy) - (setf (node-tail-p call) nil)) - (t - (setf (basic-combination-info call) :full) - (annotate-function-continuation (basic-combination-fun call) - policy nil) - (dolist (arg (reverse args)) - (annotate-unknown-values-continuation arg policy)) - (flush-full-call-tail-transfer call)))) - - (undefined-value)) - - -;;; LTN-Analyze-Local-Call -- Internal -;;; -;;; Annotate the arguments as ordinary single-value continuations. If the -;;; call is a tail call, make sure that is linked directly to the bind node. -;;; Usually it will be, but calls from XEPs and calls that might have needed a -;;; cleanup after them won't have been swung over yet, since we weren't sure -;;; they would really be TR until now. -;;; -(defun ltn-analyze-local-call (call policy) - (declare (type combination call) - (type policies policy)) - (setf (basic-combination-info call) :local) - - (dolist (arg (basic-combination-args call)) - (when arg - (annotate-ordinary-continuation arg policy))) - - (when (node-tail-p call) - (let ((caller (node-home-lambda call)) - (callee (combination-lambda call))) - (assert (eq (lambda-tail-set caller) - (lambda-tail-set (lambda-home callee)))) - (node-ends-block call) - (let ((block (node-block call))) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (node-block (lambda-bind callee)))))) - (undefined-value)) - - -;;; LTN-Analyze-Set -- Internal -;;; -;;; Annotate the value continuation. -;;; -(defun ltn-analyze-set (node policy) - (declare (type cset node) (type policies policy)) - (setf (node-tail-p node) nil) - (annotate-ordinary-continuation (set-value node) policy) - (undefined-value)) - - -;;; LTN-Analyze-If -- Internal -;;; -;;; If the only use of the Test continuation is a combination annotated with -;;; a conditional template, then don't annotate the continuation so that IR2 -;;; conversion knows not to emit any code, otherwise annotate as an ordinary -;;; continuation. Since we only use a conditional template if the call -;;; immediately precedes the IF node in the same block, we know that any -;;; predicate will already be annotated. -;;; -(defun ltn-analyze-if (node policy) - (declare (type cif node) (type policies policy)) - (setf (node-tail-p node) nil) - (let* ((test (if-test node)) - (use (continuation-use test))) - (unless (and (combination-p use) - (let ((info (basic-combination-info use))) - (and (template-p info) - (eq (template-result-types info) :conditional)))) - (annotate-ordinary-continuation test policy))) - (undefined-value)) - - -;;; LTN-Analyze-Exit -- Internal -;;; -;;; If there is a value continuation, then annotate it for unknown values. -;;; In this case, the exit is non-local, since all other exits are deleted or -;;; degenerate by this point. -;;; -(defun ltn-analyze-exit (node policy) - (setf (node-tail-p node) nil) - (let ((value (exit-value node))) - (when value - (annotate-unknown-values-continuation value policy))) - (undefined-value)) - - -;;; LTN annotate %Unwind-Protect -- Internal -;;; -;;; We need a special method for %Unwind-Protect that ignores the cleanup -;;; function. We don't annotate either arg, since we don't need them at -;;; run-time. -;;; -;;; [The default is o.k. for %Catch, since environment analysis converted the -;;; reference to the escape function into a constant reference to the -;;; NLX-Info.] -;;; -(defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node policy) - policy ; Ignore... - (setf (basic-combination-info node) :funny) - (setf (node-tail-p node) nil) - ) - - -;;; LTN annotate %Slot-Setter, %Slot-Accessor -- Internal -;;; -;;; Both of these functions need special LTN-annotate methods, since we only -;;; want to clear the Type-Check in unsafe policies. If we allowed the call to -;;; be annotated as a full call, then no type checking would be done. -;;; -;;; We also need a special LTN annotate method for %Slot-Setter so that the -;;; function is ignored. This is because the reference to a SETF function -;;; can't be delayed, so IR2 conversion would have already emitted a call to -;;; FDEFINITION by the time the IR2 convert method got control. -;;; -(defoptimizer (%slot-accessor ltn-annotate) ((struct) node policy) - (setf (basic-combination-info node) :funny) - (setf (node-tail-p node) nil) - (annotate-ordinary-continuation struct policy)) -;;; -(defoptimizer (%slot-setter ltn-annotate) ((struct value) node policy) - (setf (basic-combination-info node) :funny) - (setf (node-tail-p node) nil) - (annotate-ordinary-continuation struct policy) - (annotate-ordinary-continuation value policy)) - - -;;;; Known call annotation: - -;;; OPERAND-RESTRICTION-OK -- Interface -;;; -;;; Return true if Restr is satisfied by Type. If T-OK is true, then a T -;;; restriction allows any operand type. This is also called by IR2tran when -;;; it determines whether a result temporary needs to be made, and by -;;; representation selection when it is deciding which move VOP to use. -;;; Cont and TN are used to test for constant arguments. -;;; -(proclaim '(inline operand-restriction-ok)) -(defun operand-restriction-ok (restr type &key cont tn (t-ok t)) - (declare (type (or (member *) cons) restr) - (type primitive-type type) - (type (or continuation null) cont) - (type (or tn null) tn)) - (if (eq restr '*) - t - (ecase (first restr) - (:or - (dolist (mem (rest restr) nil) - (when (or (and t-ok (eq mem (backend-any-primitive-type *backend*))) - (eq mem type)) - (return t)))) - (:constant - (cond (cont - (and (constant-continuation-p cont) - (funcall (second restr) (continuation-value cont)))) - (tn - (and (eq (tn-kind tn) :constant) - (funcall (second restr) (tn-value tn)))) - (t - (error "Neither CONT nor TN supplied."))))))) - - -;;; Template-Args-OK -- Internal -;;; -;;; Check that the argument type restriction for Template are satisfied in -;;; call. If an argument's TYPE-CHECK is :NO-CHECK and our policy is safe, -;;; then only :SAFE templates are o.k. -;;; -(defun template-args-ok (template call safe-p) - (declare (type template template) - (type combination call)) - (let ((mtype (template-more-args-type template))) - (do ((args (basic-combination-args call) (cdr args)) - (types (template-arg-types template) (cdr types))) - ((null types) - (cond ((null args) t) - ((not mtype) nil) - (t - (dolist (arg args t) - (unless (operand-restriction-ok mtype - (continuation-ptype arg)) - (return nil)))))) - (when (null args) (return nil)) - (let ((arg (car args)) - (type (car types))) - (when (and (eq (continuation-type-check arg) :no-check) - safe-p - (not (eq (template-policy template) :safe))) - (return nil)) - (unless (operand-restriction-ok type (continuation-ptype arg) - :cont arg) - (return nil)))))) - - -;;; Template-Results-OK -- Internal -;;; -;;; Check that Template can be used with the specifed Result-Type. Result -;;; type checking is pretty different from argument type checking due to the -;;; relaxed rules for values count. We succeed if for each required result, -;;; there is a positional restriction on the value that is at least as good. -;;; If we run out of result types before we run out of restrictions, then we -;;; only suceed if the leftover restrictions are *. If we run out of -;;; restrictions before we run out of result types, then we always win. -;;; -(defun template-results-ok (template result-type) - (declare (type template template) - (type ctype result-type)) - (when (template-more-results-type template) - (error "~S has :MORE results with :TRANSLATE." (template-name template))) - (let ((types (template-result-types template))) - (cond - ((values-type-p result-type) - (do ((ltypes (append (args-type-required result-type) - (args-type-optional result-type)) - (rest ltypes)) - (types types (rest types))) - ((null ltypes) - (dolist (type types t) - (unless (eq type '*) - (return nil)))) - (when (null types) (return t)) - (let ((type (first types))) - (unless (operand-restriction-ok type - (primitive-type (first ltypes))) - (return nil))))) - (types - (operand-restriction-ok (first types) (primitive-type result-type))) - (t t)))) - - -;;; IS-OK-TEMPLATE-USE -- Internal -;;; -;;; Return true if Call is an ok use of Template according to Safe-P. -;;; -- If the template has a Guard that isn't true, then we ignore the -;;; template, not even considering it to be rejected. -;;; -- If the argument type restrictions aren't satisfied, then we reject the -;;; template. -;;; -- If the template is :Conditional, then we accept it only when the -;;; destination of the value is an immediately following IF node. -;;; -- If either the template is safe or the policy is unsafe (i.e. we can -;;; believe output assertions), then we test against the intersection of the -;;; node derived type and the continuation asserted type. Otherwise, we -;;; just use the node type. If TYPE-CHECK is null, there is no point in -;;; doing the intersection, since the node type must be a subtype of the -;;; assertion. -;;; -;;; If the template is *not* ok, then the second value is a keyword indicating -;;; which aspect failed. -;;; -(defun is-ok-template-use (template call safe-p) - (declare (type template template) (type combination call)) - (let* ((guard (template-guard template)) - (cont (node-cont call)) - (atype (continuation-asserted-type cont)) - (dtype (node-derived-type call))) - (cond ((and guard (not (funcall guard))) - (values nil :guard)) - ((not (template-args-ok template call safe-p)) - (values nil - (if (and safe-p (template-args-ok template call nil)) - :arg-check - :arg-types))) - ((eq (template-result-types template) :conditional) - (let ((dest (continuation-dest cont))) - (if (and (if-p dest) - (immediately-used-p (if-test dest) call)) - (values t nil) - (values nil :conditional)))) - ((template-results-ok - template - (if (and (or (eq (template-policy template) :safe) - (not safe-p)) - (continuation-type-check cont)) - (values-type-intersection dtype atype) - dtype)) - (values t nil)) - (t - (values nil :result-types))))) - - -;;; Find-Template -- Internal -;;; -;;; Use operand type information to choose a template from the list -;;; Templates for a known Call. We return three values: -;;; 1] The template we found. -;;; 2] Some template that we rejected due to unsatisfied type restrictions, or -;;; NIL if none. -;;; 3] The tail of Templates for templates we haven't examined yet. -;;; -;;; We just call IS-OK-TEMPLATE-USE until it returns true. -;;; -(defun find-template (templates call safe-p) - (declare (list templates) (type combination call)) - (do ((templates templates (rest templates)) - (rejected nil)) - ((null templates) - (values nil rejected nil)) - (let ((template (first templates))) - (when (is-ok-template-use template call safe-p) - (return (values template rejected (rest templates)))) - (setq rejected template)))) - - -;;; Find-Template-For-Policy -- Internal -;;; -;;; Given a partially annotated known call and a translation policy, return -;;; the appropriate template, or NIL if none can be found. We scan the -;;; templates (ordered by increasing cost) looking for a template whose -;;; restrictions are satisfied and that has our policy. -;;; -;;; If we find a template that doesn't have our policy, but has a legal -;;; alternate policy, then we also record that to return as a last resort. If -;;; our policy is safe, then only safe policies are O.K., otherwise anything -;;; goes. -;;; -;;; If we find a template with :SAFE policy, then we return it, or any cheaper -;;; fallback template. The theory behind this is that if it is cheapest, small -;;; and safe, we can't lose. If it is not cheapest, then we use the fallback, -;;; which won't have the desired policy, but :SAFE isn't desired either, so we -;;; might as well go with the cheaper one. The main reason for doing this is -;;; to make sure that cheap safe templates are used when they apply and the -;;; current policy is something else. This is useful because :SAFE has the -;;; additional semantics of implicit argument type checking, so we may be -;;; forced to define a template with :SAFE policy when it is really small and -;;; fast as well. -;;; -(defun find-template-for-policy (call policy) - (declare (type combination call) - (type policies policy)) - (let ((safe-p (policy-safe-p policy))) - (let ((current (function-info-templates (basic-combination-kind call))) - (fallback nil) - (rejected nil)) - (loop - (multiple-value-bind (template this-reject more) - (find-template current call safe-p) - (unless rejected - (setq rejected this-reject)) - (setq current more) - (unless template - (return (values fallback rejected))) - - (let ((tpolicy (template-policy template))) - (cond ((eq tpolicy policy) - (return (values template rejected))) - ((eq tpolicy :safe) - (return (values (or fallback template) rejected))) - ((or (not safe-p) (eq tpolicy :fast-safe)) - (unless fallback - (setq fallback template)))))))))) - - -(defvar *efficiency-note-limit* 2 - "This is the maximum number of possible optimization alternatives will be - mentioned in a particular efficiency note. NIL means no limit.") -(proclaim '(type (or index null) *efficiency-note-limit*)) - -(defvar *efficiency-note-cost-threshold* 5 - "This is the minumum cost difference between the chosen implementation and - the next alternative that justifies an efficiency note.") -(proclaim '(type index *efficiency-note-cost-threshold*)) - - -;;; STRANGE-TEMPLATE-FAILURE -- Internal -;;; -;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't figure -;;; out any reason why Template was rejected. Users should never see these -;;; messages, but they can happen in situations where the VM definition is -;;; messed up somehow. -;;; -(defun strange-template-failure (template call policy frob) - (declare (type template template) (type combination call) - (type policies policy) (type function frob)) - (funcall frob "This shouldn't happen! Bug?") - (multiple-value-bind (win why) - (is-ok-template-use template call - (policy-safe-p policy)) - (assert (not win)) - (ecase why - (:guard - (funcall frob "Template guard failed.")) - (:arg-check - (funcall frob "Template is not safe, yet we were counting on it.")) - (:arg-types - (funcall frob "Argument types invalid.") - (funcall frob "Argument primitive types:~% ~S" - (mapcar #'(lambda (x) - (primitive-type-name - (continuation-ptype x))) - (combination-args call))) - (funcall frob "Argument type assertions:~% ~S" - (mapcar #'(lambda (x) - (if (atom x) - x - (ecase (car x) - (:or `(:or .,(mapcar #'primitive-type-name - (cdr x)))) - (:constant `(:constant ,(third x)))))) - (template-arg-types template)))) - (:conditional - (funcall frob "Conditional in a non-conditional context.")) - (:result-types - (funcall frob "Result types invalid."))))) - - -;;; Note-Rejected-Templates -- Internal -;;; -;;; This function emits efficiency notes describing all of the templates -;;; better (faster) than Template that we might have been able to use if there -;;; were better type declarations. Template is null when we didn't find any -;;; template, and thus must do a full call. -;;; -;;; In order to be worth complaining about, a template must: -;;; -- be allowed by its guard, -;;; -- be safe if the current policy is safe, -;;; -- have argument/result type restrictions consistent with the known type -;;; information, e.g. we don't consider float templates when an operand is -;;; known to be an integer, -;;; -- be disallowed by the stricter operand subtype test (which resembles, but -;;; is not identical to the test done by Find-Template.) -;;; -;;; Note that there may not be any possibly applicable templates, since we are -;;; called whenever any template is rejected. That template might have the -;;; wrong policy or be inconsistent with the known type. -;;; -;;; We go to some trouble to make the whole multi-line output into a single -;;; call to Compiler-Note so that repeat messages are suppressed, etc. -;;; -(defun note-rejected-templates (call policy template) - (declare (type combination call) (type policies policy) - (type (or template null) template)) - - (collect ((losers)) - (let ((safe-p (policy-safe-p policy)) - (verbose-p (policy call (= brevity 0))) - (max-cost (- (template-cost - (or template - (template-or-lose 'call-named *backend*))) - *efficiency-note-cost-threshold*))) - (dolist (try (function-info-templates (basic-combination-kind call))) - (when (> (template-cost try) max-cost) (return)) - (let ((guard (template-guard try))) - (when (and (or (not guard) (funcall guard)) - (or (not safe-p) - (policy-safe-p (template-policy try))) - (or verbose-p - (and (template-note try) - (valid-function-use - call (template-type try) - :argument-test #'types-intersect - :result-test #'values-types-intersect)))) - (losers try))))) - - (when (losers) - (collect ((messages) - (count 0 +)) - (flet ((frob (string &rest stuff) - (messages string) - (messages stuff))) - (dolist (loser (losers)) - (when (and *efficiency-note-limit* - (>= (count) *efficiency-note-limit*)) - (frob "etc.") - (return)) - (let* ((type (template-type loser)) - (valid (valid-function-use call type)) - (strict-valid (valid-function-use call type - :strict-result t))) - (frob "Unable to do ~A (cost ~D) because:" - (or (template-note loser) (template-name loser)) - (template-cost loser)) - (cond - ((and valid strict-valid) - (strange-template-failure loser call policy #'frob)) - ((not valid) - (assert (not (valid-function-use call type - :error-function #'frob - :warning-function #'frob)))) - (t - (assert (policy-safe-p policy)) - (frob "Can't trust output type assertion under safe ~ - policy."))) - (count 1)))) - - (let ((*compiler-error-context* call)) - (compiler-note "~{~?~^~&~6T~}" - (if template - `("Forced to do ~A (cost ~D)." - (,(or (template-note template) - (template-name template)) - ,(template-cost template)) - . ,(messages)) - `("Forced to do full call." - nil - . ,(messages)))))))) - (undefined-value)) - - - -;;; Flush-Type-Checks-According-To-Policy -- Internal -;;; -;;; Flush type checks according to policy. If the policy is unsafe, then we -;;; never do any checks. If our policy is safe, and we are using a safe -;;; template, then we can also flush arg and result type checks. Result type -;;; checks are only flushed when the continuation as a single use. -;;; -(defun flush-type-checks-according-to-policy (call policy template) - (declare (type combination call) (type policies policy) - (type template template)) - (let ((safe-op (eq (template-policy template) :safe))) - (when (or (not (policy-safe-p policy)) safe-op) - (dolist (arg (basic-combination-args call)) - (flush-type-check arg))) - (when safe-op - (let ((cont (node-cont call))) - (when (eq (continuation-use cont) call) - (flush-type-check cont))))) - - (undefined-value)) - - -;;; LTN-Analyze-Known-Call -- Internal -;;; -;;; If a function has a special-case annotation method use that, otherwise -;;; annotate the argument continuations and try to find a template -;;; corresponding to the type signature. If there is none, convert a full -;;; call. -;;; -;;; If we are unable to use some templates due to unstatisfied operand type -;;; restrictions and our policy enables efficiency notes, then we call -;;; Note-Rejected-Templates. -;;; -;;; If we are forced to do a full call, we check to see if the function -;;; called is the same as the current function. If so, we give a warning, as -;;; this is probably a botched interpreter stub. -;;; -(defun ltn-analyze-known-call (call policy) - (declare (type combination call) - (type policies policy)) - (let ((method (function-info-ltn-annotate (basic-combination-kind call))) - (args (basic-combination-args call))) - (when method - (funcall method call policy) - (return-from ltn-analyze-known-call (undefined-value))) - - (dolist (arg args) - (setf (continuation-info arg) - (make-ir2-continuation (primitive-type (continuation-type arg))))) - - (multiple-value-bind (template rejected) - (find-template-for-policy call policy) - (when (and rejected - (policy call (> speed brevity))) - (note-rejected-templates call policy template)) - (unless template - (when (and (eq (continuation-function-name (combination-fun call)) - (leaf-name - (environment-function - (node-environment call)))) - (let ((info (basic-combination-kind call))) - (not (or (function-info-ir2-convert info) - (ir1-attributep (function-info-attributes info) - recursive))))) - (let ((*compiler-error-context* call)) - (compiler-warning "Recursive known function definition."))) - (ltn-default-call call policy) - (return-from ltn-analyze-known-call (undefined-value))) - (setf (basic-combination-info call) template) - (setf (node-tail-p call) nil) - - (flush-type-checks-according-to-policy call policy template) - - (dolist (arg args) - (annotate-1-value-continuation arg)))) - - (undefined-value)) - - -;;;; Interfaces: - -(eval-when (compile eval) - -;;; LTN-Analyze-Block-Macro -- Internal -;;; -;;; We make the main per-block code in for LTN into a macro so that it can -;;; be shared between LTN-Analyze and LTN-Analyze-Block, yet can cache policy -;;; across blocks in the normal (full component) case. -;;; -;;; This code computes the policy and then dispatches to the appropriate -;;; node-specific function. -;;; -;;; Note: we deliberately don't use the DO-NODES macro, since the block can be -;;; split out from underneath us, and DO-NODES scans past the block end in this -;;; case. -;;; -(defmacro ltn-analyze-block-macro () - '(do* ((node (continuation-next (block-start block)) - (continuation-next cont)) - (cont (node-cont node) (node-cont node))) - (()) - (unless (eq (node-lexenv node) lexenv) - (setq policy (translation-policy node)) - (setq lexenv (node-lexenv node))) - - (etypecase node - (ref) - (combination - (case (basic-combination-kind node) - (:local (ltn-analyze-local-call node policy)) - ((:full :error) (ltn-default-call node policy)) - (t - (ltn-analyze-known-call node policy)))) - (cif - (ltn-analyze-if node policy)) - (creturn - (ltn-analyze-return node policy)) - ((or bind entry)) - (exit - (ltn-analyze-exit node policy)) - (cset (ltn-analyze-set node policy)) - (mv-combination - (ecase (basic-combination-kind node) - (:local (ltn-analyze-mv-bind node policy)) - ((:full :error) (ltn-analyze-mv-call node policy))))) - - (when (eq node (block-last block)) (return)))) - -); Eval-When (Compile Eval) - - -;;; LTN-Analyze -- Interface -;;; -;;; Loop over the blocks in Component, doing stuff to nodes that receive -;;; values. In addition to the stuff done by LTN-Analyze-Block-Macro, we also -;;; see if there are any unknown values receivers, making notations in the -;;; components Generators and Receivers as appropriate. -;;; -;;; If any unknown-values continations are received by this block (as -;;; indicated by IR2-Block-Popped, then we add the block to the -;;; IR2-Component-Values-Receivers. -;;; -;;; This is where we allocate IR2 blocks because it is the first place we -;;; need them. -;;; -(defun ltn-analyze (component) - (declare (type component component)) - (let ((2comp (component-info component)) - (lexenv nil) - policy) - (do-blocks (block component) - (assert (not (block-info block))) - (let ((2block (make-ir2-block block))) - (setf (block-info block) 2block) - (ltn-analyze-block-macro) - (let ((popped (ir2-block-popped 2block))) - (when popped - (push block (ir2-component-values-receivers 2comp))))))) - (undefined-value)) - - -;;; LTN-Analyze-Block -- Interface -;;; -;;; This function is used to analyze blocks that must be added to the flow -;;; graph after the normal LTN phase runs. Such code is constrained not to -;;; use weird unknown values (and probably in lots of other ways). -;;; -(defun ltn-analyze-block (block) - (declare (type cblock block)) - (let ((lexenv nil) - policy) - (ltn-analyze-block-macro)) - - (assert (not (ir2-block-popped (block-info block)))) - (undefined-value)) diff --git a/compiler/ltv.lisp b/compiler/ltv.lisp deleted file mode 100644 index e57d5923ce53cd68e9e4c6c5bd2b6c7760139b86..0000000000000000000000000000000000000000 --- a/compiler/ltv.lisp +++ /dev/null @@ -1,60 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/ltv.lisp,v 1.1 1991/11/25 12:09:36 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file implements LOAD-TIME-VALUE. -;;; -;;; Written by William Lott -;;; -(in-package "C") - -(in-package "LISP") -(export 'load-time-value) - -(in-package "C") - -(defknown %load-time-value (t) t (flushable movable)) - -(def-ir1-translator load-time-value ((form &optional read-only-p) start cont) - "Arrange for FORM to be evaluated at load-time and use the value produced - as if it were a constant. If READ-ONLY-P is non-NIL, then the resultant - object is guaranteed to never be modified, so it can be put in read-only - storage." - (if (producing-fasl-file) - (multiple-value-bind - (handle type) - (compile-load-time-value (if read-only-p - form - `(make-value-cell ,form))) - (declare (ignore type)) - (ir1-convert start cont - (if read-only-p - `(%load-time-value ',handle) - `(value-cell-ref (%load-time-value ',handle))))) - (let ((value - (handler-case (eval form) - (error (condition) - (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A" - condition))))) - (ir1-convert start cont - (if read-only-p - `',value - `(value-cell-ref ',(make-value-cell value))))))) - - -(defoptimizer (%load-time-value ir2-convert) ((handle) node block) - (assert (constant-continuation-p handle)) - (let ((cont (node-cont node)) - (tn (make-load-time-value-tn (continuation-value handle) - *universal-type*))) - (move-continuation-result node block (list tn) cont))) - diff --git a/compiler/macros.lisp b/compiler/macros.lisp deleted file mode 100644 index 3ac4ad2dca58add6e70c81266961d7ed7ccb07f9..0000000000000000000000000000000000000000 --- a/compiler/macros.lisp +++ /dev/null @@ -1,1155 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/macros.lisp,v 1.32 1992/09/07 16:04:55 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Random types and macros used in writing the compiler. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") - -(export '(lisp::with-compilation-unit) "LISP") - -(export '(policy symbolicate def-ir1-translator def-source-transform - def-primitive-translator deftransform defknown defoptimizer - derive-type optimizer ltn-annotate ir2-convert attributes - def-boolean-attribute attributes-union attributes-intersection - attributes=)) - -(proclaim '(special *wild-type* *universal-type* *compiler-error-context*)) - -;;;; Deftypes: - -;;; -;;; Should be standard: -(deftype boolean () '(member t nil)) - -;;; -;;; Inlinep is used to determine how a function is called. The values have -;;; these meanings: -;;; Nil No declaration seen: do whatever you feel like, but don't dump -;;; an inline expansion. -;;; -;;; :Notinline Notinline declaration seen: always do full function call. -;;; -;;; :Inline Inline declaration seen: save expansion, expanding to it if -;;; policy favors. -;;; -;;; :Maybe-Inline -;;; Retain expansion, but only use it opportunistically. -;;; -(deftype inlinep () '(member :inline :maybe-inline :notinline nil)) - - -;;;; The Policy macro: - -(proclaim '(special *lexical-environment*)) - -(eval-when (compile load eval) -(defconstant policy-parameter-slots - '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety) - (cspeed . cookie-cspeed) (brevity . cookie-brevity) - (debug . cookie-debug))) - -;;; Find-Used-Parameters -- Internal -;;; -;;; Find all the policy parameters which are actually mentioned in Stuff, -;;; returning the names in a list. We assume everything is evaluated. -;;; -(defun find-used-parameters (stuff) - (if (atom stuff) - (if (assoc stuff policy-parameter-slots) (list stuff) ()) - (collect ((res () nunion)) - (dolist (arg (cdr stuff) (res)) - (res (find-used-parameters arg)))))) - -); Eval-When (Compile Load Eval) - -;;; Policy -- Public -;;; -;;; This macro provides some syntactic sugar for querying the settings of -;;; the compiler policy parameters. -;;; -(defmacro policy (node &rest conditions) - "Policy Node Condition* - Test whether some conditions apply to the current compiler policy for Node. - Each condition is a predicate form which accesses the policy values by - referring to them as the variables SPEED, SPACE, SAFETY, CSPEED, BREVITY and - DEBUG. The results of all the conditions are combined with AND and returned - as the result. - - Node is a form which is evaluated to obtain the node which the policy is for. - If Node is NIL, then we use the current policy as defined by *default-cookie* - and *current-cookie*. This option is only well defined during IR1 - conversion." - (let* ((form `(and ,@conditions)) - (n-cookie (gensym)) - (binds (mapcar - #'(lambda (name) - (let ((slot (cdr (assoc name policy-parameter-slots)))) - `(,name (,slot ,n-cookie)))) - (find-used-parameters form)))) - `(let* ((,n-cookie (lexenv-cookie - ,(if node - `(node-lexenv ,node) - '*lexical-environment*))) - ,@binds) - ,form))) - - -;;;; Source-hacking defining forms: - -(eval-when (compile load eval) - -;;; Symbolicate -- Interface -;;; -;;; Concatenate together the names of some strings and symbols, producing -;;; a symbol in the current package. -;;; -(proclaim '(function symbolicate (&rest (or string symbol)) symbol)) -(defun symbolicate (&rest things) - (values (intern (reduce #'(lambda (x y) - (concatenate 'string (string x) (string y))) - things)))) - -); Eval-When (Compile Load Eval) - -;;; SPECIAL-FORM-FUNCTION -- Internal -;;; -;;; This function is stored in the SYMBOL-FUNCTION of special form names so -;;; that they are FBOUND. -;;; -(defun special-form-function (&rest stuff) - (declare (ignore stuff)) - (error "Can't funcall the SYMBOL-FUNCTION of special forms.")) - -;;; CONVERT-CONDITION-INTO-COMPILER-ERROR -- Internal -;;; -;;; Passed to parse-defmacro when we want compiler errors instead of real -;;; errors. -;;; -(proclaim '(inline convert-condition-into-compiler-error)) -(defun convert-condition-into-compiler-error (datum &rest stuff) - (if (stringp datum) - (apply #'compiler-error datum stuff) - (compiler-error "~A" - (if (symbolp datum) - (apply #'make-condition datum stuff) - datum)))) - -;;; Def-IR1-Translator -- Interface -;;; -;;; Parse defmacro style lambda-list, setting things up so that a compiler -;;; error happens if the syntax is invalid. -;;; -(defmacro def-ir1-translator (name (lambda-list start-var cont-var - &key (kind :special-form)) - &body body) - "Def-IR1-Translator Name (Lambda-List Start-Var Cont-Var {Key Value}*) - [Doc-String] Form* - Define a function that converts a Special-Form or other magical thing into - IR1. Lambda-List is a defmacro style lambda list. Start-Var and Cont-Var - are bound to the start and result continuations for the resulting IR1. - This keyword is defined: - Kind - The function kind to associate with Name (default :special-form)." - (let ((fn-name (symbolicate "IR1-CONVERT-" name)) - (n-form (gensym)) - (n-env (gensym))) - (multiple-value-bind - (body decls doc) - (lisp::parse-defmacro lambda-list n-form body name "special form" - :doc-string-allowed t - :environment n-env - :error-fun 'convert-condition-into-compiler-error) - `(progn - (proclaim '(function ,fn-name (continuation continuation t) void)) - (defun ,fn-name (,start-var ,cont-var ,n-form) - (let ((,n-env *lexical-environment*)) - ,@decls - ,body)) - ,@(when doc - `((setf (documentation ',name 'function) ,doc))) - (setf (info function ir1-convert ',name) #',fn-name) - (setf (info function kind ',name) ,kind) - #+new-compiler - ,@(when (eq kind :special-form) - `((setf (symbol-function ',name) #'special-form-function))))))) - - -;;; Def-Source-Transform -- Interface -;;; -;;; Similar to Def-IR1-Translator, except that we pass if the syntax is -;;; invalid. -;;; -(defmacro def-source-transform (name lambda-list &body body) - "Def-Source-Transform Name Lambda-List Form* - Define a macro-like source-to-source transformation for the function Name. - A source transform may \"pass\" by returning a non-nil second value. If the - transform passes, then the form is converted as a normal function call. If - the supplied arguments are not compatible with the specified lambda-list, - then the transform automatically passes. - - Source-Transforms may only be defined for functions. Source transformation - is not attempted if the function is declared Notinline. Source transforms - should not examine their arguments. If it matters how the function is used, - then Deftransform should be used to define an IR1 transformation. - - If the desirability of the transformation depends on the current Optimize - parameters, then the Policy macro should be used to determine when to pass." - (let ((fn-name (symbolicate "SOURCE-TRANSFORM-" name)) - (n-form (gensym)) - (n-env (gensym))) - (multiple-value-bind - (body decls) - (lisp::parse-defmacro lambda-list n-form body name "form" - :environment n-env - :error-fun `(lambda (&rest stuff) - (declare (ignore stuff)) - (return-from ,fn-name - (values nil t)))) - `(progn - (defun ,fn-name (,n-form) - (let ((,n-env *lexical-environment*)) - ,@decls - ,body)) - (setf (info function source-transform ',name) #',fn-name))))) - - -(defmacro def-primitive-translator (name lambda-list &body body) - "Def-Primitive-Translator Name Lambda-List Form* - Define a function that converts a use of (%PRIMITIVE Name ...) into Lisp - code. Lambda-List is a defmacro style lambda list." - (let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name)) - (n-form (gensym)) - (n-env (gensym))) - (multiple-value-bind - (body decls) - (lisp::parse-defmacro lambda-list n-form body name "%primitive" - :environment n-env - :error-fun 'convert-condition-into-compiler-error) - `(progn - (defun ,fn-name (,n-form) - (let ((,n-env *lexical-environment*)) - ,@decls - ,body)) - (setf (gethash ',name *primitive-translators*) ',fn-name))))) - - -;;;; Lambda-list parsing utilities: -;;; -;;; IR1 transforms, optimizers and type inferencers need to be able to parse -;;; the IR1 representation of a function call using a standard function -;;; lambda-list. - - -(eval-when (compile load eval) - -;;; Parse-Deftransform -- Internal -;;; -;;; Given a deftransform style lambda-list, generate code that parses the -;;; arguments of a combination with respect to that lambda-list. Body is the -;;; the list of forms which are to be evaluated within the bindings. Args is -;;; the variable that holds list of argument continuations. Error-Form is a -;;; form which is evaluated when the syntax of the supplied arguments is -;;; incorrect or a non-constant argument keyword is supplied. Defaults and -;;; other gunk are ignored. The second value is a list of all the arguments -;;; bound. We make the variables IGNORABLE so that we don't have to manually -;;; declare them Ignore if their only purpose is to make the syntax work. -;;; -(proclaim '(function parse-deftransform (list list symbol t) list)) -(defun parse-deftransform (lambda-list body args error-form) - (multiple-value-bind (req opt restp rest keyp keys allowp) - (parse-lambda-list lambda-list) - (let* ((min-args (length req)) - (max-args (+ min-args (length opt))) - (n-keys (gensym))) - (collect ((binds) - (vars) - (pos 0 +) - (keywords)) - (dolist (arg req) - (vars arg) - (binds `(,arg (nth ,(pos) ,args))) - (pos 1)) - - (dolist (arg opt) - (let ((var (if (atom arg) arg (first arg)))) - (vars var) - (binds `(,var (nth ,(pos) ,args))) - (pos 1))) - - (when restp - (vars rest) - (binds `(,rest (nthcdr ,(pos) ,args)))) - - (dolist (spec keys) - (if (or (atom spec) (atom (first spec))) - (let* ((var (if (atom spec) spec (first spec))) - (key (intern (symbol-name var) "KEYWORD"))) - (vars var) - (binds `(,var (find-keyword-continuation ,n-keys ,key))) - (keywords key)) - (let* ((head (first spec)) - (var (second head)) - (key (first head))) - (vars var) - (binds `(,var (find-keyword-continuation ,n-keys ,key))) - (keywords key)))) - - (let ((n-length (gensym)) - (limited-legal (not (or restp keyp)))) - (values - `(let ((,n-length (length ,args)) - ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args))))) - (unless (and - ,(if limited-legal - `(<= ,min-args ,n-length ,max-args) - `(<= ,min-args ,n-length)) - ,@(when keyp - (if allowp - `((check-keywords-constant ,n-keys)) - `((check-transform-keys ,n-keys ',(keywords)))))) - ,error-form) - (let ,(binds) - ;;; ### Bootstrap hack... - #+new-compiler - (declare (ignorable ,@(vars))) - #-new-compiler - (progn ,@(vars)) - ,@body)) - (vars))))))) - -); Eval-When (Compile Load Eval) - - -;;;; Utilities used at run-time for parsing keyword args in IR1: - -;;; Find-Keyword-Continuation -- Internal -;;; -;;; This function is used by the result of Parse-Deftransform to find the -;;; continuation for the value of the keyword argument Key in the list of -;;; continuations Args. It returns the continuation if the keyword is present, -;;; or NIL otherwise. The legality and constantness of the keywords should -;;; already have been checked. -;;; -(proclaim '(function find-keyword-continuation (list keyword) (or continuation null))) -(defun find-keyword-continuation (args key) - (do ((arg args (cddr arg))) - ((null arg) nil) - (when (eq (continuation-value (first arg)) key) - (return (second arg))))) - - -;;; Check-Keywords-Constant -- Internal -;;; -;;; This function is used by the result of Parse-Deftransform to verify that -;;; alternating continuations in Args are constant and that there is an even -;;; number of args. -;;; -(proclaim '(function check-keywords-constant (list) boolean)) -(defun check-keywords-constant (args) - (do ((arg args (cddr arg))) - ((null arg) t) - (unless (and (rest arg) - (constant-continuation-p (first arg))) - (return nil)))) - - -;;; Check-Transform-Keys -- Internal -;;; -;;; This function is used by the result of Parse-Deftransform to verify that -;;; the list of continuations Args is a well-formed keyword arglist and that -;;; only keywords present in the list Keys are supplied. -;;; -(proclaim '(function check-transform-keys (list list) boolean)) -(defun check-transform-keys (args keys) - (and (check-keywords-constant args) - (do ((arg args (cddr arg))) - ((null arg) t) - (unless (member (continuation-value (first arg)) keys) - (return nil))))) - - -;;;; Deftransform: - -;;; Deftransform -- Interface -;;; -;;; Parse the lambda-list and generate code to test the policy and -;;; automatically create the result lambda. -;;; -(defmacro deftransform (name (lambda-list &optional (arg-types '*) - (result-type '*) - &key result policy node defun-only - eval-name important) - &body (body decls doc)) - "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*) - Declaration* [Doc-String] Form* - Define an IR1 transformation for Name. An IR1 transformation computes a - lambda that replaces the function variable reference for the call. A - transform may pass (decide not to transform the call) by calling the Give-Up - function. Lambda-List both determines how the current call is parsed and - specifies the Lambda-List for the resulting lambda. - - We parse the call and bind each of the lambda-list variables to the - continuation which represents the value of the argument. When parsing the - call, we ignore the defaults, and always bind the variables for unsupplied - arguments to NIL. If a required argument is missing, an unknown keyword is - supplied, or an argument keyword is not a constant, then the transform - automatically passes. The Declarations apply to the bindings made by - Deftransform at transformation time, rather than to the variables of the - resulting lambda. Bound-but-not-referenced warnings are suppressed for the - lambda-list variables. The Doc-String is used when printing efficiency notes - about the defined transform. - - Normally, the body evaluates to a form which becomes the body of an - automatically constructed lambda. We make Lambda-List the lambda-list for - the lambda, and automatically insert declarations of the argument and result - types. If the second value of the body is non-null, then it is a list of - declarations which are to be inserted at the head of the lambda. Automatic - lambda generation may be inhibited by explicitly returning a lambda from the - body. - - The Arg-Types and Result-Type are used to create a function type which the - call must satisfy before transformation is attempted. The function type - specifier is constructed by wrapping (FUNCTION ...) around these values, so - the lack of a restriction may be specified by omitting the argument or - supplying *. The argument syntax specified in the Arg-Types need not be the - same as that in the Lambda-List, but the transform will never happen if - the syntaxes can't be satisfied simultaneously. If there is an existing - transform for the same function that has the same type, then it is replaced - with the new definition. - - These are the legal keyword options: - :Result - A variable which is bound to the result continuation. - :Node - A variable which is bound to the combination node for the call. - :Policy - A form which is supplied to the Policy macro to determine whether - this transformation is appropriate. If the result is false, then - the transform automatically passes. - :Eval-Name - - The name and argument/result types are actually forms to be - evaluated. Useful for getting closures that transform similar - functions. - :Defun-Only - - Don't actually instantiate a transform, instead just DEFUN - Name with the specified transform definition function. This may - be later instantiated with %Deftransform. - :Important - - If supplied and non-NIL, note this transform as ``important,'' - which means effeciency notes will be generated when this - transform fails even if brevity=speed (but not if brevity>speed)" - - (when (and eval-name defun-only) - (error "Can't specify both DEFUN-ONLY and EVAL-NAME.")) - (let ((n-args (gensym)) - (n-node (or node (gensym))) - (n-decls (gensym)) - (n-lambda (gensym)) - (body `(,@decls ,@body))) - (multiple-value-bind (parsed-form vars) - (parse-deftransform - lambda-list - (if policy - `((unless (policy ,n-node ,policy) (give-up)) - ,@body) - body) - n-args '(give-up)) - (let ((stuff - `((,n-node) - (let* ((,n-args (basic-combination-args ,n-node)) - ,@(when result - `((,result (node-cont ,n-node))))) - (multiple-value-bind (,n-lambda ,n-decls) - ,parsed-form - (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda)) - ,n-lambda - `(lambda ,',lambda-list - (declare (ignorable ,@',vars)) - ,@,n-decls - ,,n-lambda))))))) - (if defun-only - `(defun ,name ,@(when doc `(,doc)) ,@stuff) - `(%deftransform - ,(if eval-name name `',name) - ,(if eval-name - ``(function ,,arg-types ,,result-type) - `'(function ,arg-types ,result-type)) - #'(lambda ,@stuff) - ,doc - ,(if important t nil))))))) - -;;;; Defknown, Defoptimizer: - -;;; Defknown -- Interface -;;; -;;; This macro should be the way that all implementation independent -;;; information about functions is made known to the compiler. -;;; -(defmacro defknown (name arg-types result-type &optional (attributes '(any)) - &rest keys) - "Defknown Name Arg-Types Result-Type [Attributes] {Key Value}* - Declare the function Name to be a known function. We construct a type - specifier for the function by wrapping (FUNCTION ...) around the Arg-Types - and Result-Type. Attributes is a an unevaluated list of the boolean - attributes that the function has. These attributes are meaningful here: - call - May call functions that are passed as arguments. In order to determine - what other effects are present, we must find the effects of all arguments - that may be functions. - - unsafe - May incorporate arguments in the result or somehow pass them upward. - - unwind - May fail to return during correct execution. Errors are O.K. - - any - The (default) worst case. Includes all the other bad things, plus any - other possible bad thing. - - foldable - May be constant-folded. The function has no side effects, but may be - affected by side effects on the arguments. e.g. SVREF, MAPC. - - flushable - May be eliminated if value is unused. The function has no side effects - except possibly CONS. If a function is defined to signal errors, then - it is not flushable even if it is movable or foldable. - - movable - May be moved with impunity. Has no side effects except possibly CONS, - and is affected only by its arguments. - - predicate - A true predicate likely to be open-coded. This is a hint to IR1 - conversion that it should ensure calls always appear as an IF test. - Not usually specified to Defknown, since this is implementation - dependent, and is usually automatically set by the Define-VOP - :Conditional option. - - Name may also be a list of names, in which case the same information is given - to all the names. The keywords specify the initial values for various - optimizers that the function might have." - (when (and (intersection attributes '(any call unwind)) - (intersection attributes '(movable))) - (error "Function cannot have both good and bad attributes: ~S" attributes)) - - `(%defknown ',(if (and (consp name) - (not (eq (car name) 'setf))) - name - (list name)) - '(function ,arg-types ,result-type) - (ir1-attributes ,@(if (member 'any attributes) - (union '(call unsafe unwind) attributes) - attributes)) - ,@keys)) - - -;;; Defoptimizer -- Interface -;;; -;;; Create a function which parses combination args according to a -;;; Lambda-List, optionally storing it in a function-info slot. -;;; -(defmacro defoptimizer (what (lambda-list &optional (n-node (gensym)) - &rest vars) - &body body) - "Defoptimizer (Function Kind) (Lambda-List [Node-Var] Var*) - Declaration* Form* - Define some Kind of optimizer for the named Function. Function must be a - known function. Lambda-List is used to parse the arguments to the - combination as in Deftransform. If the argument syntax is invalid or there - are non-constant keys, then we simply return NIL. - - The function is DEFUN'ed as Function-Kind-OPTIMIZER. Possible kinds are - DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If a symbol is - specified instead of a (Function Kind) list, then we just do a DEFUN with the - symbol as its name, and don't do anything with the definition. This is - useful for creating optimizers to be passed by name to DEFKNOWN. - - If supplied, Node-Var is bound to the combination node being optimized. If - additional Vars are supplied, then they are used as the rest of the optimizer - function's lambda-list. LTN-ANNOTATE methods are passed an additional POLICY - argument, and IR2-CONVERT methods are passed an additional IR2-BLOCK - argument." - - (let ((name (if (symbolp what) what - (symbolicate (first what) "-" (second what) "-OPTIMIZER")))) - - (let ((n-args (gensym))) - `(progn - (defun ,name (,n-node ,@vars) - (let ((,n-args (basic-combination-args ,n-node))) - ,(parse-deftransform lambda-list body n-args - `(return-from ,name nil)))) - ,@(when (consp what) - `((setf (,(symbolicate "FUNCTION-INFO-" (second what)) - (function-info-or-lose ',(first what))) - #',name))))))) - - -;;;; IR groveling macros: - -;;; Do-Blocks, Do-Blocks-Backwards -- Interface -;;; -(defmacro do-blocks ((block-var component &optional ends result) &body body) - "Do-Blocks (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}* - Iterate over the blocks in a component, binding Block-Var to each block in - turn. The value of Ends determines whether to iterate over dummy head and - tail blocks: - NIL -- Skip Head and Tail (the default) - :Head -- Do head but skip tail - :Tail -- Do tail but skip head - :Both -- Do both head and tail - - If supplied, Result-Form is the value to return." - (unless (member ends '(nil :head :tail :both)) - (error "Losing Ends value: ~S." ends)) - (let ((n-component (gensym)) - (n-tail (gensym))) - `(let* ((,n-component ,component) - (,n-tail ,(if (member ends '(:both :tail)) - nil - `(component-tail ,n-component)))) - (do ((,block-var ,(if (member ends '(:both :head)) - `(component-head ,n-component) - `(block-next (component-head ,n-component))) - (block-next ,block-var))) - ((eq ,block-var ,n-tail) ,result) - ,@body)))) -;;; -(defmacro do-blocks-backwards ((block-var component &optional ends result) &body body) - "Do-Blocks-Backwards (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}* - Like Do-Blocks, only iterate over the blocks in reverse order." - (unless (member ends '(nil :head :tail :both)) - (error "Losing Ends value: ~S." ends)) - (let ((n-component (gensym)) - (n-head (gensym))) - `(let* ((,n-component ,component) - (,n-head ,(if (member ends '(:both :head)) - nil - `(component-head ,n-component)))) - (do ((,block-var ,(if (member ends '(:both :tail)) - `(component-tail ,n-component) - `(block-prev (component-tail ,n-component))) - (block-prev ,block-var))) - ((eq ,block-var ,n-head) ,result) - ,@body)))) - - -;;; Do-Uses -- Interface -;;; -;;; Could change it not to replicate the code someday perhaps... -;;; -(defmacro do-uses ((node-var continuation &optional result) &body body) - "Do-Uses (Node-Var Continuation [Result]) {Declaration}* {Form}* - Iterate over the uses of Continuation, binding Node to each one succesively." - (once-only ((n-cont continuation)) - `(ecase (continuation-kind ,n-cont) - (:unused) - (:inside-block - (block nil - (let ((,node-var (continuation-use ,n-cont))) - ,@body - ,result))) - ((:block-start :deleted-block-start) - (dolist (,node-var (block-start-uses (continuation-block ,n-cont)) - ,result) - ,@body))))) - - -;;; Do-Nodes, Do-Nodes-Backwards -- Interface -;;; -;;; In the forward case, we terminate on Last-Cont so that we don't have to -;;; worry about our termination condition being changed when new code is added -;;; during the iteration. In the backward case, we do NODE-PREV before -;;; evaluating the body so that we can keep going when the current node is -;;; deleted. -;;; -;;; When Restart-P is supplied to DO-NODES, we start iterating over again at -;;; the beginning of the block when we run into a continuation whose block -;;; differs from the one we are trying to iterate over, either beacuse the -;;; block was split, or because a node was deleted out from under us (hence its -;;; block is NIL.) If the block start is deleted, we just punt. With -;;; Restart-P, we are also more careful about termination, re-indirecting the -;;; BLOCK-LAST each time. -;;; -(defmacro do-nodes ((node-var cont-var block &key restart-p) &body body) - "Do-Nodes (Node-Var Cont-Var Block {Key Value}*) {Declaration}* {Form}* - Iterate over the nodes in Block, binding Node-Var to the each node and - Cont-Var to the node's Cont. The only keyword option is Restart-P, which - causes iteration to be restarted when a node is deleted out from under us (if - not supplied, this is an error.)" - (let ((n-block (gensym)) - (n-last-cont (gensym))) - `(let* ((,n-block ,block) - ,@(unless restart-p - `((,n-last-cont (node-cont (block-last ,n-block)))))) - (do* ((,node-var (continuation-next (block-start ,n-block)) - ,(if restart-p - `(cond - ((eq (continuation-block ,cont-var) ,n-block) - (assert (continuation-next ,cont-var)) - (continuation-next ,cont-var)) - (t - (let ((start (block-start ,n-block))) - (unless (eq (continuation-kind start) - :block-start) - (return nil)) - (continuation-next start)))) - `(continuation-next ,cont-var))) - (,cont-var (node-cont ,node-var) (node-cont ,node-var))) - (()) - ,@body - (when ,(if restart-p - `(eq ,node-var (block-last ,n-block)) - `(eq ,cont-var ,n-last-cont)) - (return nil)))))) -;;; -(defmacro do-nodes-backwards ((node-var cont-var block) &body body) - "Do-Nodes-Backwards (Node-Var Cont-Var Block) {Declaration}* {Form}* - Like Do-Nodes, only iterates in reverse order." - (let ((n-block (gensym)) - (n-start (gensym)) - (n-last (gensym)) - (n-next (gensym))) - `(let* ((,n-block ,block) - (,n-start (block-start ,n-block)) - (,n-last (block-last ,n-block))) - (do* ((,cont-var (node-cont ,n-last) ,n-next) - (,node-var ,n-last (continuation-use ,cont-var)) - (,n-next (node-prev ,node-var) (node-prev ,node-var))) - (()) - ,@body - (when (eq ,n-next ,n-start) - (return nil)))))) - - -;;; With-IR1-Environment -- Interface -;;; -;;; The lexical environment is presumably already null... -;;; -(defmacro with-ir1-environment (node &rest forms) - "With-IR1-Environment Node Form* - Bind the IR1 context variables so that IR1 conversion can be done after the - main conversion pass has finished." - (let ((n-node (gensym))) - `(let* ((,n-node ,node) - (*current-component* (block-component (node-block ,n-node))) - (*lexical-environment* (node-lexenv ,n-node)) - (*current-path* (node-source-path ,n-node))) - ,@forms))) - - -;;; WITH-IR1-NAMESPACE -- Interface -;;; -;;; Bind the hashtables used for keeping track of global variables, -;;; functions, &c. -;;; -(defmacro with-ir1-namespace (&body forms) - `(let ((*free-variables* (make-hash-table :test #'eq)) - (*free-functions* (make-hash-table :test #'equal)) - (*constants* (make-hash-table :test #'equal)) - (*source-paths* (make-hash-table :test #'eq))) - ,@forms)) - - -;;; LEXENV-FIND -- Interface -;;; -(defmacro lexenv-find (name slot &key test) - "LEXENV-FIND Name Slot {Key Value}* - Look up Name in the lexical environment namespace designated by Slot, - returning the <value, T>, or <NIL, NIL> if no entry. The :TEST keyword - may be used to determine the name equality predicate." - (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot) - *lexical-environment*) - ,@(when test `(:test ,test))))) - `(if ,n-res - (values (cdr ,n-res) t) - (values nil nil)))) - - -;;;; The Defprinter macro: - -(defvar *defprint-pretty* nil - "If true, defprinter print functions print each slot on a separate line.") - - -;;; Defprinter-Prin1, Defprinter-Princ -- Internal -;;; -;;; These functions are called by the expansion of the Defprinter -;;; macro to do the actual printing. -;;; -(proclaim '(ftype (function (symbol t stream &optional t) void) - defprinter-prin1 defprinter-princ)) -(defun defprinter-prin1 (name value stream &optional indent) - (declare (ignore indent)) - (write-string " " stream) - (when *print-pretty* - (pprint-newline :linear stream)) - (princ name stream) - (write-string "= " stream) - (prin1 value stream)) -;;; -(defun defprinter-princ (name value stream &optional indent) - (declare (ignore indent)) - (write-string " " stream) - (when *print-pretty* - (pprint-newline :linear stream)) - (princ name stream) - (write-string "= " stream) - (princ value stream)) - -(defmacro defprinter (name &rest slots) - "Defprinter Name Slot-Desc* - Define some kind of reasonable defstruct structure-print function. Name - is the name of the structure. We define a function %PRINT-name which - prints the slots in the structure in the way described by the Slot-Descs. - Each Slot-Desc can be a slot name, indicating that the slot should simply - be printed. A Slot-Desc may also be a list of a slot name and other stuff. - The other stuff is composed of keywords followed by expressions. The - expressions are evaluated with the variable which is the slot name bound - to the value of the slot. These keywords are defined: - - :PRIN1 Print the value of the expression instead of the slot value. - :PRINC Like :PRIN1, only princ the value - :TEST Only print something if the test is true. - - If no printing thing is specified then the slot value is printed as PRIN1. - - The structure being printed is bound to Structure and the stream is bound to - Stream." - - (flet ((sref (slot) `(,(symbolicate name "-" slot) structure))) - (collect ((prints)) - (dolist (slot slots) - (if (atom slot) - (prints `(defprinter-prin1 ',slot ,(sref slot) stream)) - (let ((sname (first slot)) - (test t)) - (collect ((stuff)) - (do ((option (rest slot) (cddr option))) - ((null option) - (prints - `(let ((,sname ,(sref sname))) - (when ,test - ,@(or (stuff) - `((defprinter-prin1 ',sname ,sname - stream))))))) - (case (first option) - (:prin1 - (stuff `(defprinter-prin1 ',sname ,(second option) - stream))) - (:princ - (stuff `(defprinter-princ ',sname ,(second option) - stream))) - (:test (setq test (second option))) - (t - (error "Losing Defprinter option: ~S." - (first option))))))))) - - `(defun ,(symbolicate "%PRINT-" name) (structure stream depth) - (flet ((do-prints (stream) - (declare (ignorable stream)) - ,@(prints))) - (cond (*print-readably* - (error "~S cannot be printed readably." structure)) - ((and *print-level* (>= depth *print-level*)) - (format stream "#<~S ~X>" - ',name - (get-lisp-obj-address structure))) - (*print-pretty* - (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (pprint-indent :current 2 stream) - (prin1 ',name stream) - (write-char #\space stream) - (let ((*print-base* 16) - (*print-radix* t)) - (prin1 (get-lisp-obj-address structure) stream)) - (do-prints stream))) - (t - (descend-into (stream) - (format stream "#<~S ~X" - ',name - (get-lisp-obj-address structure)) - (do-prints stream) - (format stream ">"))))) - nil)))) - - -;;;; Boolean attribute utilities: -;;; -;;; We need to maintain various sets of boolean attributes for known -;;; functions and VOPs. To save space and allow for quick set operations, we -;;; represent them as bits in a fixnum. -;;; - -(deftype attributes () 'fixnum) - -(eval-when (compile load eval) -;;; Compute-Attribute-Mask -- Internal -;;; -;;; Given a list of attribute names and an alist that translates them to -;;; masks, return the OR of the masks. -;;; -(defun compute-attribute-mask (names alist) - (collect ((res 0 logior)) - (dolist (name names) - (let ((mask (cdr (assoc name alist)))) - (unless mask - (error "Unknown attribute name: ~S." name)) - (res mask))) - (res))) - -); Eval-When (Compile Load Eval) - -;;; Def-Boolean-Attribute -- Interface -;;; -;;; Parse the specification and generate some accessor macros. -;;; -(defmacro def-boolean-attribute (name &rest attribute-names) - "Def-Boolean-Attribute Name Attribute-Name* - Define a new class of boolean attributes, with the attributes havin the - specified Attribute-Names. Name is the name of the class, which is used to - generate some macros to manipulate sets of the attributes: - - NAME-attributep attributes attribute-name* - Return true if one of the named attributes is present, false otherwise. - When set with SETF, updates the place Attributes setting or clearing the - specified attributes. - - NAME-attributes attribute-name* - Return a set of the named attributes." - - (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS")) - (test-name (symbolicate name "-ATTRIBUTEP"))) - (collect ((alist)) - (do ((mask 1 (ash mask 1)) - (names attribute-names (cdr names))) - ((null names)) - (alist (cons (car names) mask))) - - `(progn - (eval-when (compile load eval) - (defconstant ,const-name ',(alist))) - - (defmacro ,test-name (attributes &rest attribute-names) - "Automagically generated boolean attribute test function. See - Def-Boolean-Attribute." - `(logtest ,(compute-attribute-mask attribute-names ,const-name) - (the attributes ,attributes))) - - (define-setf-method ,test-name (place &rest attributes - &environment env) - - "Automagically generated boolean attribute setter. See - Def-Boolean-Attribute." - (multiple-value-bind (temps values stores set get) - (get-setf-method place env) - (let ((newval (gensym)) - (n-place (gensym)) - (mask (compute-attribute-mask attributes ,const-name))) - (values `(,@temps ,n-place) - `(,@values ,get) - `(,newval) - `(let ((,(first stores) - (if ,newval - (logior ,n-place ,mask) - (logand ,n-place ,(lognot mask))))) - ,set - ,newval) - `(,',test-name ,n-place ,@attributes))))) - - (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names) - "Automagically generated boolean attribute creation function. See - Def-Boolean-Attribute." - (compute-attribute-mask attribute-names ,const-name)))))) - - -;;; Attributes-Union, Attributes-Intersection, Attributes= -- Interface -;;; -;;; And now for some gratuitous pseudo-abstraction... -;;; -(defmacro attributes-union (&rest attributes) - "Returns the union of all the sets of boolean attributes which are its - arguments." - `(the attributes - (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes)))) -;;; -(defmacro attributes-intersection (&rest attributes) - "Returns the intersection of all the sets of boolean attributes which are its - arguments." - `(the attributes - (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes)))) -;;; -(proclaim '(inline attributes=)) -(proclaim '(function attributes= (attributes attributes) boolean)) -(defun attributes= (attr1 attr2) - "Returns true if the attributes present in Attr1 are indentical to those in - Attr2." - (eql attr1 attr2)) - - -;;;; The Event statistics/trace utility: - -(eval-when (compile load eval) - -(defstruct event-info - ;; - ;; The name of this event. - (name (required-argument) :type symbol) - ;; - ;; The string rescribing this event. - (description (required-argument) :type string) - ;; - ;; The name of the variable we stash this in. - (var (required-argument) :type symbol) - ;; - ;; The number of times this event has happened. - (count 0 :type fixnum) - ;; - ;; The level of significance of this event. - (level (required-argument) :type unsigned-byte) - ;; - ;; If true, a function that gets called with the node that the event happened - ;; to. - (action nil :type (or function null))) - -;;; A hashtable from event names to event-info structures. -;;; -(defvar *event-info* (make-hash-table :test #'eq)) - - -;;; Event-Info-Or-Lose -- Internal -;;; -;;; Return the event info for Name or die trying. -;;; -(proclaim '(function event-info-or-lose (t) event-info)) -(defun event-info-or-lose (name) - (let ((res (gethash name *event-info*))) - (unless res - (error "~S is not the name of an event." name)) - res)) - -); Eval-When (Compile Load Eval) - - -;;; Event-Count, Event-Action, Event-Level -- Interface -;;; -(proclaim '(function event-count (symbol) fixnum)) -(defun event-count (name) - "Return the number of times that Event has happened." - (event-info-count (event-info-or-lose name))) -;;; -(proclaim '(function event-action (symbol) (or function null))) -(defun event-action (name) - "Return the function that is called when Event happens. If this is null, - there is no action. The function is passed the node to which the event - happened, or NIL if there is no relevant node. This may be set with SETF." - (event-info-action (event-info-or-lose name))) -;;; -(proclaim '(function %set-event-action (symbol (or function null)) (or function null))) -(defun %set-event-action (name new-value) - (setf (event-info-action (event-info-or-lose name)) - new-value)) -;;; -(defsetf event-action %set-event-action) -;;; -(proclaim '(function event-level (symbol) unsigned-byte)) -(defun event-level (name) - "Return the non-negative integer which represents the level of significance - of the event Name. This is used to determine whether to print a message when - the event happens. This may be set with SETF." - (event-info-level (event-info-or-lose name))) -;;; -(proclaim '(function %set-event-level (symbol unsigned-byte) unsigned-byte)) -(defun %set-event-level (name new-value) - (setf (event-info-level (event-info-or-lose name)) - new-value)) -;;; -(defsetf event-level %set-event-level) - - -;;; Defevent -- Interface -;;; -;;; Make an event-info structure and stash it in a variable so we can get at -;;; it quickly. -;;; -(defmacro defevent (name description &optional (level 0)) - "Defevent Name Description - Define a new kind of event. Name is a symbol which names the event and - Description is a string which describes the event. Level (default 0) is the - level of significance associated with this event; it is used to determine - whether to print a Note when the event happens." - (let ((var-name (symbolicate "*" name "-EVENT-INFO*"))) - `(eval-when (compile load eval) - (defvar ,var-name - (make-event-info :name ',name :description ',description :var ',var-name - :level ,level)) - (setf (gethash ',name *event-info*) ,var-name) - ',name))) - -(proclaim '(type unsigned-byte *event-note-threshold*)) -(defvar *event-note-threshold* 1 - "This variable is a non-negative integer specifying the lowest level of - event that will print a Note when it occurs.") - -;;; Event -- Interface -;;; -;;; Increment the counter and do any action. Mumble about the event if -;;; policy indicates. -;;; -(defmacro event (name &optional node) - "Event Name Node - Note that the event with the specified Name has happened. Node is evaluated - to determine the node to which the event happened." - `(%event ,(event-info-var (event-info-or-lose name)) ,node)) -;;; -(proclaim '(function %event (event-info (or node null)))) -(defun %event (info node) - (incf (event-info-count info)) - (when (and (>= (event-info-level info) *event-note-threshold*) - (if node - (policy node (= brevity 0)) - (policy nil (= brevity 0)))) - (let ((*compiler-error-context* node)) - (compiler-note (event-info-description info)))) - - (let ((action (event-info-action info))) - (when action (funcall action node)))) - - -;;; Event-Statistics, Clear-Statistics -- Interface -;;; -(proclaim '(function event-statistics (&optional unsigned-byte stream) void)) -(defun event-statistics (&optional (min-count 1) (stream *standard-output*)) - "Print a listing of events and their counts, sorted by the count. Events - that happened fewer than Min-Count times will not be printed. Stream is the - stream to write to." - (collect ((info)) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (>= (event-info-count v) min-count) - (info v))) - *event-info*) - (dolist (event (sort (info) #'> :key #'event-info-count)) - (format stream "~6D: ~A~%" (event-info-count event) - (event-info-description event))) - (values))) -;;; -(proclaim '(function clear-statistics () void)) -(defun clear-statistics () - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf (event-info-count v) 0)) - *event-info*) - (values)) - diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp deleted file mode 100644 index 37c3b12ff8c33ce9f0485c1f81308b7328b8e4a2..0000000000000000000000000000000000000000 --- a/compiler/mips/alloc.lisp +++ /dev/null @@ -1,234 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/alloc.lisp,v 1.22 1992/12/16 19:41:18 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Allocation VOPs for the MIPS port. -;;; -;;; Written by William Lott. -;;; - -(in-package "MIPS") - - -;;;; LIST and LIST* - -#-gengc -(define-vop (list-or-list*) - (:args (things :more t)) - (:temporary (:scs (descriptor-reg) :type list) ptr) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) - res) - (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:info num) - (:results (result :scs (descriptor-reg))) - (:variant-vars star) - (:policy :safe) - (:generator 0 - (cond ((zerop num) - (move result null-tn)) - ((and star (= num 1)) - (move result (tn-ref-tn things))) - (t - (macrolet - ((store-car (tn list &optional (slot cons-car-slot)) - `(let ((reg - (sc-case ,tn - ((any-reg descriptor-reg) ,tn) - (zero zero-tn) - (null null-tn) - (control-stack - (load-stack-tn temp ,tn) - temp)))) - (storew reg ,list ,slot list-pointer-type)))) - (let ((cons-cells (if star (1- num) num))) - (pseudo-atomic (pa-flag - :extra (* (pad-data-block cons-size) - cons-cells)) - (inst or res alloc-tn list-pointer-type) - (move ptr res) - (dotimes (i (1- cons-cells)) - (store-car (tn-ref-tn things) ptr) - (setf things (tn-ref-across things)) - (inst addu ptr ptr (pad-data-block cons-size)) - (storew ptr ptr - (- cons-cdr-slot cons-size) - list-pointer-type)) - (store-car (tn-ref-tn things) ptr) - (cond (star - (setf things (tn-ref-across things)) - (store-car (tn-ref-tn things) ptr cons-cdr-slot)) - (t - (storew null-tn ptr - cons-cdr-slot list-pointer-type))) - (assert (null (tn-ref-across things))) - (move result res)))))))) - -#-gengc -(define-vop (list list-or-list*) - (:variant nil)) - -#-gengc -(define-vop (list* list-or-list*) - (:variant t)) - - -;;;; Special purpose inline allocators. - -(define-vop (allocate-code-object) - (:args (boxed-arg :scs (any-reg)) - (unboxed-arg :scs (any-reg))) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:temporary (:scs (any-reg) :from (:argument 0)) boxed) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) - (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:generator 100 - (inst li ndescr (lognot lowtag-mask)) - (inst addu boxed boxed-arg - (fixnum (1+ #-gengc code-trace-table-offset-slot - #+gengc code-debug-info-slot))) - (inst and boxed ndescr) - (inst srl unboxed unboxed-arg word-shift) - (inst addu unboxed unboxed lowtag-mask) - (inst and unboxed ndescr) - (inst sll ndescr boxed (- type-bits word-shift)) - (inst or ndescr code-header-type) - - #-gengc - (pseudo-atomic (pa-flag) - (inst or result alloc-tn other-pointer-type) - (storew ndescr result 0 other-pointer-type) - (storew unboxed result code-code-size-slot other-pointer-type) - (storew null-tn result code-entry-points-slot other-pointer-type) - (inst addu alloc-tn boxed) - (inst addu alloc-tn unboxed)) - #+gengc - (without-scheduling () - (inst or result alloc-tn other-pointer-type) - (storew ndescr alloc-tn 0) - (storew unboxed alloc-tn code-code-size-slot) - (storew null-tn alloc-tn code-entry-points-slot) - (inst addu alloc-tn boxed) - (inst addu alloc-tn unboxed)) - - (storew null-tn result code-debug-info-slot other-pointer-type))) - -(define-vop (make-fdefn) - (:policy :fast-safe) - (:translate make-fdefn) - (:args (name :scs (descriptor-reg) :to :eval)) - (:temporary (:scs (non-descriptor-reg)) temp) - #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:results (result :scs (descriptor-reg) :from :argument)) - (:generator 37 - (with-fixed-allocation (result pa-flag temp fdefn-type fdefn-size) - (storew name result fdefn-name-slot other-pointer-type) - (storew null-tn result fdefn-function-slot other-pointer-type) - (inst li temp (make-fixup "undefined_tramp" :foreign)) - (storew temp result fdefn-raw-addr-slot other-pointer-type)))) - -(define-vop (make-closure) - (:args (function :to :save :scs (descriptor-reg))) - (:info length) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:results (result :scs (descriptor-reg))) - (:generator 10 - #-gengc - (let ((size (+ length closure-info-offset))) - (inst li temp (logior (ash (1- size) type-bits) closure-header-type)) - (pseudo-atomic (pa-flag :extra (pad-data-block size)) - (inst or result alloc-tn function-pointer-type) - (storew temp result 0 function-pointer-type)) - (storew function result closure-function-slot function-pointer-type)) - #+gengc - (let ((size (+ length closure-info-offset))) - (inst li temp (logior (ash (1- size) type-bits) closure-header-type)) - (without-scheduling () - (inst or result alloc-tn function-pointer-type) - (storew temp alloc-tn) - (inst addu alloc-tn (pad-data-block size))) - (inst addu temp function - (- (* function-code-offset word-bytes) function-pointer-type)) - (storew temp result closure-entry-point-slot function-pointer-type)))) - -;;; The compiler likes to be able to directly make value cells. -;;; -(define-vop (make-value-cell) - (:args (value :to :save :scs (descriptor-reg any-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:results (result :scs (descriptor-reg))) - (:generator 10 - (with-fixed-allocation - (result pa-flag temp value-cell-header-type value-cell-size)) - (storew value result value-cell-value-slot other-pointer-type))) - - -;;;; Automatic allocators for primitive objects. - -(define-vop (make-unbound-marker) - (:args) - (:results (result :scs (any-reg))) - (:generator 1 - (inst li result unbound-marker-type))) - -(define-vop (fixed-alloc) - (:args) - (:info name words type lowtag) - (:ignore name) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:generator 4 - #-gengc - (pseudo-atomic (pa-flag :extra (pad-data-block words)) - (inst or result alloc-tn lowtag) - (when type - (inst li temp (logior (ash (1- words) type-bits) type)) - (storew temp result 0 lowtag))) - #+gengc - (progn - (when type - (inst li temp (logior (ash (1- words) type-bits) type))) - (without-scheduling () - (inst or result alloc-tn lowtag) - (when type - (storew temp alloc-tn)) - (inst addu alloc-tn (pad-data-block words)))))) - -(define-vop (var-alloc) - (:args (extra :scs (any-reg))) - (:arg-types positive-fixnum) - (:info name words type lowtag) - (:ignore name) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (any-reg)) header) - (:temporary (:scs (non-descriptor-reg)) bytes) - #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:generator 6 - (inst addu bytes extra (* (1+ words) word-bytes)) - (inst sll header bytes (- type-bits 2)) - (inst addu header header (+ (ash -2 type-bits) type)) - (inst srl bytes bytes lowtag-bits) - (inst sll bytes bytes lowtag-bits) - #-gengc - (pseudo-atomic (pa-flag) - (inst or result alloc-tn lowtag) - (storew header result 0 lowtag) - (inst addu alloc-tn alloc-tn bytes)) - #+gengc - (without-scheduling () - (inst or result alloc-tn lowtag) - (storew header result 0 lowtag) - (inst addu alloc-tn alloc-tn bytes)))) diff --git a/compiler/mips/arith.lisp b/compiler/mips/arith.lisp deleted file mode 100644 index 0ded0c196d4dd6d242f161ac3370a9cdf7459c44..0000000000000000000000000000000000000000 --- a/compiler/mips/arith.lisp +++ /dev/null @@ -1,926 +0,0 @@ -;;; -*- Package: MIPS; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/mips/arith.lisp,v 1.49 1993/01/13 15:51:36 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.49 1993/01/13 15:51:36 wlott Exp $ -;;; -;;; This file contains the VM definition arithmetic VOPs for the MIPS. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by William Lott. -;;; - -(in-package "MIPS") - - - -;;;; Unary operations. - -(define-vop (fixnum-unop) - (:args (x :scs (any-reg))) - (:results (res :scs (any-reg))) - (:note "inline fixnum arithmetic") - (:arg-types tagged-num) - (:result-types tagged-num) - (:policy :fast-safe)) - -(define-vop (signed-unop) - (:args (x :scs (signed-reg))) - (:results (res :scs (signed-reg))) - (:note "inline (signed-byte 32) arithmetic") - (:arg-types signed-num) - (:result-types signed-num) - (:policy :fast-safe)) - -(define-vop (fast-negate/fixnum fixnum-unop) - (:translate %negate) - (:generator 1 - (inst subu res zero-tn x))) - -(define-vop (fast-negate/signed signed-unop) - (:translate %negate) - (:generator 2 - (inst subu res zero-tn x))) - -(define-vop (fast-lognot/fixnum fixnum-unop) - (:temporary (:scs (any-reg) :type fixnum :to (:result 0)) - temp) - (:translate lognot) - (:generator 2 - (inst li temp (fixnum -1)) - (inst xor res x temp))) - -(define-vop (fast-lognot/signed signed-unop) - (:translate lognot) - (:generator 1 - (inst nor res x zero-tn))) - - - -;;;; Binary fixnum operations. - -;;; Assume that any constant operand is the second arg... - -(define-vop (fast-fixnum-binop) - (:args (x :target r :scs (any-reg)) - (y :target r :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:results (r :scs (any-reg))) - (:result-types tagged-num) - (:note "inline fixnum arithmetic") - (:effects) - (:affected) - (:policy :fast-safe)) - -(define-vop (fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:note "inline (unsigned-byte 32) arithmetic") - (:effects) - (:affected) - (:policy :fast-safe)) - -(define-vop (fast-signed-binop) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) - (:arg-types signed-num signed-num) - (:results (r :scs (signed-reg))) - (:result-types signed-num) - (:note "inline (signed-byte 32) arithmetic") - (:effects) - (:affected) - (:policy :fast-safe)) - -(define-vop (fast-fixnum-c-binop fast-fixnum-binop) - (:args (x :target r :scs (any-reg))) - (:info y) - (:arg-types tagged-num (:constant integer))) - -(define-vop (fast-signed-c-binop fast-signed-binop) - (:args (x :target r :scs (signed-reg))) - (:info y) - (:arg-types tagged-num (:constant integer))) - -(define-vop (fast-unsigned-c-binop fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg))) - (:info y) - (:arg-types tagged-num (:constant integer))) - -(defmacro define-binop (translate cost untagged-cost op - tagged-type untagged-type) - `(progn - (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") - fast-fixnum-binop) - (:args (x :target r :scs (any-reg)) - (y :target r :scs (any-reg))) - (:translate ,translate) - (:generator ,(1+ cost) - (inst ,op r x y))) - (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") - fast-signed-binop) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) - (:translate ,translate) - (:generator ,(1+ untagged-cost) - (inst ,op r x y))) - (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") - fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) - (:translate ,translate) - (:generator ,(1+ untagged-cost) - (inst ,op r x y))) - (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") - fast-fixnum-c-binop) - (:arg-types tagged-num (:constant ,tagged-type)) - (:translate ,translate) - (:generator ,cost - (inst ,op r x (fixnum y)))) - (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") - fast-signed-c-binop) - (:arg-types signed-num (:constant ,untagged-type)) - (:translate ,translate) - (:generator ,untagged-cost - (inst ,op r x y))) - (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED") - fast-unsigned-c-binop) - (:arg-types unsigned-num (:constant ,untagged-type)) - (:translate ,translate) - (:generator ,untagged-cost - (inst ,op r x y))))) - -(define-binop + 1 5 addu (signed-byte 14) (signed-byte 16)) -(define-binop - 1 5 subu - (integer #.(- (1- (ash 1 14))) #.(ash 1 14)) - (integer #.(- (1- (ash 1 16))) #.(ash 1 16))) -(define-binop logior 1 3 or (unsigned-byte 14) (unsigned-byte 16)) -(define-binop lognor 1 3 nor (unsigned-byte 14) (unsigned-byte 16)) -(define-binop logand 1 3 and (unsigned-byte 14) (unsigned-byte 16)) -(define-binop logxor 1 3 xor (unsigned-byte 14) (unsigned-byte 16)) - -;;; Special case fixnum + and - that trap on overflow. Useful when we don't -;;; know that the result is going to be a fixnum. - -(define-vop (fast-+/fixnum fast-+/fixnum=>fixnum) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types (:or signed-num unsigned-num)) - (:note nil) - (:generator 4 - (inst add r x y))) - -(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types (:or signed-num unsigned-num)) - (:note nil) - (:generator 3 - (inst add r x (fixnum y)))) - -(define-vop (fast--/fixnum fast--/fixnum=>fixnum) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types (:or signed-num unsigned-num)) - (:note nil) - (:generator 4 - (inst sub r x y))) - -(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types (:or signed-num unsigned-num)) - (:note nil) - (:generator 3 - (inst sub r x (fixnum y)))) - - -;;; Shifting - - -(define-vop (fast-ash) - (:note "inline ASH") - (:args (number :scs (signed-reg unsigned-reg) :to :save) - (amount :scs (signed-reg))) - (:arg-types (:or signed-num unsigned-num) signed-num) - (:results (result :scs (signed-reg unsigned-reg))) - (:result-types (:or signed-num unsigned-num)) - (:translate ash) - (:policy :fast-safe) - (:temporary (:sc non-descriptor-reg) ndesc) - (:temporary (:sc non-descriptor-reg :to :eval) temp) - (:generator 3 - (inst bgez amount positive) - (inst subu ndesc zero-tn amount) - (inst slt temp ndesc 31) - (inst bne temp zero-tn done) - (sc-case number - (signed-reg (inst sra result number ndesc)) - (unsigned-reg (inst srl result number ndesc))) - (inst b done) - (sc-case number - (signed-reg (inst sra result number 31)) - (unsigned-reg (inst srl result number 31))) - - POSITIVE - ;; The result-type assures us that this shift will not overflow. - (inst sll result number amount) - - DONE)) - -(define-vop (fast-ash-c) - (:policy :fast-safe) - (:translate ash) - (:note nil) - (:args (number :scs (signed-reg unsigned-reg))) - (:info count) - (:arg-types (:or signed-num unsigned-num) (:constant integer)) - (:results (result :scs (signed-reg unsigned-reg))) - (:result-types (:or signed-num unsigned-num)) - (:generator 1 - (cond ((< count 0) - ;; It is a right shift. - (sc-case number - (signed-reg (inst sra result number (min (- count) 31))) - (unsigned-reg (inst srl result number (min (- count) 31))))) - ((> count 0) - ;; It is a left shift. - (inst sll result number (min count 31))) - (t - ;; Count=0? Shouldn't happen, but it's easy: - (move result number))))) - -(define-vop (signed-byte-32-len) - (:translate integer-length) - (:note "inline (signed-byte 32) integer-length") - (:policy :fast-safe) - (:args (arg :scs (signed-reg) :target shift)) - (:arg-types signed-num) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) - (:generator 30 - (let ((loop (gen-label)) - (test (gen-label))) - (move shift arg) - (inst bgez shift test) - (move res zero-tn) - (inst b test) - (inst nor shift shift) - - (emit-label loop) - (inst add res (fixnum 1)) - - (emit-label test) - (inst bne shift loop) - (inst srl shift 1)))) - -(define-vop (unsigned-byte-32-count) - (:translate logcount) - (:note "inline (unsigned-byte 32) logcount") - (:policy :fast-safe) - (:args (arg :scs (unsigned-reg) :target num)) - (:arg-types unsigned-num) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0) - :target res) num) - (:temporary (:scs (non-descriptor-reg)) mask temp) - (:generator 30 - (inst li mask #x55555555) - (inst srl temp arg 1) - (inst and num arg mask) - (inst and temp mask) - (inst addu num temp) - (inst li mask #x33333333) - (inst srl temp num 2) - (inst and num mask) - (inst and temp mask) - (inst addu num temp) - (inst li mask #x0f0f0f0f) - (inst srl temp num 4) - (inst and num mask) - (inst and temp mask) - (inst addu num temp) - (inst li mask #x00ff00ff) - (inst srl temp num 8) - (inst and num mask) - (inst and temp mask) - (inst addu num temp) - (inst li mask #x0000ffff) - (inst srl temp num 16) - (inst and num mask) - (inst and temp mask) - (inst addu res num temp))) - - -;;; Multiply and Divide. - -(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) - (:temporary (:scs (non-descriptor-reg)) temp) - (:translate *) - (:generator 4 - (inst sra temp y 2) - (inst mult x temp) - (inst mflo r))) - -(define-vop (fast-*/signed=>signed fast-signed-binop) - (:translate *) - (:generator 3 - (inst mult x y) - (inst mflo r))) - -(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop) - (:translate *) - (:generator 3 - (inst multu x y) - (inst mflo r))) - - - -(define-vop (fast-truncate/fixnum fast-fixnum-binop) - (:translate truncate) - (:results (q :scs (any-reg)) - (r :scs (any-reg))) - (:result-types tagged-num tagged-num) - (:temporary (:scs (non-descriptor-reg) :to :eval) temp) - (:vop-var vop) - (:save-p :compute-only) - (:generator 11 - (let ((zero (generate-error-code vop division-by-zero-error x y))) - (inst beq y zero-tn zero)) - (inst div x y) - (inst mflo temp) - (inst sll q temp 2) - (inst mfhi r))) - -(define-vop (fast-truncate/unsigned fast-unsigned-binop) - (:translate truncate) - (:results (q :scs (unsigned-reg)) - (r :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:vop-var vop) - (:save-p :compute-only) - (:generator 12 - (let ((zero (generate-error-code vop division-by-zero-error x y))) - (inst beq y zero-tn zero)) - (inst divu x y) - (inst mflo q) - (inst mfhi r))) - -(define-vop (fast-truncate/signed fast-signed-binop) - (:translate truncate) - (:results (q :scs (signed-reg)) - (r :scs (signed-reg))) - (:result-types signed-num signed-num) - (:vop-var vop) - (:save-p :compute-only) - (:generator 12 - (let ((zero (generate-error-code vop division-by-zero-error x y))) - (inst beq y zero-tn zero)) - (inst div x y) - (inst mflo q) - (inst mfhi r))) - - - -;;;; Binary conditional VOPs: - -(define-vop (fast-conditional) - (:conditional) - (:info target not-p) - (:effects) - (:affected) - (:temporary (:scs (non-descriptor-reg)) temp) - (:policy :fast-safe)) - -(deftype integer-with-a-bite-out (s bite) - (cond ((eq s '*) 'integer) - ((and (integerp s) (> s 1)) - (let ((bound (ash 1 (1- s)))) - `(integer ,(- bound) ,(- bound bite 1)))) - (t - (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) - -(define-vop (fast-conditional/fixnum fast-conditional) - (:args (x :scs (any-reg)) - (y :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison")) - -(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg))) - (:arg-types tagged-num (:constant (integer-with-a-bite-out 14 #.(fixnum 1)))) - (:info target not-p y)) - -(define-vop (fast-conditional/signed fast-conditional) - (:args (x :scs (signed-reg)) - (y :scs (signed-reg))) - (:arg-types signed-num signed-num) - (:note "inline (signed-byte 32) comparison")) - -(define-vop (fast-conditional-c/signed fast-conditional/signed) - (:args (x :scs (signed-reg))) - (:arg-types signed-num (:constant (integer-with-a-bite-out 16 1))) - (:info target not-p y)) - -(define-vop (fast-conditional/unsigned fast-conditional) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:note "inline (unsigned-byte 32) comparison")) - -(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num (:constant (and (integer-with-a-bite-out 16 1) - unsigned-byte))) - (:info target not-p y)) - - -(defmacro define-conditional-vop (translate &rest generator) - `(progn - ,@(mapcar #'(lambda (suffix cost signed) - (unless (and (member suffix '(/fixnum -c/fixnum)) - (eq translate 'eql)) - `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" - translate suffix)) - ,(intern - (format nil "~:@(FAST-CONDITIONAL~A~)" - suffix))) - (:translate ,translate) - (:generator ,cost - (let* ((signed ,signed) - (-c/fixnum ,(eq suffix '-c/fixnum)) - (y (if -c/fixnum (fixnum y) y))) - (declare (optimize (inhibit-warnings 3))) - ,@generator))))) - '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) - '(3 2 5 4 5 4) - '(t t t t nil nil)))) - -(define-conditional-vop < - (cond ((and signed (eql y 0)) - (if not-p - (inst bgez x target) - (inst bltz x target))) - (t - (if signed - (inst slt temp x y) - (inst sltu temp x y)) - (if not-p - (inst beq temp zero-tn target) - (inst bne temp zero-tn target)))) - (inst nop)) - -(define-conditional-vop > - (cond ((and signed (eql y 0)) - (if not-p - (inst blez x target) - (inst bgtz x target))) - ((integerp y) - (let ((y (+ y (if -c/fixnum (fixnum 1) 1)))) - (if signed - (inst slt temp x y) - (inst sltu temp x y)) - (if not-p - (inst bne temp zero-tn target) - (inst beq temp zero-tn target)))) - (t - (if signed - (inst slt temp y x) - (inst sltu temp y x)) - (if not-p - (inst beq temp zero-tn target) - (inst bne temp zero-tn target)))) - (inst nop)) - -;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a -;;; known fixnum. - -(define-conditional-vop eql - (declare (ignore signed)) - (when (integerp y) - (inst li temp y) - (setf y temp)) - (if not-p - (inst bne x y target) - (inst beq x y target)) - (inst nop)) - -;;; These versions specify a fixnum restriction on their first arg. We have -;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on -;;; the first arg and a higher cost. The reason for doing this is to prevent -;;; fixnum specific operations from being used on word integers, spuriously -;;; consing the argument. -;;; -(define-vop (fast-eql/fixnum fast-conditional) - (:args (x :scs (any-reg)) - (y :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison") - (:translate eql) - (:ignore temp) - (:generator 3 - (if not-p - (inst bne x y target) - (inst beq x y target)) - (inst nop))) -;;; -(define-vop (generic-eql/fixnum fast-eql/fixnum) - (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg))) - (:arg-types * tagged-num) - (:variant-cost 7)) - -(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg))) - (:arg-types tagged-num (:constant (signed-byte 14))) - (:info target not-p y) - (:translate eql) - (:generator 2 - (let ((y (cond ((eql y 0) zero-tn) - (t - (inst li temp (fixnum y)) - temp)))) - (if not-p - (inst bne x y target) - (inst beq x y target)) - (inst nop)))) -;;; -(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) - (:args (x :scs (any-reg descriptor-reg))) - (:arg-types * (:constant (signed-byte 14))) - (:variant-cost 6)) - - -;;;; 32-bit logical operations - -(define-vop (merge-bits) - (:translate merge-bits) - (:args (shift :scs (signed-reg unsigned-reg)) - (prev :scs (unsigned-reg)) - (next :scs (unsigned-reg))) - (:arg-types tagged-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:policy :fast-safe) - (:generator 4 - (let ((done (gen-label))) - (inst beq shift done) - (inst srl res next shift) - (inst subu temp zero-tn shift) - (inst sll temp prev temp) - (inst or res res temp) - (emit-label done) - (move result res)))) - - -(define-vop (32bit-logical) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:policy :fast-safe)) - -(define-vop (32bit-logical-not 32bit-logical) - (:translate 32bit-logical-not) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:generator 1 - (inst nor r x zero-tn))) - -(define-vop (32bit-logical-and 32bit-logical) - (:translate 32bit-logical-and) - (:generator 1 - (inst and r x y))) - -(deftransform 32bit-logical-nand ((x y) (* *)) - '(32bit-logical-not (32bit-logical-and x y))) - -(define-vop (32bit-logical-or 32bit-logical) - (:translate 32bit-logical-or) - (:generator 1 - (inst or r x y))) - -(define-vop (32bit-logical-nor 32bit-logical) - (:translate 32bit-logical-nor) - (:generator 1 - (inst nor r x y))) - -(define-vop (32bit-logical-xor 32bit-logical) - (:translate 32bit-logical-xor) - (:generator 1 - (inst xor r x y))) - -(deftransform 32bit-logical-eqv ((x y) (* *)) - '(32bit-logical-not (32bit-logical-xor x y))) - -(deftransform 32bit-logical-andc1 ((x y) (* *)) - '(32bit-logical-and (32bit-logical-not x) y)) - -(deftransform 32bit-logical-andc2 ((x y) (* *)) - '(32bit-logical-and x (32bit-logical-not y))) - -(deftransform 32bit-logical-orc1 ((x y) (* *)) - '(32bit-logical-or (32bit-logical-not x) y)) - -(deftransform 32bit-logical-orc2 ((x y) (* *)) - '(32bit-logical-or x (32bit-logical-not y))) - - -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) - (:arg-types unsigned-num tagged-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "SHIFT-TOWARDS-START") - (:generator 1 - (ecase (backend-byte-order *backend*) - (:big-endian - (inst sll r num amount)) - (:little-endian - (inst srl r num amount))))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:generator 1 - (ecase (backend-byte-order *backend*) - (:big-endian - (inst srl r num amount)) - (:little-endian - (inst sll r num amount))))) - - - -;;;; Bignum stuff. - -(define-vop (bignum-length get-header-data) - (:translate bignum::%bignum-length) - (:policy :fast-safe)) - -(define-vop (bignum-set-length set-header-data) - (:translate bignum::%bignum-set-length) - (:policy :fast-safe)) - -(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type - (unsigned-reg) unsigned-num bignum::%bignum-ref) - -(define-full-setter bignum-set * bignum-digits-offset other-pointer-type - (unsigned-reg) unsigned-num bignum::%bignum-set #+gengc nil) - -(define-vop (digit-0-or-plus) - (:translate bignum::%digit-0-or-plusp) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:conditional) - (:info target not-p) - (:generator 2 - (if not-p - (inst bltz digit target) - (inst bgez digit target)) - (inst nop))) - -(define-vop (add-w/carry) - (:translate bignum::%add-with-carry) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (any-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) - (:results (result :scs (unsigned-reg)) - (carry :scs (unsigned-reg) :from :eval)) - (:result-types unsigned-num positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 5 - (let ((carry-in (gen-label)) - (done (gen-label))) - (inst bne c carry-in) - (inst addu res a b) - - (inst b done) - (inst sltu carry res b) - - (emit-label carry-in) - (inst addu res 1) - (inst nor temp a zero-tn) - (inst sltu carry b temp) - (inst xor carry 1) - - (emit-label done) - (move result res)))) - -(define-vop (sub-w/borrow) - (:translate bignum::%subtract-with-borrow) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (any-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) - (:results (result :scs (unsigned-reg)) - (borrow :scs (unsigned-reg) :from :eval)) - (:result-types unsigned-num positive-fixnum) - (:generator 4 - (let ((no-borrow-in (gen-label)) - (done (gen-label))) - - (inst bne c no-borrow-in) - (inst subu res a b) - - (inst subu res 1) - (inst b done) - (inst sltu borrow b a) - - (emit-label no-borrow-in) - (inst sltu borrow a b) - (inst xor borrow 1) - - (emit-label done) - (move result res)))) - -(define-vop (bignum-mult-and-add-3-arg) - (:translate bignum::%multiply-and-add) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg)) - (carry-in :scs (unsigned-reg) :to :save)) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :from (:argument 1)) temp) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 6 - (inst multu x y) - (inst mflo temp) - (inst addu lo temp carry-in) - (inst sltu temp lo carry-in) - (inst mfhi hi) - (inst addu hi temp))) - -(define-vop (bignum-mult-and-add-4-arg) - (:translate bignum::%multiply-and-add) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg)) - (prev :scs (unsigned-reg)) - (carry-in :scs (unsigned-reg) :to :save)) - (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :from (:argument 2)) temp) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 9 - (inst multu x y) - (inst addu lo prev carry-in) - (inst sltu temp lo carry-in) - (inst mfhi hi) - (inst addu hi temp) - (inst mflo temp) - (inst addu lo temp) - (inst sltu temp lo temp) - (inst addu hi temp))) - -(define-vop (bignum-mult) - (:translate bignum::%multiply) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 3 - (inst multu x y) - (inst mflo lo) - (inst mfhi hi))) - -(define-vop (bignum-lognot) - (:translate bignum::%lognot) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst nor r x zero-tn))) - -(define-vop (fixnum-to-digit) - (:translate bignum::%fixnum-to-digit) - (:policy :fast-safe) - (:args (fixnum :scs (any-reg))) - (:arg-types tagged-num) - (:results (digit :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst sra digit fixnum 2))) - -(define-vop (bignum-floor) - (:translate bignum::%floor) - (:policy :fast-safe) - (:args (num-high :scs (unsigned-reg) :target rem) - (num-low :scs (unsigned-reg) :target rem-low) - (denom :scs (unsigned-reg) :to (:eval 1))) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low) - (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp) - (:results (quo :scs (unsigned-reg) :from (:eval 0)) - (rem :scs (unsigned-reg) :from (:argument 0))) - (:result-types unsigned-num unsigned-num) - (:generator 325 ; number of inst assuming targeting works. - (move rem num-high) - (move rem-low num-low) - (flet ((maybe-subtract (&optional (guess temp)) - (inst subu temp guess 1) - (inst and temp denom) - (inst subu rem temp))) - (inst sltu quo rem denom) - (maybe-subtract quo) - (dotimes (i 32) - (inst sll rem 1) - (inst srl temp rem-low 31) - (inst or rem temp) - (inst sll rem-low 1) - (inst sltu temp rem denom) - (inst sll quo 1) - (inst or quo temp) - (maybe-subtract))) - (inst nor quo zero-tn))) - -(define-vop (signify-digit) - (:translate bignum::%fixnum-digit-with-correct-sign) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg) :target res)) - (:arg-types unsigned-num) - (:results (res :scs (any-reg signed-reg))) - (:result-types signed-num) - (:generator 1 - (sc-case res - (any-reg - (inst sll res digit 2)) - (signed-reg - (move res digit))))) - - -(define-vop (digit-ashr) - (:translate bignum::%ashr) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg)) - (count :scs (unsigned-reg))) - (:arg-types unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst sra result digit count))) - -(define-vop (digit-lshr digit-ashr) - (:translate bignum::%digit-logical-shift-right) - (:generator 1 - (inst srl result digit count))) - -(define-vop (digit-ashl digit-ashr) - (:translate bignum::%ashl) - (:generator 1 - (inst sll result digit count))) - - -;;;; Static functions. - -(define-static-function two-arg-gcd (x y) :translate gcd) -(define-static-function two-arg-lcm (x y) :translate lcm) - -(define-static-function two-arg-+ (x y) :translate +) -(define-static-function two-arg-- (x y) :translate -) -(define-static-function two-arg-* (x y) :translate *) -(define-static-function two-arg-/ (x y) :translate /) - -(define-static-function two-arg-< (x y) :translate <) -(define-static-function two-arg-<= (x y) :translate <=) -(define-static-function two-arg-> (x y) :translate >) -(define-static-function two-arg->= (x y) :translate >=) -(define-static-function two-arg-= (x y) :translate =) -(define-static-function two-arg-/= (x y) :translate /=) - -(define-static-function %negate (x) :translate %negate) - -(define-static-function two-arg-and (x y) :translate logand) -(define-static-function two-arg-ior (x y) :translate logior) -(define-static-function two-arg-xor (x y) :translate logxor) diff --git a/compiler/mips/array.lisp b/compiler/mips/array.lisp deleted file mode 100644 index d74af077a0032d2994eabf8937ffb8ba46e6fc7f..0000000000000000000000000000000000000000 --- a/compiler/mips/array.lisp +++ /dev/null @@ -1,445 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/array.lisp,v 1.37 1993/01/13 15:55:23 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the MIPS definitions for array operations. -;;; -;;; Written by William Lott -;;; -(in-package "MIPS") - - -;;;; Allocator for the array header. - -#-gengc -(define-vop (make-array-header) - (:policy :fast-safe) - (:translate make-array-header) - (:args (type :scs (any-reg)) - (rank :scs (any-reg))) - (:arg-types positive-fixnum positive-fixnum) - (:temporary (:scs (any-reg)) bytes) - (:temporary (:scs (non-descriptor-reg)) header) - (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:results (result :scs (descriptor-reg))) - (:generator 13 - (inst addu bytes rank (+ (* array-dimensions-offset word-bytes) - lowtag-mask)) - (inst li header (lognot lowtag-mask)) - (inst and bytes header) - (inst addu header rank (fixnum (1- array-dimensions-offset))) - (inst sll header type-bits) - (inst or header header type) - (inst srl header 2) - (pseudo-atomic (pa-flag) - (inst or result alloc-tn other-pointer-type) - (storew header alloc-tn) - (inst addu alloc-tn bytes)))) - -#+gengc -(define-vop (make-array-header) - (:args (type :scs (any-reg)) - (rank :scs (any-reg))) - (:arg-types positive-fixnum positive-fixnum) - (:temporary (:sc non-descriptor-reg :offset nl0-offset) nl0) - (:temporary (:sc non-descriptor-reg :offset nl1-offset) nl1) - (:temporary (:sc non-descriptor-reg :offset nl2-offset) nl2) - (:temporary (:sc descriptor-reg :offset a0-offset :target result - :from (:argument 0) :to (:result 0)) - a0) - (:results (result :scs (descriptor-reg))) - (:ignore nl2) - (:generator 13 - (inst addu a0 rank (fixnum (1+ array-dimensions-offset))) - (inst addu nl1 rank (fixnum (1- array-dimensions-offset))) - (inst sll nl1 (- type-bits 2)) - (inst or nl1 type) - (inst jal (make-fixup 'var-alloc :assembly-routine)) - (inst li nl0 other-pointer-type) - (move result a0))) - - - -;;;; Additional accessors and setters for the array header. - -(defknown lisp::%array-dimension (t index) index - (flushable)) -(defknown lisp::%set-array-dimension (t index index) index - ()) - -(define-full-reffer %array-dimension * - array-dimensions-offset other-pointer-type - (any-reg) positive-fixnum lisp::%array-dimension) - -(define-full-setter %set-array-dimension * - array-dimensions-offset other-pointer-type - (any-reg) positive-fixnum lisp::%set-array-dimension nil) - - -(defknown lisp::%array-rank (t) index (flushable)) - -(define-vop (array-rank-vop) - (:translate lisp::%array-rank) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadw temp x 0 other-pointer-type) - (inst sra temp type-bits) - (inst subu temp (1- array-dimensions-offset)) - (inst sll res temp 2))) - - - -;;;; Bounds checking routine. - - -(define-vop (check-bound) - (:translate %check-bound) - (:policy :fast-safe) - (:args (array :scs (descriptor-reg)) - (bound :scs (any-reg descriptor-reg)) - (index :scs (any-reg descriptor-reg) :target result)) - (:results (result :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (let ((error (generate-error-code vop invalid-array-index-error - array bound index))) - (inst sltu temp index bound) - (inst beq temp zero-tn error) - (inst nop) - (move result index)))) - - - -;;;; Accessors/Setters - -;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos -;;; elements are represented in integer registers and are built out of -;;; 8, 16, or 32 bit elements. - -(eval-when (compile eval) - -(defmacro def-full-data-vector-frobs (type element-type &rest scs) - `(progn - (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type - vector-data-offset other-pointer-type ,scs ,element-type - data-vector-ref) - (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type - vector-data-offset other-pointer-type ,scs ,element-type - data-vector-set #+gengc ,(if (member 'descriptor-reg scs) t nil)))) - -(defmacro def-partial-data-vector-frobs - (type element-type size signed &rest scs) - `(progn - (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type - ,size ,signed vector-data-offset other-pointer-type ,scs - ,element-type data-vector-ref) - (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type - ,size vector-data-offset other-pointer-type ,scs - ,element-type data-vector-set))) - -); eval-when (compile eval) - -(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg) - -(def-partial-data-vector-frobs simple-string base-char :byte nil - base-char-reg) - -(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum - :byte nil unsigned-reg signed-reg) - -(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum - :short nil unsigned-reg signed-reg) - -(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num - unsigned-reg) - - - -;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, -;;; and 4-bit vectors. -;;; - -(defmacro def-small-data-vector-frobs (type bits) - (let* ((elements-per-word (floor word-bits bits)) - (bit-shift (1- (integer-length elements-per-word)))) - `(progn - (define-vop (,(symbolicate 'data-vector-ref/ type)) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (value :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) - (:generator 20 - (inst srl temp index ,bit-shift) - (inst sll temp 2) - (inst addu lip object temp) - (inst lw result lip - (- (* vector-data-offset word-bytes) - other-pointer-type)) - (inst and temp index ,(1- elements-per-word)) - ,@(when (eq (backend-byte-order *backend*) :big-endian) - `((inst xor temp ,(1- elements-per-word)))) - ,@(unless (= bits 1) - `((inst sll temp ,(1- (integer-length bits))))) - (inst srl result temp) - (inst and result ,(1- (ash 1 bits))) - (inst sll value result 2))) - (define-vop (,(symbolicate 'data-vector-ref-c/ type)) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:arg-types ,type - (:constant - (integer 0 - ,(1- (* (1+ (- (floor (+ #x7fff - other-pointer-type) - word-bytes) - vector-data-offset)) - elements-per-word))))) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 15 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - ,@(when (eq (backend-byte-order *backend*) :big-endian) - `((setf extra (logxor extra (1- ,elements-per-word))))) - (loadw result object (+ word vector-data-offset) - other-pointer-type) - (unless (zerop extra) - (inst srl result (* extra ,bits))) - (unless (= extra ,(1- elements-per-word)) - (inst and result ,(1- (ash 1 bits))))))) - (define-vop (,(symbolicate 'data-vector-set/ type)) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg) :target shift) - (value :scs (unsigned-reg zero immediate) :target result)) - (:arg-types ,type positive-fixnum positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg)) temp old) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift) - (:generator 25 - (inst srl temp index ,bit-shift) - (inst sll temp 2) - (inst addu lip object temp) - (inst lw old lip - (- (* vector-data-offset word-bytes) - other-pointer-type)) - (inst and shift index ,(1- elements-per-word)) - ,@(when (eq (backend-byte-order *backend*) :big-endian) - `((inst xor shift ,(1- elements-per-word)))) - ,@(unless (= bits 1) - `((inst sll shift ,(1- (integer-length bits))))) - (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) - (inst li temp ,(1- (ash 1 bits))) - (inst sll temp shift) - (inst nor temp temp zero-tn) - (inst and old temp)) - (unless (sc-is value zero) - (sc-case value - (immediate - (inst li temp (logand (tn-value value) ,(1- (ash 1 bits))))) - (unsigned-reg - (inst and temp value ,(1- (ash 1 bits))))) - (inst sll temp shift) - (inst or old temp)) - (inst sw old lip - (- (* vector-data-offset word-bytes) - other-pointer-type)) - (sc-case value - (immediate - (inst li result (tn-value value))) - (zero - (move result zero-tn)) - (unsigned-reg - (move result value))))) - (define-vop (,(symbolicate 'data-vector-set-c/ type)) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs (unsigned-reg zero immediate) :target result)) - (:arg-types ,type - (:constant - (integer 0 - ,(1- (* (1+ (- (floor (+ #x7fff - other-pointer-type) - word-bytes) - vector-data-offset)) - elements-per-word)))) - positive-fixnum) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp old) - (:generator 20 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - ,@(when (eq (backend-byte-order *backend*) :big-endian) - `((setf extra (logxor extra (1- ,elements-per-word))))) - (inst lw old object - (- (* (+ word vector-data-offset) word-bytes) - other-pointer-type)) - (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) - (cond ((= extra ,(1- elements-per-word)) - (inst sll old ,bits) - (inst srl old ,bits)) - (t - (inst li temp - (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits)))) - (inst and old temp)))) - (sc-case value - (zero) - (immediate - (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits))) - (* extra ,bits)))) - (cond ((< value #x10000) - (inst or old value)) - (t - (inst li temp value) - (inst or old temp))))) - (unsigned-reg - (inst sll temp value (* extra ,bits)) - (inst or old temp))) - (inst sw old object - (- (* (+ word vector-data-offset) word-bytes) - other-pointer-type)) - (sc-case value - (immediate - (inst li result (tn-value value))) - (zero - (move result zero-tn)) - (unsigned-reg - (move result value))))))))) - -(def-small-data-vector-frobs simple-bit-vector 1) -(def-small-data-vector-frobs simple-array-unsigned-byte-2 2) -(def-small-data-vector-frobs simple-array-unsigned-byte-4 4) - - -;;; And the float variants. -;;; - -(define-vop (data-vector-ref/simple-array-single-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-single-float positive-fixnum) - (:results (value :scs (single-reg))) - (:result-types single-float) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (inst addu lip object index) - (inst lwc1 value lip - (- (* vector-data-offset word-bytes) - other-pointer-type)) - (inst nop))) - -(define-vop (data-vector-set/simple-array-single-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (single-reg) :target result)) - (:arg-types simple-array-single-float positive-fixnum single-float) - (:results (result :scs (single-reg))) - (:result-types single-float) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (inst addu lip object index) - (inst swc1 value lip - (- (* vector-data-offset word-bytes) - other-pointer-type)) - (unless (location= result value) - (inst fmove :single result value)))) - -(define-vop (data-vector-ref/simple-array-double-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-double-float positive-fixnum) - (:results (value :scs (double-reg))) - (:result-types double-float) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (inst addu lip object index) - (inst addu lip index) - (inst lwc1 value lip - (- (* vector-data-offset word-bytes) - other-pointer-type)) - (inst lwc1-odd value lip - (+ (- (* vector-data-offset word-bytes) - other-pointer-type) - word-bytes)) - (inst nop))) - -(define-vop (data-vector-set/simple-array-double-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (double-reg) :target result)) - (:arg-types simple-array-double-float positive-fixnum double-float) - (:results (result :scs (double-reg))) - (:result-types double-float) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (inst addu lip object index) - (inst addu lip index) - (inst swc1 value lip - (- (* vector-data-offset word-bytes) - other-pointer-type)) - (inst swc1-odd value lip - (+ (- (* vector-data-offset word-bytes) - other-pointer-type) - word-bytes)) - (unless (location= result value) - (inst fmove :double result value)))) - - - -;;; These vops are useful for accessing the bits of a vector irrespective of -;;; what type of vector it is. -;;; - -(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num - %raw-bits) -(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg) - unsigned-num %set-raw-bits #+gengc nil) - - - -;;;; Misc. Array VOPs. - -(define-vop (get-vector-subtype get-header-data)) -(define-vop (set-vector-subtype set-header-data)) - diff --git a/compiler/mips/c-call.lisp b/compiler/mips/c-call.lisp deleted file mode 100644 index 93e1aef92ed466f03a8151347e9e75edd7caa95d..0000000000000000000000000000000000000000 --- a/compiler/mips/c-call.lisp +++ /dev/null @@ -1,201 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/c-call.lisp,v 1.12 1992/07/28 20:37:17 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VOPs and other necessary machine specific support -;;; routines for call-out to C. -;;; -;;; Written by William Lott. -;;; -(in-package "MIPS") -(use-package "ALIEN") -(use-package "ALIEN-INTERNALS") - -(defun my-make-wired-tn (prim-type-name sc-name offset) - (make-wired-tn (primitive-type-or-lose prim-type-name *backend*) - (sc-number-or-lose sc-name *backend*) - offset)) - -(defstruct arg-state - (stack-frame-size 0) - (did-int-arg nil) - (float-args 0)) - -(def-alien-type-method (integer :arg-tn) (type state) - (let ((stack-frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) - (setf (arg-state-did-int-arg state) t) - (multiple-value-bind - (ptype reg-sc stack-sc) - (if (alien-integer-type-signed type) - (values 'signed-byte-32 'signed-reg 'signed-stack) - (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)) - (if (< stack-frame-size 4) - (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4)) - (my-make-wired-tn ptype stack-sc stack-frame-size))))) - -(def-alien-type-method (system-area-pointer :arg-tn) (type state) - (declare (ignore type)) - (let ((stack-frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) - (setf (arg-state-did-int-arg state) t) - (if (< stack-frame-size 4) - (my-make-wired-tn 'system-area-pointer - 'sap-reg - (+ stack-frame-size 4)) - (my-make-wired-tn 'system-area-pointer - 'sap-stack - stack-frame-size)))) - -(def-alien-type-method (double-float :arg-tn) (type state) - (declare (ignore type)) - (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1)) - (float-args (arg-state-float-args state))) - (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2)) - (setf (arg-state-float-args state) (1+ float-args)) - (cond ((>= stack-frame-size 4) - (my-make-wired-tn 'double-float - 'double-stack - stack-frame-size)) - ((and (not (arg-state-did-int-arg state)) - (< float-args 2)) - (my-make-wired-tn 'double-float - 'double-reg - (+ (* float-args 2) 12))) - (t - (error "Can't put floats in int regs yet."))))) - -(def-alien-type-method (single-float :arg-tn) (type state) - (declare (ignore type)) - (let ((stack-frame-size (arg-state-stack-frame-size state)) - (float-args (arg-state-float-args state))) - (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) - (setf (arg-state-float-args state) (1+ float-args)) - (cond ((>= stack-frame-size 4) - (my-make-wired-tn 'single-float - 'single-stack - stack-frame-size)) - ((and (not (arg-state-did-int-arg state)) - (< float-args 2)) - (my-make-wired-tn 'single-float - 'single-reg - (+ (* float-args 2) 12))) - (t - (error "Can't put floats in int regs yet."))))) - - -(defstruct result-state - (num-results 0)) - -(def-alien-type-method (integer :result-tn) (type state) - (let ((num-results (result-state-num-results state))) - (setf (result-state-num-results state) (1+ num-results)) - (multiple-value-bind - (ptype reg-sc) - (if (alien-integer-type-signed type) - (values 'signed-byte-32 'signed-reg) - (values 'unsigned-byte-32 'unsigned-reg)) - (my-make-wired-tn ptype reg-sc (+ num-results 2))))) - -(def-alien-type-method (system-area-pointer :result-tn) (type state) - (declare (ignore type)) - (let ((num-results (result-state-num-results state))) - (setf (result-state-num-results state) (1+ num-results)) - (my-make-wired-tn 'system-area-pointer 'sap-reg (+ num-results 2)))) - -(def-alien-type-method (double-float :result-tn) (type state) - (declare (ignore type)) - (let ((num-results (result-state-num-results state))) - (setf (result-state-num-results state) (1+ num-results)) - (my-make-wired-tn 'double-float 'double-reg (* num-results 2)))) - -(def-alien-type-method (single-float :result-tn) (type state) - (declare (ignore type)) - (let ((num-results (result-state-num-results state))) - (setf (result-state-num-results state) (1+ num-results)) - (my-make-wired-tn 'single-float 'single-reg (* num-results 2)))) - -(def-alien-type-method (values :result-tn) (type state) - (mapcar #'(lambda (type) - (invoke-alien-type-method :result-tn type state)) - (alien-values-type-values type))) - -(def-vm-support-routine make-call-out-tns (type) - (let ((arg-state (make-arg-state))) - (collect ((arg-tns)) - (dolist (arg-type (alien-function-type-arg-types type)) - (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) - (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset) - (* (max (arg-state-stack-frame-size arg-state) 4) word-bytes) - (arg-tns) - (invoke-alien-type-method :result-tn - (alien-function-type-result-type type) - (make-result-state)))))) - - -(define-vop (foreign-symbol-address) - (:translate foreign-symbol-address) - (:policy :fast-safe) - (:args) - (:arg-types (:constant simple-string)) - (:info foreign-symbol) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst li res (make-fixup foreign-symbol :foreign)))) - -(define-vop (call-out) - (:args (function :scs (sap-reg) :target cfunc) - (args :more t)) - (:results (results :more t)) - (:ignore args results) - (:save-p t) - (:temporary (:sc any-reg :offset cfunc-offset - :from (:argument 0) :to (:result 0)) cfunc) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:vop-var vop) - (:generator 0 - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (move cfunc function) - (inst jal (make-fixup "call_into_c" :foreign)) - (inst nop) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - -(define-vop (alloc-number-stack-space) - (:info amount) - (:results (result :scs (sap-reg any-reg))) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 0 - (unless (zerop amount) - (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 15)) - (inst subu nsp-tn delta)) - (t - (inst li temp delta) - (inst subu nsp-tn temp))))) - (move result nsp-tn))) - -(define-vop (dealloc-number-stack-space) - (:info amount) - (:policy :fast-safe) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 0 - (unless (zerop amount) - (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 15)) - (inst addu nsp-tn delta)) - (t - (inst li temp delta) - (inst addu nsp-tn temp))))))) diff --git a/compiler/mips/char.lisp b/compiler/mips/char.lisp deleted file mode 100644 index 13e2341d64184df2feed649e9a1bd617d46231ac..0000000000000000000000000000000000000000 --- a/compiler/mips/char.lisp +++ /dev/null @@ -1,136 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/mips/char.lisp,v 1.13 1991/11/09 02:37:38 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/char.lisp,v 1.13 1991/11/09 02:37:38 wlott Exp $ -;;; -;;; This file contains the RT VM definition of character operations. -;;; -;;; Written by Rob MacLachlan -;;; Converted for the MIPS R2000 by Christopher Hoover. -;;; -(in-package "MIPS") - - - -;;;; Moves and coercions: - -;;; Move a tagged char to an untagged representation. -;;; -(define-vop (move-to-base-char) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (base-char-reg))) - (:generator 1 - (inst srl y x vm:type-bits))) -;;; -(define-move-vop move-to-base-char :move - (any-reg descriptor-reg) (base-char-reg)) - - -;;; Move an untagged char to a tagged representation. -;;; -(define-vop (move-from-base-char) - (:args (x :scs (base-char-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:generator 1 - (inst sll y x vm:type-bits) - (inst or y y vm:base-char-type))) -;;; -(define-move-vop move-from-base-char :move - (base-char-reg) (any-reg descriptor-reg)) - -;;; Move untagged base-char values. -;;; -(define-vop (base-char-move) - (:args (x :target y - :scs (base-char-reg) - :load-if (not (location= x y)))) - (:results (y :scs (base-char-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move y x))) -;;; -(define-move-vop base-char-move :move - (base-char-reg) (base-char-reg)) - - -;;; Move untagged base-char arguments/return-values. -;;; -(define-vop (move-base-char-argument) - (:args (x :target y - :scs (base-char-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y base-char-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (base-char-reg - (move y x)) - (base-char-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-base-char-argument :move-argument - (any-reg base-char-reg) (base-char-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char -;;; to a descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (base-char-reg) (any-reg descriptor-reg)) - - - -;;;; Other operations: - -(define-vop (char-code) - (:translate char-code) - (:policy :fast-safe) - (:args (ch :scs (base-char-reg) :target res)) - (:arg-types base-char) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:generator 1 - (inst sll res ch 2))) - -(define-vop (code-char) - (:translate code-char) - (:policy :fast-safe) - (:args (code :scs (any-reg) :target res)) - (:arg-types positive-fixnum) - (:results (res :scs (base-char-reg))) - (:result-types base-char) - (:generator 1 - (inst srl res code 2))) - - -;;; Comparison of base-chars. -;;; -(define-vop (base-char-compare pointer-compare) - (:args (x :scs (base-char-reg)) - (y :scs (base-char-reg))) - (:arg-types base-char base-char)) - -(define-vop (fast-char=/base-char base-char-compare) - (:translate char=) - (:variant :eq)) - -(define-vop (fast-char</base-char base-char-compare) - (:translate char<) - (:variant :lt)) - -(define-vop (fast-char>/base-char base-char-compare) - (:translate char>) - (:variant :gt)) - diff --git a/compiler/mips/debug.lisp b/compiler/mips/debug.lisp deleted file mode 100644 index 79d049c828bf02bf9d10b5aa23b927173c1222f2..0000000000000000000000000000000000000000 --- a/compiler/mips/debug.lisp +++ /dev/null @@ -1,149 +0,0 @@ -;;; -*- Package: MIPS; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/mips/debug.lisp,v 1.15 1993/01/13 15:57:11 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Compiler support for the new whizzy debugger. -;;; -;;; Written by William Lott. -;;; -(in-package "MIPS") - - -(define-vop (debug-cur-sp) - (:translate current-sp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move res csp-tn))) - -(define-vop (debug-cur-fp) - (:translate current-fp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move res cfp-tn))) - -(define-vop (read-control-stack) - (:translate stack-ref) - (:policy :fast-safe) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (any-reg))) - (:arg-types system-area-pointer positive-fixnum) - (:temporary (:scs (sap-reg) :from :eval) sap) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 5 - (inst add sap object offset) - (inst lw result sap 0) - (inst nop))) - -(define-vop (read-control-stack-c) - (:translate stack-ref) - (:policy :fast-safe) - (:args (object :scs (sap-reg))) - (:info offset) - (:arg-types system-area-pointer (:constant (signed-byte 14))) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 4 - (inst lw result object (* offset word-bytes)) - (inst nop))) - -(define-vop (write-control-stack) - (:translate %set-stack-ref) - (:policy :fast-safe) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (any-reg)) - (value :scs (descriptor-reg) :target result)) - (:arg-types system-area-pointer positive-fixnum *) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:temporary (:scs (sap-reg) :from (:argument 1)) sap) - (:generator 2 - (inst add sap object offset) - (inst sw value sap 0) - (move result value))) - -(define-vop (write-control-stack-c) - (:translate %set-stack-ref) - (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (value :scs (descriptor-reg) :target result)) - (:info offset) - (:arg-types system-area-pointer (:constant (signed-byte 14)) *) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 1 - (inst sw value sap (* offset word-bytes)) - (move result value))) - - -(define-vop (code-from-mumble) - (:policy :fast-safe) - (:args (thing :scs (descriptor-reg))) - (:results (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:variant-vars lowtag) - (:generator 5 - (let ((bogus (gen-label)) - (done (gen-label))) - (loadw temp thing 0 lowtag) - (inst srl temp vm:type-bits) - (inst beq temp bogus) - (inst sll temp (1- (integer-length vm:word-bytes))) - (unless (= lowtag vm:other-pointer-type) - (inst addu temp (- lowtag vm:other-pointer-type))) - (inst subu code thing temp) - (emit-label done) - (assemble (*elsewhere*) - (emit-label bogus) - (inst b done) - (move code null-tn))))) - -#-gengc -(define-vop (code-from-lra code-from-mumble) - (:translate lra-code-header) - (:variant vm:other-pointer-type)) - -(define-vop (code-from-function code-from-mumble) - (:translate function-code-header) - (:variant vm:function-pointer-type)) - -(define-vop (make-lisp-obj) - (:policy :fast-safe) - (:translate make-lisp-obj) - (:args (value :scs (unsigned-reg) :target result)) - (:arg-types unsigned-num) - (:results (result :scs (descriptor-reg))) - (:generator 1 - (move result value))) - -(define-vop (get-lisp-obj-address) - (:policy :fast-safe) - (:translate get-lisp-obj-address) - (:args (thing :scs (descriptor-reg) :target result)) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (move result thing))) - -(define-vop (function-word-offset) - (:policy :fast-safe) - (:translate function-word-offset) - (:args (fun :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 5 - (loadw res fun 0 function-pointer-type) - (inst srl res vm:type-bits))) diff --git a/compiler/mips/float.lisp b/compiler/mips/float.lisp deleted file mode 100644 index 84e4deab3929a25ecba00b63791f0f3ca9e047ce..0000000000000000000000000000000000000000 --- a/compiler/mips/float.lisp +++ /dev/null @@ -1,424 +0,0 @@ -;;; -*- Package: MIPS; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/mips/float.lisp,v 1.17 1993/01/13 15:58:21 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains floating point support for the MIPS. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "MIPS") - - -;;;; Move functions: - -(define-move-function (load-single 1) (vop x y) - ((single-stack) (single-reg)) - (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) word-bytes)) - (inst nop)) - -(define-move-function (store-single 1) (vop x y) - ((single-reg) (single-stack)) - (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) word-bytes))) - - -(define-move-function (load-double 2) (vop x y) - ((double-stack) (double-reg)) - (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset x) word-bytes))) - (inst lwc1 y nfp offset) - (inst lwc1-odd y nfp (+ offset word-bytes))) - (inst nop)) - -(define-move-function (store-double 2) (vop x y) - ((double-reg) (double-stack)) - (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset y) word-bytes))) - (inst swc1 x nfp offset) - (inst swc1-odd x nfp (+ offset word-bytes)))) - - - -;;;; Move VOPs: - -(macrolet ((frob (vop sc format) - `(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") - (:generator 0 - (unless (location= y x) - (inst fmove ,format y x)))) - (define-move-vop ,vop :move (,sc) (,sc))))) - (frob single-move single-reg :single) - (frob double-move double-reg :double)) - - -(define-vop (move-from-float) - (:args (x :to :save)) - (:results (y)) - (:temporary (:scs (non-descriptor-reg)) ndescr) - #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:variant-vars double-p size type data) - (:note "float to pointer coercion") - (:generator 13 - (with-fixed-allocation (y pa-flag ndescr type size) - (inst swc1 x y (- (* data word-bytes) other-pointer-type)) - (when double-p - (inst swc1-odd x y (- (* (1+ data) word-bytes) - other-pointer-type)))))) - -(macrolet ((frob (name sc &rest args) - `(progn - (define-vop (,name move-from-float) - (:args (x :scs (,sc) :to :save)) - (:results (y :scs (descriptor-reg))) - (:variant ,@args)) - (define-move-vop ,name :move (,sc) (descriptor-reg))))) - (frob move-from-single single-reg - nil single-float-size single-float-type single-float-value-slot) - (frob move-from-double double-reg - t double-float-size double-float-type double-float-value-slot)) - -(macrolet ((frob (name sc double-p value) - `(progn - (define-vop (,name) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (,sc))) - (:note "pointer to float coercion") - (:generator 2 - (inst lwc1 y x (- (* ,value word-bytes) - other-pointer-type)) - ,@(when double-p - `((inst lwc1-odd y x (- (* (1+ ,value) word-bytes) - other-pointer-type)))) - (inst nop))) - (define-move-vop ,name :move (descriptor-reg) (,sc))))) - (frob move-to-single single-reg nil single-float-value-slot) - (frob move-to-double double-reg t double-float-value-slot)) - - -(macrolet ((frob (name sc stack-sc format double-p) - `(progn - (define-vop (,name) - (:args (x :scs (,sc) :target y) - (nfp :scs (any-reg) - :load-if (not (sc-is y ,sc)))) - (:results (y)) - (:note "float argument move") - (:generator ,(if double-p 2 1) - (sc-case y - (,sc - (unless (location= x y) - (inst fmove ,format y x))) - (,stack-sc - (let ((offset (* (tn-offset y) word-bytes))) - (inst swc1 x nfp offset) - ,@(when double-p - '((inst swc1-odd x nfp - (+ offset word-bytes))))))))) - (define-move-vop ,name :move-argument - (,sc descriptor-reg) (,sc))))) - (frob move-single-float-argument single-reg single-stack :single nil) - (frob move-double-float-argument double-reg double-stack :double t)) - - -(define-move-vop move-argument :move-argument - (single-reg double-reg) (descriptor-reg)) - - -;;;; Arithmetic VOPs: - -(define-vop (float-op) - (:args (x) (y)) - (:results (r)) - (:variant-vars format operation) - (:policy :fast-safe) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (note-this-location vop :internal-error) - (inst float-op operation format r x y))) - -(macrolet ((frob (name sc ptype) - `(define-vop (,name float-op) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:results (r :scs (,sc))) - (:arg-types ,ptype ,ptype) - (:result-types ,ptype)))) - (frob single-float-op single-reg single-float) - (frob double-float-op double-reg double-float)) - -(macrolet ((frob (op sname scost dname dcost) - `(progn - (define-vop (,sname single-float-op) - (:translate ,op) - (:variant :single ',op) - (:variant-cost ,scost)) - (define-vop (,dname double-float-op) - (:translate ,op) - (:variant :double ',op) - (:variant-cost ,dcost))))) - (frob + +/single-float 2 +/double-float 2) - (frob - -/single-float 2 -/double-float 2) - (frob * */single-float 4 */double-float 5) - (frob / //single-float 12 //double-float 19)) - -(macrolet ((frob (name inst translate format sc type) - `(define-vop (,name) - (:args (x :scs (,sc))) - (:results (y :scs (,sc))) - (:translate ,translate) - (:policy :fast-safe) - (:arg-types ,type) - (:result-types ,type) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:generator 1 - (note-this-location vop :internal-error) - (inst ,inst ,format y x))))) - (frob abs/single-float fabs abs :single single-reg single-float) - (frob abs/double-float fabs abs :double double-reg double-float) - (frob %negate/single-float fneg %negate :single single-reg single-float) - (frob %negate/double-float fneg %negate :double double-reg double-float)) - - -;;;; Comparison: - -(define-vop (float-compare) - (:args (x) (y)) - (:conditional) - (:info target not-p) - (:variant-vars format operation complement) - (:policy :fast-safe) - (:note "inline float comparison") - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (note-this-location vop :internal-error) - (inst fcmp operation format x y) - (inst nop) - (if (if complement (not not-p) not-p) - (inst bc1f target) - (inst bc1t target)) - (inst nop))) - -(macrolet ((frob (name sc ptype) - `(define-vop (,name float-compare) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:arg-types ,ptype ,ptype)))) - (frob single-float-compare single-reg single-float) - (frob double-float-compare double-reg double-float)) - -(macrolet ((frob (translate op complement sname dname) - `(progn - (define-vop (,sname single-float-compare) - (:translate ,translate) - (:variant :single ,op ,complement)) - (define-vop (,dname double-float-compare) - (:translate ,translate) - (:variant :double ,op ,complement))))) - (frob < :lt nil </single-float </double-float) - (frob > :ngt t >/single-float >/double-float) - (frob eql :seq nil eql/single-float eql/double-float)) - - -;;;; Conversion: - -(macrolet ((frob (name translate - from-sc from-type from-format - to-sc to-type to-format) - (let ((word-p (eq from-format :word))) - `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (,to-sc))) - (:arg-types ,from-type) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:generator ,(if word-p 3 2) - ,@(if word-p - `((inst mtc1 y x) - (inst nop) - (note-this-location vop :internal-error) - (inst fcvt ,to-format :word y y)) - `((note-this-location vop :internal-error) - (inst fcvt ,to-format ,from-format y x)))))))) - (frob %single-float/signed %single-float - signed-reg signed-num :word - single-reg single-float :single) - (frob %double-float/signed %double-float - signed-reg signed-num :word - double-reg double-float :double) - (frob %single-float/double-float %single-float - double-reg double-float :double - single-reg single-float :single) - (frob %double-float/single-float %double-float - single-reg single-float :single - double-reg double-float :double)) - - -(macrolet ((frob (name from-sc from-type from-format) - `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (signed-reg))) - (:temporary (:from (:argument 0) :sc ,from-sc) temp) - (:arg-types ,from-type) - (:result-types signed-num) - (:translate %unary-round) - (:policy :fast-safe) - (:note "inline float round") - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (note-this-location vop :internal-error) - (inst fcvt :word ,from-format temp x) - (inst mfc1 y temp) - (inst nop))))) - (frob %unary-round/single-float single-reg single-float :single) - (frob %unary-round/double-float double-reg double-float :double)) - - -;;; These VOPs have to uninterruptibly frob the rounding mode in order to get -;;; the desired round-to-zero behavior. -;;; -(macrolet ((frob (name from-sc from-type from-format) - `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (signed-reg))) - (:temporary (:from (:argument 0) :sc ,from-sc) temp) - (:temporary (:sc non-descriptor-reg) status-save new-status) - (:temporary (:sc non-descriptor-reg :offset nl4-offset) - pa-flag) - (:arg-types ,from-type) - (:result-types signed-num) - (:translate %unary-truncate) - (:policy :fast-safe) - (:note "inline float truncate") - (:vop-var vop) - (:save-p :compute-only) - (:generator 16 - (pseudo-atomic (pa-flag) - (inst cfc1 status-save 31) - (inst li new-status (lognot 3)) - (inst and new-status status-save) - (inst or new-status float-round-to-zero) - (inst ctc1 new-status 31) - - ;; These instructions seem to be necessary to ensure that - ;; the new modes affect the fcvt instruction. - (inst nop) - (inst cfc1 new-status 31) - - (note-this-location vop :internal-error) - (inst fcvt :word ,from-format temp x) - (inst mfc1 y temp) - (inst nop) - (inst ctc1 status-save 31)))))) - (frob %unary-truncate/single-float single-reg single-float :single) - (frob %unary-truncate/double-float double-reg double-float :double)) - - -(define-vop (make-single-float) - (:args (bits :scs (signed-reg))) - (:results (res :scs (single-reg))) - (:arg-types signed-num) - (:result-types single-float) - (:translate make-single-float) - (:policy :fast-safe) - (:generator 2 - (inst mtc1 res bits) - (inst nop))) - -(define-vop (make-double-float) - (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) - (:results (res :scs (double-reg))) - (:arg-types signed-num unsigned-num) - (:result-types double-float) - (:translate make-double-float) - (:policy :fast-safe) - (:generator 2 - (inst mtc1 res lo-bits) - (inst mtc1-odd res hi-bits) - (inst nop))) - -(define-vop (single-float-bits) - (:args (float :scs (single-reg))) - (:results (bits :scs (signed-reg))) - (:arg-types single-float) - (:result-types signed-num) - (:translate single-float-bits) - (:policy :fast-safe) - (:generator 2 - (inst mfc1 bits float) - (inst nop))) - -(define-vop (double-float-high-bits) - (:args (float :scs (double-reg))) - (:results (hi-bits :scs (signed-reg))) - (:arg-types double-float) - (:result-types signed-num) - (:translate double-float-high-bits) - (:policy :fast-safe) - (:generator 2 - (inst mfc1-odd hi-bits float) - (inst nop))) - -(define-vop (double-float-low-bits) - (:args (float :scs (double-reg))) - (:results (lo-bits :scs (unsigned-reg))) - (:arg-types double-float) - (:result-types unsigned-num) - (:translate double-float-low-bits) - (:policy :fast-safe) - (:generator 2 - (inst mfc1 lo-bits float) - (inst nop))) - - -;;;; Float mode hackery: - -(deftype float-modes () '(unsigned-byte 24)) -(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) - (:generator 3 - (inst cfc1 res 31) - (inst nop))) - -(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) - (:generator 3 - (inst ctc1 res 31) - (move res new))) diff --git a/compiler/mips/insts.lisp b/compiler/mips/insts.lisp deleted file mode 100644 index 89dde81a81d54757d2e5b0bbc1a7851368482c2e..0000000000000000000000000000000000000000 --- a/compiler/mips/insts.lisp +++ /dev/null @@ -1,1273 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/insts.lisp,v 1.43 1992/07/23 16:25:22 hallgren Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Description of the MIPS architecture. -;;; -;;; Written by William Lott -;;; -(in-package "MIPS") - -(use-package "NEW-ASSEM") -(use-package "EXT") -(use-package "C") - -(def-assembler-params - :scheduler-p nil) - - -;;;; Constants, types, conversion functions, some disassembler stuff. - -(defun reg-tn-encoding (tn) - (declare (type tn tn)) - (sc-case tn - (zero zero-offset) - (null null-offset) - (t - (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers) - (tn-offset tn) - (error "~S isn't a register." tn))))) - -(defun fp-reg-tn-encoding (tn) - (declare (type tn tn)) - (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers) - (error "~S isn't a floating-point register." tn)) - (tn-offset tn)) - -(disassem:set-disassem-params :instruction-alignment 32) - -(defvar *disassem-use-lisp-reg-names* t) - -(defconstant reg-symbols - (map 'vector - #'(lambda (name) - (cond ((null name) nil) - (t (make-symbol (concatenate 'string "$" name))))) - *register-names*)) - -(disassem:define-argument-type reg - :printer #'(lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref reg-symbols value))) - (princ regname stream) - (disassem:maybe-note-associated-storage-ref - value - 'registers - regname - dstate)))) - -(defconstant float-reg-symbols - (coerce - (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n))) - 'vector)) - -(disassem:define-argument-type fp-reg - :printer #'(lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref float-reg-symbols value))) - (princ regname stream) - (disassem:maybe-note-associated-storage-ref - value - 'float-registers - regname - dstate)))) - -(disassem:define-argument-type control-reg - :printer "(CR:#x~X)") - -(disassem:define-argument-type relative-label - :sign-extend t - :use-label #'(lambda (value dstate) - (declare (type (signed-byte 16) value) - (type disassem:disassem-state dstate)) - (+ (ash (1+ value) 2) (disassem:dstate-cur-addr dstate)))) - -(deftype float-format () - '(member :s :single :d :double :w :word)) - -(defun float-format-value (format) - (ecase format - ((:s :single) 0) - ((:d :double) 1) - ((:w :word) 4))) - -(disassem:define-argument-type float-format - :printer #'(lambda (value stream dstate) - (declare (ignore dstate) - (stream stream) - (fixnum value)) - (princ (case value - (0 's) - (1 'd) - (4 'w) - (t '?)) - stream))) - -(defconstant compare-kinds - '(:f :un :eq :ueq :olt :ult :ole :ule :sf :ngle :seq :ngl :lt :nge :le :ngt)) - -(defconstant compare-kinds-vec - (apply #'vector compare-kinds)) - -(deftype compare-kind () - `(member ,@compare-kinds)) - -(defun compare-kind (kind) - (or (position kind compare-kinds) - (error "Unknown floating point compare kind: ~S~%Must be one of: ~S" - kind - compare-kinds))) - -(disassem:define-argument-type compare-kind - :printer compare-kinds-vec) - -(defconstant float-operations '(+ - * /)) - -(deftype float-operation () - `(member ,@float-operations)) - -(defconstant float-operation-names - ;; this gets used for output only - #(add sub mul div)) - -(defun float-operation (op) - (or (position op float-operations) - (error "Unknown floating point operation: ~S~%Must be one of: ~S" - op - float-operations))) - -(disassem:define-argument-type float-operation - :printer float-operation-names) - - - -;;;; Constants used by instruction emitters. - -(defconstant special-op #b000000) -(defconstant bcond-op #b000001) -(defconstant cop0-op #b010000) -(defconstant cop1-op #b010001) -(defconstant cop2-op #b010010) -(defconstant cop3-op #b010011) - - - -;;;; dissassem:define-instruction-formats - -(defconstant immed-printer - '(:name :tab rt (:unless (:same-as rt) ", " rs) ", " immediate)) - -;;; for things that use rt=0 as a nop -(defconstant immed-zero-printer - '(:name :tab rt (:unless (:constant 0) ", " rs) ", " immediate)) - -(disassem:define-instruction-format - (immediate 32 :default-printer immed-printer) - (op :field (byte 6 26)) - (rs :field (byte 5 21) :type 'reg) - (rt :field (byte 5 16) :type 'reg) - (immediate :field (byte 16 0) :sign-extend t)) - -(defconstant jump-printer - #'(lambda (value stream dstate) - (let ((addr (ash value 2))) - (disassem:maybe-note-assembler-routine addr dstate) - (write addr :base 16 :radix t :stream stream)))) - -(disassem:define-instruction-format - (jump 32 :default-printer '(:name :tab target)) - (op :field (byte 6 26)) - (target :field (byte 26 0) :printer jump-printer)) - -(defconstant reg-printer - '(:name :tab rd (:unless (:same-as rd) ", " rs) ", " rt)) - -(disassem:define-instruction-format - (register 32 :default-printer reg-printer) - (op :field (byte 6 26)) - (rs :field (byte 5 21) :type 'reg) - (rt :field (byte 5 16) :type 'reg) - (rd :field (byte 5 11) :type 'reg) - (shamt :field (byte 5 6) :value 0) - (funct :field (byte 6 0))) - -(disassem:define-instruction-format - (break 32 :default-printer - '(:name :tab code (:unless (:constant 0) subcode))) - (op :field (byte 6 26) :value special-op) - (code :field (byte 10 16)) - (subcode :field (byte 10 6) :value 0) - (funct :field (byte 6 0) :value #b001101)) - -(disassem:define-instruction-format - (coproc-branch 32 :default-printer '(:name :tab offset)) - (op :field (byte 6 26)) - (funct :field (byte 10 16)) - (offset :field (byte 16 0))) - -(defconstant float-fmt-printer - '((:unless :constant funct) - (:choose (:unless :constant sub-funct) nil) - "." format)) - -(defconstant float-printer - `(:name ,@float-fmt-printer - :tab - fd - (:unless (:same-as fd) ", " fs) - ", " ft)) - -(disassem:define-instruction-format - (float 32 :default-printer float-printer) - (op :field (byte 6 26) :value cop1-op) - (filler :field (byte 1 25) :value 1) - (format :field (byte 4 21) :type 'float-format) - (ft :field (byte 5 16) :value 0) - (fs :field (byte 5 11) :type 'fp-reg) - (fd :field (byte 5 6) :type 'fp-reg) - (funct :field (byte 6 0))) - -(disassem:define-instruction-format - (float-aux 32 :default-printer float-printer) - (op :field (byte 6 26) :value cop1-op) - (filler-1 :field (byte 1 25) :value 1) - (format :field (byte 4 21) :type 'float-format) - (ft :field (byte 5 16) :type 'fp-reg) - (fs :field (byte 5 11) :type 'fp-reg) - (fd :field (byte 5 6) :type 'fp-reg) - (funct :field (byte 2 4)) - (sub-funct :field (byte 4 0))) - - - -;;;; Primitive emitters. - -(define-emitter emit-word 32 - (byte 32 0)) - -(define-emitter emit-short 16 - (byte 16 0)) - -(define-emitter emit-immediate-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0)) - -(define-emitter emit-jump-inst 32 - (byte 6 26) (byte 26 0)) - -(define-emitter emit-register-inst 32 - (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 6 0)) - -(define-emitter emit-break-inst 32 - (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0)) - -(define-emitter emit-float-inst 32 - (byte 6 26) (byte 1 25) (byte 4 21) (byte 5 16) - (byte 5 11) (byte 5 6) (byte 6 0)) - - - -;;;; Math instructions. - -(defun emit-math-inst (segment dst src1 src2 reg-opcode immed-opcode - &optional allow-fixups) - (unless src2 - (setf src2 src1) - (setf src1 dst)) - (etypecase src2 - (tn - (emit-register-inst segment special-op (reg-tn-encoding src1) - (reg-tn-encoding src2) (reg-tn-encoding dst) - 0 reg-opcode)) - (integer - (emit-immediate-inst segment immed-opcode (reg-tn-encoding src1) - (reg-tn-encoding dst) src2)) - (fixup - (unless allow-fixups - (error "Fixups aren't allowed.")) - (note-fixup segment :addi src2) - (emit-immediate-inst segment immed-opcode (reg-tn-encoding src1) - (reg-tn-encoding dst) 0)))) - -(define-instruction add (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn (signed-byte 16) null) src1 src2)) - (:printer register ((op special-op) (funct #b100000))) - (:printer immediate ((op #b001000))) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-math-inst segment dst src1 src2 #b100000 #b001000))) - -(define-instruction addu (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn (signed-byte 16) fixup null) src1 src2)) - (:printer register ((op special-op) (funct #b100001))) - (:printer immediate ((op #b001001))) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-math-inst segment dst src1 src2 #b100001 #b001001 t))) - -(define-instruction sub (segment dst src1 &optional src2) - (:declare - (type tn dst) - (type (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) null) src1 src2)) - (:printer register ((op special-op) (funct #b100010))) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (unless src2 - (setf src2 src1) - (setf src1 dst)) - (emit-math-inst segment dst src1 - (if (integerp src2) (- src2) src2) - #b100010 #b001000))) - -(define-instruction subu (segment dst src1 &optional src2) - (:declare - (type tn dst) - (type - (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) fixup null) src1 src2)) - (:printer register ((op special-op) (funct #b100011))) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (unless src2 - (setf src2 src1) - (setf src1 dst)) - (emit-math-inst segment dst src1 - (if (integerp src2) (- src2) src2) - #b100011 #b001001 t))) - -(define-instruction and (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn (unsigned-byte 16) null) src1 src2)) - (:printer register ((op special-op) (funct #b100100))) - (:printer immediate ((op #b001100) (immediate nil :sign-extend nil))) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-math-inst segment dst src1 src2 #b100100 #b001100))) - -(define-instruction or (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn (unsigned-byte 16) null) src1 src2)) - (:printer register ((op special-op) (funct #b100101))) - (:printer immediate ((op #b001101))) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-math-inst segment dst src1 src2 #b100101 #b001101))) - -(define-instruction xor (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn (unsigned-byte 16) null) src1 src2)) - (:printer register ((op special-op) (funct #b100110))) - (:printer immediate ((op #b001110))) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-math-inst segment dst src1 src2 #b100110 #b001110))) - -(define-instruction nor (segment dst src1 &optional src2) - (:declare (type tn dst src1) (type (or tn null) src2)) - (:printer register ((op special-op) (funct #b100111))) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-math-inst segment dst src1 src2 #b100111 #b000000))) - -(define-instruction slt (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn (signed-byte 16) null) src1 src2)) - (:printer register ((op special-op) (funct #b101010))) - (:printer immediate ((op #b001010))) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-math-inst segment dst src1 src2 #b101010 #b001010))) - -(define-instruction sltu (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn (signed-byte 16) null) src1 src2)) - (:printer register ((op special-op) (funct #b101011))) - (:printer immediate ((op #b001011))) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-math-inst segment dst src1 src2 #b101011 #b001011))) - -(defconstant divmul-printer '(:name :tab rs ", " rt)) - -(define-instruction div (segment src1 src2) - (:declare (type tn src1 src2)) - (:printer register ((op special-op) (rd 0) (funct #b011010)) divmul-printer) - (:reads (list src1 src2)) - (:writes (list :hi-reg :low-reg)) - (:delay 1) - (:emitter - (emit-register-inst segment special-op (reg-tn-encoding src1) - (reg-tn-encoding src2) 0 0 #b011010))) - -(define-instruction divu (segment src1 src2) - (:declare (type tn src1 src2)) - (:printer register ((op special-op) (rd 0) (funct #b011011)) - divmul-printer) - (:reads (list src1 src2)) - (:writes (list :hi-reg :low-reg)) - (:delay 1) - (:emitter - (emit-register-inst segment special-op (reg-tn-encoding src1) - (reg-tn-encoding src2) 0 0 #b011011))) - -(define-instruction mult (segment src1 src2) - (:declare (type tn src1 src2)) - (:printer register ((op special-op) (rd 0) (funct #b011000)) divmul-printer) - (:reads (list src1 src2)) - (:writes (list :hi-reg :low-reg)) - (:delay 1) - (:emitter - (emit-register-inst segment special-op (reg-tn-encoding src1) - (reg-tn-encoding src2) 0 0 #b011000))) - -(define-instruction multu (segment src1 src2) - (:declare (type tn src1 src2)) - (:printer register ((op special-op) (rd 0) (funct #b011001))) - (:reads (list src1 src2)) - (:writes :hi-reg :low-reg) - (:delay 1) - (:emitter - (emit-register-inst segment special-op (reg-tn-encoding src1) - (reg-tn-encoding src2) 0 0 #b011001))) - -(defun emit-shift-inst (segment opcode dst src1 src2) - (unless src2 - (setf src2 src1) - (setf src1 dst)) - (etypecase src2 - (tn - (emit-register-inst segment special-op (reg-tn-encoding src2) - (reg-tn-encoding src1) (reg-tn-encoding dst) - 0 (logior #b000100 opcode))) - ((unsigned-byte 5) - (emit-register-inst segment special-op 0 (reg-tn-encoding src1) - (reg-tn-encoding dst) src2 opcode)))) - -(defconstant shift-printer - '(:name :tab - rd - (:unless (:same-as rd) ", " rt) - ", " (:cond ((rs :constant 0) shamt) - (t rs)))) - -(define-instruction sll (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn (unsigned-byte 5) null) src1 src2)) - (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000000)) - shift-printer) - (:printer register ((op special-op) (funct #b000100)) shift-printer) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-shift-inst segment #b00 dst src1 src2))) - -(define-instruction sra (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn (unsigned-byte 5) null) src1 src2)) - (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000011)) - shift-printer) - (:printer register ((op special-op) (funct #b000111)) shift-printer) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-shift-inst segment #b11 dst src1 src2))) - -(define-instruction srl (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn (unsigned-byte 5) null) src1 src2)) - (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000010)) - shift-printer) - (:printer register ((op special-op) (funct #b000110)) shift-printer) - (:reads (if src2 (list src1 src2) (list dst src1))) - (:writes dst) - (:emitter - (emit-shift-inst segment #b10 dst src1 src2))) - - -;;;; Floating point math. - -(define-instruction float-op (segment operation format dst src1 src2) - (:declare (type float-operation operation) - (type float-format format) - (type tn dst src1 src2)) - (:reads (list src1 src2)) - (:writes dst) - (:emitter - (emit-float-inst segment cop1-op 1 (float-format-value format) - (fp-reg-tn-encoding src2) (fp-reg-tn-encoding src1) - (fp-reg-tn-encoding dst) (float-operation operation)))) - -(defconstant float-unop-printer - `(:name ,@float-fmt-printer :tab fd (:unless (:same-as fd) ", " fs))) - -(define-instruction fabs (segment format dst &optional (src dst)) - (:declare (type float-format format) (type tn dst src)) -; (:printer float ((funct #b000101)) float-unop-printer) - (:reads src) - (:writes dst) - (:emitter - (emit-float-inst segment cop1-op 1 (float-format-value format) - 0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst) - #b000101))) - -(define-instruction fneg (segment format dst &optional (src dst)) - (:declare (type float-format format) (type tn dst src)) -; (:printer float ((funct #b000111)) float-unop-printer) - (:reads src) - (:writes dst) - (:emitter - (emit-float-inst segment cop1-op 1 (float-format-value format) - 0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst) - #b000111))) - -(define-instruction fcvt (segment format1 format2 dst src) - (:declare (type float-format format1 format2) (type tn dst src)) - (:printer float-aux ((funct #b10) (sub-funct nil :type 'float-format)) - `(:name "." sub-funct "." format :tab fd ", " fs)) - (:reads src) - (:writes dst) - (:emitter - (emit-float-inst segment cop1-op 1 (float-format-value format2) 0 - (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst) - (logior #b100000 (float-format-value format1))))) - -(define-instruction fcmp (segment operation format fs ft) - (:declare (type compare-kind operation) - (type float-format format) - (type tn fs ft)) - (:printer float-aux ((fd 0) (funct #b11) (sub-funct nil :type 'compare-kind)) - `(:name "-" sub-funct "." format :tab fs ", " ft)) - (:reads (list fs ft)) - (:writes :float-status) - (:delay 1) - (:emitter - (emit-float-inst segment cop1-op 1 (float-format-value format) - (fp-reg-tn-encoding ft) (fp-reg-tn-encoding fs) 0 - (logior #b110000 (compare-kind operation))))) - - -;;;; Branch/Jump instructions. - -(defun emit-relative-branch (segment opcode r1 r2 target) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (emit-immediate-inst segment - opcode - (if (fixnump r1) - r1 - (reg-tn-encoding r1)) - (if (fixnump r2) - r2 - (reg-tn-encoding r2)) - (ash (- (label-position target) - (+ posn 4)) - -2))))) - -(define-instruction b (segment target) - (:declare (type label target)) - (:printer immediate ((op #b000100) (rs 0) (rt 0) - (immediate nil :type 'relative-label)) - '(:name :tab immediate)) - (:attributes branch) - (:delay 1) - (:emitter - (emit-relative-branch segment #b000100 0 0 target))) - - -(define-instruction beq (segment r1 r2-or-target &optional target) - (:declare (type tn r1) - (type (or tn fixnum label) r2-or-target) - (type (or label null) target)) - (:printer immediate ((op #b000100) (immediate nil :type 'relative-label))) - (:attributes branch) - (:delay 1) - (:reads (list r1 r2-or-target)) - (:emitter - (unless target - (setf target r2-or-target) - (setf r2-or-target 0)) - (emit-relative-branch segment #b000100 r1 r2-or-target target))) - -(define-instruction bne (segment r1 r2-or-target &optional target) - (:declare (type tn r1) - (type (or tn fixnum label) r2-or-target) - (type (or label null) target)) - (:printer immediate ((op #b000101) (immediate nil :type 'relative-label))) - (:attributes branch) - (:delay 1) - (:reads (list r1 r2-or-target)) - (:emitter - (unless target - (setf target r2-or-target) - (setf r2-or-target 0)) - (emit-relative-branch segment #b000101 r1 r2-or-target target))) - -(defconstant cond-branch-printer - '(:name :tab rs ", " immediate)) - -(define-instruction blez (segment reg target) - (:declare (type label target) (type tn reg)) - (:printer - immediate ((op #b000110) (rt 0) (immediate nil :type 'relative-label)) - cond-branch-printer) - (:attributes branch) - (:delay 1) - (:reads reg) - (:emitter - (emit-relative-branch segment #b000110 reg 0 target))) - -(define-instruction bgtz (segment reg target) - (:declare (type label target) (type tn reg)) - (:printer - immediate ((op #b000111) (rt 0) (immediate nil :type 'relative-label)) - cond-branch-printer) - (:attributes branch) - (:delay 1) - (:reads reg) - (:emitter - (emit-relative-branch segment #b000111 reg 0 target))) - -(define-instruction bltz (segment reg target) - (:declare (type label target) (type tn reg)) - (:printer - immediate ((op bcond-op) (rt 0) (immediate nil :type 'relative-label)) - cond-branch-printer) - (:attributes branch) - (:delay 1) - (:reads reg) - (:emitter - (emit-relative-branch segment bcond-op reg #b00000 target))) - -(define-instruction bgez (segment reg target) - (:declare (type label target) (type tn reg)) - (:printer - immediate ((op bcond-op) (rt 1) (immediate nil :type 'relative-label)) - cond-branch-printer) - (:attributes branch) - (:delay 1) - (:reads reg) - (:emitter - (emit-relative-branch segment bcond-op reg #b00001 target))) - -(define-instruction bltzal (segment reg target) - (:declare (type label target) (type tn reg)) - (:printer - immediate ((op bcond-op) (rt #b01000) (immediate nil :type 'relative-label)) - cond-branch-printer) - (:attributes branch) - (:delay 1) - (:reads reg) - (:writes :r31) - (:emitter - (emit-relative-branch segment bcond-op reg #b01000 target))) - -(define-instruction bgezal (segment reg target) - (:declare (type label target) (type tn reg)) - (:printer - immediate ((op bcond-op) (rt #b01001) (immediate nil :type 'relative-label)) - cond-branch-printer) - (:attributes branch) - (:delay 1) - (:reads reg) - (:writes :r31) - (:emitter - (emit-relative-branch segment bcond-op reg #b01001 target))) - -(defconstant j-printer - '(:name :tab (:choose rs target))) - -(define-instruction j (segment target) - (:declare (type (or tn fixup) target)) - (:printer register ((op special-op) (rt 0) (rd 0) (funct #b001000)) j-printer) - (:printer jump ((op #b000010)) j-printer) - (:attributes branch) - (:delay 1) - (:emitter - (etypecase target - (tn - (emit-register-inst segment special-op (reg-tn-encoding target) - 0 0 0 #b001000)) - (fixup - (note-fixup segment :jump target) - (emit-jump-inst segment #b000010 0))))) - -(define-instruction jal (segment reg-or-target &optional target) - (:declare (type (or null tn fixup) target) - (type (or tn fixup (integer -16 31)) reg-or-target)) - (:printer register ((op special-op) (rt 0) (funct #b001001)) j-printer) - (:printer jump ((op #b000011)) j-printer) - (:attributes branch) - (:delay 1) - (:writes (if target reg-or-target :r31)) ; ### fix this - (:emitter - (unless target - (setf target reg-or-target) - (setf reg-or-target 31)) - (etypecase target - (tn - (emit-register-inst segment special-op (reg-tn-encoding target) 0 - reg-or-target 0 #b001001)) - (fixup - (note-fixup segment :jump target) - (emit-jump-inst segment #b000011 0))))) - -(define-instruction bc1f (segment target) - (:declare (type label target)) - (:printer coproc-branch ((op cop1-op) (funct #x100) - (offset nil :type 'relative-label))) - (:reads :float-status) - (:attributes branch) - (:delay 1) - (:emitter - (emit-relative-branch segment cop1-op #b01000 #b00000 target))) - -(define-instruction bc1t (segment target) - (:declare (type label target)) - (:printer coproc-branch ((op cop1-op) (funct #x101) - (offset nil :type 'relative-label))) - (:reads :float-status) - (:attributes branch) - (:delay 1) - (:emitter - (emit-relative-branch segment cop1-op #b01000 #b00001 target))) - - - -;;;; Random movement instructions. - -(eval-when (compile load eval) - (defun lui-arg-printer (value stream dstate) - (declare (ignore dstate)) - (format stream "#x~4,'0X" value))) - -(define-instruction lui (segment reg value) - (:declare (type tn reg) - (type (or fixup (signed-byte 16) (unsigned-byte 16)) value)) - (:printer immediate ((op #b001111) (immed nil :printer #'lui-arg-printer))) - (:writes reg) - (:emitter - (when (fixup-p value) - (note-fixup segment :lui value) - (setf value 0)) - (emit-immediate-inst segment #b001111 0 (reg-tn-encoding reg) value))) - -(defconstant mvsreg-printer '(:name :tab rd)) - -(define-instruction mfhi (segment reg) - (:declare (type tn reg)) - (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010000)) - mvsreg-printer) - (:reads :hi-reg) - (:writes reg) - (:delay 2) - (:emitter - (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0 - #b010000))) - -(define-instruction mthi (segment reg) - (:declare (type tn reg)) - (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010001)) - mvsreg-printer) - (:reads reg) - (:writes :hi-reg) - (:emitter - (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0 - #b010001))) - -(define-instruction mflo (segment reg) - (:declare (type tn reg)) - (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010010)) - mvsreg-printer) - (:reads :low-reg) - (:writes reg) - (:delay 2) - (:emitter - (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0 - #b010010))) - -(define-instruction mtlo (segment reg) - (:declare (type tn reg)) - (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010011)) - mvsreg-printer) - (:reads reg) - (:writes :low-reg) - (:emitter - (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0 - #b010011))) - -(define-instruction move (segment dst src) - (:declare (type tn dst src)) - (:printer register ((op special-op) (rt 0) (funct #b100001)) - '(:name :tab rd ", " rs)) - (:reads src) - (:writes dst) - (:attributes flushable) - (:emitter - (emit-register-inst segment special-op (reg-tn-encoding src) 0 - (reg-tn-encoding dst) 0 #b100001))) - -(define-instruction fmove (segment format dst src) - (:declare (type float-format format) (type tn dst src)) - (:printer float ((funct #b000110)) '(:name :tab fd ", " fs)) - (:reads src) - (:writes dst) - (:attributes flushable) - (:emitter - (emit-float-inst segment cop1-op 1 (float-format-value format) 0 - (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst) - #b000110))) - -(defun %li (reg value) - (etypecase value - ((unsigned-byte 16) - (inst or reg zero-tn value)) - ((signed-byte 16) - (inst addu reg zero-tn value)) - ((or (signed-byte 32) (unsigned-byte 32)) - (inst lui reg (ldb (byte 16 16) value)) - (inst or reg (ldb (byte 16 0) value))) - (fixup - (inst lui reg value) - (inst addu reg value)))) - -(define-instruction-macro li (reg value) - `(%li ,reg ,value)) - -(defconstant sub-op-printer '(:name :tab rd ", " rt)) - -(define-instruction mtc1 (segment to from) - (:declare (type tn to from)) - (:printer register ((op cop1-op) (rs #b00100) (funct 0)) sub-op-printer) - (:reads from) - (:writes to) - (:delay 1) - (:emitter - (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from) - (fp-reg-tn-encoding to) 0 0))) - -(define-instruction mtc1-odd (segment to from) - (:declare (type tn to from)) - (:reads from) - (:writes to) - (:delay 1) - (:emitter - (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from) - (1+ (fp-reg-tn-encoding to)) 0 0))) - -(define-instruction mfc1 (segment to from) - (:declare (type tn to from)) - (:printer register ((op cop1-op) (rs 0) (rd nil :type 'fp-reg) (funct 0)) - sub-op-printer) - (:reads from) - (:writes to) - (:emitter - (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to) - (fp-reg-tn-encoding from) 0 0))) - -(define-instruction mfc1-odd (segment to from) - (:declare (type tn to from)) - (:reads from) - (:writes to) - (:emitter - (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to) - (1+ (fp-reg-tn-encoding from)) 0 0))) - -(define-instruction cfc1 (segment reg cr) - (:declare (type tn reg) (type (unsigned-byte 5) cr)) - (:printer register ((op cop1-op) (rs #b00010) (rd nil :type 'control-reg) - (funct 0)) sub-op-printer) - (:reads nil) ;; ### fix this - (:writes reg) - (:emitter - (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding reg) - cr 0 0))) - -(define-instruction ctc1 (segment reg cr) - (:declare (type tn reg) (type (unsigned-byte 5) cr)) - (:printer register ((op cop1-op) (rs #b00110) (rd nil :type 'control-reg) - (funct 0)) sub-op-printer) - (:reads reg) - (:writes nil) ;; ### fix this - (:emitter - (emit-register-inst segment cop1-op #b00110 (reg-tn-encoding reg) - cr 0 0))) - - - -;;;; Random system hackery and other noise - -(define-instruction-macro entry-point () - nil) - -(define-emitter emit-break-inst 32 - (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0)) - -(defun snarf-error-junk (sap offset &optional length-only) - (let* ((length (system:sap-ref-8 sap offset)) - (vector (make-array length :element-type '(unsigned-byte 8)))) - (declare (type system:system-area-pointer sap) - (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) - (cond (length-only - (values 0 (1+ length) nil nil)) - (t - (kernel:copy-from-system-area sap (* mips:byte-bits (1+ offset)) - vector (* mips:word-bits - mips:vector-data-offset) - (* length mips:byte-bits)) - (collect ((sc-offsets) - (lengths)) - (lengths 1) ; the length byte - (let* ((index 0) - (error-number (c::read-var-integer vector index))) - (lengths index) - (loop - (when (>= index length) - (return)) - (let ((old-index index)) - (sc-offsets (c::read-var-integer vector index)) - (lengths (- index old-index)))) - (values error-number - (1+ length) - (sc-offsets) - (lengths)))))))) - -(defmacro break-cases (breaknum &body cases) - (let ((bn-temp (gensym))) - (collect ((clauses)) - (dolist (case cases) - (clauses `((= ,bn-temp ,(car case)) ,@(cdr case)))) - `(let ((,bn-temp ,breaknum)) - (cond ,@(clauses)))))) - -(defun break-control (chunk inst stream dstate) - (declare (ignore inst)) - (flet ((nt (x) (if stream (disassem:note x dstate)))) - (case (break-code chunk dstate) - (#.vm:error-trap - (nt "Error trap") - (disassem:handle-break-args #'snarf-error-junk stream dstate)) - (#.vm:cerror-trap - (nt "Cerror trap") - (disassem:handle-break-args #'snarf-error-junk stream dstate)) - (#.vm:breakpoint-trap - (nt "Breakpoint trap")) - (#.vm:pending-interrupt-trap - (nt "Pending interrupt trap")) - (#.vm:halt-trap - (nt "Halt trap")) - (#.vm:function-end-breakpoint-trap - (nt "Function end breakpoint trap")) - ))) - -(define-instruction break (segment code &optional (subcode 0)) - (:declare (type (unsigned-byte 10) code subcode)) - (:printer break ((op special-op) (funct #b001101)) - '(:name :tab code (:unless (:constant 0) subcode)) - :control #'break-control ) - :pinned - (:emitter - (emit-break-inst segment special-op code subcode #b001101))) - -(define-instruction syscall (segment) - :pinned - (:printer register ((op special-op) (rd 0) (rt 0) (rs 0) (funct #b001100)) - '(:name)) - (:emitter - (emit-register-inst segment special-op 0 0 0 0 #b001100))) - -(define-instruction nop (segment) - (:attributes flushable) - (:printer register ((op 0) (rd 0) (rd 0) (rs 0) (funct 0)) '(:name)) - (:emitter - (emit-word segment 0))) - -(define-instruction word (segment word) - (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word)) - :pinned - (:emitter - (emit-word segment word))) - -(define-instruction short (segment short) - (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short)) - :pinned - (:emitter - (emit-short segment short))) - -(define-instruction byte (segment byte) - (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte)) - :pinned - (:emitter - (emit-byte segment byte))) - - -(defun emit-header-data (segment type) - (emit-back-patch - segment 4 - #'(lambda (segment posn) - (emit-word segment - (logior type - (ash (+ posn (component-header-length)) - (- type-bits word-shift))))))) - -(define-instruction function-header-word (segment) - :pinned - (:emitter - (emit-header-data segment function-header-type))) - -(define-instruction lra-header-word (segment) - :pinned - (:emitter - (emit-header-data segment return-pc-header-type))) - - -(defun emit-compute-inst (segment vop dst src label temp calc) - (emit-chooser - ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments. - segment 12 3 - #'(lambda (segment posn delta-if-after) - (let ((delta (funcall calc label posn delta-if-after))) - (when (<= (- (ash 1 15)) delta (1- (ash 1 15))) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (assemble (segment vop) - (inst addu dst src - (funcall calc label posn 0))))) - t))) - #'(lambda (segment posn) - (let ((delta (funcall calc label posn 0))) - (assemble (segment vop) - (inst lui temp (ldb (byte 16 16) delta)) - (inst or temp (ldb (byte 16 0) delta)) - (inst addu dst src temp)))))) - -;; code = fn - header - label-offset + other-pointer-tag -(define-instruction compute-code-from-fn (segment dst src label temp) - (:declare (type tn dst src temp) (type label label)) - (:reads src) - (:writes (list dst temp)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (- other-pointer-type - (label-position label posn delta-if-after) - (component-header-length)))))) - -;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag -(define-instruction compute-code-from-lra (segment dst src label temp) - (:declare (type tn dst src temp) (type label label)) - (:reads src) - (:writes (list dst temp)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (- (+ (label-position label posn delta-if-after) - (component-header-length))))))) - -;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag -(define-instruction compute-lra-from-code (segment dst src label temp) - (:declare (type tn dst src temp) (type label label)) - (:reads src) - (:writes (list dst temp)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (+ (label-position label posn delta-if-after) - (component-header-length)))))) - - -;;;; Loads and Stores - -(defun emit-load/store-inst (segment opcode reg base index) - (when (fixup-p index) - (note-fixup segment :addi index) - (setf index 0)) - (emit-immediate-inst segment opcode (reg-tn-encoding reg) - (reg-tn-encoding base) index)) - -(defconstant load-store-printer - '(:name :tab - rt ", " - rs - (:unless (:constant 0) "[" immediate "]"))) - -(define-instruction lb (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b100000)) load-store-printer) - (:reads (list base :memory)) - (:writes reg) - (:delay 1) - (:emitter - (emit-load/store-inst segment #b100000 base reg index))) - -(define-instruction lh (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b100001)) load-store-printer) - (:reads (list base :memory)) - (:writes reg) - (:delay 1) - (:emitter - (emit-load/store-inst segment #b100001 base reg index))) - -(define-instruction lwl (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b100010)) load-store-printer) - (:reads (list base :memory)) - (:writes reg) - (:delay 1) - (:emitter - (emit-load/store-inst segment #b100010 base reg index))) - -(define-instruction lw (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b100011)) load-store-printer) - (:reads (list base :memory)) - (:writes reg) - (:delay 1) - (:emitter - (emit-load/store-inst segment #b100011 base reg index))) - -(define-instruction lbu (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b100100)) load-store-printer) - (:reads (list base :memory)) - (:writes reg) - (:delay 1) - (:emitter - (emit-load/store-inst segment #b100100 base reg index))) - -(define-instruction lhu (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b100101)) load-store-printer) - (:reads (list base :memory)) - (:writes reg) - (:delay 1) - (:emitter - (emit-load/store-inst segment #b100101 base reg index))) - -(define-instruction lwr (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b100110)) load-store-printer) - (:reads (list base :memory)) - (:writes reg) - (:delay 1) - (:emitter - (emit-load/store-inst segment #b100110 base reg index))) - -(define-instruction sb (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b101000)) load-store-printer) - (:reads base reg) - (:writes :memory) - (:emitter - (emit-load/store-inst segment #b101000 base reg index))) - -(define-instruction sh (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b101001)) load-store-printer) - (:reads base reg) - (:writes :memory) - (:emitter - (emit-load/store-inst segment #b101001 base reg index))) - -(define-instruction swl (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b101010)) load-store-printer) - (:reads base reg) - (:writes :memory) - (:emitter - (emit-load/store-inst segment #b101010 base reg index))) - -(define-instruction sw (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b101011)) load-store-printer) - (:reads base reg) - (:writes :memory) - (:emitter - (emit-load/store-inst segment #b101011 base reg index))) - -(define-instruction swr (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b101110)) load-store-printer) - (:reads base reg) - (:writes :memory) - (:emitter - (emit-load/store-inst segment #b101110 base reg index))) - - -(defun emit-fp-load/store-inst (segment opcode reg odd base index) - (when (fixup-p index) - (note-fixup segment :addi index) - (setf index 0)) - (emit-immediate-inst segment opcode (reg-tn-encoding base) - (+ (fp-reg-tn-encoding reg) odd) index)) - -(define-instruction lwc1 (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b110001) (rt nil :type 'fp-reg)) load-store-printer) - (:reads base :memory) - (:writes reg) - (:delay 1) - (:emitter - (emit-fp-load/store-inst segment #b110001 reg 0 base index))) - -(define-instruction lwc1-odd (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:reads base :memory) - (:writes reg) - (:delay 1) - (:emitter - (emit-fp-load/store-inst segment #b110001 reg 1 base index))) - -(define-instruction swc1 (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:printer immediate ((op #b111001) (rt nil :type 'fp-reg)) load-store-printer) - (:reads base reg) - (:writes :memory) - (:emitter - (emit-fp-load/store-inst segment #b111001 reg 0 base index))) - -(define-instruction swc1-odd (segment reg base &optional (index 0)) - (:declare (type tn reg base) - (type (or (signed-byte 16) fixup) index)) - (:reads base reg) - (:writes :memory) - (:emitter - (emit-fp-load/store-inst segment #b111001 reg 1 base index))) diff --git a/compiler/mips/macros.lisp b/compiler/mips/macros.lisp deleted file mode 100644 index 57bb6e300b8e6cc74121a2d0577c2d61ad8aab16..0000000000000000000000000000000000000000 --- a/compiler/mips/macros.lisp +++ /dev/null @@ -1,485 +0,0 @@ -;;; -*- Package: MIPS; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/mips/macros.lisp,v 1.48 1993/01/13 16:08:25 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains various useful macros for generating MIPS code. -;;; -;;; Written by William Lott and Christopher Hoover. -;;; - -(in-package "MIPS") - -;;; Handy macro for defining top-level forms that depend on the compile -;;; environment. - -(defmacro expand (expr) - (let ((gensym (gensym))) - `(macrolet - ((,gensym () - ,expr)) - (,gensym)))) - - -;;; Instruction-like macros. - -(defmacro move (dst src &optional (always-emit-code-p nil)) - "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P - is nil)." - (once-only ((n-dst dst) - (n-src src)) - (if always-emit-code-p - `(inst move ,n-dst ,n-src) - `(unless (location= ,n-dst ,n-src) - (inst move ,n-dst ,n-src))))) - -(defmacro def-mem-op (op inst shift load) - `(defmacro ,op (object base &optional (offset 0) (lowtag 0)) - `(progn - (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)) - ,,@(when load '('(inst nop)))))) -;;; -(def-mem-op loadw lw word-shift t) -(def-mem-op storew sw word-shift nil) -#+gengc -(def-mem-op storew-and-remember-slot sw-and-remember-slot word-shift nil) -#+gengc -(def-mem-op storew-and-remember-object sw-and-remember-object word-shift nil) - -(defmacro load-symbol (reg symbol) - `(inst addu ,reg null-tn (static-symbol-offset ,symbol))) - -#-gengc -(defmacro load-symbol-value (reg symbol) - `(progn - (inst lw ,reg null-tn - (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-type))) - (inst nop))) -#-gengc -(defmacro store-symbol-value (reg symbol) - `(inst sw ,reg null-tn - (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-type)))) - -(defmacro load-type (target source &optional (offset 0)) - "Loads the type bits of a pointer into target independent of - byte-ordering issues." - (once-only ((n-target target) - (n-source source) - (n-offset offset)) - (ecase (backend-byte-order *backend*) - (:little-endian - `(inst lbu ,n-target ,n-source ,n-offset )) - (:big-endian - `(inst lbu ,n-target ,n-source (+ ,n-offset 3)))))) - - -;;; Macros to handle the fact that we cannot use the machine native call and -;;; return instructions. - -#-gengc -(defmacro lisp-jump (function lip) - "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." - `(progn - (inst addu ,lip ,function (- (ash vm:function-header-code-offset - vm:word-shift) - vm:function-pointer-type)) - (inst j ,lip) - (move code-tn ,function))) - -#-gengc -(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) - "Return to RETURN-PC. LIP is an interior-reg temporary." - `(progn - (inst addu ,lip ,return-pc - (- (* (1+ ,offset) word-bytes) other-pointer-type)) - (inst j ,lip) - ,(if frob-code - `(move code-tn ,return-pc) - '(inst nop)))) - - -(defmacro emit-return-pc (label) - "Emit a return-pc header word. LABEL is the label to use for this return-pc." - `(progn - #-gengc - (align lowtag-bits) - (emit-label ,label) - #-gengc - (inst lra-header-word))) - - - -;;;; Stack TN's - -;;; Load-Stack-TN, Store-Stack-TN -- Interface -;;; -;;; Move a stack TN to a register and vice-versa. -;;; -(defmacro load-stack-tn (reg stack) - `(let ((reg ,reg) - (stack ,stack)) - (let ((offset (tn-offset stack))) - (sc-case stack - ((control-stack) - (loadw reg cfp-tn offset)))))) - -(defmacro store-stack-tn (stack reg) - `(let ((stack ,stack) - (reg ,reg)) - (let ((offset (tn-offset stack))) - (sc-case stack - ((control-stack) - (storew reg cfp-tn offset)))))) - - -;;; MAYBE-LOAD-STACK-TN -- Interface -;;; -(defmacro maybe-load-stack-tn (reg reg-or-stack) - "Move the TN Reg-Or-Stack into Reg if it isn't already there." - (once-only ((n-reg reg) - (n-stack reg-or-stack)) - `(sc-case ,n-reg - ((any-reg descriptor-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg) - (move ,n-reg ,n-stack)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) - - -;;;; Storage allocation: - -#-gengc -(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size) - &body body) - "Do stuff to allocate an other-pointer object of fixed Size with a single - word header having the specified Type-Code. The result is placed in - Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non- - descriptor temp (which may be randomly used by the body.) The body is - placed inside the PSEUDO-ATOMIC, and presumably initializes the object." - `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) - (inst or ,result-tn alloc-tn other-pointer-type) - (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code)) - (storew ,temp-tn ,result-tn 0 other-pointer-type) - ,@body)) - -#+gengc -(defun fixed-allocate (result temp type-code size) - (assemble () - (without-scheduling () - (inst li temp (logior (ash (1- size) type-bits) type-code)) - (inst or result alloc-tn other-pointer-type) - (inst sw temp alloc-tn) - (inst addu alloc-tn alloc-tn (pad-data-block size))))) - -#+gengc -(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size) - &body body) - (declare (ignore flag-tn)) - `(progn - (fixed-allocate ,result-tn ,temp-tn ,type-code ,size) - ,@body)) - - -;;;; Three Way Comparison - -(defun three-way-comparison (x y condition flavor not-p target temp) - (ecase condition - (:eq - (if not-p - (inst bne x y target) - (inst beq x y target))) - (:lt - (ecase flavor - (:unsigned - (inst sltu temp x y)) - (:signed - (inst slt temp x y))) - (if not-p - (inst beq temp zero-tn target) - (inst bne temp zero-tn target))) - (:gt - (ecase flavor - (:unsigned - (inst sltu temp y x)) - (:signed - (inst slt temp y x))) - (if not-p - (inst beq temp zero-tn target) - (inst bne temp zero-tn target)))) - (inst nop)) - - - -;;;; Error Code - - -(defvar *adjustable-vectors* nil) - -(defmacro with-adjustable-vector ((var) &rest body) - `(let ((,var (or (pop *adjustable-vectors*) - (make-array 16 - :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t)))) - (setf (fill-pointer ,var) 0) - (unwind-protect - (progn - ,@body) - (push ,var *adjustable-vectors*)))) - -(eval-when (compile load eval) - (defun emit-error-break (vop kind code values) - (let ((vector (gensym))) - `((let ((vop ,vop)) - (when vop - (note-this-location vop :internal-error))) - (inst break ,kind) - (with-adjustable-vector (,vector) - (write-var-integer (error-number-or-lose ',code) ,vector) - ,@(mapcar #'(lambda (tn) - `(let ((tn ,tn)) - (write-var-integer (make-sc-offset (sc-number - (tn-sc tn)) - (tn-offset tn)) - ,vector))) - values) - (inst byte (length ,vector)) - (dotimes (i (length ,vector)) - (inst byte (aref ,vector i)))) - (align word-shift))))) - -(defmacro error-call (vop error-code &rest values) - "Cause an error. ERROR-CODE is the error to cause." - (cons 'progn - (emit-error-break vop error-trap error-code values))) - - -(defmacro cerror-call (vop label error-code &rest values) - "Cause a continuable error. If the error is continued, execution resumes at - LABEL." - `(progn - (inst b ,label) - ,@(emit-error-break vop cerror-trap error-code values))) - -(defmacro generate-error-code (vop error-code &rest values) - "Generate-Error-Code Error-code Value* - Emit code for an error with the specified Error-Code and context Values." - `(assemble (*elsewhere*) - (let ((start-lab (gen-label))) - (emit-label start-lab) - (error-call ,vop ,error-code ,@values) - start-lab))) - -(defmacro generate-cerror-code (vop error-code &rest values) - "Generate-CError-Code Error-code Value* - Emit code for a continuable error with the specified Error-Code and - context Values. If the error is continued, execution resumes after - the GENERATE-CERROR-CODE form." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) - `(let ((,continue (gen-label))) - (emit-label ,continue) - (assemble (*elsewhere*) - (let ((,error (gen-label))) - (emit-label ,error) - (cerror-call ,vop ,continue ,error-code ,@values) - ,error))))) - - -;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. -;;; -(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms) - #+gengc - (unless (eql extra 0) - (error "Can't allocate any extra with pseudo-atomic in the gengc system.")) - `(progn - (assert (= (tn-offset ,flag-tn) nl4-offset)) - (without-scheduling () - (inst li ,flag-tn #-gengc (1- ,extra) #+gengc -1) - (inst addu alloc-tn 1)) - ,@forms - (without-scheduling () - (inst add alloc-tn ,flag-tn)))) - - - -;;;; Memory accessor vop generators - -(deftype load/store-index (scale lowtag min-offset - &optional (max-offset min-offset)) - `(integer ,(- (truncate (+ (ash 1 16) - (* min-offset word-bytes) - (- lowtag)) - scale)) - ,(truncate (- (+ (1- (ash 1 16)) lowtag) - (* max-offset word-bytes)) - scale))) - -(defmacro define-full-reffer (name type offset lowtag scs el-type - &optional translate) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types ,type tagged-num) - (:temporary (:scs (interior-reg)) lip) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst add lip object index) - (inst lw value lip (- (* ,offset word-bytes) ,lowtag)) - (inst nop))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,word-bytes ,(eval lowtag) - ,(eval offset)))) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 4 - (inst lw value object (- (* (+ ,offset index) word-bytes) ,lowtag)) - (inst nop))))) - -(defmacro define-full-setter (name type offset lowtag scs el-type - &optional translate #+gengc (remember t)) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs ,scs :target result)) - (:arg-types ,type tagged-num ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 2 - (inst add lip object index) - (inst #+gengc ,(if remember 'sw-and-remember-slot 'sw) #-gengc sw - value lip (- (* ,offset word-bytes) ,lowtag)) - (move result value))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs ,scs)) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,word-bytes ,(eval lowtag) - ,(eval offset))) - ,el-type) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 1 - (inst #+gengc ,(if remember 'sw-and-remember-slot 'sw) #-gengc sw - value object (- (* (+ ,offset index) word-bytes) ,lowtag)) - (move result value))))) - - -(defmacro define-partial-reffer (name type size signed offset lowtag scs - el-type &optional translate) - (let ((scale (ecase size (:byte 1) (:short 2)))) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:generator 5 - (inst addu lip object index) - ,@(when (eq size :short) - '((inst addu lip index))) - (inst ,(ecase size - (:byte (if signed 'lb 'lbu)) - (:short (if signed 'lh 'lhu))) - value lip (- (* ,offset word-bytes) ,lowtag)) - (inst nop))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset)))) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst ,(ecase size - (:byte (if signed 'lb 'lbu)) - (:short (if signed 'lh 'lhu))) - value object - (- (+ (* ,offset word-bytes) (* index ,scale)) ,lowtag)) - (inst nop)))))) - -(defmacro define-partial-setter (name type size offset lowtag scs el-type - &optional translate) - (let ((scale (ecase size (:byte 1) (:short 2)))) - `(progn - (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg)) - (value :scs ,scs :target result)) - (:arg-types ,type positive-fixnum ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst addu lip object index) - ,@(when (eq size :short) - '((inst addu lip index))) - (inst ,(ecase size (:byte 'sb) (:short 'sh)) - value lip (- (* ,offset word-bytes) ,lowtag)) - (move result value))) - (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs ,scs :target result)) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset))) - ,el-type) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst ,(ecase size (:byte 'sb) (:short 'sh)) - value object - (- (* ,offset word-bytes) (* index ,scale) ,lowtag)) - (move result value)))))) - diff --git a/compiler/mips/memory.lisp b/compiler/mips/memory.lisp deleted file mode 100644 index 04b98b6cffbf81031bc4c3241ce7b742b3727168..0000000000000000000000000000000000000000 --- a/compiler/mips/memory.lisp +++ /dev/null @@ -1,73 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/memory.lisp,v 1.14 1993/01/13 16:06:43 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the MIPS definitions of some general purpose memory -;;; reference VOPs inherited by basic memory reference operations. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by William Lott. -;;; - -(in-package "MIPS") - - -;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to -;;; be read or written is a property of the VOP used. -;;; -(define-vop (cell-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (loadw value object offset lowtag))) -;;; -(define-vop (cell-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - #+gengc (:info remember) - (:policy :fast-safe) - (:generator 4 - #+gengc - (if remember - (storew-and-remember-slot value object offset lowtag) - (storew value object offset lowtag)) - #-gengc - (storew value object offset lowtag))) - -;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the -;;; offset is constant at compile time, but varies for different uses. We add -;;; in the stardard g-vector overhead. -;;; -(define-vop (slot-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:variant-vars base lowtag) - (:info offset) - (:generator 4 - (loadw value object (+ base offset) lowtag))) -;;; -(define-vop (slot-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:variant-vars base lowtag) - (:info offset #+gengc remember) - (:generator 4 - #+gengc - (if remember - (storew-and-remember-slot value object (+ base offset) lowtag) - (storew value object (+ base offset) lowtag)) - #-gengc - (storew value object (+ base offset) lowtag))) diff --git a/compiler/mips/mips-regs.txt b/compiler/mips/mips-regs.txt deleted file mode 100644 index 1c0728b0dcc0ee90bb56d1b9af333ae6983f7f15..0000000000000000000000000000000000000000 --- a/compiler/mips/mips-regs.txt +++ /dev/null @@ -1,60 +0,0 @@ -Global Lisp Registers: - NULL - Wired NIL register. - CSP - Control stack pointer. - CONT - Continuation pointer. - NSP - Number stack pointer. - BSP - Binding stack pointer. - FLAGS - Special flags register. - ALLOC - Allocation pointer. - CODE - Current code object. - -Linkage Registers: - NARGS - Number of arguments or values. - LEXENV - Lexical Environment being called. - OLDCONT - Old continuation pointer. - CNAME - Name of called function. - A0-A5 - First 6 arguments. - ARGS - Argument pointer. - LRA - Lisp Return Address. - - - Reg CN PR C Usage LN Lisp Usage GC ------------------------------------------------------------------------- - R0 - - Wired Zero ZERO Wired Zero N - R1 - N Assembler Temp LIP Lisp-Interior Special - R2 v0 N Results NL0 Non-Lisp Reg N - R3 v1 N Static Link NL1 Non-Lisp Reg N - R4 a0 N Integer Arg NL2 Non-Lisp Reg N - R5 a1 N Integer Arg NL3 Non-Lisp Reg N - R6 a2 N Integer Arg NL4 Non-Lisp Reg N - R7 a3 N Integer Arg NARGS Arg Count N - R8 t0 N Temporary Reg A0 Argument Y - R9 t1 N Temporary Reg A1 Argument Y - R10 t2 N Temporary Reg A2 Argument Y - R11 t3 N Temporary Reg A3 Argument Y - R12 t4 N Temporary Reg A4 Argument Y - R13 t5 N Temporary Reg A5 Argument Y - R14 t6 N Temporary Reg CNAME Call Name Y - R15 t7 N Temporary Reg LEXENV Lexical Env Y - R16 s0 Y Saved Temp Reg ARGS Arg Pointer Y - R17 s1 Y Saved Temp Reg OLDCONT Old Continuation Y - R18 s2 Y Saved Temp Reg LRA Lisp Return Address Y - R19 s3 Y Saved Temp Reg L0 Random Lisp Reg Y - R20 s4 Y Saved Temp Reg NULL Null / Nil Constant Y - R21 s5 Y Saved Temp Reg BSP Binding Stack Pointer Special - R22 s6 Y Saved Temp Reg CONT Current Continuation Special - R23 s7 Y Saved Temp Reg CSP Control Stack Pointer Special - R24 t8 N Temporary Reg FLAGS Flags register N - R25 t9 N Temporary Reg ALLOC Allocation Pointer Special - R26 k0 - (reserved) - Kernel Reg (reserved) N - R27 k1 - (reserved) - Kernel Reg (reserved) N - R28 gp - Global Pointer L1 Random Lisp Reg Y - R29 sp - Stack Pointer NSP Number Stack Pointer N - R30 s8 Y Saved Temp Reg CODE Code Pointer Y - R31 ra N Return Addr L2 Random Lisp Reg Y - -Key: - CN == C/UNIX name - NL == Lisp name - PR == Preserved on C function call (callee saves) - GC == Considered as a root for GC diff --git a/compiler/mips/move.lisp b/compiler/mips/move.lisp deleted file mode 100644 index 15cc0c2d1ef1f3022f3f732bfa2fa2aac5882643..0000000000000000000000000000000000000000 --- a/compiler/mips/move.lisp +++ /dev/null @@ -1,323 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/move.lisp,v 1.33 1993/01/13 16:05:52 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the MIPS VM definition of operand loading/saving and -;;; the Move VOP. -;;; -;;; Written by Rob MacLachlan. -;;; MIPS conversion by William Lott. -;;; -(in-package "MIPS") - - -(define-move-function (load-immediate 1) (vop x y) - ((null zero immediate) - (any-reg descriptor-reg)) - (let ((val (tn-value x))) - (etypecase val - (integer - (inst li y (fixnum val))) - (null - (move y null-tn)) - (symbol - (load-symbol y val)) - (character - (inst li y (logior (ash (char-code val) type-bits) - base-char-type)))))) - -(define-move-function (load-number 1) (vop x y) - ((zero immediate) - (signed-reg unsigned-reg)) - (inst li y (tn-value x))) - -(define-move-function (load-base-char 1) (vop x y) - ((immediate) (base-char-reg)) - (inst li y (char-code (tn-value x)))) - -(define-move-function (load-system-area-pointer 1) (vop x y) - ((immediate) (sap-reg)) - (inst li y (sap-int (tn-value x)))) - -(define-move-function (load-constant 5) (vop x y) - ((constant) (descriptor-reg any-reg)) - (loadw y code-tn (tn-offset x) other-pointer-type)) - -(define-move-function (load-stack 5) (vop x y) - ((control-stack) (any-reg descriptor-reg)) - (load-stack-tn y x)) - -(define-move-function (load-number-stack 5) (vop x y) - ((base-char-stack) (base-char-reg) - (sap-stack) (sap-reg) - (signed-stack) (signed-reg) - (unsigned-stack) (unsigned-reg)) - (let ((nfp (current-nfp-tn vop))) - (loadw y nfp (tn-offset x)))) - -(define-move-function (store-stack 5) (vop x y) - ((any-reg descriptor-reg) (control-stack)) - (store-stack-tn y x)) - -(define-move-function (store-number-stack 5) (vop x y) - ((base-char-reg) (base-char-stack) - (sap-reg) (sap-stack) - (signed-reg) (signed-stack) - (unsigned-reg) (unsigned-stack)) - (let ((nfp (current-nfp-tn vop))) - (storew x nfp (tn-offset y)))) - - -;;;; The Move VOP: -;;; -(define-vop (move) - (:args (x :target y - :scs (any-reg descriptor-reg) - :load-if (not (location= x y)))) - (:results (y :scs (any-reg descriptor-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move y x))) - -(define-move-vop move :move - (any-reg descriptor-reg) - (any-reg descriptor-reg)) - -;;; Make Move the check VOP for T so that type check generation doesn't think -;;; it is a hairy type. This also allows checking of a few of the values in a -;;; continuation to fall out. -;;; -(primitive-type-vop move (:check) t) - -;;; The Move-Argument VOP is used for moving descriptor values into another -;;; frame for argument or known value passing. -;;; -(define-vop (move-argument) - (:args (x :target y - :scs (any-reg descriptor-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y any-reg descriptor-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - ((any-reg descriptor-reg) - (move y x)) - (control-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-argument :move-argument - (any-reg descriptor-reg) - (any-reg descriptor-reg)) - - - -;;;; ILLEGAL-MOVE - -;;; This VOP exists just to begin the lifetime of a TN that couldn't be written -;;; legally due to a type error. An error is signalled before this VOP is -;;; so we don't need to do anything (not that there would be anything sensible -;;; to do anyway.) -;;; -(define-vop (illegal-move) - (:args (x) (type)) - (:results (y)) - (:ignore y) - (:vop-var vop) - (:save-p :compute-only) - (:generator 666 - (error-call vop object-not-type-error x type))) - - - -;;;; Moves and coercions: - -;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word -;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer -;;; to a tagged bignum or fixnum. - -;;; Arg is a fixnum, so just shift it. We need a type restriction because some -;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs. -;;; -(define-vop (move-to-word/fixnum) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:arg-types tagged-num) - (:note "fixnum untagging") - (:generator 1 - (inst sra y x 2))) -;;; -(define-move-vop move-to-word/fixnum :move - (any-reg descriptor-reg) (signed-reg unsigned-reg)) - -;;; Arg is a non-immediate constant, load it. -(define-vop (move-to-word-c) - (:args (x :scs (constant))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "constant load") - (:generator 1 - (inst li y (tn-value x)))) -;;; -(define-move-vop move-to-word-c :move - (constant) (signed-reg unsigned-reg)) - -;;; Arg is a fixnum or bignum, figure out which and load if necessary. -(define-vop (move-to-word/integer) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "integer to untagged word coercion") - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 3 - (let ((done (gen-label))) - (inst and temp x 3) - (inst beq temp done) - (inst sra y x 2) - - (loadw y x bignum-digits-offset other-pointer-type) - (emit-label done)))) -;;; -(define-move-vop move-to-word/integer :move - (descriptor-reg) (signed-reg unsigned-reg)) - - -;;; Result is a fixnum, so we can just shift. We need the result type -;;; restriction because of the control-stack ambiguity noted above. -;;; -(define-vop (move-from-word/fixnum) - (:args (x :scs (signed-reg unsigned-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "fixnum tagging") - (:generator 1 - (inst sll y x 2))) -;;; -(define-move-vop move-from-word/fixnum :move - (signed-reg unsigned-reg) (any-reg descriptor-reg)) - -;;; Result may be a bignum, so we have to check. Use a worst-case cost to make -;;; sure people know they may be number consing. -;;; -(define-vop (move-from-signed) - (:args (arg :scs (signed-reg unsigned-reg) :target x)) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) - #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:note "signed word to integer coercion") - (:generator 18 - (move x arg) - (let ((fixnum (gen-label)) - (done (gen-label))) - (inst sra temp x 29) - (inst beq temp fixnum) - (inst nor temp zero-tn) - (inst beq temp done) - (inst sll y x 2) - - (with-fixed-allocation - (y pa-flag temp bignum-type (1+ bignum-digits-offset)) - (storew x y bignum-digits-offset other-pointer-type)) - (inst b done) - (inst nop) - - (emit-label fixnum) - (inst sll y x 2) - (emit-label done)))) -;;; -(define-move-vop move-from-signed :move - (signed-reg) (descriptor-reg)) - - -;;; Check for fixnum, and possibly allocate one or two word bignum result. Use -;;; a worst-case cost to make sure people know they may be number consing. -;;; -(define-vop (move-from-unsigned) - (:args (arg :scs (signed-reg unsigned-reg) :target x)) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) - #-gengc - (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:note "unsigned word to integer coercion") - (:generator 20 - (move x arg) - (inst srl temp x 29) - (inst beq temp done) - (inst sll y x 2) - - #-gengc - (pseudo-atomic - (pa-flag :extra (pad-data-block (+ bignum-digits-offset 2))) - (inst or y alloc-tn other-pointer-type) - (inst slt temp x zero-tn) - (inst sll temp type-bits) - (inst addu temp (logior (ash 1 type-bits) bignum-type)) - (storew temp y 0 other-pointer-type)) - - #+gengc - (progn - (inst slt temp x zero-tn) - (inst sll temp type-bits) - (inst addu temp (logior (ash 1 type-bits) bignum-type)) - (inst or y alloc-tn other-pointer-type) - (storew temp alloc-tn) - (inst addu alloc-tn (pad-data-block (+ bignum-digits-offset 2)))) - - (storew x y bignum-digits-offset other-pointer-type) - DONE)) -;;; -(define-move-vop move-from-unsigned :move - (unsigned-reg) (descriptor-reg)) - - -;;; Move untagged numbers. -;;; -(define-vop (word-move) - (:args (x :target y - :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:results (y :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:note "word integer move") - (:generator 0 - (move y x))) -;;; -(define-move-vop word-move :move - (signed-reg unsigned-reg) (signed-reg unsigned-reg)) - - -;;; Move untagged number arguments/return-values. -;;; -(define-vop (move-word-argument) - (:args (x :target y - :scs (signed-reg unsigned-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (:note "word integer argument move") - (:generator 0 - (sc-case y - ((signed-reg unsigned-reg) - (move y x)) - ((signed-stack unsigned-stack) - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-word-argument :move-argument - (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a -;;; descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp deleted file mode 100644 index 09ad59456d4461e9eb66adf094a6fb4599f2e889..0000000000000000000000000000000000000000 --- a/compiler/mips/nlx.lisp +++ /dev/null @@ -1,328 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/nlx.lisp,v 1.19 1993/01/13 16:05:00 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the definitions of VOPs used for non-local exit -;;; (throw, lexical exit, etc.) -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "MIPS") - -;;; MAKE-NLX-SP-TN -- Interface -;;; -;;; Make an environment-live stack TN for saving the SP for NLX entry. -;;; -(def-vm-support-routine make-nlx-sp-tn (env) - (environment-live-tn - (make-representation-tn *fixnum-primitive-type* immediate-arg-scn) - env)) - - - -;;; Save and restore dynamic environment. -;;; -;;; These VOPs are used in the reentered function to restore the appropriate -;;; dynamic environment. Currently we only save the Current-Catch and binding -;;; stack pointer. We don't need to save/restore the current unwind-protect, -;;; since unwind-protects are implicitly processed during unwinding. If there -;;; were any additional stacks, then this would be the place to restore the top -;;; pointers. - - -;;; Make-Dynamic-State-TNs -- Interface -;;; -;;; Return a list of TNs that can be used to snapshot the dynamic state for -;;; use with the Save/Restore-Dynamic-Environment VOPs. -;;; -(def-vm-support-routine make-dynamic-state-tns () - (make-n-tns 4 *any-primitive-type*)) - -(define-vop (save-dynamic-state) - (:results (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg)) - (eval :scs (descriptor-reg))) - (:vop-var vop) - (:generator 13 - #-gengc - (load-symbol-value catch lisp::*current-catch-block*) - #+gengc - (loadw catch mutator-tn mutator-current-catch-block-slot) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move nfp cur-nfp))) - (move nsp nsp-tn) - #-gengc - (load-symbol-value eval lisp::*eval-stack-top*) - #+gengc - (loadw eval mutator-tn mutator-eval-stack-top-slot))) - -(define-vop (restore-dynamic-state) - (:args (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg)) - (eval :scs (descriptor-reg))) - (:vop-var vop) - (:generator 10 - #-gengc - (store-symbol-value catch lisp::*current-catch-block*) - #+gengc - (storew catch mutator-tn mutator-current-catch-block-slot) - #-gengc - (store-symbol-value eval lisp::*eval-stack-top*) - #+gengc - (storew eval mutator-tn mutator-eval-stack-top-slot) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move cur-nfp nfp))) - (move nsp-tn nsp))) - -(define-vop (current-stack-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move res csp-tn))) - -(define-vop (current-binding-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move res bsp-tn))) - - - -;;;; Unwind block hackery: - -;;; Compute the address of the catch block from its TN, then store into the -;;; block the current Fp, Env, Unwind-Protect, and the entry PC. -;;; -(define-vop (make-unwind-block) - (:args (tn)) - (:info entry-label) - (:results (block :scs (any-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 22 - (inst addu block cfp-tn (* (tn-offset tn) vm:word-bytes)) - #-gengc - (load-symbol-value temp lisp::*current-unwind-protect-block*) - #+gengc - (loadw temp mutator-tn mutator-current-unwind-protect-slot) - (storew temp block vm:unwind-block-current-uwp-slot) - (storew cfp-tn block vm:unwind-block-current-cont-slot) - (storew code-tn block vm:unwind-block-current-code-slot) - #-gengc - (inst compute-lra-from-code temp code-tn entry-label ndescr) - #+gengc - (inst compute-ra-from-code temp code-tn entry-label ndescr) - (storew temp block vm:catch-block-entry-pc-slot))) - - -;;; Like Make-Unwind-Block, except that we also store in the specified tag, and -;;; link the block into the Current-Catch list. -;;; -(define-vop (make-catch-block) - (:args (tn) - (tag :scs (descriptor-reg))) - (:info entry-label) - (:results (block :scs (any-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 44 - (inst addu result cfp-tn (* (tn-offset tn) vm:word-bytes)) - #-gengc - (load-symbol-value temp lisp::*current-unwind-protect-block*) - #+gengc - (loadw temp mutator-tn mutator-current-unwind-protect-slot) - (storew temp result vm:catch-block-current-uwp-slot) - (storew cfp-tn result vm:catch-block-current-cont-slot) - (storew code-tn result vm:catch-block-current-code-slot) - #-gengc - (inst compute-lra-from-code temp code-tn entry-label ndescr) - #+gengc - (inst compute-ra-from-code temp code-tn entry-label ndescr) - (storew temp result vm:catch-block-entry-pc-slot) - - (storew tag result vm:catch-block-tag-slot) - #-gengc - (load-symbol-value temp lisp::*current-catch-block*) - #+gengc - (loadw temp mutator-tn mutator-current-catch-block-slot) - (storew temp result vm:catch-block-previous-catch-slot) - #-gengc - (store-symbol-value result lisp::*current-catch-block*) - #+gengc - (storew result mutator-tn mutator-current-catch-block-slot) - - (move block result))) - - -;;; Just set the current unwind-protect to TN's address. This instantiates an -;;; unwind block as an unwind-protect. -;;; -(define-vop (set-unwind-protect) - (:args (tn)) - (:temporary (:scs (descriptor-reg)) new-uwp) - (:generator 7 - (inst addu new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes)) - #-gengc - (store-symbol-value new-uwp lisp::*current-unwind-protect-block*) - #+gengc - (storew new-uwp mutator-tn mutator-current-unwind-protect-slot))) - - -(define-vop (unlink-catch-block) - (:temporary (:scs (any-reg)) block) - (:policy :fast-safe) - (:translate %catch-breakup) - (:generator 17 - #-gengc - (load-symbol-value block lisp::*current-catch-block*) - #+gengc - (loadw block mutator-tn mutator-current-catch-block-slot) - (loadw block block vm:catch-block-previous-catch-slot) - #-gengc - (store-symbol-value block lisp::*current-catch-block*) - #+gengc - (storew block mutator-tn mutator-current-catch-block-slot))) - -(define-vop (unlink-unwind-protect) - (:temporary (:scs (any-reg)) block) - (:policy :fast-safe) - (:translate %unwind-protect-breakup) - (:generator 17 - #-gengc - (load-symbol-value block lisp::*current-unwind-protect-block*) - #+gengc - (loadw block mutator-tn mutator-current-unwind-protect-slot) - (loadw block block vm:unwind-block-current-uwp-slot) - #-gengc - (store-symbol-value block lisp::*current-unwind-protect-block*) - #+gengc - (storew block mutator-tn mutator-current-unwind-protect-slot))) - - -;;;; NLX entry VOPs: - - -(define-vop (nlx-entry) - (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops - ; would be inserted before the LRA. - (start) - (count)) - (:results (values :more t)) - (:temporary (:scs (descriptor-reg)) move-temp) - (:info label nvals) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (emit-return-pc label) - (note-this-location vop :non-local-entry) - (cond ((zerop nvals)) - ((= nvals 1) - (let ((no-values (gen-label))) - (inst beq count zero-tn no-values) - (move (tn-ref-tn values) null-tn) - (loadw (tn-ref-tn values) start) - (emit-label no-values))) - (t - (collect ((defaults)) - (do ((i 0 (1+ i)) - (tn-ref values (tn-ref-across tn-ref))) - ((null tn-ref)) - (let ((default-lab (gen-label)) - (tn (tn-ref-tn tn-ref))) - (defaults (cons default-lab tn)) - - (inst beq count zero-tn default-lab) - (inst addu count count (fixnum -1)) - (sc-case tn - ((descriptor-reg any-reg) - (loadw tn start i)) - (control-stack - (loadw move-temp start i) - (store-stack-tn tn move-temp))))) - - (let ((defaulting-done (gen-label))) - - (emit-label defaulting-done) - - (assemble (*elsewhere*) - (dolist (def (defaults)) - (emit-label (car def)) - (let ((tn (cdr def))) - (sc-case tn - ((descriptor-reg any-reg) - (move tn null-tn)) - (control-stack - (store-stack-tn tn null-tn))))) - (inst b defaulting-done) - (inst nop)))))) - (load-stack-tn csp-tn sp))) - - -(define-vop (nlx-entry-multiple) - (:args (top :target dst) (start :target src) (count :target num)) - ;; Again, no SC restrictions for the args, 'cause the loading would - ;; happen before the entry label. - (:info label) - (:temporary (:scs (any-reg) :from (:argument 0)) dst) - (:temporary (:scs (any-reg) :from (:argument 1)) src) - (:temporary (:scs (any-reg) :from (:argument 2)) num) - (:temporary (:scs (descriptor-reg)) temp) - (:results (new-start) (new-count)) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (emit-return-pc label) - (note-this-location vop :non-local-entry) - (let ((loop (gen-label)) - (done (gen-label))) - - ;; Copy args. - (load-stack-tn dst top) - (move src start) - (move num count) - - ;; Establish results. - (sc-case new-start - (any-reg (move new-start dst)) - (control-stack (store-stack-tn new-start dst))) - (inst beq num zero-tn done) - (sc-case new-count - (any-reg (inst move new-count num)) - (control-stack (store-stack-tn new-count num))) - - ;; Copy stuff on stack. - (emit-label loop) - (loadw temp src) - (inst addu src src vm:word-bytes) - (storew temp dst) - (inst addu num num (fixnum -1)) - (inst bne num zero-tn loop) - (inst addu dst dst vm:word-bytes) - - (emit-label done) - (inst move csp-tn dst)))) - - -;;; This VOP is just to force the TNs used in the cleanup onto the stack. -;;; -(define-vop (uwp-entry) - (:info label) - (:save-p :force-to-stack) - (:results (block) (start) (count)) - (:ignore block start count) - (:vop-var vop) - (:generator 0 - (emit-return-pc label) - (note-this-location vop :non-local-entry))) diff --git a/compiler/mips/notes.txt b/compiler/mips/notes.txt deleted file mode 100644 index 6ab180a1a2877c7d606d4a72f58782f1396c73a4..0000000000000000000000000000000000000000 --- a/compiler/mips/notes.txt +++ /dev/null @@ -1,161 +0,0 @@ - -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/notes.txt,v 1.2 1990/02/07 14:05:49 ram Rel $ - - - -Call: - -There are several different kinds of call, depending on what is going on. - -The call can be named (i.e. use the symbol-function slot) or through a -function object. - -The call can pass either a fixed number of args or a variable number of -args. - -The call can return a fixed number of values, a variable number of values, -or be a tail call. - - - -Register usage at the time of the call: - -LEXENV: Holds the lexical environment to use during the call if it's a -closure, or garbage if not. - -CALL-NAME: Holds the symbol for a named call and garbage for others. - -OLD-CONT: Holds the context pointer that should be restored upon return. - -A0...An: Holds the first n+1 args. - -NARGS: Holds the number of args, as a fixnum. - -ARGS: Holds a pointer to the args. Note: indexes off of this pointer are -as if all the arguments were stored at it, e.g. the first stack arg is at -ARGS[n] where n is number of register args. Because of this, ARGS is the -same as the callers CONT (OLD-CONT at the time of the call for non-tail -call). -[RAM: note that this must be set up even when NARGS<=n, since the callee may be -expecting more arguments (due to optionals or a bad call.) ARGS must be -pointing to some valid chunk of memory, since the callee moves all of the -positional args before checking to see if they are actually supplied.] - -LRA: Holds the lisp-return-address object that the call should be returned -to. Calculated for non-tail call, and left as is for tail call. - -CSP: Left as is. The callee will set this as necessary based on CONT. - -NSP: ??? -[RAM: will be managed similarly to CSP, i.e. callee has to allocate and is -required to deallocate.] - -CONT: The callee's context pointer. Established as CSP for non-tail call, -and left as is for tail call. - -CODE: The function object being called. - - - -Register usage at the time of the return for single value return: - -A0: The value. - -CODE: The lisp-return-address we returned to. - -CSP: Restored from CONT. -[RAM: i.e. stack is guaranteed to be clean. No SP frobbing is necessary.] - -CONT: Restored from OLD-CONT. - - -Additional register usage for multiple value return: - -NARGS: Number of values being returned. - -A0...An: The first n+1 values, or NIL if there are less than n+1 values. - -ARGS: Pointer to the rest of the values. The returnee's CONT. -[RAM: i.e. as with ARGS in call, points n+1 words before the first stack -value.] - - -CSP: CONT + NARGS*4 - - - - -What has to happen for this to work: - -Caller: - set NARGS - set ARGS - if tail call - CONT <- OLD-CONT - else - calc LRA - CONT <- CSP - if named - set CALL-NAME - set LEXENV - set CODE - calc target addr (CODE + n) - jr - -Callee: - allocate-frame - emit function header. - set CSP = CONT + size. - do something with nsp - setup-environment - set CODE = CODE - n - move-argument - move stack args from ARGS[n] to CONT[n] - -Returner: - known values: - move-result - move values from CONT[n] to OLD-CONT[n]. - known-return - CONT = OLD-CONT - CODE = LRA - calc target addr (CODE + n) - jr - - unknown constant values (return VOP): - nargs = 1 case: - CSP = CONT - CONT = OLD-CONT - CODE = LRA - calc target addr (CODE + n + 8) - jr - nargs != 1 case: - set NARGS - nil out unused arg regs - ARGS = CONT - CSP = CONT + NARGS * word-bytes - CONT = OLD-CONT - CODE = LRA - calc target addr (CODE + n) - jr - - unknown variable values (return-multiple VOP): - copy the args from wherever to the top of the stack. -[RAM: I would phrase this "to the beginning of the current (returner's) frame". -They will already be there except with RETURN-MULTIPLE (when they *will* be on -the stack top.) But then after any copy, we adjust CSP so that the values are -once again on stack top.] - nil out unused arg regs - ARGS = CONT - CSP = CONT + NARGS * word-bytes - CONT = OLD-CONT - CODE = LRA - calc target addr (CODE + n) - jr - - -Returnee: - want fixed number of values: - - - want variable number of values: diff --git a/compiler/mips/pred.lisp b/compiler/mips/pred.lisp deleted file mode 100644 index 8e5fd56c424a4d1318bfd14236331306ceee5150..0000000000000000000000000000000000000000 --- a/compiler/mips/pred.lisp +++ /dev/null @@ -1,63 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/mips/pred.lisp,v 1.6 1991/02/20 15:15:00 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/pred.lisp,v 1.6 1991/02/20 15:15:00 ram Exp $ -;;; -;;; This file contains the VM definition of predicate VOPs for the MIPS. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by William Lott. -;;; - -(in-package "MIPS") - - -;;;; The Branch VOP. - -;;; The unconditional branch, emitted when we can't drop through to the desired -;;; destination. Dest is the continuation we transfer control to. -;;; -(define-vop (branch) - (:info dest) - (:generator 5 - (inst b dest) - (inst nop))) - - -;;;; Conditional VOPs: - -;if-true (???), if-eql, ... - -(define-vop (if-eq) - (:args (x :scs (any-reg descriptor-reg zero null)) - (y :scs (any-reg descriptor-reg zero null))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:translate eq) - (:generator 3 - (let ((x-prime (sc-case x - ((any-reg descriptor-reg) x) - (zero zero-tn) - (null null-tn))) - (y-prime (sc-case y - ((any-reg descriptor-reg) y) - (zero zero-tn) - (null null-tn)))) - (if not-p - (inst bne x-prime y-prime target) - (inst beq x-prime y-prime target))) - (inst nop))) - - diff --git a/compiler/mips/print.lisp b/compiler/mips/print.lisp deleted file mode 100644 index 66772e0491fa424bc48dedc9fdd8bedd0a601978..0000000000000000000000000000000000000000 --- a/compiler/mips/print.lisp +++ /dev/null @@ -1,41 +0,0 @@ -;;; -*- Package: C -*- -;;; -;;; ********************************************************************** -;;; 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/mips/print.lisp,v 1.9 1992/07/28 20:37:46 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains temporary printing utilities and similar noise. -;;; -;;; Written by William Lott. - -(in-package "MIPS") - - -(define-vop (print) - (:args (object :scs (descriptor-reg) :target a0)) - (:results (result :scs (descriptor-reg))) - (:save-p t) - (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0)) - cfunc) - (:temporary (:sc descriptor-reg :offset 4 :from (:argument 0)) a0) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:vop-var vop) - (:generator 0 - (let ((cur-nfp (current-nfp-tn vop))) - (move a0 object) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (inst li cfunc (make-fixup "debug_print" :foreign)) - (inst jal (make-fixup "call_into_c" :foreign)) - (inst addu nsp-tn nsp-tn -16) - (inst addu nsp-tn nsp-tn 16) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - (move result cfunc)))) diff --git a/compiler/mips/random-doc.txt b/compiler/mips/random-doc.txt deleted file mode 100644 index 1391ca83391e03aab5febcf7b4776c7ec6a2e404..0000000000000000000000000000000000000000 --- a/compiler/mips/random-doc.txt +++ /dev/null @@ -1,351 +0,0 @@ --*- Mode: Text, Fill -*- - -$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/random-doc.txt,v 1.3 1990/03/02 17:40:56 ch Rel $ - -DEFINE-STORAGE-BASE - - Define-Storage-Base Name Kind {Key Value}* - - Define a storage base having the specified Name. Kind may be :Finite, - :Unbounded or :Non-Packed. The following keywords are legal: - - :Size <Size> - Specify the number of locations in a :Finite SB or the initial size of a - :Unbounded SB. - - -DEFINE-STORAGE-CLASS - - Define-Storage-Class Name Number Storage-Base {Key Value}* - - Define a storage class Name that uses the named Storage-Base. Number is a - small, non-negative integer that is used as an alias. The following - keywords are defined: - - :Element-Size <Size> - The size of objects in this SC in whatever units the SB uses. This - defaults to 1. - - :Locations - If the SB is :Finite, then this is a list of the offsets within the SB - that are in this SC. - - -DEFINE-MOVE-COSTS - - Define-Move-Costs {((Source-SC*) {(Cost Dest-SC*)}*)}* - - This macro declares the cost of the implicit move operations needed to load - arguments and store results. The format is somewhat similar to the costs - specifications in Define-VOP. Each argument form gives the cost for moving - to all possible destination SCs from some collection of equivalent source - SCs. - - This information is used only to compute the cost of moves from arguments to - Load TNs or from Load TNs to results. It is not necessary to specify the - costs for moves between combinations of SCs impossible in this context. - - -DEFINE-SAVE-SCS - - Define-Save-SCs {(save-sc saved-sc*)}* - - This form is used to define which SCs must be saved on a function call. The - Saved-SCs are SCs that must be saved. The Save-SC a SC that is used in - combination with the defined move costs to determine the cost of saving. - - -DEF-PRIMITIVE-TYPE - - Def-Primitive-Type Name (SC*) {Key Value}* - - Define a primitive type Name. Each SC specifies a Storage Class that values - of this type may be allocated in. The following keyword options are defined: - - :Type - The type descriptor for the Lisp type that is equivalent to this type - (defaults to Name.) - - -DEF-BOOLEAN-ATTRIBUTE - - Def-Boolean-Attribute Name Attribute-Name* - - Define a new class of boolean attributes, with the attributes havin the - specified Attribute-Names. Name is the name of the class, which is used to - generate some macros to manipulate sets of the attributes: - - NAME-attributep attributes attribute-name* - Return true if one of the named attributes is present, false otherwise. - - NAME-attributes attribute-name* - Return a set of the named attributes. - - -PRIMITIVE-TYPE-VOP - - Primitive-Type-VOP Vop (Kind*) Type* - - Annotate all the specified primitive Types with the named VOP under each of - the specified kinds: - - :Coerce-To-T - :Coerce-From-T - :Move - One argument one result VOPs used for coercion between representations - and explicit moves. - - :Check - A one argument one result VOP that moves the argument to the result, - checking that the value is of this type in the process. - -DEFINE-VOP - - Define-VOP (Name [Inherits]) Spec* - - Define the symbol Name to be a Virtual OPeration in the compiler. If - specified, Inherits is the name of a VOP that we default unspecified - information from. Each Spec is a list beginning with a keyword indicating - the interpretation of the other forms in the Spec: - - :Args {(Name {Key Value}*)}* - :Results {(Name {Key Value}*)}* - The Args and Results are specifications of the operand TNs passed to the - VOP. The following operand options are defined: - - :SCs (SC*) - :Load T-or-NIL - :SCs specifies good SCs for this operand. Other SCs will be - penalized according to move costs. If :Load is true (the default), - then a load TN will be allocated if necessary, guaranteeing that the - operand is always one of the specified SCs. - - :More T-or-NIL - If specified, Name is bound to the TN-Ref for the first argument or - result following the fixed arguments or results. A more operand must - appear last, and cannot be targeted or restricted. - - :Target Operand - This operand is targeted to the named operand, indicating a desire to - pack in the same location. Not legal for results. - - :Conditional - This is used in place of :Results with conditional branch VOPs. There - are no result values: the result is a transfer of control. The - consequent and alternative continuations are passed as the first and - second :Info arguments. A side-effect is to set the Predicate attribute - for functions in the :Translate option. - - :Temporary ({Key Value}*) Name* - Allocate a temporary TN for each Name, binding that variable to the TN - within the body of the generators. In addition to :Target (which is - is the same as for operands), the following options are - defined: - - :Type Type - Specify the primitive type for the temporary, default T. - - :SC SC-Name - :Offset SB-Offset - Force the temporary to be allocated in the specified SC with the - specified offset. Offset is evaluated at macroexpand time. - - :SCs (SC*) - Restrict the temporary to a subset of the SCs allowed by the type, - possibly requiring packing in a finite SC. - - :From Time-Spec - :To Time-Spec - Specify the beginning and end of the temporary's lives. The defaults - are :Load and :Save, i.e. the duration of the VOP. The other - intervening phases are :Argument, :Eval and :Result. Non-zero - sub-phases can be specified by a list, e.g. the second argument's - life ends at (:Argument 1). - - :Generator Cost Form* - Specifies the translation into assembly code. Cost is the estimated cost - of the code emitted by this generator. The body is arbitrary Lisp code - that emits the assembly language translation of the VOP. An Assemble - form is wrapped around the body, so code may be emitted by using the - local Inst macro. During the evaluation of the body, the names of the - operands and temporaries are bound to the actual TNs. - - :Effects Effect* - :Affected Effect* - Specifies the side effects that this VOP has and the side effects that - effect its execution. If unspecified, these default to the worst case. - - :Info Name* - Define some magic arguments that are passed directly to the code - generator. The corresponding trailing arguments to VOP or %Primitive are - stored in the VOP structure. Within the body of the generators, the - named variables are bound to these values. Except in the case of - :Conditional VOPs, :Info arguments cannot be specified for VOPS that are - the direct translation for a function (specified by :Translate). - - :Ignore Name* - Causes the named variables to be declared IGNORE in the generator body. - - :Variant Thing* - :Variant-Vars Name* - These options provide a way to parameterize families of VOPs that differ - only trivially. :Variant makes the specified evaluated Things be the - "variant" associated with this VOP. :Variant-Vars causes the named - variables to be bound to the corresponding Things within the body of the - generator. - - :Variant-Cost Cost - Specifies the cost of this VOP, overriding the cost of any inherited - generator. - - :Note String - A short noun-like phrase describing what this VOP "does", i.e. the - implementation strategy. This is for use in efficiency notes. - - :Arg-Types Type* - :Result-Types Type* - Specify the template type restrictions used for automatic translation. - If there is a :More operand, the last type is the more type. - - :Translate Name* - This option causes the VOP template to be entered as an IR2 translation - for the named functions. - - :Policy {:Small | :Fast | :Safe | :Fast-Safe} - Specifies the policy under which this VOP is the best translation. - - :Guard Form - Specifies a Form that is evaluated in the global environment. If - form returns NIL, then emission of this VOP is prohibited even when - all other restrictions are met. - - :Save-P {T | NIL | :Force-To-Stack} - Indicates how a VOP wants live registers saved. - - -SC-CASE - - SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}* - - Case off of TN's SC. The first clause containing TN's SC is evaulated, - returning the values of the last form. A clause beginning with T specifies a - default. If it appears, it must be last. If no default is specified, and no - clause matches, then an error is signalled. - - -DEFINE-MISCOP - - Define-Miscop Name Args {Key Value}* - - Define a miscop with the specified args/results and options. The - following keywords are defined: - - :results - Defaults to '(r). - - :translate - :policy - :arg-types - :result-types - :cost - :conditional - - -DEFINE-MISCOP-VARIANTS - - Define-Miscop-Variants Vop Names* - - Define a bunch of miscops VOPs that inherit the specified VOP and whose - Template name, Miscop name and translate function are all the same. - - -DEF-SOURCE-TRANSFORM - - Def-Source-Transform Name Lambda-List Form* - - Define a macro-like source-to-source transformation for the function Name. - A source transform may "pass" by returning a non-nil second value. If the - transform passes, then the form is converted as a normal function call. If - the supplied arguments are not compatible with the specified lambda-list, - then the transform automatically passes. - - Source-Transforms may only be defined for functions. Source transformation - is not attempted if the function is declared Notinline. Source transforms - should not examine their arguments. If it matters how the function is used, - then Deftransform should be used to define an IR1 transformation. - - If the desirability of the transformation depends on the current Optimize - parameters, then the Policy macro should be used to determine when to pass. - - -DEFKNOWN - - Defknown Name Arg-Types Result-Type [Attributes] {Key Value}* - - Declare the function Name to be a known function. We construct a type - specifier for the function by wrapping (FUNCTION ...) around the Arg-Types - and Result-Type. Attributes is a an unevaluated list of the boolean - attributes that the function has. These attributes are meaningful here: - call - May call functions that are passed as arguments. In order to determine - what other effects are present, we must find the effects of all arguments - that may be functions. - - unsafe - May incorporate arguments in the result or somehow pass them upward. - - unwind - May fail to return during correct execution. Errors are O.K. - - any - The (default) worst case. Includes all the other bad things, plus any - other possible bad thing. - - foldable - May be constant-folded. The function has no side effects, but may be - affected by side effects on the arguments. e.g. SVREF, MAPC. - - flushable - May be eliminated if value is unused. The function has no side effects - except possibly CONS. If a function is defined to signal errors, then - it is not flushable even if it is movable or foldable. - - movable - May be moved with impunity. Has no side effects except possibly CONS, - and is affected only by its arguments. - - predicate - A true predicate likely to be open-coded. This is a hint to IR1 - conversion that it should ensure calls always appear as an IF test. - Not usually specified to Defknown, since this is implementation - dependent, and is usually automatically set by the Define-VOP - :Conditional option. - - Name may also be a list of names, in which case the same information is given - to all the names. The keywords specify the initial values for various - optimizers that the function might have. - - -DEF-PRIMITIVE-TRANSLATOR - - Def-Primitive-Translator Name Lambda-List Form* - - Define a function that converts a use of (%PRIMITIVE Name ...) into Lisp - code. Lambda-List is a defmacro style lambda list. - - -CTYPE-OF - - CType-Of Object - - Like Type-Of, only returns a Type structure instead of a type - specifier. We try to return the type most useful for type checking, - rather than trying to come up with the one that the user might find - most informative. - - -SC-IS - - SC-Is TN SC* - - Returns true if TNs SC is any of the named SCs, false otherwise. diff --git a/compiler/mips/sap.lisp b/compiler/mips/sap.lisp deleted file mode 100644 index efbf2b6f5b1c50cf57de561f4c22daf88ef9c411..0000000000000000000000000000000000000000 --- a/compiler/mips/sap.lisp +++ /dev/null @@ -1,321 +0,0 @@ -;;; -*- Package: VM; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/mips/sap.lisp,v 1.27 1993/01/13 15:58:41 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the MIPS VM definition of SAP operations. -;;; -;;; Written by William Lott. -;;; -(in-package "MIPS") - - -;;;; Moves and coercions: - -;;; Move a tagged SAP to an untagged representation. -;;; -(define-vop (move-to-sap) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (sap-reg))) - (:note "system area pointer indirection") - (:generator 1 - (loadw y x sap-pointer-slot other-pointer-type))) - -;;; -(define-move-vop move-to-sap :move - (descriptor-reg) (sap-reg)) - - -;;; Move an untagged SAP to a tagged representation. -;;; -(define-vop (move-from-sap) - (:args (x :scs (sap-reg) :target sap)) - (:temporary (:scs (sap-reg) :from (:argument 0)) sap) - (:temporary (:scs (non-descriptor-reg)) ndescr) - #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:results (y :scs (descriptor-reg))) - (:note "system area pointer allocation") - (:generator 20 - (move sap x) - (with-fixed-allocation (y pa-flag ndescr sap-type sap-size) - (storew sap y sap-pointer-slot other-pointer-type)))) -;;; -(define-move-vop move-from-sap :move - (sap-reg) (descriptor-reg)) - - -;;; Move untagged sap values. -;;; -(define-vop (sap-move) - (:args (x :target y - :scs (sap-reg) - :load-if (not (location= x y)))) - (:results (y :scs (sap-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move y x))) -;;; -(define-move-vop sap-move :move - (sap-reg) (sap-reg)) - - -;;; Move untagged sap arguments/return-values. -;;; -(define-vop (move-sap-argument) - (:args (x :target y - :scs (sap-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (sap-reg - (move y x)) - (sap-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-sap-argument :move-argument - (descriptor-reg sap-reg) (sap-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a -;;; descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (sap-reg) (descriptor-reg)) - - - -;;;; SAP-INT and INT-SAP - -(define-vop (sap-int) - (:args (sap :scs (sap-reg) :target int)) - (:arg-types system-area-pointer) - (:results (int :scs (unsigned-reg))) - (:result-types unsigned-num) - (:translate sap-int) - (:policy :fast-safe) - (:generator 1 - (move int sap))) - -(define-vop (int-sap) - (:args (int :scs (unsigned-reg) :target sap)) - (:arg-types unsigned-num) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate int-sap) - (:policy :fast-safe) - (:generator 1 - (move sap int))) - - - -;;;; POINTER+ and POINTER- - -(define-vop (pointer+) - (:translate sap+) - (:args (ptr :scs (sap-reg)) - (offset :scs (signed-reg immediate))) - (:arg-types system-area-pointer signed-num) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:policy :fast-safe) - (:generator 1 - (sc-case offset - (signed-reg - (inst addu res ptr offset)) - (immediate - (inst addu res ptr (tn-value offset)))))) - -(define-vop (pointer-) - (:translate sap-) - (:args (ptr1 :scs (sap-reg)) - (ptr2 :scs (sap-reg))) - (:arg-types system-area-pointer system-area-pointer) - (:policy :fast-safe) - (:results (res :scs (signed-reg))) - (:result-types signed-num) - (:generator 1 - (inst subu res ptr1 ptr2))) - - - -;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET - -(eval-when (compile eval) - -(defmacro def-system-ref-and-set - (ref-name set-name sc type size &optional signed) - (let ((ref-name-c (symbolicate ref-name "-C")) - (set-name-c (symbolicate set-name "-C"))) - `(progn - (define-vop (,ref-name) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (unsigned-reg))) - (:arg-types system-area-pointer unsigned-num) - (:results (result :scs (,sc))) - (:result-types ,type) - (:temporary (:scs (sap-reg) :from (:argument 0)) sap) - (:generator 5 - (inst addu sap object offset) - ,@(ecase size - (:byte - (if signed - '((inst lb result sap 0)) - '((inst lbu result sap 0)))) - (:short - (if signed - '((inst lh result sap 0)) - '((inst lhu result sap 0)))) - (:long - '((inst lw result sap 0))) - (:single - '((inst lwc1 result sap 0))) - (:double - '((inst lwc1 result sap 0) - (inst lwc1-odd result sap word-bytes)))) - (inst nop))) - (define-vop (,ref-name-c) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg))) - (:arg-types system-area-pointer - (:constant ,(if (eq size :double) - ;; We need to be able to add 4. - `(integer ,(- (ash 1 16)) - ,(- (ash 1 16) 5)) - '(signed-byte 16)))) - (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 4 - ,@(ecase size - (:byte - (if signed - '((inst lb result object offset)) - '((inst lbu result object offset)))) - (:short - (if signed - '((inst lh result object offset)) - '((inst lhu result object offset)))) - (:long - '((inst lw result object offset))) - (:single - '((inst lwc1 result object offset))) - (:double - '((inst lwc1 result object offset) - (inst lwc1-odd result object (+ offset word-bytes))))) - (inst nop))) - (define-vop (,set-name) - (:translate ,set-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg) :target sap) - (offset :scs (unsigned-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer unsigned-num ,type) - (:results (result :scs (,sc))) - (:result-types ,type) - (:temporary (:scs (sap-reg) :from (:argument 0)) sap) - (:generator 5 - (inst addu sap object offset) - ,@(ecase size - (:byte - '((inst sb value sap 0) - (move result value))) - (:short - '((inst sh value sap 0) - (move result value))) - (:long - '((inst sw value sap 0) - (move result value))) - (:single - '((inst swc1 value sap 0) - (unless (location= result value) - (inst fmove :single result value)))) - (:double - '((inst swc1 value sap 0) - (inst swc1-odd value sap word-bytes) - (unless (location= result value) - (inst fmove :double result value))))))) - (define-vop (,set-name-c) - (:translate ,set-name) - (:policy :fast-safe) - (:args (object :scs (sap-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer - (:constant ,(if (eq size :double) - ;; We need to be able to add 4. - `(integer ,(- (ash 1 16)) - ,(- (ash 1 16) 5)) - '(signed-byte 16))) - ,type) - (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 5 - ,@(ecase size - (:byte - '((inst sb value object offset) - (move result value))) - (:short - '((inst sh value object offset) - (move result value))) - (:long - '((inst sw value object offset) - (move result value))) - (:single - '((inst swc1 value object offset) - (unless (location= result value) - (inst fmove :single result value)))) - (:double - '((inst swc1 value object offset) - (inst swc1-odd value object (+ offset word-bytes)) - (unless (location= result value) - (inst fmove :double result value)))))))))) - -); eval-when (compile eval) - -(def-system-ref-and-set sap-ref-8 %set-sap-ref-8 - unsigned-reg positive-fixnum :byte nil) -(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 - signed-reg tagged-num :byte t) -(def-system-ref-and-set sap-ref-16 %set-sap-ref-16 - unsigned-reg positive-fixnum :short nil) -(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 - signed-reg tagged-num :short t) -(def-system-ref-and-set sap-ref-32 %set-sap-ref-32 - unsigned-reg unsigned-num :long nil) -(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 - signed-reg signed-num :long t) -(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap - sap-reg system-area-pointer :long) -(def-system-ref-and-set sap-ref-single %set-sap-ref-single - single-reg single-float :single) -(def-system-ref-and-set sap-ref-double %set-sap-ref-double - double-reg double-float :double) - - -;;; Noise to convert normal lisp data objects into SAPs. - -(define-vop (vector-sap) - (:translate vector-sap) - (:policy :fast-safe) - (:args (vector :scs (descriptor-reg))) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst addu sap vector - (- (* vector-data-offset word-bytes) other-pointer-type)))) - diff --git a/compiler/mips/static-fn.lisp b/compiler/mips/static-fn.lisp deleted file mode 100644 index f00057c8f59ff7be6d559cc16e086b2f4caf4e2d..0000000000000000000000000000000000000000 --- a/compiler/mips/static-fn.lisp +++ /dev/null @@ -1,147 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/static-fn.lisp,v 1.19 1993/01/13 16:03:23 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VOPs and macro magic necessary to call static -;;; functions. -;;; -;;; Written by William Lott. -;;; -(in-package "MIPS") - - - -(define-vop (static-function-template) - (:save-p t) - (:policy :safe) - (:variant-vars symbol) - (:vop-var vop) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg)) move-temp) - #-gengc (:temporary (:sc descriptor-reg :offset lra-offset) lra) - (:temporary (:sc interior-reg :offset lip-offset) entry-point) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) ocfp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) - - -(eval-when (compile load eval) - - -(defun static-function-template-name (num-args num-results) - (intern (format nil "~:@(~R-arg-~R-result-static-function~)" - num-args num-results))) - - -(defun moves (dst src) - (collect ((moves)) - (do ((dst dst (cdr dst)) - (src src (cdr src))) - ((or (null dst) (null src))) - (moves `(move ,(car dst) ,(car src)))) - (moves))) - -(defun static-function-template-vop (num-args num-results) - (assert (and (<= num-args register-arg-count) - (<= num-results register-arg-count)) - (num-args num-results) - "Either too many args (~D) or too many results (~D). Max = ~D" - num-args num-results register-arg-count) - (let ((num-temps (max num-args num-results))) - (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) - (dotimes (i num-results) - (let ((result-name (intern (format nil "RESULT-~D" i)))) - (result-names result-name) - (results `(,result-name :scs (any-reg descriptor-reg))))) - (dotimes (i num-temps) - (let ((temp-name (intern (format nil "TEMP-~D" i)))) - (temp-names temp-name) - (temps `(:temporary (:sc descriptor-reg - :offset ,(nth i register-arg-offsets) - ,@(when (< i num-args) - `(:from (:argument ,i))) - ,@(when (< i num-results) - `(:to (:result ,i) - :target ,(nth i (result-names))))) - ,temp-name)))) - (dotimes (i num-args) - (let ((arg-name (intern (format nil "ARG-~D" i)))) - (arg-names arg-name) - (args `(,arg-name - :scs (any-reg descriptor-reg) - :target ,(nth i (temp-names)))))) - `(define-vop (,(static-function-template-name num-args num-results) - static-function-template) - (:args ,@(args)) - ,@(temps) - (:results ,@(results)) - (:generator ,(+ 50 num-args num-results) - (let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - ,@(moves (temp-names) (arg-names)) - (inst li nargs (fixnum ,num-args)) - (inst lw entry-point null-tn (static-function-offset symbol)) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (inst move ocfp cfp-tn) - #-gengc (inst compute-lra-from-code lra code-tn lra-label temp) - (note-this-location vop :call-site) - (inst #-gengc j #+gengc jal entry-point) - (inst move cfp-tn csp-tn) - (emit-return-pc lra-label) - ,(collect ((bindings) (links)) - (do ((temp (temp-names) (cdr temp)) - (name 'values (gensym)) - (prev nil name) - (i 0 (1+ i))) - ((= i num-results)) - (bindings `(,name - (make-tn-ref ,(car temp) nil))) - (when prev - (links `(setf (tn-ref-across ,prev) ,name)))) - `(let ,(bindings) - ,@(links) - (default-unknown-values vop - ,(if (zerop num-results) nil 'values) - ,num-results move-temp temp lra-label))) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - ,@(moves (result-names) (temp-names)))))))) - - -) ; eval-when (compile load eval) - - -(expand - (collect ((templates (list 'progn))) - (dotimes (i register-arg-count) - (templates (static-function-template-vop i 1))) - (templates))) - - -(defmacro define-static-function (name args &key (results '(x)) translate - policy cost arg-types result-types) - `(define-vop (,name - ,(static-function-template-name (length args) - (length results))) - (:variant ',name) - (:note ,(format nil "static-function ~@(~S~)" name)) - ,@(when translate - `((:translate ,translate))) - ,@(when policy - `((:policy ,policy))) - ,@(when cost - `((:generator-cost ,cost))) - ,@(when arg-types - `((:arg-types ,@arg-types))) - ,@(when result-types - `((:result-types ,@result-types))))) diff --git a/compiler/mips/subprim.lisp b/compiler/mips/subprim.lisp deleted file mode 100644 index 5b0449e5815af291a35af25216f3920450aabf4f..0000000000000000000000000000000000000000 --- a/compiler/mips/subprim.lisp +++ /dev/null @@ -1,64 +0,0 @@ -;;; -*- Package: MIPS; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/mips/subprim.lisp,v 1.21 1992/07/28 20:37:52 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Linkage information for standard static functions, and random vops. -;;; -;;; Written by William Lott. -;;; -(in-package "MIPS") - - - -;;;; Length - -(define-vop (length/list) - (:translate length) - (:args (object :scs (descriptor-reg) :target ptr)) - (:arg-types list) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result) - count) - (:results (result :scs (any-reg descriptor-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:generator 50 - (move ptr object) - (move count zero-tn) - - LOOP - - (inst beq ptr null-tn done) - (inst nop) - - (inst and temp ptr lowtag-mask) - (inst xor temp list-pointer-type) - (inst bne temp zero-tn not-list) - (inst nop) - - (loadw ptr ptr cons-cdr-slot list-pointer-type) - (inst b loop) - (inst addu count count (fixnum 1)) - - NOT-LIST - (cerror-call vop done object-not-list-error ptr) - - DONE - (move result count))) - - -(define-static-function length (object) :translate length) - - - diff --git a/compiler/mips/system.lisp b/compiler/mips/system.lisp deleted file mode 100644 index d695f2f9c4ea94566cc9128f76dec8918dd7b8dc..0000000000000000000000000000000000000000 --- a/compiler/mips/system.lisp +++ /dev/null @@ -1,323 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/system.lisp,v 1.47 1993/01/13 16:02:06 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; MIPS VM definitions of various system hacking operations. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Mips conversion by William Lott and Christopher Hoover. -;;; -(in-package "MIPS") - - -;;;; Random pointer comparison VOPs - -(define-vop (pointer-compare) - (:args (x :scs (sap-reg)) - (y :scs (sap-reg))) - (:arg-types system-area-pointer system-area-pointer) - (:temporary (:scs (non-descriptor-reg)) temp) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:note "inline comparison") - (:variant-vars condition) - (:generator 3 - (three-way-comparison x y condition :unsigned not-p target temp))) - -(macrolet ((frob (name cond) - `(progn - (def-primitive-translator ,name (x y) `(,',name ,x ,y)) - (defknown ,name (t t) boolean (movable foldable flushable)) - (define-vop (,name pointer-compare) - (:translate ,name) - (:variant ,cond))))) - (frob pointer< :lt) - (frob pointer> :gt)) - - - -;;;; Type frobbing VOPs - -(define-vop (get-lowtag) - (:translate get-lowtag) - (:policy :fast-safe) - (:args (object :scs (any-reg descriptor-reg))) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 1 - (inst and result object lowtag-mask))) - -(define-vop (get-type) - (:translate get-type) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - ;; Pick off objects with headers. - (inst and ndescr object lowtag-mask) - (inst xor ndescr other-pointer-type) - (inst beq ndescr other-ptr) - (inst xor ndescr (logxor other-pointer-type function-pointer-type)) - (inst beq ndescr function-ptr) - - ;; Pick off fixnums. - (inst and result object 3) - (inst beq result done) - - ;; Pick off structure and list pointers. - (inst and result object 1) - (inst bne result lowtag-only) - (inst nop) - - ;; Must be an other immediate. - (inst b done) - (inst and result object type-mask) - - FUNCTION-PTR - (load-type result object (- function-pointer-type)) - (inst b done) - (inst nop) - - LOWTAG-ONLY - (inst b done) - (inst and result object lowtag-mask) - - OTHER-PTR - (load-type result object (- other-pointer-type)) - (inst nop) - - DONE)) - -(define-vop (function-subtype) - (:translate function-subtype) - (:policy :fast-safe) - (:args (function :scs (descriptor-reg))) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (load-type result function (- function-pointer-type)) - (inst nop))) - -(define-vop (set-function-subtype) - (:translate (setf function-subtype)) - (:policy :fast-safe) - (:args (type :scs (unsigned-reg) :target result) - (function :scs (descriptor-reg))) - (:arg-types positive-fixnum *) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (inst sb type function (- function-pointer-type)) - (move result type))) - - -(define-vop (get-header-data) - (:translate get-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (loadw res x 0 other-pointer-type) - (inst srl res res type-bits))) - -(define-vop (get-closure-length) - (:translate get-closure-length) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (loadw res x 0 function-pointer-type) - (inst srl res res type-bits))) - -(define-vop (set-header-data) - (:translate set-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg) :target res) - (data :scs (any-reg immediate zero))) - (:arg-types * positive-fixnum) - (:results (res :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) t1 t2) - (:generator 6 - (loadw t1 x 0 other-pointer-type) - (inst and t1 type-mask) - (sc-case data - (any-reg - (inst sll t2 data (- type-bits 2)) - (inst or t1 t2)) - (immediate - (inst or t1 (ash (tn-value data) type-bits))) - (zero)) - (storew t1 x 0 other-pointer-type) - (move res x))) - -(define-vop (c::make-fixnum) - (:args (ptr :scs (any-reg descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - ;; - ;; Some code (the hash table code) depends on this returning a - ;; positive number so make sure it does. - (inst sll res ptr 3) - (inst srl res res 1))) - -(define-vop (c::make-other-immediate-type) - (:args (val :scs (any-reg descriptor-reg)) - (type :scs (any-reg descriptor-reg immediate) - :target temp)) - (:results (res :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 2 - (sc-case type - ((immediate) - (inst sll temp val type-bits) - (inst or res temp (tn-value type))) - (t - (inst sra temp type 2) - (inst sll res val (- type-bits 2)) - (inst or res res temp))))) - - -;;;; Allocation - -(define-vop (dynamic-space-free-pointer) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate dynamic-space-free-pointer) - (:policy :fast-safe) - (:generator 1 - (move int alloc-tn))) - -(define-vop (binding-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate binding-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move int bsp-tn))) - -(define-vop (control-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate control-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move int csp-tn))) - - -;;;; Code object frobbing. - -(define-vop (code-instructions) - (:translate code-instructions) - (:policy :fast-safe) - (:args (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 10 - (loadw ndescr code 0 other-pointer-type) - (inst srl ndescr type-bits) - (inst sll ndescr word-shift) - (inst subu ndescr other-pointer-type) - (inst addu sap code ndescr))) - -(define-vop (compute-function) - (:args (code :scs (descriptor-reg)) - (offset :scs (signed-reg unsigned-reg))) - (:arg-types * positive-fixnum) - (:results (func :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 10 - (loadw ndescr code 0 other-pointer-type) - (inst srl ndescr type-bits) - (inst sll ndescr word-shift) - (inst addu ndescr offset) - (inst addu ndescr (- function-pointer-type other-pointer-type)) - (inst addu func code ndescr))) - -#+gengc -(progn - -(define-vop (%function-self) - (:policy :fast-safe) - (:translate (setf %function-self)) - (:args (function :scs (descriptor-reg))) - (:temporary (:scs (any-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:generator 3 - (loadw temp function function-entry-point-slot function-pointer-type) - (inst addu result temp - (- function-pointer-type (* function-code-offset word-bytes))))) - -(defknown %set-function-self (function function) (values) (unsafe)) - -(define-vop (%set-function-self) - (:policy :fast-safe) - (:translate %set-function-self) - (:args (function :scs (descriptor-reg)) - (new-self :scs (descriptor-reg))) - (:temporary (:scs (any-reg)) temp) - (:generator 3 - (inst addu temp new-self - (- (* function-code-offset word-bytes) function-pointer-type)) - (storew temp function function-entry-point-slot function-pointer-type))) - -(def-source-transform %closure-function (closure) - `(%function-self ,closure)) - -(def-source-transform (setf %function-self) (new-self fun) - `(let ((new-self ,new-self) (fun ,fun)) - (%set-function-self fun new-self) - new-self)) - -(def-source-transform %set-funcallable-instance-function (fin fun) - `(let ((fin ,fin) (fun ,fun)) - (%set-function-self fin fun) - fun)) - -); #+gengc progn - - -;;;; Other random VOPs. - - -(defknown unix::do-pending-interrupt () (values)) -(define-vop (unix::do-pending-interrupt) - (:policy :fast-safe) - (:translate unix::do-pending-interrupt) - (:generator 1 - (inst break pending-interrupt-trap))) - - -(define-vop (halt) - (:generator 1 - (inst break halt-trap))) - - -;;;; Dynamic vop count collection support - -(define-vop (count-me) - (:args (count-vector :scs (descriptor-reg))) - (:info index) - (:temporary (:scs (non-descriptor-reg)) count) - (:generator 1 - (let ((offset - (- (* (+ index vector-data-offset) word-bytes) other-pointer-type))) - (inst lw count count-vector offset) - (inst nop) - (inst addu count 1) - (inst sw count count-vector offset)))) diff --git a/compiler/mips/utils.lisp b/compiler/mips/utils.lisp deleted file mode 100644 index b413d600b19f9b3712ddd4fcdf639c25bbd0051b..0000000000000000000000000000000000000000 --- a/compiler/mips/utils.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*- Package: MIPS; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/mips/utils.lisp,v 1.1 1991/07/26 01:44:45 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains various useful utilities for generating MIPS code. -;;; -;;; Written by William Lott and Christopher Hoover. -;;; - -(in-package "MIPS") - - - -;;;; Three Way Comparison - -(defun three-way-comparison (x y condition flavor not-p target temp) - (ecase condition - (:eq - (if not-p - (inst bne x y target) - (inst beq x y target))) - (:lt - (ecase flavor - (:unsigned - (inst sltu temp x y)) - (:signed - (inst slt temp x y))) - (if not-p - (inst beq temp zero-tn target) - (inst bne temp zero-tn target))) - (:gt - (ecase flavor - (:unsigned - (inst sltu temp y x)) - (:signed - (inst slt temp y x))) - (if not-p - (inst beq temp zero-tn target) - (inst bne temp zero-tn target)))) - (inst nop)) - - -;;;; Pseudo-atomic support. - -(defun start-pseudo-atomic () - ;; I don't think that we need to clear the interrupted slot. It should - ;; be clear already. - ;(storew zero-tn mutator-tn mutator-pseudo-atomic-interrupted-slot) - (storew csp-tn mutator-tn mutator-pseudo-atomic-atomic-slot)) - -(defun end-pseudo-atomic (ndescr) - (let ((label (gen-label))) - (storew zero-tn mutator-tn mutator-pseudo-atomic-atomic-slot) - (loadw ndescr mutator-tn mutator-pseudo-atomic-interrupted-slot) - (inst beq ndescr label) - (inst nop) - (inst break pending-interrupt-trap) - (emit-label label))) - - - -;;;; write-list support. - -(defun check-pointer-ages-p (vop value) - (and (sc-is value descriptor-reg) - (let ((option (assoc :check-pointer-ages - (c::lexenv-options - (c::node-lexenv - (c::vop-node vop)))))) - (or (null option) - (cdr option))))) diff --git a/compiler/mips/values.lisp b/compiler/mips/values.lisp deleted file mode 100644 index 4e16808ebeb996886dc5cadd7cd3840b07190df2..0000000000000000000000000000000000000000 --- a/compiler/mips/values.lisp +++ /dev/null @@ -1,98 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/values.lisp,v 1.13 1992/07/28 20:38:01 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the implementation of unknown-values VOPs. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted for MIPS by William Lott. -;;; - -(in-package "MIPS") - -(define-vop (reset-stack-pointer) - (:args (ptr :scs (any-reg))) - (:generator 1 - (move csp-tn ptr))) - - -;;; Push some values onto the stack, returning the start and number of values -;;; pushed as results. It is assumed that the Vals are wired to the standard -;;; argument locations. Nvals is the number of values to push. -;;; -;;; The generator cost is pseudo-random. We could get it right by defining a -;;; bogus SC that reflects the costs of the memory-to-memory moves for each -;;; operand, but this seems unworthwhile. -;;; -(define-vop (push-values) - (:args - (vals :more t)) - (:results - (start :scs (any-reg)) - (count :scs (any-reg))) - (:info nvals) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) - :to (:result 0) - :target start) - start-temp) - (:generator 20 - (move start-temp csp-tn) - (inst addu csp-tn csp-tn (* nvals word-bytes)) - (do ((val vals (tn-ref-across val)) - (i 0 (1+ i))) - ((null val)) - (let ((tn (tn-ref-tn val))) - (sc-case tn - (descriptor-reg - (storew tn start-temp i)) - (control-stack - (load-stack-tn temp tn) - (storew temp start-temp i))))) - (move start start-temp) - (inst li count (fixnum nvals)))) - - -;;; Push a list of values on the stack, returning Start and Count as used in -;;; unknown values continuations. -;;; -(define-vop (values-list) - (:args (arg :scs (descriptor-reg) :target list)) - (:arg-types list) - (:policy :fast-safe) - (:results (start :scs (any-reg)) - (count :scs (any-reg))) - (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (move list arg) - (move start csp-tn) - - LOOP - (inst beq list null-tn done) - (loadw temp list cons-car-slot list-pointer-type) - (loadw list list cons-cdr-slot list-pointer-type) - (inst addu csp-tn csp-tn word-bytes) - (storew temp csp-tn -1) - (inst and ndescr list lowtag-mask) - (inst xor ndescr list-pointer-type) - (inst beq ndescr zero-tn loop) - (inst nop) - (error-call vop bogus-argument-to-values-list-error list) - - DONE - (inst subu count csp-tn start))) - diff --git a/compiler/mips/vm.lisp b/compiler/mips/vm.lisp deleted file mode 100644 index 6803cd96fff75e24771e84e16cc3dd948c8940a2..0000000000000000000000000000000000000000 --- a/compiler/mips/vm.lisp +++ /dev/null @@ -1,363 +0,0 @@ -;;; -*- Package: MIPS -*- -;;; -;;; ********************************************************************** -;;; 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/mips/vm.lisp,v 1.47 1993/01/13 15:59:31 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition for the MIPS R2000 and the new -;;; object format. -;;; -;;; Written by Christopher Hoover and William Lott. -;;; -(in-package "MIPS") - - -;;;; Registers - -(eval-when (compile eval) - -(defmacro defreg (name offset) - (let ((offset-sym (symbolicate name "-OFFSET"))) - `(eval-when (compile eval load) - (defconstant ,offset-sym ,offset) - (setf (svref *register-names* ,offset-sym) ,(symbol-name name))))) - -(defmacro defregset (name &rest regs) - `(eval-when (compile eval load) - (defconstant ,name - (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))) - -) - -(eval-when (compile eval load) - -(defvar *register-names* (make-array 32 :initial-element nil)) - -); eval-when - -(defreg zero 0) -#-gengc (defreg nl3 1) -#+gengc (defreg lip 1) -(defreg cfunc 2) -(defreg nl4 3) -(defreg nl0 4) ; First C argument reg. -(defreg nl1 5) -(defreg nl2 6) -(defreg nargs 7) -(defreg a0 8) -(defreg a1 9) -(defreg a2 10) -(defreg a3 11) -(defreg a4 12) -(defreg a5 13) -(defreg fdefn 14) -(defreg lexenv 15) -;; First saved reg -(defreg nfp 16) -(defreg ocfp 17) -#-gengc (defreg lra 18) -#+gengc (defreg mutator 18) -(defreg l0 19) -(defreg null 20) -(defreg bsp 21) -(defreg cfp 22) -(defreg csp 23) -#-gengc (defreg l1 24) -#+gengc (defreg ssb 24) -(defreg alloc 25) -(defreg nsp 29) -(defreg code 30) -#-gengc -(defreg lip 31) -#+gengc -(defreg ra 31) - -(defregset non-descriptor-regs - nl0 nl1 nl2 ra nl4 cfunc nargs) - -(defregset descriptor-regs - a0 a1 a2 a3 a4 a5 fdefn lexenv nfp ocfp #-gengc lra l0 #-gengc l1) - -(defregset register-arg-offsets - a0 a1 a2 a3 a4 a5) - -(defregset reserve-descriptor-regs - fdefn lexenv) - -(defregset reserve-non-descriptor-regs - nl4 cfunc) - - -;;;; SB and SC definition: - -(define-storage-base registers :finite :size 32) -(define-storage-base float-registers :finite :size 32) -(define-storage-base control-stack :unbounded :size 8) -(define-storage-base non-descriptor-stack :unbounded :size 0) -(define-storage-base constant :non-packed) -(define-storage-base immediate-constant :non-packed) - -;;; -;;; Handy macro so we don't have to keep changing all the numbers whenever -;;; we insert a new storage class. -;;; -(defmacro define-storage-classes (&rest classes) - (do ((forms (list 'progn) - (let* ((class (car classes)) - (sc-name (car class)) - (constant-name (intern (concatenate 'simple-string - (string sc-name) - "-SC-NUMBER")))) - (list* `(define-storage-class ,sc-name ,index - ,@(cdr class)) - `(defconstant ,constant-name ,index) - `(export ',constant-name) - forms))) - (index 0 (1+ index)) - (classes classes (cdr classes))) - ((null classes) - (nreverse forms)))) - -(define-storage-classes - - ;; Non-immediate constants in the constant pool - (constant constant) - - ;; Immediate constant. - (null immediate-constant) - (zero immediate-constant) - (immediate immediate-constant) - - ;; **** The stacks. - - ;; The control stack. (Scanned by GC) - (control-stack control-stack) - - ;; The non-descriptor stacks. - (signed-stack non-descriptor-stack) ; (signed-byte 32) - (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) - (base-char-stack non-descriptor-stack) ; non-descriptor characters. - (sap-stack non-descriptor-stack) ; System area pointers. - (single-stack non-descriptor-stack) ; single-floats - (double-stack non-descriptor-stack :element-size 2) ; double floats. - - - ;; **** Things that can go in the integer registers. - - ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing - ;; bad will happen if they are. (fixnums, characters, header values, etc). - (any-reg - registers - :locations #.(append non-descriptor-regs descriptor-regs) - :reserve-locations #.(append reserve-non-descriptor-regs - reserve-descriptor-regs) - :constant-scs (constant zero immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; Pointer descriptor objects. Must be seen by GC. - (descriptor-reg registers - :locations #.descriptor-regs - :reserve-locations #.reserve-descriptor-regs - :constant-scs (constant null immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; Non-Descriptor characters - (base-char-reg registers - :locations #.non-descriptor-regs - :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (immediate) - :save-p t - :alternate-scs (base-char-stack)) - - ;; Non-Descriptor SAP's (arbitrary pointers into address space) - (sap-reg registers - :locations #.non-descriptor-regs - :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (immediate) - :save-p t - :alternate-scs (sap-stack)) - - ;; Non-Descriptor (signed or unsigned) numbers. - (signed-reg registers - :locations #.non-descriptor-regs - :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (zero immediate) - :save-p t - :alternate-scs (signed-stack)) - (unsigned-reg registers - :locations #.non-descriptor-regs - :reserve-locations #.reserve-non-descriptor-regs - :constant-scs (zero immediate) - :save-p t - :alternate-scs (unsigned-stack)) - - ;; Random objects that must not be seen by GC. Used only as temporaries. - (non-descriptor-reg registers - :locations #.non-descriptor-regs) - - ;; Pointers to the interior of objects. Used only as an temporary. - (interior-reg registers - :locations (#.lip-offset)) - - - ;; **** Things that can go in the floating point registers. - - ;; Non-Descriptor single-floats. - (single-reg float-registers - :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) - :reserve-locations (26 28 30) - :constant-scs () - :save-p t - :alternate-scs (single-stack)) - - ;; Non-Descriptor double-floats. - (double-reg float-registers - :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) - :reserve-locations (26 28 30) - ;; Note: we don't bother with the element size, 'cause nothing can be - ;; allocated in the odd fp regs anyway. - :constant-scs () - :save-p t - :alternate-scs (double-stack)) - - ;; A catch or unwind block. - (catch-block control-stack :element-size vm:catch-block-size)) - - - - -;;;; Random TNs for interesting registers - -(eval-when (compile eval) - -(defmacro defregtn (name sc) - (let ((offset-sym (symbolicate name "-OFFSET")) - (tn-sym (symbolicate name "-TN"))) - `(defparameter ,tn-sym - (make-random-tn :kind :normal - :sc (sc-or-lose ',sc) - :offset ,offset-sym)))) - -) - -(defregtn zero any-reg) -(defregtn lip interior-reg) -(defregtn code descriptor-reg) -(defregtn alloc any-reg) -(defregtn null descriptor-reg) -#+gengc (defregtn mutator sap-reg) -#+gengc (defregtn ssb sap-reg) - -(defregtn nargs any-reg) -(defregtn fdefn descriptor-reg) -(defregtn lexenv descriptor-reg) - -(defregtn bsp any-reg) -(defregtn csp any-reg) -(defregtn cfp any-reg) -(defregtn ocfp any-reg) -(defregtn nsp any-reg) -(defregtn nfp any-reg) -#+gengc (defregtn ra any-reg) - - -;;; -;;; Immediate-Constant-SC -- Interface -;;; -;;; If value can be represented as an immediate constant, then return the -;;; appropriate SC number, otherwise return NIL. -;;; -(def-vm-support-routine immediate-constant-sc (value) - (typecase value - ((integer 0 0) - (sc-number-or-lose 'zero *backend*)) - (null - (sc-number-or-lose 'null *backend*)) - (symbol - (if (vm:static-symbol-p value) - (sc-number-or-lose 'immediate *backend*) - nil)) - ((signed-byte 30) - (sc-number-or-lose 'immediate *backend*)) - (system-area-pointer - (sc-number-or-lose 'immediate *backend*)) - (character - (sc-number-or-lose 'immediate *backend*)))) - - -;;;; Function Call Parameters - -;;; The SC numbers for register and stack arguments/return values. -;;; -(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) -(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) -(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) - -(eval-when (compile load eval) - -;;; Offsets of special stack frame locations -(defconstant ocfp-save-offset 0) -#-gengc (defconstant lra-save-offset 1) -#+gengc (defconstant ra-save-offset 1) -(defconstant nfp-save-offset 2) -#+gengc (defconstant code-save-offset 3) - - -;;; The number of arguments/return values passed in registers. -;;; -(defconstant register-arg-count 6) - -;;; The offsets within the register-arg SC that we pass values in, first -;;; value first. -;;; - -;;; Names to use for the argument registers. -;;; -(defconstant register-arg-names '(a0 a1 a2 a3 a4 a5)) - -); Eval-When (Compile Load Eval) - - -;;; A list of TN's describing the register arguments. -;;; -(defparameter register-arg-tns - (mapcar #'(lambda (n) - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset n)) - register-arg-offsets)) - -;;; SINGLE-VALUE-RETURN-BYTE-OFFSET -;;; -;;; This is used by the debugger. -;;; -(export 'single-value-return-byte-offset) -(defconstant single-value-return-byte-offset 8) - - -;;; LOCATION-PRINT-NAME -- Interface -;;; -;;; This function is called by debug output routines that want a pretty name -;;; for a TN's location. It returns a thing that can be printed with PRINC. -;;; -(def-vm-support-routine location-print-name (tn) - (declare (type tn tn)) - (let ((sb (sb-name (sc-sb (tn-sc tn)))) - (offset (tn-offset tn))) - (ecase sb - (registers (or (svref *register-names* offset) - (format nil "R~D" offset))) - (float-registers (format nil "F~D" offset)) - (control-stack (format nil "CS~D" offset)) - (non-descriptor-stack (format nil "NS~D" offset)) - (constant (format nil "Const~D" offset)) - (immediate-constant "Immed")))) diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp deleted file mode 100644 index b8f47b953bb3e2b8a5abaebbafdf8ab065c02cce..0000000000000000000000000000000000000000 --- a/compiler/new-assem.lisp +++ /dev/null @@ -1,1778 +0,0 @@ -;;; -*- Package: NEW-ASSEM -*- -;;; -;;; ********************************************************************** -;;; 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/new-assem.lisp,v 1.21 1992/11/23 13:42:36 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Effecient retargetable scheduling assembler. -;;; -;;; Written by William Lott. -;;; -(in-package :new-assem) - -(in-package :c) -(import '(branch flushable) :new-assem) -(import '(sset-element sset make-sset do-elements - sset-adjoin sset-delete sset-empty) - :new-assem) - -(in-package :new-assem) -(export '(emit-byte emit-skip emit-back-patch emit-chooser emit-postit - define-emitter define-instruction define-instruction-macro - def-assembler-params branch flushable variable-length reads writes - - segment make-segment segment-name - assemble align inst without-scheduling - label label-p gen-label emit-label label-position - append-segment finalize-segment - segment-map-output release-segment)) - - -;;;; Assembly control parameters. - -(defstruct (assem-params - (:print-function %print-assem-params)) - (backend (ext:required-argument) :type c::backend) - (scheduler-p nil :type (member t nil)) - (instructions (make-hash-table :test #'equal) :type hash-table) - (max-locations 0 :type index)) -;;; -(c::defprinter assem-params - (backend :prin1 (c:backend-name backend))) - -;;; DEF-ASSEMBLER-PARAMS -- Interface. -;;; -(defmacro def-assembler-params (&rest options) - "Set up the assembler." - `(eval-when (compile load eval) - (setf (c:backend-assembler-params c:*target-backend*) - (make-assem-params :backend c:*target-backend* - ,@options)))) - - -;;;; Constants. - -;;; ASSEMBLY-UNIT-BITS -- Number of bits in the minimum assembly unit, -;;; (also refered to as a ``byte''). Hopefully, different instruction -;;; sets won't require chainging this. -;;; -(defconstant assembly-unit-bits 8) - -(deftype assembly-unit () - `(unsigned-byte ,assembly-unit-bits)) - -;;; OUTPUT-BLOCK-SIZE -- The size (in bytes) to use per output block. Each -;;; output block is a chunk of raw memory, pointed to by a sap. -;;; -(defconstant output-block-size (* 8 1024)) - -(deftype output-block-index () - `(integer 0 ,output-block-size)) - -;;; MAX-ALIGNMENT -- The maximum alignment we can guarentee given the object -;;; format. If the loader only loads objects 8-byte aligned, we can't do -;;; any better then that ourselves. -;;; -(defconstant max-alignment 3) - -(deftype alignment () - `(integer 0 ,max-alignment)) - -;;; MAX-INDEX -- The maximum an index will ever become. Well, actually, -;;; just a bound on it so we can define a type. There is no real hard -;;; limit on indexes, but we will run out of memory sometime. -;;; -(defconstant max-index (1- most-positive-fixnum)) - -(deftype index () - `(integer 0 ,max-index)) - -;;; MAX-POSN -- Like MAX-INDEX, except for positions. -;;; -(defconstant max-posn (1- most-positive-fixnum)) - -(deftype posn () - `(integer 0 ,max-posn)) - - - -;;;; The SEGMENT structure. - -;;; SEGMENT -- This structure holds the state of the assembler. -;;; -(defstruct (segment - (:print-function %print-segment) - (:constructor make-segment (&key name run-scheduler inst-hook))) - ;; - ;; The name of this segment. Only using in trace files. - (name "Unnamed" :type simple-base-string) - ;; - ;; Wether or not run the scheduler. Note: if the instruction defintions - ;; were not compiled with the scheduler turned on, this has no effect. - (run-scheduler nil) - ;; - ;; If a function, then it is funcalled for each inst emitted with the - ;; segment, the VOP, the name of the inst (as a string), and the inst - ;; arguments. - (inst-hook nil :type (or function null)) - ;; - ;; Where to deposit the next byte. - (fill-pointer (system:int-sap 0) :type system:system-area-pointer) - ;; - ;; Where the current output block ends. If fill-pointer is ever sap= to - ;; this, don't deposit a byte. Move the fill pointer into a new block. - (block-end (system:int-sap 0) :type system:system-area-pointer) - ;; - ;; What position does this correspond to. Initially, positions and indexes - ;; are the same, but after we start collapsing choosers, positions can change - ;; while indexes stay the same. - (current-posn 0 :type posn) - ;; - ;; Were in the output blocks are we currently outputing. - (current-index 0 :type index) - ;; - ;; A vector of the output blocks. - (output-blocks (make-array 4 :initial-element nil) :type simple-vector) - ;; - ;; A list of all the annotations that have been output to this segment. - (annotations nil :type list) - ;; - ;; A pointer to the last cons cell in the annotations list. This is - ;; so we can quickly add things to the end of the annotations list. - (last-annotation nil :type list) - ;; - ;; The number of bits of alignment at the last time we synchronized. - (alignment max-alignment :type alignment) - ;; - ;; The position the last time we synchronized. - (sync-posn 0 :type posn) - ;; - ;; The posn and index everything ends at. This is not maintained while the - ;; data is being generated, but is filled in after. Basically, we copy - ;; current-posn and current-index so that we can trash them while processing - ;; choosers and back-patches. - (final-posn 0 :type posn) - (final-index 0 :type index) - ;; - ;; *** State used by the scheduler during instruction queueing. - ;; - ;; List of postit's. These are accumulated between instructions. - (postits nil :type list) - ;; - ;; ``Number'' for last instruction queued. Used only to supply insts - ;; with unique sset-element-number's. - (inst-number 0 :type index) - ;; - ;; Simple-Vectors mapping locations to the instruction that reads them and - ;; instructions that write them. - (readers (make-array (assem-params-max-locations - (c:backend-assembler-params c:*backend*)) - :initial-element nil) - :type simple-vector) - (writers (make-array (assem-params-max-locations - (c:backend-assembler-params c:*backend*)) - :initial-element nil) - :type simple-vector) - ;; - ;; The number of additional cycles before the next control transfer, or NIL - ;; if a control transfer hasn't been queued. When a delayed branch is - ;; queued, this slot is set to the delay count. - (branch-countdown nil :type (or null (and fixnum unsigned-byte))) - ;; - ;; *** These two slots are used both by the queuing noise and the - ;; scheduling noise. - ;; - ;; All the instructions that are pending and don't have any unresolved - ;; dependents. We don't list branches here even if they would otherwise - ;; qualify. They are listed above. - ;; - (emittable-insts-sset (make-sset) :type sset) - ;; - ;; List of queued branches. We handle these specially, because they have to - ;; be emitted at a specific place (e.g. one slot before the end of the - ;; block). - (queued-branches nil :type list) - ;; - ;; *** State used by the scheduler duing instruction scheduling. - ;; - ;; The instructions who would have had a read dependent removed if it were - ;; not for a delay slot. This is a list of lists. Each element in the - ;; top level list corresponds to yet another cycle of delay. Each element - ;; in the second level lists is a dotted pair, holding the dependency - ;; instruction and the dependent to remove. - (delayed nil :type list) - ;; - ;; The emittable insts again, except this time as a list sorted by depth. - (emittable-insts-queue nil :type list)) - -(c::defprinter segment name) - - -;;;; Structures/types used by the scheduler. - -(c:def-boolean-attribute instruction - ;; - ;; This attribute is set if the scheduler can freely flush this instruction - ;; if it thinks it is not needed. Examples are NOP and instructions that - ;; have no side effect not described by the writes. - flushable - ;; - ;; This attribute is set when an instruction can cause a control transfer. - ;; For test instructions, the delay is used to determine how many - ;; instructions follow the branch. - branch - ;; - ;; This attribute indicates that this ``instruction'' can be variable length, - ;; and therefore better never be used in a branch delay slot. - variable-length - ) - -(defstruct (instruction - (:include sset-element) - (:print-function %print-instruction) - (:conc-name inst-) - (:constructor make-instruction (number emitter attributes delay))) - ;; - ;; The function to envoke to actually emit this instruction. Gets called - ;; with the segment as its one argument. - (emitter (required-argument) :type (or null function)) - ;; - ;; The attributes of this instruction. - (attributes (instruction-attributes) :type c:attributes) - ;; - ;; Number of instructions or cycles of delay before additional instructions - ;; can read our writes. - (delay 0 :type (and fixnum unsigned-byte)) - ;; - ;; The maximum number of instructions in the longest dependency chain from - ;; this instruction to one of the independent instructions. This is used - ;; as a heuristic at to which instructions should be scheduled first. - (depth nil :type (or null (and fixnum unsigned-byte))) - ;; - ;; ** When trying remember which of the next four is which, note that the - ;; ``read'' or ``write'' always referes to the dependent (second) - ;; instruction. - ;; - ;; Instructions whos writes this instruction tries to read. - (read-dependencies (make-sset) :type sset) - ;; - ;; Instructions whos writes or reads are overwritten by this instruction. - (write-dependencies (make-sset) :type sset) - ;; - ;; Instructions who write what we read or write. - (write-dependents (make-sset) :type sset) - ;; - ;; Instructions who read what we write. - (read-dependents (make-sset) :type sset)) -;;; -#+debug (defvar *inst-ids* (make-hash-table :test #'eq)) -#+debug (defvar *next-inst-id* 0) -(defun %print-instruction (inst stream depth) - (declare (ignore depth)) - (print-unreadable-object (inst stream :type t :identity t) - #+debug - (princ (or (gethash inst *inst-ids*) - (setf (gethash inst *inst-ids*) - (incf *next-inst-id*))) - stream) - (format stream #+debug " emitter=~S" #-debug "emitter=~S" - (let ((emitter (inst-emitter inst))) - (if emitter - (multiple-value-bind - (lambda lexenv-p name) - (function-lambda-expression emitter) - (declare (ignore lambda lexenv-p)) - name) - '<flushed>))) - (when (inst-depth inst) - (format stream ", depth=~D" (inst-depth inst))))) - -#+debug -(defun reset-inst-ids () - (clrhash *inst-ids*) - (setf *next-inst-id* 0)) - - -;;;; The scheduler itself. - -;;; WITHOUT-SCHEDULING -- interface. -;;; -(defmacro without-scheduling ((&optional (segment '*current-segment*)) - &body body) - "Execute BODY (as a progn) without scheduling any of the instructions - generated inside it. DO NOT throw or return-from out of it." - (let ((var (gensym)) - (seg (gensym))) - `(let* ((,seg ,segment) - (,var (segment-run-scheduler ,seg))) - (when ,var - (schedule-pending-instructions ,seg) - (setf (segment-run-scheduler ,seg) nil)) - ,@body - (setf (segment-run-scheduler ,seg) ,var)))) - -(defmacro note-dependencies ((segment inst) &body body) - (ext:once-only ((segment segment) (inst inst)) - `(macrolet ((reads (loc) `(note-read-dependency ,',segment ,',inst ,loc)) - (writes (loc &rest keys) - `(note-write-dependency ,',segment ,',inst ,loc ,@keys))) - ,@body))) - -(defun note-read-dependency (segment inst read) - (let ((index (c:location-number read))) - #+debug (format *trace-output* "~&~S reads ~S[~D]~%" inst read index) - (when index - (let ((writers (svref (segment-writers segment) index))) - (when writers - ;; The inst that wrote the value we want to read must have completed. - (let ((writer (car writers))) - (sset-adjoin writer (inst-read-dependencies inst)) - (sset-adjoin inst (inst-read-dependents writer)) - (sset-delete writer (segment-emittable-insts-sset segment)) - ;; And it must have been completed *after* all other writes to that - ;; location. Actually, that isn't quite true. Each of the earlier - ;; writes could be done either before this last write, or after the - ;; read, but we have no way of representing that. - (dolist (other-writer (cdr writers)) - (sset-adjoin other-writer (inst-write-dependencies writer)) - (sset-adjoin writer (inst-write-dependents other-writer)) - (sset-delete other-writer - (segment-emittable-insts-sset segment)))) - ;; And we don't need to remember about earlier writes any more. - ;; Shortening the writers list means that we won't bother generating - ;; as many explicit arcs in the graph. - (setf (cdr writers) nil))) - (push inst (svref (segment-readers segment) index)))) - (ext:undefined-value)) - -(defun note-write-dependency (segment inst write &key partially) - (let ((index (c:location-number write))) - #+debug (format *trace-output* "~&~S writes ~S[~D]~%" inst write index) - (when index - ;; All previous reads of this location must have completed. - (dolist (prev-inst (svref (segment-readers segment) index)) - (unless (eq prev-inst inst) - (sset-adjoin prev-inst (inst-write-dependencies inst)) - (sset-adjoin inst (inst-write-dependents prev-inst)) - (sset-delete prev-inst (segment-emittable-insts-sset segment)))) - (when partially - ;; All previous writes to the location must have completed. - (dolist (prev-inst (svref (segment-writers segment) index)) - (sset-adjoin prev-inst (inst-write-dependencies inst)) - (sset-adjoin inst (inst-write-dependents prev-inst)) - (sset-delete prev-inst (segment-emittable-insts-sset segment))) - ;; And we can forget about remembering them, because depending on us - ;; is as good as depending on them. - (setf (svref (segment-writers segment) index) nil)) - (push inst (svref (segment-writers segment) index)))) - (ext:undefined-value)) - -;;; QUEUE-INST -- internal. -;;; -;;; This routine is called by due to uses of the INST macro when the scheduler -;;; is turned on. The change to the dependency graph has already been -;;; computed, so we just have to check to see if the basic block is terminated. -;;; -(defun queue-inst (segment inst) - #+debug (format *trace-output* "~&Queuing ~S~%" inst) - (assert (segment-run-scheduler segment)) - (let ((countdown (segment-branch-countdown segment))) - (when countdown - (decf countdown) - (assert (not (instruction-attributep (inst-attributes inst) - variable-length)))) - (cond ((instruction-attributep (inst-attributes inst) branch) - (unless countdown - (setf countdown (inst-delay inst))) - (push (cons countdown inst) - (segment-queued-branches segment))) - (t - (sset-adjoin inst (segment-emittable-insts-sset segment)))) - (when countdown - (setf (segment-branch-countdown segment) countdown) - (when (zerop countdown) - (schedule-pending-instructions segment)))) - #+debug - (format *trace-output* " reads ~S~% writes ~S~%" - (ext:collect ((reads)) - (do-elements (read (inst-read-dependencies inst)) - (reads read)) - (reads)) - (ext:collect ((writes)) - (do-elements (write (inst-write-dependencies inst)) - (writes write)) - (writes))) - (ext:undefined-value)) - -;;; SCHEDULE-PENDING-INSTRUCTIONS -- internal. -;;; -;;; Emit all the pending instructions, and reset any state. This is called -;;; whenever we hit a label (i.e. an entry point of some kind) and when the -;;; user turns the scheduler off (otherwise, the queued instructions would -;;; sit there until the scheduler was turned back on, and emitted in the -;;; wrong place). -;;; -(defun schedule-pending-instructions (segment) - (assert (segment-run-scheduler segment)) - ;; - ;; Quick blow-out if nothing to do. - (when (and (sset-empty (segment-emittable-insts-sset segment)) - (null (segment-queued-branches segment))) - (return-from schedule-pending-instructions - (ext:undefined-value))) - ;; - ;; Note that any values live at the end of the block have to be computed - ;; last. - (let ((emittable-insts (segment-emittable-insts-sset segment)) - (writers (segment-writers segment))) - (dotimes (index (length writers)) - (let* ((writer (svref writers index)) - (inst (car writer)) - (overwritten (cdr writer))) - (when writer - (when overwritten - (let ((write-dependencies (inst-write-dependencies inst))) - (dolist (other-inst overwritten) - (sset-adjoin inst (inst-write-dependents other-inst)) - (sset-adjoin other-inst write-dependencies) - (sset-delete other-inst emittable-insts)))) - ;; If the value is live at the end of the block, we can't flush it. - (setf (instruction-attributep (inst-attributes inst) flushable) - nil))))) - ;; - ;; Grovel through the entire graph in the forward direction finding all - ;; the leaf instructions. - (labels ((grovel-inst (inst) - (let ((max 0)) - (do-elements (dep (inst-write-dependencies inst)) - (let ((dep-depth (or (inst-depth dep) (grovel-inst dep)))) - (when (> dep-depth max) - (setf max dep-depth)))) - (do-elements (dep (inst-read-dependencies inst)) - (let ((dep-depth - (+ (or (inst-depth dep) (grovel-inst dep)) - (inst-delay dep)))) - (when (> dep-depth max) - (setf max dep-depth)))) - (cond ((and (sset-empty (inst-read-dependents inst)) - (instruction-attributep (inst-attributes inst) - flushable)) - #+debug - (format *trace-output* "Flushing ~S~%" inst) - (setf (inst-emitter inst) nil) - (setf (inst-depth inst) max)) - (t - (setf (inst-depth inst) max)))))) - (let ((emittable-insts nil) - (delayed nil)) - (do-elements (inst (segment-emittable-insts-sset segment)) - (grovel-inst inst) - (if (zerop (inst-delay inst)) - (push inst emittable-insts) - (setf delayed - (add-to-nth-list delayed inst (1- (inst-delay inst)))))) - (setf (segment-emittable-insts-queue segment) - (sort emittable-insts #'> :key #'inst-depth)) - (setf (segment-delayed segment) delayed)) - (dolist (branch (segment-queued-branches segment)) - (grovel-inst (cdr branch)))) - #+debug - (format *trace-output* "Queued branches: ~S~%" - (segment-queued-branches segment)) - #+debug - (format *trace-output* "Initially emittable: ~S~%" - (segment-emittable-insts-queue segment)) - #+debug - (format *trace-output* "Initially delayed: ~S~%" - (segment-delayed segment)) - ;; - ;; Accumulate the results in reverse order. Well, actually, this list will - ;; be in forward order, because we are generating the reverse order in - ;; reverse. - (let ((results nil)) - ;; - ;; Schedule all the branches in their exact locations. - (let ((insts-from-end (segment-branch-countdown segment))) - (dolist (branch (segment-queued-branches segment)) - (let ((inst (cdr branch))) - (dotimes (i (- (car branch) insts-from-end)) - #+debug - (format *trace-output* "Filling branch delay slot...~%") - (flet ((maybe-schedule-dependent (dependents) - (do-elements (inst dependents) - (note-resolved-dependencies segment inst) - (setf (segment-emittable-insts-queue segment) - (delete inst - (segment-emittable-insts-queue segment) - :test #'eq)) - (return inst)))) - (push (or (maybe-schedule-dependent (inst-read-dependents inst)) - (maybe-schedule-dependent (inst-write-dependents inst)) - (schedule-one-inst segment t) - :nop) - results)) - (advance-one-inst segment) - (incf insts-from-end)) - (note-resolved-dependencies segment inst) - (push inst results) - #+debug - (format *trace-output* "Emitting ~S~%" inst) - (advance-one-inst segment)))) - ;; - ;; Keep scheduling stuff until we run out. - (loop - (let ((inst (schedule-one-inst segment nil))) - (unless inst - (return)) - (push inst results) - (advance-one-inst segment))) - ;; - ;; Now call the emitters, but turn the scheduler off for the duration. - (setf (segment-run-scheduler segment) nil) - (dolist (inst results) - (if (eq inst :nop) - (c:emit-nop segment) - (funcall (inst-emitter inst) segment))) - (setf (segment-run-scheduler segment) t)) - ;; - ;; Clear out any residue left over. - (setf (segment-inst-number segment) 0) - (setf (segment-queued-branches segment) nil) - (setf (segment-branch-countdown segment) nil) - (setf (segment-emittable-insts-sset segment) (make-sset)) - (fill (segment-readers segment) nil) - (fill (segment-writers segment) nil) - ;; - ;; That's all folks. - (ext:undefined-value)) - -;;; ADD-TO-NTH-LIST -- internal. -;;; -;;; Utility for maintaining the segment-delayed list. We cdr down list -;;; n times (extending it if necessary) and then push thing on into the car -;;; of that cons cell. -;;; -(defun add-to-nth-list (list thing n) - (do ((cell (or list (setf list (list nil))) - (or (cdr cell) (setf (cdr cell) (list nil)))) - (i n (1- i))) - ((zerop i) - (push thing (car cell)) - list))) - -;;; SCHEDULE-ONE-INST -- internal. -;;; -;;; Find the next instruction to schedule and return it after updating -;;; any dependency information. If we can't do anything useful right -;;; now, but there is more work to be done, return :NOP to indicate that -;;; a nop must be emitted. If we are all done, return NIL. -;;; -(defun schedule-one-inst (segment delay-slot-p) - (do ((prev nil remaining) - (remaining (segment-emittable-insts-queue segment) (cdr remaining))) - ((null remaining)) - (let ((inst (car remaining))) - (unless (and delay-slot-p - (instruction-attributep (inst-attributes inst) - variable-length)) - ;; We've got us a live one here. Go for it. - #+debug - (format *Trace-output* "Emitting ~S~%" inst) - ;; Delete it from the list of insts. - (if prev - (setf (cdr prev) (cdr remaining)) - (setf (segment-emittable-insts-queue segment) - (cdr remaining))) - ;; Note that this inst has been emitted. - (note-resolved-dependencies segment inst) - ;; And return. - (return-from schedule-one-inst - ;; Are we wanting to flush this instruction? - (if (inst-emitter inst) - ;; Nope, it's still a go. So return it. - inst - ;; Yes, so pick a new one. We have to start over, - ;; because note-resolved-dependencies might have - ;; changed the emittable-insts-queue. - (schedule-one-inst segment delay-slot-p)))))) - ;; Nothing to do, so make something up. - (cond ((segment-delayed segment) - ;; No emittable instructions, but we have more work to do. Emit - ;; a NOP to fill in a delay slot. - #+debug (format *trace-output* "Emitting a NOP.~%") - :nop) - (t - ;; All done. - nil))) - -;;; NOTE-RESOLVED-DEPENDENCIES -- internal. -;;; -;;; This function is called whenever an instruction has been scheduled, and we -;;; want to know what possibilities that opens up. So look at all the -;;; instructions that this one depends on, and remove this instruction from -;;; their dependents list. If we were the last dependent, then that -;;; dependency can be emitted now. -;;; -(defun note-resolved-dependencies (segment inst) - (assert (sset-empty (inst-read-dependents inst))) - (assert (sset-empty (inst-write-dependents inst))) - (do-elements (dep (inst-write-dependencies inst)) - ;; These are the instructions who have to be completed before our - ;; write fires. Doesn't matter how far before, just before. - (let ((dependents (inst-write-dependents dep))) - (sset-delete inst dependents) - (when (and (sset-empty dependents) - (sset-empty (inst-read-dependents dep))) - (insert-emittable-inst segment dep)))) - (do-elements (dep (inst-read-dependencies inst)) - ;; These are the instructions who write values we read. If there - ;; is no delay, then just remove us from the dependent list. - ;; Otherwise, record the fact that in n cycles, we should be - ;; removed. - (if (zerop (inst-delay dep)) - (let ((dependents (inst-read-dependents dep))) - (sset-delete inst dependents) - (when (and (sset-empty dependents) - (sset-empty (inst-write-dependents dep))) - (insert-emittable-inst segment dep))) - (setf (segment-delayed segment) - (add-to-nth-list (segment-delayed segment) - (cons dep inst) - (inst-delay dep))))) - (ext:undefined-value)) - -;;; ADVANCE-ONE-INST -- internal. -;;; -;;; Process the next entry in segment-delayed. This is called whenever anyone -;;; emits an instruction. -;;; -(defun advance-one-inst (segment) - (let ((delayed-stuff (pop (segment-delayed segment)))) - (dolist (stuff delayed-stuff) - (if (consp stuff) - (let* ((dependency (car stuff)) - (dependent (cdr stuff)) - (dependents (inst-read-dependents dependency))) - (sset-delete dependent dependents) - (when (and (sset-empty dependents) - (sset-empty (inst-write-dependents dependency))) - (insert-emittable-inst segment dependency))) - (insert-emittable-inst segment stuff))))) - -;;; INSERT-EMITTABLE-INST -- internal. -;;; -;;; Note that inst is emittable by sticking it in the SEGMENT-EMITTABLE-INSTS- -;;; QUEUE list. We keep the emittable-insts sorted with the largest ``depths'' -;;; first. Except that if INST is a branch, don't bother. It will be handled -;;; correctly by the branch emitting code in SCHEDULE-PENDING-INSTRUCTIONS. -;;; -(defun insert-emittable-inst (segment inst) - (unless (instruction-attributep (inst-attributes inst) branch) - #+debug - (format *Trace-output* "Now emittable: ~S~%" inst) - (do ((my-depth (inst-depth inst)) - (remaining (segment-emittable-insts-queue segment) (cdr remaining)) - (prev nil remaining)) - ((or (null remaining) (> my-depth (inst-depth (car remaining)))) - (if prev - (setf (cdr prev) (cons inst remaining)) - (setf (segment-emittable-insts-queue segment) - (cons inst remaining)))))) - (ext:undefined-value)) - - -;;;; Structure used during output emission. - -;;; ANNOTATION -- Common supertype for all the different kinds of annotations. -;;; -(defstruct (annotation - (:constructor nil)) - ;; - ;; Where in the raw output stream was this annotation emitted. - (index 0 :type index) - ;; - ;; What position does that correspond to. - (posn nil :type (or index null))) - -;;; LABEL -- Doesn't need any additional information beyond what is in the -;;; annotation structure. -;;; -(defstruct (label - (:include annotation) - (:constructor gen-label ()) - (:print-function %print-label)) - ) -;;; -(defun %print-label (label stream depth) - (declare (ignore depth)) - (if (or *print-escape* *print-readably*) - (print-unreadable-object (label stream :type t) - (prin1 (c:label-id label) stream)) - (format stream "L~D" (c:label-id label)))) - -;;; ALIGNMENT-NOTE -- A constraint on how the output stream must be aligned. -;;; -(defstruct (alignment-note - (:include annotation) - (:conc-name alignment-) - (:predicate alignment-p) - (:constructor make-alignment (bits size))) - ;; - ;; The minimum number of low-order bits that must be zero. - (bits 0 :type alignment) - ;; - ;; The amount of filler we are assuming this alignment op will take. - (size 0 :type (integer 0 #.(1- (ash 1 max-alignment))))) - -;;; BACK-PATCH -- a reference to someplace that needs to be back-patched when -;;; we actually know what label positions, etc. are. -;;; -(defstruct (back-patch - (:include annotation) - (:constructor make-back-patch (size function))) - ;; - ;; The area effected by this back-patch. - (size 0 :type index) - ;; - ;; The function to use to generate the real data - (function nil :type function)) - -;;; CHOOSER -- Similar to a back-patch, but also an indication that the amount -;;; of stuff output depends on label-positions, etc. Back-patches can't change -;;; their mind about how much stuff to emit, but choosers can. -;;; -(defstruct (chooser - (:include annotation) - (:constructor make-chooser - (size alignment maybe-shrink worst-case-fun))) - ;; - ;; The worst case size for this chooser. There is this much space allocated - ;; in the output buffer. - (size 0 :type index) - ;; - ;; The worst case alignment this chooser is guarenteed to preserve. - (alignment 0 :type alignment) - ;; - ;; The function to call to determine of we can use a shorter sequence. It - ;; returns NIL if nothing shorter can be used, or emits that sequence and - ;; returns T. - (maybe-shrink nil :type function) - ;; - ;; The function to call to generate the worst case sequence. This is used - ;; when nothing else can be condensed. - (worst-case-fun nil :type function)) - -;;; FILLER -- Used internally when we figure out a chooser or alignment doesn't -;;; really need as much space as we initially gave it. -;;; -(defstruct (filler - (:include annotation) - (:constructor make-filler (bytes))) - ;; - ;; The number of bytes of filler here. - (bytes 0 :type index)) - - - -;;;; Output buffer utility functions. - -;;; A list of all the output-blocks we have allocated but aren't using. -;;; We free-list them because allocation more is slow and the garbage collector -;;; doesn't know about them, so it can't be slowed down by use keep ahold of -;;; them. -;;; -(defvar *available-output-blocks* nil) - -;;; A list of all the output-blocks we have ever allocated. We don't really -;;; need to keep tract of this if RELEASE-OUTPUT-BLOCK were always called, -;;; but... -;;; -(defvar *all-output-blocks* nil) - -;;; NEW-OUTPUT-BLOCK -- internal. -;;; -;;; Return a new output block, allocating one if necessary. -;;; -(defun new-output-block () - (if *available-output-blocks* - (pop *available-output-blocks*) - (let ((block (system:allocate-system-memory output-block-size))) - (push block *all-output-blocks*) - block))) - -;;; RELEASE-OUTPUT-BLOCK -- internal. -;;; -;;; Return block to the list of avaiable blocks. -;;; -(defun release-output-block (block) - (push block *available-output-blocks*)) - -;;; FORGET-OUTPUT-BLOCKS -- internal. -;;; -;;; We call this whenever a core starts up, because system-memory isn't -;;; saves with the core. If we didn't, we would find our hands full of -;;; bogus SAPs, which would make all sorts of things unhappy. -;;; -(defun forget-output-blocks () - (setf *all-output-blocks* nil) - (setf *available-output-blocks* nil)) -;;; -(pushnew 'forget-output-blocks ext:*after-save-initializations*) - - - -;;;; Output functions. - -;;; FIND-NEW-FILL-POINTER -- internal. -;;; -;;; Find us a new fill pointer for the current index in segment. Allocate -;;; any additional storage as necessary. -;;; -(defun find-new-fill-pointer (segment) - (declare (type segment segment)) - (let* ((index (segment-current-index segment)) - (blocks (segment-output-blocks segment)) - (num-blocks (length blocks))) - (multiple-value-bind - (block-num offset) - (truncate index output-block-size) - (when (>= block-num num-blocks) - (setf blocks - (adjust-array blocks (+ block-num 3) :initial-element nil)) - (setf (segment-output-blocks segment) blocks)) - (let ((block (or (aref blocks block-num) - (setf (aref blocks block-num) (new-output-block))))) - (setf (segment-block-end segment) - (system:sap+ block output-block-size)) - (setf (segment-fill-pointer segment) (system:sap+ block offset)))))) - -;;; EMIT-BYTE -- interface. -;;; -;;; Emit the supplied BYTE to SEGMENT, growing it if necessary. -;;; -(declaim (inline emit-byte)) -(defun emit-byte (segment byte) - "Emit BYTE to SEGMENT." - (declare (type segment segment) - (type (or assembly-unit (signed-byte #.assembly-unit-bits)) byte)) - (let* ((orig-ptr (segment-fill-pointer segment)) - (ptr (if (system:sap= orig-ptr (segment-block-end segment)) - (find-new-fill-pointer segment) - orig-ptr))) - (setf (system:sap-ref-8 ptr 0) (ldb (byte assembly-unit-bits 0) byte)) - (setf (segment-fill-pointer segment) (system:sap+ ptr 1))) - (incf (segment-current-posn segment)) - (incf (segment-current-index segment)) - (ext:undefined-value)) - -;;; EMIT-SKIP -- interface. -;;; -(defun emit-skip (segment amount) - "Output AMOUNT zeros (in bytes) to SEGMENT." - (declare (type segment segment) - (type index amount)) - (dotimes (i amount) - (emit-byte segment 0)) - (ext:undefined-value)) - -;;; EMIT-ANNOTATION -- internal. -;;; -;;; Used to handle the common parts of annotation emision. We just -;;; assign the posn and index of the note and tack it on to the end -;;; of the segment's annotations list. -;;; -(defun emit-annotation (segment note) - (declare (type segment segment) - (type annotation note)) - (when (annotation-posn note) - (error "Attempt to emit ~S for the second time.")) - (setf (annotation-posn note) (segment-current-posn segment)) - (setf (annotation-index note) (segment-current-index segment)) - (let ((last (segment-last-annotation segment)) - (new (list note))) - (setf (segment-last-annotation segment) - (if last - (setf (cdr last) new) - (setf (segment-annotations segment) new)))) - (ext:undefined-value)) - -;;; EMIT-BACK-PATCH -- interface. -;;; -(defun emit-back-patch (segment size function) - "Note that the instruction stream has to be back-patched when label positions - are finally known. SIZE bytes are reserved in SEGMENT, and function will - be called with two arguments: the segment and the position. The function - should look at the position and the position of any labels it wants to - and emit the correct sequence. (And it better be the same size as SIZE). - SIZE can be zero, which is useful if you just want to find out where things - ended up." - (emit-annotation segment (make-back-patch size function)) - (emit-skip segment size)) - -;;; EMIT-CHOOSER -- interface. -;;; -(defun emit-chooser (segment size alignment maybe-shrink worst-case-fun) - "Note that the instruction stream here depends on the actual positions of - various labels, so can't be output until label positions are known. Space - is made in SEGMENT for at least SIZE bytes. When all output has been - generated, the MAYBE-SHRINK functions for all choosers are called with - three arguments: the segment, the position, and a magic value. The MAYBE- - SHRINK decides if it can use a shorter sequence, and if so, emits that - sequence to the segment and returns T. If it can't do better than the - worst case, it should return NIL (without emitting anything). When calling - LABEL-POSITION, it should pass it the position and the magic-value it was - passed so that LABEL-POSITION can return the correct result. If the chooser - never decides to use a shorter sequence, the WORST-CASE-FUN will be called, - just like a BACK-PATCH. (See EMIT-BACK-PATCH.)" - (declare (type segment segment) (type index size) (type alignment alignment) - (type function maybe-shrink worst-case-fun)) - (let ((chooser (make-chooser size alignment maybe-shrink worst-case-fun))) - (emit-annotation segment chooser) - (emit-skip segment size) - (adjust-alignment-after-chooser segment chooser))) - -;;; ADJUST-ALIGNMENT-AFTER-CHOOSER -- internal. -;;; -;;; Called in EMIT-CHOOSER and COMPRESS-SEGMENT in order to recompute the -;;; current alignment information in light of this chooser. If the alignment -;;; guarenteed byte the chooser is less then the segments current alignment, -;;; we have to adjust the segments notion of the current alignment. -;;; -;;; The hard part is recomputing the sync posn, because it's not just the -;;; choosers posn. Consider a chooser that emits either one or three words. -;;; It preserves 8-byte (3 bit) alignments, because the difference between -;;; the two choices is 8 bytes. -;;; -(defun adjust-alignment-after-chooser (segment chooser) - (declare (type segment segment) (type chooser chooser)) - (let ((alignment (chooser-alignment chooser)) - (seg-alignment (segment-alignment segment))) - (when (< alignment seg-alignment) - ;; The chooser might change the alignment of the output. So we have - ;; to figure out what the worst case alignment could be. - (setf (segment-alignment segment) alignment) - (let* ((posn (chooser-posn chooser)) - (sync-posn (segment-sync-posn segment)) - (offset (- posn sync-posn)) - (delta (logand offset (1- (ash 1 alignment))))) - (setf (segment-sync-posn segment) (- posn delta))))) - (ext:undefined-value)) - -;;; EMIT-FILLER -- internal. -;;; -;;; Used internally whenever a chooser or alignment decides it doesn't need -;;; as much space as it originally though. -;;; -(defun emit-filler (segment bytes) - (let ((last (segment-last-annotation segment))) - (cond ((and last (filler-p (car last))) - (incf (filler-bytes (car last)) bytes)) - (t - (emit-annotation segment (make-filler bytes))))) - (incf (segment-current-index segment) bytes) - (setf (segment-fill-pointer segment) (system:int-sap 0)) - (setf (segment-block-end segment) (system:int-sap 0)) - (ext:undefined-value)) - -;;; %EMIT-LABEL -- internal. -;;; -;;; EMIT-LABEL (the interface) basically just expands into this, supplying -;;; the segment and vop. -;;; -(defun %emit-label (segment vop label) - (when (segment-run-scheduler segment) - (schedule-pending-instructions segment)) - (let ((postits (segment-postits segment))) - (setf (segment-postits segment) nil) - (dolist (postit postits) - (emit-back-patch segment 0 postit))) - (let ((hook (segment-inst-hook segment))) - (when hook - (funcall hook segment vop :label label))) - (emit-annotation segment label)) - -;;; EMIT-ALIGNMENT -- internal. -;;; -;;; Called by the ALIGN macro to emit an alignment note. We check to see -;;; if we can guarentee the alignment restriction by just outputing a fixed -;;; number of bytes. If so, we do so. Otherwise, we create and emit -;;; an alignment note. -;;; -(defun emit-alignment (segment vop bits) - (when (segment-run-scheduler segment) - (schedule-pending-instructions segment)) - (let ((hook (segment-inst-hook segment))) - (when hook - (funcall hook segment vop :align bits))) - (let ((alignment (segment-alignment segment)) - (offset (- (segment-current-posn segment) - (segment-sync-posn segment)))) - (cond ((> bits alignment) - ;; We need more bits of alignment. First emit enough noise - ;; to get back in sync with alignment, and then emit an alignment - ;; note to cover the rest. - (let ((slop (logand offset (1- (ash 1 alignment))))) - (unless (zerop slop) - (emit-skip segment (- (ash 1 alignment) slop)))) - (let ((size (logand (1- (ash 1 bits)) - (lognot (1- (ash 1 alignment)))))) - (assert (> size 0)) - (emit-annotation segment (make-alignment bits size)) - (emit-skip segment size)) - (setf (segment-alignment segment) bits) - (setf (segment-sync-posn segment) (segment-current-posn segment))) - (t - ;; The last alignment was more restrictive then this one. - ;; So we can just figure out how much noise to emit assuming - ;; the last alignment was met. - (let* ((mask (1- (ash 1 bits))) - (new-offset (logand (+ offset mask) (lognot mask)))) - (emit-skip segment (- new-offset offset))) - ;; But we emit an alignment with size=0 so we can verify - ;; that everything works. - (emit-annotation segment (make-alignment bits 0))))) - (ext:undefined-value)) - - -;;; FIND-ALIGNMENT -- internal. -;;; -;;; Used to find how ``aligned'' different offsets are. Returns the number -;;; of low-order 0 bits, up to MAX-ALIGNMENT. -;;; -(defun find-alignment (offset) - (dotimes (i max-alignment max-alignment) - (when (logbitp i offset) - (return i)))) - -;;; EMIT-POSTIT -- Internal. -;;; -;;; Emit a postit. The function will be called as a back-patch with the -;;; position the following instruction is finally emitted. Postits do not -;;; interfere at all with scheduling. -;;; -(defun %emit-postit (segment function) - (push function (segment-postits segment)) - (ext:undefined-value)) - - - -;;;; Output compression/position assignment stuff - -;;; COMPRESS-OUTPUT -- internal. -;;; -;;; Grovel though all the annotations looking for choosers. When we find -;;; a chooser, invoke the maybe-shrink function. If it returns T, it output -;;; some other byte sequence. -;;; -(defun compress-output (segment) - (dotimes (i 5) ; it better not take more than one or two passes. - (let ((delta 0)) - (setf (segment-alignment segment) max-alignment) - (setf (segment-sync-posn segment) 0) - (do* ((prev nil) - (remaining (segment-annotations segment) next) - (next (cdr remaining) (cdr remaining))) - ((null remaining)) - (let* ((note (car remaining)) - (posn (annotation-posn note))) - (unless (zerop delta) - (decf posn delta) - (setf (annotation-posn note) posn)) - (cond - ((chooser-p note) - (setf (segment-current-index segment) (chooser-index note)) - (setf (segment-current-posn segment) posn) - (setf (segment-fill-pointer segment) (system:int-sap 0)) - (setf (segment-block-end segment) (system:int-sap 0)) - (setf (segment-last-annotation segment) prev) - (cond - ((funcall (chooser-maybe-shrink note) segment posn delta) - ;; It emitted some replacement. - (let ((new-size (- (segment-current-index segment) - (chooser-index note))) - (old-size (chooser-size note))) - (when (> new-size old-size) - (error "~S emitted ~D bytes, but claimed it's max was ~D" - note new-size old-size)) - (let ((additional-delta (- old-size new-size))) - (when (< (find-alignment additional-delta) - (chooser-alignment note)) - (error "~S shrunk by ~D bytes, but claimed that it ~ - preserve ~D bits of alignment." - note additional-delta (chooser-alignment note))) - (incf delta additional-delta) - (emit-filler segment additional-delta)) - (setf prev (segment-last-annotation segment)) - (if prev - (setf (cdr prev) (cdr remaining)) - (setf (segment-annotations segment) - (cdr remaining))))) - (t - ;; The chooser passed on shrinking. Make sure it didn't emit - ;; anything. - (unless (= (segment-current-index segment) (chooser-index note)) - (error "Chooser ~S passed, but not before emitting ~D bytes." - note - (- (segment-current-index segment) - (chooser-index note)))) - ;; Act like we just emitted this chooser. - (let ((size (chooser-size note))) - (incf (segment-current-index segment) size) - (incf (segment-current-posn segment) size)) - ;; Adjust the alignment accordingly. - (adjust-alignment-after-chooser segment note) - ;; And keep this chooser for next time around. - (setf prev remaining)))) - ((alignment-p note) - (unless (zerop (alignment-size note)) - ;; Re-emit the alignment, letting it collapse if we know anything - ;; more about the alignment guarentees of the segment. - (let ((index (alignment-index note))) - (setf (segment-current-index segment) index) - (setf (segment-current-posn segment) posn) - (setf (segment-fill-pointer segment) (system:int-sap 0)) - (setf (segment-block-end segment) (system:int-sap 0)) - (setf (segment-last-annotation segment) prev) - (emit-alignment segment nil (alignment-bits note)) - (let* ((new-index (segment-current-index segment)) - (size (- new-index index)) - (old-size (alignment-size note)) - (additional-delta (- old-size size))) - (when (minusp additional-delta) - (error "Alignment ~S needs more space now? It was ~D, ~ - and is ~D now." - note old-size size)) - (when (plusp additional-delta) - (emit-filler segment additional-delta) - (incf delta additional-delta))) - (setf prev (segment-last-annotation segment)) - (if prev - (setf (cdr prev) (cdr remaining)) - (setf (segment-annotations segment) - (cdr remaining)))))) - (t - (setf prev remaining))))) - (when (zerop delta) - (return)) - (decf (segment-final-posn segment) delta))) - (ext:undefined-value)) - -;;; FINALIZE-POSITIONS -- internal. -;;; -;;; We have run all the choosers we can, so now we have to figure out exactly -;;; how much space each alignment note needs. -;;; -(defun finalize-positions (segment) - (let ((delta 0)) - (do* ((prev nil) - (remaining (segment-annotations segment) next) - (next (cdr remaining) (cdr remaining))) - ((null remaining)) - (let* ((note (car remaining)) - (posn (- (annotation-posn note) delta))) - (cond - ((alignment-p note) - (let* ((bits (alignment-bits note)) - (mask (1- (ash 1 bits))) - (new-posn (logand (+ posn mask) (lognot mask))) - (size (- new-posn posn)) - (old-size (alignment-size note)) - (additional-delta (- old-size size))) - (assert (<= 0 size old-size)) - (unless (zerop additional-delta) - (setf (segment-last-annotation segment) prev) - (incf delta additional-delta) - (setf (segment-current-index segment) (alignment-index note)) - (setf (segment-current-posn segment) posn) - (emit-filler segment additional-delta) - (setf prev (segment-last-annotation segment))) - (if prev - (setf (cdr prev) next) - (setf (segment-annotations segment) next)))) - (t - (setf (annotation-posn note) posn) - (setf prev remaining) - (setf next (cdr remaining)))))) - (unless (zerop delta) - (decf (segment-final-posn segment) delta))) - (ext:undefined-value)) - -;;; PROCESS-BACK-PATCHES -- internal. -;;; -;;; Grovel over segment, filling in any backpatches. If any choosers are left -;;; over, we need to emit their worst case varient. -;;; -(defun process-back-patches (segment) - (do* ((prev nil) - (remaining (segment-annotations segment) next) - (next (cdr remaining) (cdr remaining))) - ((null remaining)) - (let ((note (car remaining))) - (flet ((fill-in (function old-size) - (let ((index (annotation-index note)) - (posn (annotation-posn note))) - (setf (segment-current-index segment) index) - (setf (segment-current-posn segment) posn) - (setf (segment-fill-pointer segment) (system:int-sap 0)) - (setf (segment-block-end segment) (system:int-sap 0)) - (setf (segment-last-annotation segment) prev) - (funcall function segment posn) - (let ((new-size (- (segment-current-index segment) index))) - (unless (= new-size old-size) - (error "~S emitted ~D bytes, but claimed it's was ~D" - note new-size old-size))) - (let ((tail (segment-last-annotation segment))) - (if tail - (setf (cdr tail) next) - (setf (segment-annotations segment) next))) - (setf next (cdr prev))))) - (cond ((back-patch-p note) - (fill-in (back-patch-function note) - (back-patch-size note))) - ((chooser-p note) - (fill-in (chooser-worst-case-fun note) - (chooser-size note))) - (t - (setf prev remaining))))))) - - -;;;; Interface to the rest of the compiler. - -;;; *CURRENT-SEGMENT* -- internal. -;;; -;;; The holds the current segment while assembling. Use ASSEMBLE to change -;;; it. -;;; -(defvar *current-segment*) - -;;; *CURRENT-VOP* -- internal. -;;; -;;; Just like *CURRENT-SEGMENT*, but holds the current vop. Used only to keep -;;; track of which vops emit which insts. -;;; -(defvar *current-vop* nil) - -;;; ASSEMBLE -- interface. -;;; -;;; We also symbol-macrolet *current-segment* to a local holding the segment -;;; so uses of *current-segment* inside the body don't have to keep -;;; dereferencing the symbol. Given that ASSEMBLE is the only interface to -;;; *current-segment*, we don't have to worry about the special value becomming -;;; out of sync with the lexical value. Unless some bozo closes over it, -;;; but nobody does anything like that... -;;; -(defmacro assemble ((&optional segment vop &key labels) &body body - &environment env) - "Execute BODY (as a progn) with SEGMENT as the current segment." - (flet ((label-name-p (thing) - (and thing (symbolp thing)))) - (let* ((seg-var (gensym "SEGMENT-")) - (vop-var (gensym "VOP-")) - (visable-labels (remove-if-not #'label-name-p body)) - (inherited-labels - (multiple-value-bind - (expansion expanded) - (macroexpand '..inherited-labels.. env) - (if expanded expansion nil))) - (new-labels (append labels - (set-difference visable-labels - inherited-labels))) - (nested-labels (set-difference (append inherited-labels new-labels) - visable-labels))) - (when (intersection labels inherited-labels) - (error "Duplicate nested labels: ~S" - (intersection labels inherited-labels))) - `(let* ((,seg-var ,(or segment '*current-segment*)) - (,vop-var ,(or vop '*current-vop*)) - ,@(when segment - `((*current-segment* ,seg-var))) - ,@(when vop - `((*current-vop* ,vop-var))) - ,@(mapcar #'(lambda (name) - `(,name (gen-label))) - new-labels)) - (symbol-macrolet ((*current-segment* ,seg-var) - (*current-vop* ,vop-var) - ,@(when (or inherited-labels nested-labels) - `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar #'(lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) - body)))))) - -;;; INST -- interface. -;;; -(defmacro inst (&whole whole instruction &rest args &environment env) - "Emit the specified instruction to the current segment." - (let ((inst (gethash (symbol-name instruction) - (assem-params-instructions - (c:backend-assembler-params c:*target-backend*))))) - (cond ((null inst) - (error "Unknown instruction: ~S" instruction)) - ((functionp inst) - (funcall inst (cdr whole) env)) - (t - `(,inst *current-segment* *current-vop* ,@args))))) - -;;; EMIT-LABEL -- interface. -;;; -(defmacro emit-label (label) - "Emit LABEL at this location in the current segment." - `(%emit-label *current-segment* *current-vop* ,label)) - -;;; EMIT-POSTIT -- interface. -;;; -(defmacro emit-postit (function) - `(%emit-postit *current-segment* ,function)) - -;;; ALIGN -- interface. -;;; -(defmacro align (bits) - "Emit an alignment restriction to the current segment." - `(emit-alignment *current-segment* *current-vop* ,bits)) - -;;; LABEL-POSITION -- interface. -;;; -(defun label-position (label &optional if-after delta) - "Return the current position for LABEL. Chooser maybe-shrink functions - should supply IF-AFTER and DELTA to assure correct results." - (let ((posn (label-posn label))) - (if (and if-after (> posn if-after)) - (- posn delta) - posn))) - -;;; APPEND-SEGMENT -- interface. -;;; -(defun append-segment (segment other-segment) - "Append OTHER-SEGMENT to the end of SEGMENT. Don't use OTHER-SEGMENT - for anything after this." - (when (segment-run-scheduler segment) - (schedule-pending-instructions segment)) - (let ((postits (segment-postits segment))) - (setf (segment-postits segment) (segment-postits other-segment)) - (dolist (postit postits) - (emit-back-patch segment 0 postit))) - (emit-alignment segment nil max-alignment) - (let ((offset-in-last-block (rem (segment-current-index segment) - output-block-size))) - (unless (zerop offset-in-last-block) - (emit-filler segment (- output-block-size offset-in-last-block)))) - (let* ((blocks (segment-output-blocks segment)) - (next-block-num (floor (segment-current-index segment) - output-block-size)) - (other-blocks (segment-output-blocks other-segment))) - (setf blocks - (adjust-array blocks (+ next-block-num (length other-blocks)))) - (setf (segment-output-blocks segment) blocks) - (replace blocks other-blocks :start1 next-block-num)) - (let ((index-delta (segment-current-index segment)) - (posn-delta (segment-current-posn segment)) - (other-annotations (segment-annotations other-segment))) - (setf (segment-current-index segment) - (+ index-delta (segment-current-index other-segment))) - (setf (segment-current-posn segment) - (+ posn-delta (segment-current-posn other-segment))) - (setf (segment-fill-pointer segment) (system:int-sap 0)) - (setf (segment-block-end segment) (system:int-sap 0)) - (when other-annotations - (dolist (note other-annotations) - (incf (annotation-index note) index-delta) - (incf (annotation-posn note) posn-delta)) - (let ((last (segment-last-annotation segment))) - (if last - (setf (cdr last) other-annotations) - (setf (segment-annotations segment) other-annotations)) - (setf (segment-last-annotation segment) - (segment-last-annotation other-segment))))) - (ext:undefined-value)) - -;;; FINALIZE-SEGMENT -- interface. -;;; -(defun finalize-segment (segment) - "Does any final processing of SEGMENT and returns the total number of bytes - covered by this segment." - (when (segment-run-scheduler segment) - (schedule-pending-instructions segment)) - (setf (segment-run-scheduler segment) nil) - (let ((postits (segment-postits segment))) - (setf (segment-postits segment) nil) - (dolist (postit postits) - (emit-back-patch segment 0 postit))) - (setf (segment-final-index segment) (segment-current-index segment)) - (setf (segment-final-posn segment) (segment-current-posn segment)) - (setf (segment-inst-hook segment) nil) - (compress-output segment) - (finalize-positions segment) - (process-back-patches segment) - (segment-final-posn segment)) - -;;; SEGMENT-MAP-OUTPUT -- interface. -;;; -(defun segment-map-output (segment function) - "Call FUNCTION on all the output accumulated in SEGMENT. FUNCTION is called - zero or more times with two arguments: a SAP and a number of bytes." - (let ((old-index 0) - (blocks (segment-output-blocks segment)) - (sap (system:int-sap 0)) - (end (system:int-sap 0))) - (labels ((map-until (index) - (unless (system:sap< sap end) - (multiple-value-bind - (block-num block-offset) - (floor old-index output-block-size) - (let ((block (aref blocks block-num))) - (setf sap (system:sap+ block block-offset)) - (setf end (system:sap+ block output-block-size))))) - (let* ((desired (- index old-index)) - (available (system:sap- end sap)) - (amount (min desired available))) - (funcall function sap amount) - (incf old-index amount) - (setf sap (system:sap+ sap amount)) - (when (< amount desired) - (map-until index))))) - (dolist (note (segment-annotations segment)) - (when (filler-p note) - (let ((index (filler-index note))) - (when (< old-index index) - (map-until index))) - (let ((bytes (filler-bytes note))) - (incf old-index bytes) - (setf sap (system:sap+ sap bytes))))) - (let ((index (segment-final-index segment))) - (when (< old-index index) - (map-until index)))))) - -;;; RELEASE-SEGMENT -- interface. -;;; -(defun release-segment (segment) - "Releases any output buffers held on to by segment." - (let ((blocks (segment-output-blocks segment))) - (loop - for block across blocks - do (when block - (release-output-block block)))) - (ext:undefined-value)) - - -;;;; Interface to the instruction set definition. - -;;; DEFINE-EMITTER -- Interface. -;;; -;;; Define a function named NAME that merges it's arguments into a single -;;; integer and then emits the bytes of that integer in the correct order -;;; based on the endianness of the target-backend. -;;; -(defmacro define-emitter (name total-bits &rest byte-specs) - (ext:collect ((arg-names) (arg-types)) - (let* ((total-bits (eval total-bits)) - (overall-mask (ash -1 total-bits)) - (num-bytes (multiple-value-bind - (quo rem) - (truncate total-bits assembly-unit-bits) - (unless (zerop rem) - (error "~D isn't an even multiple of ~D" - total-bits assembly-unit-bits)) - quo)) - (bytes (make-array num-bytes :initial-element nil)) - (segment-arg (gensym "SEGMENT-"))) - (dolist (byte-spec-expr byte-specs) - (let* ((byte-spec (eval byte-spec-expr)) - (byte-size (byte-size byte-spec)) - (byte-posn (byte-position byte-spec)) - (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr)))) - (when (ldb-test (byte byte-size byte-posn) overall-mask) - (error "Byte spec ~S either overlaps another byte spec, or ~ - extends past the end." - byte-spec-expr)) - (setf (ldb byte-spec overall-mask) -1) - (arg-names arg) - (arg-types `(type (integer ,(ash -1 (1- byte-size)) - ,(1- (ash 1 byte-size))) - ,arg)) - (multiple-value-bind - (start-byte offset) - (floor byte-posn assembly-unit-bits) - (let ((end-byte (floor (1- (+ byte-posn byte-size)) - assembly-unit-bits))) - (flet ((maybe-ash (expr offset) - (if (zerop offset) - expr - `(ash ,expr ,offset)))) - (declare (inline maybe-ash)) - (cond ((zerop byte-size)) - ((= start-byte end-byte) - (push (maybe-ash `(ldb (byte ,byte-size 0) ,arg) - offset) - (svref bytes start-byte))) - (t - (push (maybe-ash - `(ldb (byte ,(- assembly-unit-bits offset) 0) - ,arg) - offset) - (svref bytes start-byte)) - (do ((index (1+ start-byte) (1+ index))) - ((>= index end-byte)) - (push - `(ldb (byte ,assembly-unit-bits - ,(- (* assembly-unit-bits - (- index start-byte)) - offset)) - ,arg) - (svref bytes index))) - (let ((len (rem (+ byte-size offset) - assembly-unit-bits))) - (push - `(ldb (byte ,(if (zerop len) - assembly-unit-bits - len) - ,(- (* assembly-unit-bits - (- end-byte start-byte)) - offset)) - ,arg) - (svref bytes end-byte)))))))))) - (unless (= overall-mask -1) - (error "There are holes.")) - (let ((forms nil)) - (dotimes (i num-bytes) - (let ((pieces (svref bytes i))) - (assert pieces) - (push `(emit-byte ,segment-arg - ,(if (cdr pieces) - `(logior ,@pieces) - (car pieces))) - forms))) - `(defun ,name (,segment-arg ,@(arg-names)) - (declare (type segment ,segment-arg) ,@(arg-types)) - ,@(ecase (c:backend-byte-order c:*target-backend*) - (:little-endian (nreverse forms)) - (:big-endian forms)) - ',name))))) - -(defun grovel-lambda-list (lambda-list vop-var) - (let ((segment-name (car lambda-list)) - (vop-var (or vop-var (gensym "VOP-")))) - (ext:collect ((new-lambda-list)) - (new-lambda-list segment-name) - (new-lambda-list vop-var) - (labels - ((grovel (state lambda-list) - (when lambda-list - (let ((param (car lambda-list))) - (cond - ((member param lambda-list-keywords) - (new-lambda-list param) - (grovel param (cdr lambda-list))) - (t - (ecase state - ((nil) - (new-lambda-list param) - `(cons ,param ,(grovel state (cdr lambda-list)))) - (&optional - (multiple-value-bind - (name default supplied-p) - (if (consp param) - (values (first param) - (second param) - (or (third param) - (gensym "SUPPLIED-P-"))) - (values param nil (gensym "SUPPLIED-P-"))) - (new-lambda-list (list name default supplied-p)) - `(and ,supplied-p - (cons ,(if (consp name) - (second name) - name) - ,(grovel state (cdr lambda-list)))))) - (&key - (multiple-value-bind - (name default supplied-p) - (if (consp param) - (values (first param) - (second param) - (or (third param) - (gensym "SUPPLIED-P-"))) - (values param nil (gensym "SUPPLIED-P-"))) - (new-lambda-list (list name default supplied-p)) - (multiple-value-bind - (key var) - (if (consp name) - (values (first name) (second name)) - (values (intern (symbol-name name) :keyword) - name)) - `(append (and ,supplied-p (list ',key ,var)) - ,(grovel state (cdr lambda-list)))))) - (&rest - (new-lambda-list param) - (grovel state (cdr lambda-list)) - param)))))))) - (let ((reconstructor (grovel nil (cdr lambda-list)))) - (values (new-lambda-list) - segment-name - vop-var - reconstructor)))))) - -(defun extract-nths (index glue list-of-lists-of-lists) - (mapcar #'(lambda (list-of-lists) - (cons glue - (mapcar #'(lambda (list) - (nth index list)) - list-of-lists))) - list-of-lists-of-lists)) - -;;; DEFINE-INSTRUCTION -- interface. -;;; -(defmacro define-instruction (name lambda-list &rest options) - (let* ((sym-name (symbol-name name)) - (defun-name (ext:symbolicate sym-name "-INST-EMITTER")) - (vop-var nil) - (postits (gensym "POSTITS-")) - (emitter nil) - (decls nil) - (attributes nil) - (dependencies nil) - (delay nil) - (pinned nil) - (pdefs nil)) - (dolist (option-spec options) - (multiple-value-bind - (option args) - (if (consp option-spec) - (values (car option-spec) (cdr option-spec)) - (values option-spec nil)) - (case option - (:emitter - (when emitter - (error "Can only specify one emitter per instruction.")) - (setf emitter args)) - (:declare - (setf decls (append decls args))) - (:attributes - (setf attributes (append attributes args))) - (:dependencies - (setf dependencies (append dependencies args))) - (:delay - (when delay - (error "Can only specify delay once per instruction.")) - (setf delay args)) - ((:reads :writes) - ;; ### Ignore them for now. - nil) - (:pinned - (setf pinned t)) - (:vop-var - (if vop-var - (error "Can only specify :vop-var once.") - (setf vop-var (car args)))) - (:printer - (push - (eval - `(list - (multiple-value-list - ,(disassem:gen-printer-def-forms-def-form name - (cdr option-spec))))) - pdefs)) - (:printer-list - ;; same as :printer, but is evaled first, and is a list of printers - (push - (eval - `(eval - `(list ,@(mapcar #'(lambda (printer) - `(multiple-value-list - ,(disassem:gen-printer-def-forms-def-form - ',name printer nil))) - ,(cadr option-spec))))) - pdefs)) - (t - (error "Unknown option: ~S" option))))) - (setf pdefs (nreverse pdefs)) - (multiple-value-bind - (new-lambda-list segment-name vop-name arg-reconstructor) - (grovel-lambda-list lambda-list vop-var) - (push `(let ((hook (segment-inst-hook ,segment-name))) - (when hook - (funcall hook ,segment-name ,vop-name ,sym-name - ,arg-reconstructor))) - emitter) - (push `(dolist (postit ,postits) - (emit-back-patch ,segment-name 0 postit)) - emitter) - (when (assem-params-scheduler-p - (c:backend-assembler-params c:*target-backend*)) - (if pinned - (setf emitter - `((when (segment-run-scheduler ,segment-name) - (schedule-pending-instructions ,segment-name)) - ,@emitter)) - (let ((flet-name - (gensym (concatenate 'string "EMIT-" sym-name "-INST-"))) - (inst-name (gensym "INST-"))) - (setf emitter `((flet ((,flet-name (,segment-name) - ,@emitter)) - (if (segment-run-scheduler ,segment-name) - (let ((,inst-name - (make-instruction - (incf (segment-inst-number - ,segment-name)) - #',flet-name - (instruction-attributes - ,@attributes) - (progn ,@delay)))) - ,@(when dependencies - `((note-dependencies - (,segment-name ,inst-name) - ,@dependencies))) - (queue-inst ,segment-name ,inst-name)) - (,flet-name ,segment-name)))))))) - `(progn - (defun ,defun-name ,new-lambda-list - ,@(when decls - `((declare ,@decls))) - (let ((,postits (segment-postits ,segment-name))) - (setf (segment-postits ,segment-name) nil) - (symbol-macrolet - ((*current-segment* - (macrolet ((lose () - (error "Can't use INST without an ASSEMBLE ~ - inside emitters."))) - (lose)))) - ,@emitter)) - (ext:undefined-value)) - (eval-when (compile load eval) - (%define-instruction ,sym-name ',defun-name)) - ,@(extract-nths 1 'progn pdefs) - ,@(when pdefs - `((disassem:install-inst-flavors - ',name - (append ,@(extract-nths 0 'list pdefs))))))))) - -;;; DEFINE-INSTRUCTION-MACRO -- interface. -;;; -(defmacro define-instruction-macro (name lambda-list &body body) - (let ((whole (gensym "WHOLE-")) - (env (gensym "ENV-"))) - (multiple-value-bind - (body local-defs) - (lisp::parse-defmacro lambda-list whole body name 'instruction-macro - :environment env) - `(eval-when (compile load eval) - (%define-instruction ,(symbol-name name) - #'(lambda (,whole ,env) - ,@local-defs - (block ,name - ,body))))))) - -(defun %define-instruction (name defun) - (setf (gethash name - (assem-params-instructions - (c:backend-assembler-params c:*target-backend*))) - defun) - name) - diff --git a/compiler/old-rt/arith.lisp b/compiler/old-rt/arith.lisp deleted file mode 100644 index 5a8ab236297e3318d31f4f7dd781d3964b784a08..0000000000000000000000000000000000000000 --- a/compiler/old-rt/arith.lisp +++ /dev/null @@ -1,196 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the VM definition arithmetic VOPs for the RT. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; Assume that any constant operand is the second arg... - -(defmacro define-fixnum-binop (name inherits translate op &key - unsigned immed-op commute-op short-op - function) - `(define-vop (,name ,inherits) - (:translate ,translate) - (:generator 1 - (sc-case y - ((any-reg) - (cond ((location= x r) - (inst ,op x y)) - ,@(when commute-op - `(((location= y r) - (inst ,commute-op y x)))) - (t - (inst lr r x) - (inst ,op r y)))) - ,@(when (or immed-op short-op) - `(((short-immediate unsigned-immediate - ,@(unless unsigned '(immediate))) - (cond - ,@(when short-op - `(((and (sc-is y short-immediate) - (location= x r)) - (inst ,short-op r (tn-value y))))) - (t - (inst ,immed-op r x - ,(if function - `(,function (tn-value y)) - '(tn-value y)))))))))))) - - -;;;; Arithmetic: - -(define-vop (fast-binop/fixnum) - (:args (x :target r - :scs (any-reg)) - (y :target r - :scs (any-reg short-immediate unsigned-immediate immediate))) - (:results (r :scs (any-reg))) - (:arg-types fixnum fixnum) - (:result-types fixnum) - (:effects) - (:affected) - (:note "inline fixnum arithmetic") - (:policy :fast-safe)) - -(define-fixnum-binop fast-+/fixnum fast-binop/fixnum + a - :short-op ais :immed-op ai :commute-op a) - -(define-fixnum-binop fast--/fixnum fast-binop/fixnum - s - :short-op sis :immed-op ai :function - :commute-op sf) - - -(define-vop (fixnum-unop) - (:args (x :scs (any-reg))) - (:results (res :scs (any-reg))) - (:note "inline fixnum arithmetic") - (:arg-types fixnum) - (:result-types fixnum) - (:policy :fast-safe)) - -(macrolet ((frob (name inst trans) - `(define-vop (,name fixnum-unop) - (:translate ,trans) - (:generator 1 - (inst ,inst res x))))) - (frob fast-negate/fixnum twoc %negate) - (frob fast-lognot/fixnum onec lognot) - (frob fast-abs/fixnum abs abs)) - -(define-miscop-variants effectless-unaffected-two-arg-miscop + - / *) -(define-miscop negate (x) :translate %negate) -(define-miscop truncate (x y) :results (q r) :translate truncate) - - -;;;; Logic operations: - -;;; Like fast-binop/fixnum, except the immediate operand is unsigned, and -;;; a fixnum result assertion isn't needed. -;;; -(define-vop (fast-logic-binop/fixnum fast-binop/fixnum) - (:args (x :target r - :scs (any-reg)) - (y :target r - :scs (any-reg short-immediate unsigned-immediate)))) - -(define-fixnum-binop fast-logior/fixnum fast-logic-binop/fixnum logior o - :immed-op oil :unsigned t :commute-op o) - -(define-fixnum-binop fast-logand/fixnum fast-logic-binop/fixnum logand n - :immed-op nilz :unsigned t :commute-op n) - -(define-fixnum-binop fast-logxor/fixnum fast-logic-binop/fixnum logxor x - :immed-op xil :unsigned t :commute-op x) - - -(define-vop (fast-ash/fixnum fast-binop/fixnum) - (:args (i :scs (any-reg) - :target r)) - (:arg-types fixnum (:constant (integer -31 31))) - (:info n) - (:translate ash) - (:generator 1 - (unless (location= i r) - (inst lr r i)) - - (cond ((plusp n) - (if (> n 15) - (inst sli16 r (- n 16)) - (inst sli r n))) - ((minusp n) - (let ((n (- n))) - (if (> n 15) - (inst sari16 r (- n 16)) - (inst sari r n))))))) - - -(define-miscop-variants effectless-unaffected-two-arg-miscop - logand logior logxor) -(define-miscop-variants effectless-unaffected-one-arg-miscop lognot) -(define-miscop ldb (size pos int) :translate %ldb) -(define-miscop mask-field (size pos int) :translate %mask-field) -(define-miscop dpb (new size pos int) :translate %dpb) -(define-miscop deposit-field (new size pos int) :translate %deposit-field) - - -;;;; Binary conditional VOPs: - -(define-vop (fast-conditional/fixnum) - (:args (x :scs (any-reg)) - (y :scs (any-reg short-immediate unsigned-immediate immediate))) - (:arg-types fixnum fixnum) - (:conditional) - (:info target not-p) - (:effects) - (:affected) - (:policy :fast-safe) - (:note "inline fixnum comparison") - (:variant-vars condition) - (:generator 1 - (sc-case y - (short-immediate - (inst cis x (tn-value y))) - ((immediate unsigned-immediate) - (inst ci x (tn-value y))) - (any-reg - (inst c x y))) - - (if not-p - (inst bnb condition target) - (inst bb condition target)))) - - -(define-vop (fast-if-</fixnum fast-conditional/fixnum) - (:translate <) - (:variant :lt)) - -(define-vop (fast-if->/fixnum fast-conditional/fixnum) - (:translate >) - (:variant :gt)) - -(define-vop (fast-if-=/fixnum fast-conditional/fixnum) - (:translate =) - (:variant :eq)) - - - -(define-vop (if-< two-arg-conditional-miscop) - (:variant 'clc::compare :lt) - (:translate <)) - -(define-vop (if-> two-arg-conditional-miscop) - (:variant 'clc::compare :gt) - (:translate >)) - -(define-vop (if-= two-arg-conditional-miscop) - (:variant 'clc::compare :eq) - (:translate =)) diff --git a/compiler/old-rt/array.lisp b/compiler/old-rt/array.lisp deleted file mode 100644 index 9cf7282104a7fcb0ec815f4da78e936cb584ed95..0000000000000000000000000000000000000000 --- a/compiler/old-rt/array.lisp +++ /dev/null @@ -1,106 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the RT definitions for array operations. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(define-miscop aref1 (a i) :translate aref) -(define-miscop caref2 (a i j) :translate aref) -(define-miscop caref3 (a i j k) :translate aref) -(define-miscop aset1 (a i val) :translate %aset) -(define-miscop caset2 (a i j val) :translate %aset) -(define-miscop caset3 (a i j k val) :translate %aset) -(define-miscop svref (v i) :translate aref - :arg-types (simple-vector t)) -(define-miscop svset (v i val) :translate %aset - :arg-types (simple-vector t t)) -(define-miscop schar (v i) :translate aref - :arg-types (simple-string t)) -(define-miscop scharset (v i val) :translate %aset - :arg-types (simple-string t t)) -(define-miscop sbit (v i) :translate aref - :arg-types (simple-bit-vector t)) -(define-miscop sbitset (v i val) :translate %aset - :arg-types (simple-bit-vector t t)) -(define-miscop g-vector-length (v) :translate length - :arg-types (simple-vector)) -(define-miscop simple-string-length (s) :translate length - :arg-types (simple-string)) -(define-miscop simple-bit-vector-length (b) :translate length - :arg-types (simple-bit-vector)) -(define-miscop length (s) :translate length :cost 50) - -(define-vop (fast-length/simple-string) - (:args (vec :scs (descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:translate length) - (:arg-types simple-string) - (:policy :fast-safe) - (:generator 6 - (loadw res vec (/ clc::string-header-entries 4)) - (inst niuo res res clc::i-vector-entries-mask-16))) - -(define-vop (fast-schar byte-index-ref) - (:results (value :scs (string-char-reg))) - (:variant clc::i-vector-header-size) - (:translate aref) - (:policy :fast) - (:arg-types simple-string *) - (:result-types string-char)) - -(define-vop (fast-scharset byte-index-set) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg descriptor-reg short-immediate - unsigned-immediate)) - (value :scs (string-char-reg))) - (:results (result :scs (string-char-reg))) - (:variant clc::i-vector-header-size) - (:translate %aset) - (:policy :fast) - (:arg-types simple-string * string-char) - (:result-types string-char)) - -(define-vop (header-length) - (:args (vec :scs (descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadw res vec (/ clc::g-vector-header-words 4)) - (inst dec res clc::g-vector-header-size-in-words) - (inst niuo res res clc::g-vector-words-mask-16))) - -(define-vop (fast-length/simple-vector header-length) - (:translate length) - (:policy :fast-safe) - (:arg-types simple-vector)) - -(define-vop (get-vector-subtype) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadc res x clc::vector-subtype-byte) - (inst nilz res res clc::right-shifted-subtype-mask-16))) - -(define-vop (header-ref word-index-ref) - (:variant clc::g-vector-header-size-in-words)) - -(define-vop (fast-svref header-ref) - (:translate aref) - (:arg-types simple-vector *) - (:policy :fast)) - -(define-vop (header-set word-index-set) - (:variant clc::g-vector-header-size-in-words)) - -(define-vop (fast-svset header-set) - (:translate %aset) - (:arg-types simple-vector * *) - (:policy :fast)) diff --git a/compiler/old-rt/assem-insts.lisp b/compiler/old-rt/assem-insts.lisp deleted file mode 100644 index d791605963d0d57f6d02e6bd424089aa929cace2..0000000000000000000000000000000000000000 --- a/compiler/old-rt/assem-insts.lisp +++ /dev/null @@ -1,286 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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 instruction definitions for the IBM RT PC. -;;; -(in-package 'c) - -(def-instruction-format R 2 ; Instruction format "R" - (:unsigned 8 :instruction-constant) ; OP - (:unsigned 4 :register) ; R2 - (:unsigned 4 :register)) ; R3 - -(def-instruction-format R1 2 ; Instruction format "R" - (:unsigned 8 :instruction-constant) ; OP - (:unsigned 4 :enumeration '((:pz . #b1000) - (:lt . #b1001) - (:eq . #b1010) - (:gt . #b1011) - (:c0 . #b1100) - (:ov . #b1110) - (:tb . #b1111))) ; Condition code - (:unsigned 4 :register)) ; R3 - -(def-instruction-format R2 2 ; Instruction format "R" - (:unsigned 8 :instruction-constant) ; OP - (:unsigned 4 :register) ; R2 - (:signed 4 :immediate)) ; R3 - -(def-instruction-format DS 2 ; Instruction format "D-Short" - (:unsigned 4 :instruction-constant) ; OP - (:signed 4 :immediate) ; I - (:unsigned 4 :register) ; R2 - (:unsigned 4 :register)) ; R3 - -(def-instruction-format D 4 ; Instruction format "D" - (:unsigned 8 :instruction-constant) ; OP - (:unsigned 4 :register) ; R2 - (:unsigned 4 :register) ; R3 - (:signed 16 :immediate)) ; I - -(def-instruction-format Dr2z 4 ; Instruction format "D" with R2 0 (ci...) - (:unsigned 8 :instruction-constant) ; OP - (:unsigned 4 :constant 0) ; R2 - (:unsigned 4 :register) ; R3 - (:signed 16 :immediate)) ; I - -(def-instruction-format X 2 ; Instruction format "X" - (:unsigned 4 :instruction-constant) - (:unsigned 4 :register) ; - (:unsigned 4 :register) ; R2 - (:unsigned 4 :register)) ; R3 - -(def-instruction-format x0 2 ; Special format for the LR pseudo-instruction - (:unsigned 4 :instruction-constant) - (:unsigned 4 :register) - (:unsigned 4 :register) - (:unsigned 4 :constant 0)) - -(def-instruction-format BM 4 ;Instruction format for Miscop branches - (:unsigned 8 :instruction-constant) - (:signed 24 :fixup :miscop)) - -(def-instruction-format JI 2 ; Instruction format "JI" - (:unsigned 5 :instruction-constant) ; OP - (:unsigned 3 :enumeration '((:pz . #b000) - (:lt . #b001) - (:eq . #b010) - (:gt . #b011) - (:c0 . #b100) - (:ov . #b110) - (:tb . #b111))) ; Condition code - (:signed 8 :branch #'(lambda (x) (ash x -1)))) ; J1 - -(def-instruction-format BI 4 ; Instruction format "BI" - (:unsigned 8 :instruction-constant) ; OP - (:unsigned 4 :enumeration '((:pz . #b1000) - (:lt . #b1001) - (:eq . #b1010) - (:gt . #b1011) - (:c0 . #b1100) - (:ov . #b1110) - (:tb . #b1111))) ; Condition code - (:signed 20 :branch #'(lambda (x) (ash x -1)))) ; B1 - -; Instruction format "BI" with register arg (bal,...) - -(def-instruction-format BIR 4 - (:unsigned 8 :instruction-constant) ; OP - (:unsigned 4 :register) - (:signed 20 :branch #'(lambda (x) (ash x -1)))) ; B1 - - -(def-instruction-format BA 4 - (:unsigned 8 :instruction-constant) - (:signed 24 :branch #'(lambda (x) (ash x -1)))) - -(def-instruction-format SR 2 - (:unsigned 12 :instruction-constant) - (:unsigned 4 :register)) - -(def-instruction-format SN 2 - (:unsigned 12 :instruction-constant) - (:signed 4 :immediate)) - -;;; Storage Access instructions: - -(def-instruction lcs ds #x04) -(def-instruction lc d #xCE) -(def-instruction lhas ds #x05) -(def-instruction lha d #xCA) -(def-instruction lhs r #xEB) -(def-instruction lh d #xDA) -(def-instruction ls ds #x07) -(def-instruction l d #xCD) -(def-instruction lm d #xC9) -(def-instruction tsh d #xCF) -(def-instruction stcs ds #x01) -(def-instruction stc d #xDE) -(def-instruction sths ds #x02) -(def-instruction sth d #xDC) -(def-instruction sts ds #x03) -(def-instruction st d #xDD) -(def-instruction stm d #xD9) - -;;; Address Computation instructions: - -(def-instruction cal d #xC8) -(def-instruction cal16 d #xC2) -(def-instruction cau d #xD8) -(def-instruction cas x #x06) -(def-instruction lr x0 #x06) -(def-instruction ca16 r #xF3) -(def-instruction inc r2 #x91) -(def-instruction dec r2 #x93) -(def-instruction lis r2 #xA4) - -;;; Branching instructions: - -(def-instruction bala-inst ba #x8A) -(def-instruction balax-inst ba #x8B) -(def-instruction miscop bm #x8A) -(def-instruction miscopx bm #x8B) -(def-instruction bali-inst bir #x8C) -(def-instruction balix-inst bir #x8D) -(def-instruction balr r #xEC) -(def-instruction balrx r #xED) -(def-instruction jb-inst ji #x01) -(def-instruction bb-inst bi #x8E) -(def-instruction bbx-inst bi #x8F) -(def-instruction bbr r1 #xEE) -(def-instruction bbrx r1 #xEF) -(def-instruction jnb-inst ji #x00) -(def-instruction bnb-inst bi #x88) -(def-instruction bnbx-inst bi #x89) -(def-instruction bnbr r1 #xE8) -(def-instruction bnbrx r1 #xe9) - -;;; Trap instructions: - -(def-instruction ti d #xCC) -(def-instruction tgte r #xBD) -(def-instruction tlt r #xBE) - -;;; Move and Insert instructions. - -(def-instruction mc03 r #xF9) -(def-instruction mc13 r #xFA) -(def-instruction mc23 r #xFB) -(def-instruction mc33 r #xFC) -(def-instruction mc30 r #xFD) -(def-instruction mc31 r #xFE) -(def-instruction mc32 r #xFF) -(def-instruction mftb r #xBC) -(def-instruction mftbil r2 #x9D) -(def-instruction mftbiu r2 #x9C) -(def-instruction mttb r #xBF) -(def-instruction mttbil r2 #x9F) -(def-instruction mttbiu r2 #x9E) - -;;; Arithmetic instructions. - -(def-instruction a r #xE1) -(def-instruction ae r #xF1) -(def-instruction aei d #xD1) -(def-instruction ai d #xC1) -(def-instruction ais r2 #x90) -(def-instruction abs r #xE0) -(def-instruction onec r #xF4) -(def-instruction twoc r #xE4) -(def-instruction c r #xB4) -(def-instruction cis r2 #x94) -(def-instruction ci dr2z #xD4) -(def-instruction cl r #xB3) -(def-instruction cli dr2z #xD3) -(def-instruction exts r #xB1) -(def-instruction s r #xE2) -(def-instruction sf r #xB2) -(def-instruction se r #xF2) -(def-instruction sfi d #xD2) -(def-instruction sis r2 #x92) -(def-instruction d r #xB6) -(def-instruction m r #xE6) - -;;; Logical instructions. - -(def-instruction clrbl r2 #x99) -(def-instruction clrbu r2 #x98) -(def-instruction setbl r2 #x9B) -(def-instruction setbu r2 #x9A) -(def-instruction n r #xE5) -(def-instruction nilz d #xC5) -(def-instruction nilo d #xC6) -(def-instruction niuz d #xD5) -(def-instruction niuo d #xD6) -(def-instruction o r #xE3) -(def-instruction oil d #xC4) -(def-instruction oiu d #xC3) -(def-instruction x r #xE7) -(def-instruction xil d #xC7) -(def-instruction xiu d #xD7) -(def-instruction clz r #xF5) - -;;; Shifting instructions. - -(def-instruction sar r #xB0) -(def-instruction sari r2 #xA0) -(def-instruction sari16 r2 #xA1) -(def-instruction sr r #xB8) -(def-instruction sri r2 #xA8) -(def-instruction sri16 r2 #xA9) -(def-instruction srp r #xB9) -(def-instruction srpi r2 #xAC) -(def-instruction srpi16 r2 #xAD) -(def-instruction sl r #xBA) -(def-instruction sli r2 #xAA) -(def-instruction sli16 r2 #xAB) -(def-instruction slp r #xBB) -(def-instruction slpi r2 #xAE) -(def-instruction slpi16 r2 #xAF) - -;;; Special Purpose Register Manipulation instructions. - -(def-instruction mtmq sr #xB5A) -(def-instruction mfmq sr #x96A) -(def-instruction mtcsr sr #xB5F) -(def-instruction mfcsr sr #x96F) -(def-instruction clrcb sn #x95F) -(def-instruction setcb sn #x97F) - -;;; Execution Control instructions. - -(def-instruction lps d #xD0) -(def-instruction svc d #xC0) - - -(def-branch bala (label) label - (-32768 32767 (bala-inst label))) - -(def-branch balax (label) label - (-32768 32767 (balax-inst label))) - -(def-branch bali (pc label) label - (-32768 32767 (bali-inst pc label))) - -(def-branch balix (pc label) label - (-32768 32767 (balix-inst pc label))) - -(def-branch bbx (n label) label - (-32768 32767 (bbx-inst n label))) - -(def-branch bb (n label) label -; (-128 127 (jb-inst n label)) - (-32768 32767 (bb-inst n label))) - -(def-branch bnbx (n label) label - (-32768 32767 (bnbx-inst n label))) - -(def-branch bnb (n label) label -; (-128 127 (jnb-inst n label)) - (-32768 32767 (bnb-inst n label))) diff --git a/compiler/old-rt/assem-macs.lisp b/compiler/old-rt/assem-macs.lisp deleted file mode 100644 index f1f728fc5735e6c1390bf3ac9df264c3659cabf0..0000000000000000000000000000000000000000 --- a/compiler/old-rt/assem-macs.lisp +++ /dev/null @@ -1,296 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Some macros and stuff to make emitting RT assembler easier. -;;; -(in-package 'c) - -#-new-compiler -(setq lisp::*bootstrap-defmacro* :both) - -(defmacro no-op () - "A 2 byte no-op." - '(inst lr zero-tn zero-tn)) - - -;;; Loadi loads the specified Constant into the given Register. - -(defmacro loadi (register constant) - (once-only ((n-constant constant)) - `(cond ((<= 0 ,n-constant 15) - (inst lis ,register ,n-constant)) - ((<= -32768 ,n-constant 32767) - (inst cal ,register zero-tn ,n-constant)) - ((= (logand ,n-constant 65535) 0) - (inst cau ,register zero-tn (logand (ash ,n-constant -16) #xFFFF))) - (t - (inst cau ,register zero-tn (logand (ash ,n-constant -16) #xFFFF)) - (inst oil ,register ,register (logand ,n-constant 65535)))))) - - -(defmacro cmpi (register constant) - (once-only ((n-constant constant)) - `(cond ((<= 0 ,n-constant 15) - (inst cis ,register ,n-constant)) - ((<= -32768 ,n-constant 32767) - (inst ci ,register ,n-constant)) - (T - (error "~A is to big for a compare immediate instruction." - ,n-constant))))) - - -;;; Memory reference macros that take a scaled immediate offset and use a short -;;; form instruction when possible. -;;; -(defmacro defmemref (name ds d shift) - `(defmacro ,name (register index-register &optional (offset 0)) - (once-only ((n-offset offset)) - `(if (<= 0 ,n-offset ,,15) - (inst ,',ds ,n-offset ,register ,index-register) - (inst ,',d ,register ,index-register (ash ,n-offset ,,shift)))))) - - -(defmacro loadh (register index-register &optional (offset 0)) - (once-only ((n-offset offset)) - `(if (zerop ,n-offset) - (inst lhs ,register ,index-register) - (inst lh ,register ,index-register (ash ,n-offset 1))))) - - -(defmemref loadc lcs lc 0) ; loads a character or byte -(defmemref loadha lhas lha 1) ; loads a halfword, sign-extending -(defmemref loadw ls l 2) ; loads a fullword - -(defmemref storec stcs stc 0) ; stores a character or byte -(defmemref storeha sths sth 1) ; stores a halfword -(defmemref storew sts st 2) ; stores a fullword - - -;;; Load-Global, Store-Global -- Public -;;; -;;; Load or store a word in the assember global data area. Base is a -;;; temporary register used to compute the base of the assembler data area, and -;;; must not be NL0 (i.e. should be Descriptor-Reg.) In Load-Global, if base -;;; it omitted, we default it to the result Register. Offset is a byte offset, -;;; but must be word-aligned. -;;; -(defmacro load-global (register offset &optional (base register)) - `(progn - (inst cau ,base zero-tn clc::romp-data-base) - (loadw ,register ,base (/ ,offset 4)))) -;;; -(defmacro store-global (register offset base) - `(progn - (inst cau ,base zero-tn clc::romp-data-base) - (storew ,register ,base (/ ,offset 4)))) - - -;;; Load-Slot, Store-Slot -- Public -;;; -;;; Load or store a slot in a g-vector-like object. We just add in the -;;; g-vector header size and do the load/store. -;;; -(defmacro load-slot (register object index) - `(loadw ,register ,object - (+ ,index clc::g-vector-header-size-in-words))) -;;; -(defmacro store-slot (register object index) - `(storew ,register ,object - (+ ,index clc::g-vector-header-size-in-words))) - - -;;; Load-Stack-TN, Store-Stack-TN -- Interface -;;; -;;; Move a stack TN to a register and vice-versa. -;;; -(defmacro load-stack-tn (reg stack) - (once-only ((n-reg reg) - (n-stack stack)) - `(sc-case ,n-reg - ((any-reg descriptor-reg string-char-reg) - (sc-case ,n-stack - ((stack string-char-stack) - (loadw ,n-reg fp-tn (tn-offset ,n-stack)))))))) - - -(defmacro store-stack-tn (stack reg) - (once-only ((n-stack stack) - (n-reg reg)) - `(sc-case ,n-reg - ((any-reg descriptor-reg string-char-reg) - (sc-case ,n-stack - ((stack string-char-stack) - (storew ,n-reg fp-tn (tn-offset ,n-stack)))))))) - - -;;; MAYBE-LOAD-STACK-TN -- Interface -;;; -(defmacro maybe-load-stack-tn (reg reg-or-stack) - "Move the TN Reg-Or-Stack into Reg if it isn't already there." - (once-only ((n-reg reg) - (n-stack reg-or-stack)) - `(sc-case ,n-reg - ((any-reg descriptor-reg string-char-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg string-char-reg) - (unless (location= ,n-reg ,n-stack) - (inst lr ,n-reg ,n-stack))) - ((stack string-char-stack) - (loadw ,n-reg fp-tn (tn-offset ,n-stack)))))))) - - -(defmacro test-simple-type (register temp target not-p type-code) - "Emit conditional code that tests whether Register holds an object with the - specified Type-Code. Temp is an unboxed temporary." - (once-only ((n-register register) - (n-temp temp) - (n-target target) - (n-not-p not-p) - (n-type-code type-code)) - `(progn - (inst niuz ,n-temp ,n-register clc::type-mask-16) - (inst xiu ,n-temp ,n-temp (ash ,n-type-code clc::type-shift-16)) - (if ,n-not-p - (inst bnb :eq ,n-target) - (inst bb :eq ,n-target))))) - - - -(defmacro test-hairy-type (register temp target not-p &rest types) - "Test-Hairy-Type Register Temp Target Not-P - {Type | (Low-Type High-Type)}* - Test whether Register holds a value with one of a specified union of type - codes. Each separately specified Type is matched, and also all types - between a Low-Type and High-Type pair (inclusive) are matched. All of the - type-code expressions are evaluated at macroexpand time. - Temp may be any register." - (once-only ((n-register register) - (n-temp temp) - (n-target target) - (n-not-p not-p)) - (assert types) - (let ((codes - (sort (mapcar #'(lambda (x) - (if (listp x) - (cons (eval (first x)) (eval (second x))) - (eval x))) - types) - #'< - :key #'(lambda (x) - (if (consp x) (car x) x)))) - (n-drop-thru (gensym)) (n-in-lab (gensym)) (n-out-lab (gensym))) - - (collect ((tests)) - (do ((codes codes (cdr codes))) - ((null codes)) - (let ((code (car codes)) - (last (null (cdr codes)))) - (cond - ((consp code) - (tests - `(progn - (cmpi ,n-temp ,(car code)) - (inst bb :lt ,n-out-lab) - (cmpi ,n-temp ,(cdr code)))) - - (if last - (tests `(if ,n-not-p - (inst bb :gt ,n-target) - (inst bnb :gt ,n-target))) - (tests `(inst bnb :gt ,n-in-lab)))) - (t - (tests `(cmpi ,n-temp ,code)) - (if last - (tests `(if ,n-not-p - (inst bnb :eq ,n-target) - (inst bb :eq ,n-target))) - (tests `(inst bb :eq ,n-in-lab))))))) - - - `(let* ((,n-drop-thru (gen-label)) - (,n-in-lab (if ,n-not-p ,n-drop-thru ,n-target)) - (,n-out-lab (if ,n-not-p ,n-target ,n-drop-thru))) - ,n-out-lab - (unless (location= ,n-temp ,n-register) - (inst lr ,n-temp ,n-register)) - (inst sri16 ,n-temp clc::type-shift-16) - - ,@(tests) - - (emit-label ,n-drop-thru)))))) - - -(defmacro test-special-value (reg temp value target not-p) - "Test whether Reg holds the specified special Value (T, NIL, %Trap-Object). - Temp is an unboxed register." - (once-only ((n-reg reg) - (n-temp temp) - (n-value value) - (n-target target) - (n-not-p not-p)) - `(progn - (inst xiu ,n-temp ,n-reg - (or (cdr (assoc ,n-value - `((t . ,',clc::t-16) - (nil . ,',clc::nil-16) - (%trap-object . ,',clc::trap-16)))) - (error "Unknown special value: ~S." ,n-value))) - (if ,n-not-p - (inst bnb :eq ,n-target) - (inst bb :eq ,n-target))))) - - -(defmacro pushm (reg) - `(progn - (inst inc sp-tn 4) - (storew ,reg sp-tn 0))) - -(defmacro popm (reg) - `(progn - (loadw ,reg sp-tn 0) - (inst dec sp-tn 4))) - - -;;; ### Note sleazy use of the argument registers without allocating them. -;;; This allows expressions to be targeted to the argument registers when error -;;; checking is going on, but causes problems with parallel assignment -;;; semantics. For error2, we have to start using the stack as a temporary. -;;; -(defmacro error-call (error-code &rest values) - (once-only ((n-error-code error-code)) - `(progn - ,@(case (length values) - (0 - '((inst miscopx 'clc::error0))) - (1 - `((inst lr (second register-argument-tns) ,(first values)) - (inst miscopx 'clc::error1))) - (2 - `((pushm ,(second values)) - (inst lr (second register-argument-tns) ,(first values)) - (popm (third register-argument-tns)) - (inst miscopx 'clc::error2))) - (t - (error "Can't use Error-Call with ~D values." (length values)))) - ;; Always do a 32bit load so that we can NOTE-THIS-LOCATION. - (inst cal (first register-argument-tns) zero-tn ,n-error-code)))) - - -(defmacro generate-error-code (vop error-code &rest values) - "Generate-Error-Code VOP Error-code Value* - Emit code for an error with the specified Error-Code and context Values. - VOP is used for source context and lifetime information." - (once-only ((n-vop vop)) - `(unassemble - (assemble-elsewhere (vop-node ,n-vop) - (let ((start-lab (gen-label))) - (emit-label start-lab) - (error-call ,error-code ,@values) - (note-this-location ,n-vop :internal-error) - start-lab))))) \ No newline at end of file diff --git a/compiler/old-rt/call.lisp b/compiler/old-rt/call.lisp deleted file mode 100644 index 5a696d5d242a18c378b9de884bddca8ae91e09e5..0000000000000000000000000000000000000000 --- a/compiler/old-rt/call.lisp +++ /dev/null @@ -1,985 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of function call for the RT. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; Interfaces to IR2 conversion: - -;;; Standard-Argument-Location -- Interface -;;; -;;; Return a wired TN describing the N'th full call argument passing -;;; location. -;;; -(defun standard-argument-location (n) - (declare (type unsigned-byte n)) - (if (< n register-arg-count) - (make-wired-tn *any-primitive-type* - register-arg-scn (elt register-arg-offsets n)) - (make-wired-tn *any-primitive-type* stack-arg-scn n))) - - -;;; Make-Return-PC-Passing-Location -- Interface -;;; -;;; Make a passing location TN for a local call return PC. If standard is -;;; true, then use the standard (full call) location, otherwise use any legal -;;; location. Even in the non-standard case, this may be restricted by a -;;; desire to use a subroutine call instruction. -;;; -(defun make-return-pc-passing-location (standard) - (if standard - (make-wired-tn *any-primitive-type* register-arg-scn return-pc-offset) - (make-restricted-tn *any-primitive-type* register-arg-scn))) - - -;;; Make-Old-Fp-Passing-Location -- Interface -;;; -;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass -;;; Old-Fp in. This is (obviously) wired in the standard convention, but is -;;; totally unrestricted in non-standard conventions, since we can always fetch -;;; it off of the stack using the arg pointer. -;;; -(defun make-old-fp-passing-location (standard) - (if standard - (make-wired-tn *any-primitive-type* register-arg-scn old-fp-offset) - (make-normal-tn *any-primitive-type*))) - - -;;; Make-Old-Fp-Save-Location, Make-Return-PC-Save-Location -- Interface -;;; -;;; Make the TNs used to hold Old-Fp and Return-PC within the current -;;; function. We treat these specially so that the debugger can find them at a -;;; known location. -;;; -(defun make-old-fp-save-location (env) - (specify-save-tn - (environment-debug-live-tn (make-normal-tn *any-primitive-type*) - env) - (make-wired-tn *any-primitive-type* stack-arg-scn old-fp-save-offset))) -;;; -(defun make-return-pc-save-location (env) - (specify-save-tn - (environment-debug-live-tn (make-normal-tn *any-primitive-type*) - env) - (make-wired-tn *any-primitive-type* stack-arg-scn return-pc-save-offset))) - - -;;; Make-Argument-Count-Location -- Interface -;;; -;;; Make a TN for the standard argument count passing location. We only -;;; need to make the standard location, since a count is never passed when we -;;; are using non-standard conventions. -;;; -(defun make-argument-count-location () - (make-wired-tn *any-primitive-type* register-arg-scn argument-count-offset)) - - -;;; MAKE-NFP-TN -- Interface -;;; -;;; Make a TN to hold the number-stack frame pointer. This is allocated -;;; once per component, and is component-live. -;;; -(defun make-nfp-tn () - (component-live-tn - (make-restricted-tn *any-primitive-type* register-arg-scn))) - - -;;; MAKE-STACK-POINTER-TN () -;;; -(defun make-stack-pointer-tn () - (make-normal-tn *any-primitive-type*)) - - -;;; MAKE-NUMBER-STACK-POINTER-TN () -;;; -(defun make-number-stack-pointer-tn () - (make-normal-tn *any-primitive-type*)) - - -;;; Make-Unknown-Values-Locations -- Interface -;;; -;;; Return a list of TNs that can be used to represent an unknown-values -;;; continuation within a function. -;;; -(defun make-unknown-values-locations () - (list (make-stack-pointer-tn) - (make-normal-tn *any-primitive-type*))) - - -;;; Select-Component-Format -- Interface -;;; -;;; This function is called by the Entry-Analyze phase, allowing -;;; VM-dependent initialization of the IR2-Component structure. We push -;;; placeholder entries in the Constants to leave room for the component name, -;;; code vector and debug info. -;;; -(defun select-component-format (component) - (declare (type component component)) - (dotimes (i 3) - (vector-push-extend nil - (ir2-component-constants (component-info component)))) - (undefined-value)) - - -;;;; Frame hackery: - -;;; Used for setting up the Old-Fp in local call. -;;; -(define-vop (current-fp) - (:results (val :scs (any-reg descriptor-reg))) - (:generator 1 - (inst lr val fp-tn))) - - -#| Since we don't have a number stack yet, shouldn't be emitted. - -;;; Used for computing the caller's NFP for use in known-values return. Only -;;; works assuming there is no variable size stuff on the nstack. -;;; -(define-vop (compute-old-nfp) - (:results (val :scs (any-reg descriptor-reg))) - (:vop-var vop) - (:generator 1 - (let ((nfp (current-nfp-tn vop))) - (when nfp - (inst cal val nfp (- (* 4 (sb-allocated-size 'number-stack)))))))) -|# - - -;;; In an XEP, allocate frames for this function on the control stack (and -;;; number stack if any). We get to emit the start label, since we might need -;;; to emit variable cruft to align it, etc. -;;; -(define-vop (xep-allocate-frame) - (:info start-lab) - (:generator 1 - (emit-label start-lab) - (inst cal sp-tn fp-tn (* 4 (sb-allocated-size 'stack))))) - - -;;; Allocate the frame for the function we are about to call, returning the -;;; frame pointer(s). -;;; -(define-vop (allocate-frame) - (:results (res :scs (any-reg descriptor-reg)) (nfp)) - (:info callee) - (:ignore nfp callee) - (:generator 2 - (inst lr res sp-tn) - (inst cal sp-tn sp-tn (* 4 (sb-allocated-size 'stack))))) - - -;;; Allocate a partial frame for passing stack arguments in a full call. Nargs -;;; is the number of arguments passed. If no stack arguments are passed, then -;;; we don't have to do anything. -;;; -(define-vop (allocate-full-call-frame) - (:info nargs) - (:results (res :scs (any-reg descriptor-reg) - :load-if (> nargs register-arg-count))) - (:generator 2 - (when (> nargs register-arg-count) - (inst lr res sp-tn) - (inst cal sp-tn sp-tn (* 4 nargs))))) - - -;;; Default-Unknown-Values -- Internal -;;; -;;; Emit code needed at the return-point from an unknown-values call for a -;;; fixed number of values. Values is the head of the TN-Ref list for the -;;; locations that the values are to be received into. Nvals is the number of -;;; values that are to be received (should equal the length of Values). Node -;;; is the node to use for source context in emitted code. -;;; -;;; Move-Temp and Nil-Temp are Descriptor-Reg TNs used as temporaries. -;;; -;;; This code exploits the fact that in the unknown-values convention, a -;;; single value return returns at the return PC + 4, whereas a return of other -;;; than one value returns directly at the return PC. -;;; -;;; If 0 or 1 values are expected, then we just emit an instruction to reset -;;; the SP (which will only be executed when other than 1 value is returned.) -;;; -;;; In the general case, we have to do three things: -;;; -- Default unsupplied register values. This need only be done when a -;;; single value is returned, since register values are defaulted by the -;;; called in the non-single case. -;;; -- Default unsupplied stack values. This needs to be done whenever there -;;; are stack values. -;;; -- Reset SP. This must be done whenever other than 1 value is returned, -;;; regardless of the number of values desired. -;;; -;;; The general-case code looks like this: -#| - br regs-defaulted ; Skip if MVs - cau a1 0 nil-16 ; Default register values - ... - loadi nargs 1 ; Force defaulting of stack values - lr args sp ; Set up args for SP resetting - -regs-defaulted - cau nil-temp 0 nil-16 ; Cache nil - - cmpi nargs 3 ; If 4'th value unsupplied... - blex default-value-4 ; jump to default code - loadw move-temp old-fp-tn 3 ; Move value to correct location. - store-stack-tn val4-tn move-temp - - cmpi nargs 4 ; Check 5'th value, etc. - blex default-value-5 - loadw move-temp old-fp-tn 4 - store-stack-tn val5-tn move-temp - - ... - -defaulting-done - lr sp args ; Reset SP. -<end of code> - -<elsewhere> -default-value-4 - store-stack-tn val4-tn nil-temp ; Nil out 4'th value. - -default-value-5 - store-stack-tn val5-tn nil-temp ; Nil out 5'th value. - - ... - - br defaulting-done -|# -;;; -(defun default-unknown-values (node values nvals move-temp nil-temp) - (declare (type node node) (type (or tn-ref null) values) - (type unsigned-byte nvals) (type tn move-temp nil-temp)) - (assemble node - (if (<= nvals 1) - (inst ai sp-tn old-fp-tn 0) - (let ((regs-defaulted (gen-label)) - (defaulting-done (gen-label))) - (inst bnb :pz regs-defaulted) - - (do ((i 1 (1+ i)) - (val (tn-ref-across values) (tn-ref-across val))) - ((= i (min nvals register-arg-count))) - (inst cau (tn-ref-tn val) zero-tn clc::nil-16)) - (when (> nvals register-arg-count) - (loadi nargs-tn 1) - (inst lr old-fp-tn sp-tn)) - - (emit-label regs-defaulted) - - (when (> nvals register-arg-count) - (inst cau nil-temp zero-tn clc::nil-16) - - (collect ((defaults)) - (do ((i register-arg-count (1+ i)) - (val (do ((i 0 (1+ i)) - (val values (tn-ref-across val))) - ((= i register-arg-count) val)) - (tn-ref-across val))) - ((null val)) - - (let ((default-lab (gen-label)) - (tn (tn-ref-tn val))) - (defaults (cons default-lab tn)) - (cmpi nargs-tn i) - (inst bnbx :gt default-lab) - (loadw move-temp old-fp-tn i) - (store-stack-tn tn move-temp))) - - (emit-label defaulting-done) - (inst lr sp-tn old-fp-tn) - - (unassemble - (assemble-elsewhere node - (dolist (def (defaults)) - (emit-label (car def)) - (store-stack-tn (cdr def) nil-temp)) - (inst bnb :pz defaulting-done)))))))) - (undefined-value)) - - -;;;; Unknown values receiving: - -;;; Receive-Unknown-Values -- Internal -;;; -;;; Emit code needed at the return point for an unknown-values call for an -;;; arbitrary number of values. -;;; -;;; We do the single and non-single cases with no shared code: there doesn't -;;; seem to be any potential overlap, and receiving a single value is more -;;; important efficiency-wise. -;;; -;;; When there is a single value, we just push it on the stack, returning -;;; the old SP and 1. -;;; -;;; When there is a variable number of values, we move all of the argument -;;; registers onto the stack, and return Old-Fp and Nargs. -;;; -;;; Old-Fp and Nargs are TNs wired to the named locations. We must -;;; explicitly allocate these TNs, since their lifetimes overlap with the -;;; results Start and Count (also, it's nice to be able to target them). -;;; -(defun receive-unknown-values (node old-fp nargs start count) - (declare (type node node) (type tn old-fp nargs start count)) - (assemble node - (let ((variable-values (gen-label)) - (done (gen-label))) - (inst bnb :pz variable-values) - - (inst inc sp-tn 4) - (storew (first register-argument-tns) sp-tn -1) - (inst cal start sp-tn -4) - (loadi count 1) - - (emit-label done) - - (unassemble - (assemble-elsewhere node - (emit-label variable-values) - (do ((arg register-argument-tns (rest arg)) - (i 0 (1+ i))) - ((null arg)) - (storew (first arg) old-fp i)) - (unless (location= start old-fp) - (inst lr start old-fp)) - (unless (location= count nargs) - (inst lr count nargs)) - (inst bnb :pz done))))) - (undefined-value)) - - -;;; VOP that can be inherited by unknown values receivers. The main thing this -;;; handles is allocation of the result temporaries. -;;; -(define-vop (unknown-values-receiver) - (:results - (start :scs (descriptor-reg)) - (count :scs (descriptor-reg))) - (:node-var node) - (:temporary (:sc descriptor-reg - :offset old-fp-offset - :from :eval :to (:result 0)) - values-start) - (:temporary (:sc any-reg - :offset argument-count-offset - :from :eval :to (:result 1)) - nvals)) - - -;;;; Local call with unknown values convention return: - -;;; Non-TR local call for a fixed number of values passed according to the -;;; unknown values convention. -;;; -;;; When initially emitted, Args reference the values to be passed. -;;; Representation selection changes the Args to reference the passing -;;; locations when it inserts the move-argument VOPs. Arg-Locs is the list of -;;; passing locations used by representation selection. -;;; -;;; Values are the return value locations (wired to the standard passing -;;; locations). -;;; -;;; Save is the save info, which we can ignore since saving has been done. -;;; Return-PC is the TN that the return PC should be passed in. -;;; Target is a continuation pointing to the start of the called function. -;;; Nvals is the number of values received. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (call-local) - (:args (fp) - (nfp) - (args :more t)) - (:results (values :more t)) - (:save-p t) - (:move-args :local-call) - (:info arg-locs callee target nvals) - (:ignore arg-locs args nfp) - (:node-var node) - (:vop-var vop) - (:temporary (:scs (descriptor-reg)) move-temp nil-temp) - (:temporary (:sc stack - :offset env-save-offset) - env-save) - (:generator 5 - (store-stack-tn env-save env-tn) - (maybe-load-stack-tn fp-tn fp) - (inst bali (callee-return-pc-tn callee) target) - (note-this-location vop :unknown-return) - (unassemble - (default-unknown-values node values nvals move-temp nil-temp)) - (load-stack-tn env-tn env-save))) - - -;;; Non-TR local call for a variable number of return values passed according -;;; to the unknown values convention. The results are the start of the values -;;; glob and the number of values received. -;;; -(define-vop (multiple-call-local unknown-values-receiver) - (:args (fp) - (nfp) - (args :more t)) - (:save-p t) - (:move-args :local-call) - (:info arg-locs callee target) - (:ignore arg-locs args nfp) - (:vop-var vop) - (:temporary (:sc stack - :offset env-save-offset) - env-save) - (:generator 20 - (store-stack-tn env-save env-tn) - (maybe-load-stack-tn fp-tn fp) - (inst bali (callee-return-pc-tn callee) target) - (note-this-location vop :unknown-return) - (unassemble - (receive-unknown-values node values-start nvals start count)) - (load-stack-tn env-tn env-save))) - - -;;;; Local call with known values return: - -;;; Non-TR local call with known return locations. Known-value return works -;;; just like argument passing in local call. -;;; -(define-vop (known-call-local) - (:args (fp) - (nfp) - (args :more t)) - (:results - (res :more t)) - (:move-args :local-call) - (:save-p t) - (:info arg-locs callee target) - (:ignore arg-locs args res nfp) - (:vop-var vop) - (:generator 5 - (maybe-load-stack-tn fp-tn fp) - (inst bali (callee-return-pc-tn callee) target) - (note-this-location vop :known-return))) - - -;;; Return from known values call. We receive the return locations as -;;; arguments to terminate their lifetimes in the returning function. We -;;; restore FP and SP and jump to the Return-PC. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers could get tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN into preallocated temporaries. -;;; -(define-vop (known-return) - (:args - (old-fp :target old-fp-temp) - (return-pc :target return-pc-temp) - (vals :more t)) - (:temporary (:sc descriptor-reg :from (:argument 0)) old-fp-temp) - (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp) - (:move-args :known-return) - (:info val-locs) - (:ignore val-locs vals) - (:generator 6 - (maybe-load-stack-tn old-fp-temp old-fp) - (maybe-load-stack-tn return-pc-temp return-pc) - (inst lr sp-tn fp-tn) - (inst bnbrx :pz return-pc-temp) - (inst lr fp-tn old-fp-temp))) - - -;;;; Full call: -;;; -;;; There is something of a cross-product effect with full calls. Different -;;; versions are used depending on whether we know the number of arguments or -;;; the name of the called function, and whether we want fixed values, unknown -;;; values, or a tail call. -;;; -;;; In full call, the arguments are passed creating a partial frame on the -;;; stack top and storing stack arguments into that frame. On entry to the -;;; callee, this partial frame is pointed to by FP. If there are no stack -;;; arguments, we don't bother allocating a partial frame, and instead set FP -;;; to SP just before the call. - - -;;; Define-Full-Call -- Internal -;;; -;;; This macro helps in the definition of full call VOPs by avoiding code -;;; replication in defining the cross-product VOPs. -;;; -;;; Name is the name of the VOP to define. -;;; -;;; Named is true if the first argument is a symbol whose global function -;;; definition is to be called. -;;; -;;; Return is either :Fixed, :Unknown or :Tail: -;;; -- If :Fixed, then the call is for a fixed number of values, returned in -;;; the standard passing locations (passed as result operands). -;;; -- If :Unknown, then the result values are pushed on the stack, and the -;;; result values are specified by the Start and Count as in the -;;; unknown-values continuation representation. -;;; -- If :Tail, then do a tail-recursive call. No values are returned. -;;; The Old-Fp and Return-PC are passed as the second and third arguments. -;;; -;;; In non-tail calls, the pointer to the stack arguments is passed as the last -;;; fixed argument. If Variable is false, then the passing locations are -;;; passed as a more arg. Variable is true if there are a variable number of -;;; arguments passed on the stack. Variable cannot be specified with :Tail -;;; return. TR variable argument call is implemented separately. -;;; -;;; In tail call with fixed arguments, the passing locations are passed as a -;;; more arg, but there is no new-FP, since the arguments have been set up in -;;; the current frame. -;;; -(defmacro define-full-call (name named return variable) - (assert (not (and variable (eq return :tail)))) - `(define-vop (,name - ,@(when (eq return :unknown) - '(unknown-values-receiver))) - (:args - ,@(unless (eq return :tail) - `((new-fp :scs (descriptor-reg) :to :eval - ,@(unless variable - `(:load-if (> nargs register-arg-count)))))) - - ,(if named - '(name :scs (descriptor-reg) - :target name-pass) - '(function :scs (descriptor-reg) :to :eval)) - - ,@(when (eq return :tail) - '((old-fp :scs (descriptor-reg) - :target old-fp-pass) - (return-pc :scs (descriptor-reg) - :target return-pc-pass))) - - ,@(unless variable '((args :more t)))) - - ,@(when (eq return :fixed) - '((:results (values :more t)))) - - ,@(unless (eq return :tail) - `((:save-p t) - (:node-var node) - (:vop-var vop) - (:temporary (:sc stack - :offset env-save-offset) - env-save) - ,@(unless variable - '((:move-args :full-call))))) - - (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(nargs)) - ,@(when (eq return :fixed) '(nvals))) - - (:ignore ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(args))) - - (:temporary (:sc descriptor-reg - :offset old-fp-offset - :from (:argument 1) - :to :eval) - old-fp-pass) - - (:temporary (:sc descriptor-reg - :offset return-pc-offset - :from (:argument ,(if (eq return :tail) 2 1)) - :to :eval) - return-pc-pass) - - ,@(when named - `((:temporary (:sc descriptor-reg - :offset call-name-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - name-pass) - (:temporary (:scs (descriptor-reg) - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - function))) - - (:temporary (:sc descriptor-reg - :offset argument-count-offset - :to :eval) - nargs-pass) - - ,@(when variable - '((:temporary (:sc descriptor-reg - :offset (first register-arg-offsets) - :to :eval) - a0) - (:temporary (:sc descriptor-reg - :offset (second register-arg-offsets) - :to :eval) - a1) - (:temporary (:sc descriptor-reg - :offset (third register-arg-offsets) - :to :eval) - a2))) - - ,@(when (eq return :fixed) - '((:temporary (:scs (descriptor-reg) - :from :eval) - move-temp nil-temp))) - - (:temporary (:scs (descriptor-reg) - :to :eval) - code offset) - - (:generator ,(+ (if named 5 0) - (if variable 19 1) - (if (eq return :tail) 0 10) - 15 - (if (eq return :unknown) 25 0)) - - ,@(when named - `((unless (location= name name-pass) - (inst lr name-pass name)) - (loadw function name-pass (/ clc::symbol-definition 4)))) - - ,@(if variable - `((inst lr nargs-pass sp-tn) - (inst s nargs-pass new-fp) - (inst sari nargs-pass 2) - (loadw a0 new-fp 0) - (loadw a1 new-fp 1) - (loadw a2 new-fp 2)) - `((loadi nargs-pass nargs))) - - (load-slot code function system:%function-code-slot) - (load-slot offset function system:%function-offset-slot) - (inst cas code code offset) - - ,@(if (eq return :tail) - '((unless (location= old-fp old-fp-pass) - (inst lr old-fp-pass old-fp)) - (unless (location= return-pc return-pc-pass) - (inst lr return-pc-pass return-pc)) - (inst bnbrx :pz code) - (inst lr env-tn function)) - `((store-stack-tn env-save env-tn) - (inst lr old-fp-pass fp-tn) - ,(if variable - '(inst lr fp-tn new-fp) - '(if (> nargs register-arg-count) - (inst lr fp-tn new-fp) - (inst lr fp-tn sp-tn))) - (inst balrx return-pc-pass code) - (inst lr env-tn function) - (no-op))) - - ,@(ecase return - (:fixed - '((note-this-location vop :unknown-return) - (unassemble - (default-unknown-values node values nvals move-temp nil-temp)))) - (:unknown - '((note-this-location vop :unknown-return) - (unassemble - (receive-unknown-values node values-start nvals start count)))) - (:tail)) - - ,@(unless (eq return :tail) - '((load-stack-tn env-tn env-save)))))) - - -(define-full-call call nil :fixed nil) -(define-full-call call-named t :fixed nil) -(define-full-call multiple-call nil :unknown nil) -(define-full-call multiple-call-named t :unknown nil) -(define-full-call tail-call nil :tail nil) -(define-full-call tail-call-named t :tail nil) - -(define-full-call call-variable nil :fixed t) -(define-full-call multiple-call-variable nil :unknown t) - - -;;; Defined separately, since needs a MISCOP call that BLT's the arguments -;;; down. -;;; -;;; This miscop uses a non-standard calling convention so that the argument -;;; registers are free for loading of stack arguments. Old-Fp and the function -;;; are passed in the registers that they will ultimately go in: OLD-FP and -;;; ENV. Args is a pointer to the start of the arguments on the stack, and is -;;; passed in the special ARGS passing location. The Return-PC is passed in -;;; A3 rather than PC because the BALA trashes PC. We use BALA even though the -;;; miscop never returns, since there isn't any BA. -;;; -;;; [### We could easily code inline the special case of nargs <= 3.] -;;; -(define-vop (tail-call-variable) - (:args - (args :scs (descriptor-reg) :target args-pass) - (function :scs (descriptor-reg)) - (old-fp :scs (descriptor-reg) :target old-fp-pass) - (return-pc :scs (descriptor-reg) :target a3)) - (:temporary (:sc descriptor-reg - :offset old-fp-offset - :from (:argument 2)) - old-fp-pass) - (:temporary (:sc descriptor-reg - :offset a3-offset - :from (:argument 3)) - a3) - (:temporary (:sc descriptor-reg - :offset argument-pointer-offset - :from (:argument 0)) - args-pass) - (:generator 75 - (inst lr env-tn function) - (unless (location= args args-pass) - (inst lr args-pass args)) - (unless (location= old-fp old-fp-pass) - (inst lr old-fp-pass old-fp)) - (unless (location= return-pc a3) - (inst lr a3 return-pc)) - (inst miscop 'clc::tail-call-variable))) - - -;;;; Unknown values return: - - -;;; Do unknown-values return of a fixed number of values. The Values are -;;; required to be set up in the standard passing locations. Nvals is the -;;; number of values returned. -;;; -;;; If returning a single value, then deallocate the current frame, restore -;;; FP and jump to the single-value entry at Return-PC + 4. -;;; -;;; If returning other than one value, then load the number of values returned, -;;; NIL out unsupplied values registers, restore FP and return at Return-PC. -;;; When there are stack values, we must initialize the argument pointer to -;;; point to the beginning of the values block (which is the beginning of the -;;; current frame.) -;;; -(define-vop (return) - (:args - (old-fp :scs (descriptor-reg any-reg)) - (return-pc :scs (descriptor-reg) :target pc-save) - (values :more t)) - (:ignore values) - (:info nvals) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) pc-save) - (:temporary (:sc descriptor-reg - :offset (first register-arg-offsets) - :from (:eval 0) - :to (:eval 1)) - a0) - (:temporary (:sc descriptor-reg - :offset (second register-arg-offsets) - :from (:eval 0) - :to (:eval 1)) - a1) - (:temporary (:sc descriptor-reg - :offset (third register-arg-offsets) - :from (:eval 0) - :to (:eval 1)) - a2) - (:temporary (:sc descriptor-reg - :offset argument-count-offset) - nvals-loc) - (:temporary (:sc descriptor-reg - :offset old-fp-offset) - vals-loc) - (:generator 6 - (cond ((= nvals 1) - (inst lr sp-tn fp-tn) - (inst inc return-pc 4) - (inst bnbrx :pz return-pc) - (inst lr fp-tn old-fp)) - (t - (loadi nvals-loc nvals) - (inst lr vals-loc fp-tn) - (inst cal sp-tn vals-loc (* nvals 4)) - (inst lr fp-tn old-fp) - - (unless (location= pc-save return-pc) - (inst lr pc-save return-pc)) - - (when (< nvals 3) - (inst cau a2 zero-tn clc::nil-16) - (when (< nvals 2) - (inst lr a1 a2)) - (when (< nvals 1) - (inst lr a0 a2))) - - (inst bnbr :pz pc-save))))) - - -;;; Do unknown-values return of an arbitrary number of values (passed on the -;;; stack.) We check for the common case of a single return value, and do that -;;; inline using the normal single value return convention. Otherwise, we -;;; branch off to code that calls a miscop. -;;; -;;; The Return-Multiple miscop uses a non-standard calling convention. For one -;;; thing, it doesn't return. We only use BALA because there isn't a BA -;;; instruction. Also, we don't use A0..A2 for argument passing, since the -;;; miscop will want to load these with values off of the stack. Instead, we -;;; pass Old-Fp and Count in the normal locations for these values. The -;;; pointer to the start of the return values is passed in the special ARGS -;;; location. Return-PC is passed in A3 since PC is trashed by the BALA. -;;; -(define-vop (return-multiple) - (:args - (old-fp :scs (descriptor-reg) :target old-fp-pass) - (return-pc :scs (descriptor-reg) - :target a3) - (start :scs (descriptor-reg) - :target vals-loc) - (count :scs (descriptor-reg) - :target nvals-loc)) - (:temporary (:sc descriptor-reg - :offset old-fp-offset - :from (:argument 0)) - old-fp-pass) - (:temporary (:sc descriptor-reg - :offset a3-offset - :from (:argument 1)) - a3) - (:temporary (:sc descriptor-reg - :offset argument-pointer-offset - :from (:argument 2)) - vals-loc) - (:temporary (:sc descriptor-reg - :offset argument-count-offset - :from (:argument 3)) - nvals-loc) - (:temporary (:sc descriptor-reg - :offset (first register-arg-offsets)) - a0) - (:node-var node) - (:generator 13 - (let ((non-single (gen-label))) - (cmpi count 1) - (inst bnbx :eq non-single) - (loadw a0 start) - (inst lr sp-tn fp-tn) - (inst inc return-pc 4) - (inst bnbrx :pz return-pc) - (inst lr fp-tn old-fp) - - (unassemble - (assemble-elsewhere node - (emit-label non-single) - (unless (location= old-fp-pass old-fp) - (inst lr old-fp-pass old-fp)) - (unless (location= a3 return-pc) - (inst lr a3 return-pc)) - (unless (location= vals-loc start) - (inst lr vals-loc start)) - (unless (location= nvals-loc count) - (inst lr nvals-loc count)) - (inst miscop 'clc::return-multiple)))))) - - -;;;; XEP hackery: - -;;; Fetch the constant pool from the function entry structure. -;;; -(define-vop (setup-environment) - (:generator 5 - (load-slot env-tn env-tn system:%function-entry-constants-slot))) - -;;; Return the current Env as our result, then indirect throught the closure -;;; and the closure-entry to find the constant pool -;;; -(define-vop (setup-closure-environment) - (:results (closure :scs (descriptor-reg))) - (:generator 11 - (inst lr closure env-tn) - (load-slot env-tn env-tn system:%function-name-slot) - (load-slot env-tn env-tn system:%function-entry-constants-slot))) - - -;;; Copy a more arg from the argument area to the end of the current frame. -;;; Fixed is the number of non-more arguments. This definition and the -;;; associated miscop assume that all the arguments and stuff are in their -;;; passing registers, and that all other non-dedicated registers are free. -;;; -;;; We sleazily save the return PC in NAME so that we can do a miscop call. -;;; -(define-vop (copy-more-arg) - (:temporary (:sc descriptor-reg :offset a3-offset) a3) - (:temporary (:sc descriptor-reg :offset call-name-offset) name) - (:info fixed) - (:generator 20 - (loadi a3 fixed) - (inst lr name pc-tn) - (inst miscop 'clc::copy-more-arg) - (inst lr pc-tn name))) - - -;;; More args are stored consequtively on the stack, starting immediately at -;;; the context pointer. -;;; -(define-vop (more-arg word-index-ref) - (:variant 0) - (:translate %more-arg)) - - -;;; Turn more arg (context, count) into a list. -;;; -(define-miscop listify-rest-args (context count) - :translate %listify-rest-args) - - -;;; Return the location and size of the more arg glob created by Copy-More-Arg. -;;; Supplied is the total number of arguments supplied (originally passed in -;;; NARGS.) Fixed is the number of non-rest arguments. -;;; -;;; We must duplicate some of the work done by Copy-More-Arg, since at that -;;; time the environment is in a pretty brain-damaged state, preventing this -;;; info from being returned as values. What we do is compute -;;; supplied - fixed, and return a pointer that many words below the current -;;; stack top. -;;; -(define-vop (more-arg-context) - (:args - (supplied :scs (any-reg descriptor-reg))) - (:info fixed) - (:results - (context :scs (descriptor-reg)) - (count :scs (any-reg descriptor-reg))) - (:temporary (:scs (any-reg) :type fixnum) byte-size) - (:generator 5 - (inst ai count supplied (- fixed)) - (inst lr byte-size count) - (inst sli byte-size 2) - (inst lr context sp-tn) - (inst s context byte-size))) - - -;;; Signal wrong argument count error if Nargs isn't = to Count. -;;; -(define-vop (verify-argument-count) - (:args - (nargs :scs (any-reg descriptor-reg))) - (:info count) - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (let ((err-lab (generate-error-code vop clc::error-wrong-number-args - nargs))) - (cmpi nargs count) - (inst bnb :eq err-lab)))) - - -;;; Signal an argument count error. -;;; -(define-vop (argument-count-error) - (:args (nargs :scs (any-reg descriptor-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (error-call clc::error-wrong-number-args nargs) - (note-this-location vop :internal-error))) diff --git a/compiler/old-rt/cell.lisp b/compiler/old-rt/cell.lisp deleted file mode 100644 index 5e0243876401fda2fd39eb40511771eb743dc156..0000000000000000000000000000000000000000 --- a/compiler/old-rt/cell.lisp +++ /dev/null @@ -1,166 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of various primitive memory access -;;; VOPs for the RT. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; Symbol hacking VOPs: - -;;; Do a cell ref with an error check for being unbound. -;;; -(define-vop (checked-cell-ref) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg)) obj-temp)) - -;;; With Symbol-Value, we check that the value isn't the trap object. So -;;; Symbol-Value of NIL is NIL. -;;; -(define-vop (symbol-value checked-cell-ref) - (:translate symbol-value) - (:generator 9 - (unless (location= obj-temp object) - (inst lr obj-temp object)) - (loadw value obj-temp (/ clc::symbol-value 4)) - (let ((err-lab (generate-error-code vop clc::error-symbol-unbound - obj-temp))) - (test-special-value value temp '%trap-object err-lab nil)))) - -;;; With Symbol-Function, we check that the result is a function, so NIL is -;;; always un-fbound. -;;; -(define-vop (symbol-function checked-cell-ref) - (:translate symbol-function) - (:generator 10 - (unless (location= obj-temp object) - (inst lr obj-temp object)) - (loadw value obj-temp (/ clc::symbol-definition 4)) - (let ((err-lab (generate-error-code vop clc::error-symbol-undefined - obj-temp))) - (test-simple-type value temp err-lab t system:%function-type)))) - - -;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. -(define-vop (boundp-frob) - (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value) - (:temporary (:type random :scs (non-descriptor-reg)) temp)) - -(define-vop (boundp boundp-frob) - (:translate boundp) - (:generator 9 - (loadw value object (/ clc::symbol-value 4)) - (test-special-value value temp '%trap-object target (not not-p)))) - - -;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction -;;; on the symbol case of fboundp. Instead, we transform to a funny function. - -(defknown fboundp/symbol (t) boolean (flushable)) -;;; -(deftransform fboundp ((x) (symbol)) - '(fboundp/symbol x)) -;;; -(define-vop (fboundp/symbol boundp-frob) - (:translate fboundp/symbol) - (:generator 10 - (loadw value object (/ clc::symbol-definition 4)) - (test-simple-type value temp target not-p system:%function-type))) - -(def-source-transform makunbound (x) - `(set ,x (%primitive make-immediate-type 0 system:%trap-type))) - - -(define-vop (fast-symbol-value cell-ref) - (:variant (/ clc::symbol-value 4)) - (:policy :fast) - (:translate symbol-value)) - -(define-vop (fast-symbol-function cell-ref) - (:variant (/ clc::symbol-definition 4)) - (:policy :fast) - (:translate symbol-function)) - -(define-cell-accessors (/ clc::symbol-value 4) nil nil set set) -(define-cell-accessors (/ clc::symbol-definition 4) - nil nil set-symbol-function %sp-set-definition) -(define-cell-accessors (/ clc::symbol-property-list 4) - symbol-plist symbol-plist set-symbol-plist %sp-set-plist) -(define-cell-accessors (/ clc::symbol-print-name 4) - symbol-name symbol-name nil nil) -(define-cell-accessors (/ clc::symbol-package 4) - symbol-package symbol-package set-package nil) - - -(define-miscop bind (val symbol) :results ()) -(define-miscop unbind (num) :results ()) - - -;;;; List hackery: - -(define-cell-accessors (/ clc::list-car 4) - car car set-car %rplaca) -(define-cell-accessors (/ clc::list-cdr 4) - cdr cdr set-cdr %rplacd) - -(define-miscop cons (x y) :translate cons) - - -;;;; Value cell and closure hackery: - -(define-miscop make-value-cell (val)) -(define-miscop make-closure (nvars entry)) - -(define-vop (value-cell-ref cell-ref) - (:variant (+ clc::g-vector-header-size-in-words - system:%function-value-cell-value-slot))) - -(define-vop (value-cell-set cell-set) - (:variant (+ clc::g-vector-header-size-in-words - system:%function-value-cell-value-slot))) - -(define-vop (closure-init slot-set)) -(define-vop (closure-ref slot-ref)) - - -;;;; Structure hackery: - -(define-vop (structure-ref slot-ref)) -(define-vop (structure-set slot-set)) - - -;;;; Number hackery: - -(define-vop (realpart cell-ref) - (:policy :fast-safe) - (:variant (/ clc::complex-realpart 4))) - -(define-vop (imagpart cell-ref) - (:policy :fast-safe) - (:variant (/ clc::complex-imagpart 4))) - -(define-vop (numerator cell-ref) - (:policy :fast-safe) - (:variant (/ clc::ratio-numerator 4))) - -(define-vop (denominator cell-ref) - (:policy :fast-safe) - (:variant (/ clc::ratio-denominator 4))) diff --git a/compiler/old-rt/char.lisp b/compiler/old-rt/char.lisp deleted file mode 100644 index 37cd02e9a1ec082385c740505bd77164db015691..0000000000000000000000000000000000000000 --- a/compiler/old-rt/char.lisp +++ /dev/null @@ -1,166 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the RT VM definition of character operations. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; Moves and coercions: - -;;; Move untagged string-char values. -;;; -(define-vop (string-char-move) - (:args (x :target y - :scs (string-char-reg) - :load-if (not (location= x y)))) - (:results (y :scs (string-char-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (unless (location= x y) - (inst lr y x)))) -;;; -(define-move-vop string-char-move :move - (string-char-reg) (string-char-reg)) - - -;;; Move untagged string-char arguments/return-values. -;;; -(define-vop (move-string-char-argument) - (:args (x :target y - :scs (string-char-reg)) - (fp :scs (descriptor-reg) - :load-if (not (sc-is y string-char-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (string-char-reg - (unless (location= x y) - (inst lr y x))) - (string-char-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-string-char-argument :move-argument - (string-char-reg) (string-char-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged string-char to a -;;; descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (string-char-reg) (any-reg descriptor-reg)) - - -;;; Move a tagged string char to an untagged representation. -;;; -(define-vop (move-to-string-char) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (string-char-reg))) - (:generator 1 - (inst nilz y x system:%character-code-mask))) -;;; -(define-move-vop move-to-string-char :move - (any-reg descriptor-reg) (string-char-reg)) - - -;;; Move an untagged string char to a tagged representation. -;;; -(define-vop (move-from-string-char) - (:args (x :scs (string-char-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:generator 1 - (inst oiu y x (ash system:%string-char-type clc::type-shift-16)))) -;;; -(define-move-vop move-from-string-char :move - (string-char-reg) (any-reg descriptor-reg)) - - -;;;; Other operations: - -(define-vop (char-code) - (:args (ch :scs (string-char-reg) :target res)) - (:results (res :scs (any-reg descriptor-reg))) - (:arg-types string-char) - (:translate char-code) - (:policy :fast-safe) - (:generator 0 - (unless (location= ch res) - (inst lr res ch)))) - -(define-vop (code-char) - (:args (code :scs (any-reg descriptor-reg) :target res)) - (:results (res :scs (string-char-reg))) - (:result-types string-char) - (:translate code-char) - (:policy :fast-safe) - (:generator 0 - (unless (location= code res) - (inst lr res code)))) - - -(define-vop (pointer-compare) - (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:note "inline comparison") - (:variant-vars condition) - (:generator 3 - (inst cl x y) - (if not-p - (inst bnb condition target) - (inst bb condition target)))) - - -;;; For comparison of string-chars, we require both operands to be in the -;;; untagged string-char-reg representation. This will be a pessimization if -;;; both operands are tagged, but this won't happen often, and not in -;;; performance-critical cases. -;;; -(define-vop (string-char-compare pointer-compare) - (:args (x :scs (string-char-reg)) - (y :scs (string-char-reg))) - (:arg-types string-char string-char)) - -(define-vop (fast-char=/string-char string-char-compare) - (:translate char=) - (:variant :eq)) - -(define-vop (fast-char</string-char string-char-compare) - (:translate char<) - (:variant :lt)) - -(define-vop (fast-char>/string-char string-char-compare) - (:translate char>) - (:variant :gt)) - -;;; If we don't know that both operands are string-chars, then we just compare -;;; the whole boxed object. This assume that the hairy character type code is -;;; greater than the string-char type, since a string-char must always be less -;;; than a hairy char. -;;; -(define-vop (char-compare pointer-compare) - (:variant-cost 5)) - -(define-vop (fast-char= char-compare) - (:translate char=) - (:variant :eq)) - -(define-vop (fast-char< char-compare) - (:translate char<) - (:variant :lt)) - -(define-vop (fast-char> char-compare) - (:translate char>) - (:variant :gt)) diff --git a/compiler/old-rt/core.lisp b/compiler/old-rt/core.lisp deleted file mode 100644 index 0d6aa7da059e4208f147a2e620c4beda60377411..0000000000000000000000000000000000000000 --- a/compiler/old-rt/core.lisp +++ /dev/null @@ -1,171 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; -;;; This file contains stuff that knows how to load compiled code directly -;;; into core, e.g. incremental compilation. -;;; -(in-package 'c) - - -;;; The CORE-OBJECT structure holds the state needed to resolve cross-component -;;; references during in-core compilation. -;;; -(defstruct (core-object - (:constructor make-core-object ()) - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (format stream "#<Core-Object>")))) - ;; - ;; A hashtable translating ENTRY-INFO structures to the corresponding actual - ;; FUNCTIONs for functions in this compilation. - (entry-table (make-hash-table :test #'eq) :type hash-table) - ;; - ;; A list of all the DEBUG-INFO objects created, kept so that we can - ;; backpatch with the source info. - (debug-info () :type list)) - - -;;; MAKE-FUNCTION-ENTRY -- Internal -;;; -;;; Make a function entry, filling in slots from the ENTRY-INFO. -;;; -(defun make-function-entry (entry code-obj code-vec object) - (declare (type entry-info entry) (type core-object object)) - (let ((res (%primitive alloc-function (1+ %function-entry-type-slot)))) - (%primitive set-vector-subtype res - (if (entry-info-closure-p entry) - %function-closure-entry-subtype - %function-entry-subtype)) - (%primitive header-set res %function-name-slot (entry-info-name entry)) - (%primitive header-set res %function-code-slot code-vec) - (%primitive header-set res %function-offset-slot - (+ (label-location (entry-info-offset entry)) - clc::i-vector-header-size)) - (%primitive header-set res %function-entry-constants-slot code-obj) - (%primitive header-set res %function-entry-arglist-slot - (entry-info-arguments entry)) - (%primitive header-set res %function-entry-type-slot - (entry-info-type entry)) - - (setf (gethash entry (core-object-entry-table object)) res)) - (undefined-value)) - - -;;; CORE-FUNCTION-OR-LOSE -- Internal -;;; -;;; Get the function for a function entry that has been dumped to core. -;;; -(defun core-function-or-lose (fun object) - (declare (type clambda fun) (type core-object object)) - (let ((res (gethash (leaf-info fun) (core-object-entry-table object)))) - (assert res () "Unresolved forward function reference?") - res)) - - -;;; DO-CORE-FIXUPS -- Internal -;;; -;;; Do "load-time" fixups on the code vector. Currently there are only -;;; :MISCOP fixups. -;;; -(defun do-core-fixups (code fixups) - (declare (list fixups)) - (dolist (fixup fixups) - (let ((offset (second fixup)) - (value (third fixup))) - (ecase (first fixup) - (:miscop - (let ((loaded-addr (get value 'lisp::%loaded-address))) - (unless loaded-addr - (error "Miscop ~A is undefined." value)) - - (let ((hi-addr (logior (ash clc::type-assembler-code - clc::type-shift-16) - (logand (ash loaded-addr -16) #xFFFF)))) - (setf (aref code (+ offset 1)) (logand hi-addr #xFF)) - (setf (aref code (+ offset 2)) - (logand (ash loaded-addr -8) #xFF)) - (setf (aref code (+ offset 3)) - (logand loaded-addr #xFF))))))))) - - -;;; MAKE-CORE-COMPONENT -- Interface -;;; -;;; Dump a component to core. We pass in the assembler fixups, code vector -;;; and node info. -;;; -(defun make-core-component (component code-vector code-length - node-vector nodes-length - fixups object) - (declare (type component component) (type index nodes-length code-length) - (list fixups) (type core-object object)) - (without-gcing - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp)) - (box-num (length constants)) - (code-obj (%primitive alloc-function box-num)) - (code-vec (%primitive alloc-code code-length))) - (%primitive byte-blt code-vector 0 code-vec 0 code-length) - (%primitive header-set code-obj %function-code-slot code-vec) - (do-core-fixups code-vec fixups) - - (dolist (entry (ir2-component-entries 2comp)) - (make-function-entry entry code-obj code-vec object)) - - (%primitive set-vector-subtype code-obj %function-constants-subtype) - - (%primitive header-set code-obj %function-name-slot - (component-name component)) - (let ((info (debug-info-for-component component node-vector - nodes-length))) - (push info (core-object-debug-info object)) - (%primitive header-set code-obj %function-constants-debug-info-slot - info)) - - (dotimes (i box-num) - (let ((const (aref constants i))) - (etypecase const - (null) - (constant - (%primitive header-set code-obj i (constant-value const))) - (list - (ecase (car const) - (:entry - (%primitive header-set code-obj i - (core-function-or-lose (cdr const) object))) - (:label - (%primitive header-set code-obj i - (+ (label-location (cdr const)) - clc::i-vector-header-size)))))))))) - (undefined-value)) - - -;;; CORE-CALL-TOP-LEVEL-LAMBDA -- Interface -;;; -;;; Call the top-level lambda function dumped for Entry, returning the -;;; values. -;;; -(defun core-call-top-level-lambda (entry object) - (declare (type clambda entry) (type core-object object)) - (funcall (core-function-or-lose entry object))) - - -;;; FIX-CORE-SOURCE-INFO -- Interface -;;; -;;; Backpatch all the DEBUG-INFOs dumped so far with the specified -;;; SOURCE-INFO list. -;;; -(defun fix-core-source-info (info object) - (declare (type source-info info) (type core-object object)) - (let ((res (debug-source-for-info info))) - (dolist (info (core-object-debug-info object)) - (setf (compiled-debug-info-source info) res)) - (setf (core-object-debug-info object) ())) - (undefined-value)) diff --git a/compiler/old-rt/dump.lisp b/compiler/old-rt/dump.lisp deleted file mode 100644 index 9f9f75f414b421937f9b680660ab2075be57f88a..0000000000000000000000000000000000000000 --- a/compiler/old-rt/dump.lisp +++ /dev/null @@ -1,1062 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; -;;; This file contains stuff that knows about dumping code both to files to -;;; the running Lisp. -;;; -(in-package 'c) - -(proclaim '(special compiler-version)) - -(import '(system:%primitive system:%array-data-slot - system:%array-displacement-slot - system:%g-vector-structure-subtype - system:%function-constants-constants-offset)) - - - -;;;; Fasl dumper state: - -;;; The Fasl-File structure represents everything we need to know about dumping -;;; to a fasl file. We need to objectify the state, since the fasdumper must -;;; be reentrant. -;;; -(defstruct (fasl-file - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (format stream "#<Fasl-File ~S>" - (namestring (fasl-file-stream s)))))) - ;; - ;; The stream we dump to. - (stream nil :type stream) - ;; - ;; Hashtables we use to keep track of dumped constants so that we can get - ;; them from the table rather than dumping them again. The EQUAL-TABLE is - ;; used for lists and strings, and the EQ-TABLE is used for everything else. - ;; We use a separate EQ table to avoid performance patholigies with objects - ;; for which EQUAL degnerates to EQL. Everything entered in the EQUAL table - ;; is also entered in the EQ table. - (equal-table (make-hash-table :test #'equal) :type hash-table) - (eq-table (make-hash-table :test #'eq) :type hash-table) - ;; - ;; The table's current free pointer: the next offset to be used. - (table-free 0 :type unsigned-byte) - ;; - ;; Alist (Package . Offset) of the table offsets for each package we have - ;; currently located. - (packages () :type list) - ;; - ;; Table mapping from the Entry-Info structures for dumped XEPs to the table - ;; offsets of the corresponding code pointers. - (entry-table (make-hash-table :test #'eq) :type hash-table) - ;; - ;; Table holding back-patching info for forward references to XEPs. The key - ;; is the Entry-Info structure for the XEP, and the value is a list of conses - ;; (<code-handle> . <offset>), where <code-handle> is the offset in the table - ;; of the code object needing to be patched, and <offset> is the offset that - ;; must be patched. - (patch-table (make-hash-table :test #'eq) :type hash-table) - ;; - ;; A list of the table handles for all of the DEBUG-INFO structures dumped in - ;; this file. These structures must be back-patched with source location - ;; information when the compilation is complete. - (debug-info () :type list) - ;; - ;; Used to keep track of objects that we are in the process of dumping so that - ;; circularities can be preserved. The key is the object that we have - ;; previously seen, and the value is the object that we reference in the table - ;; to find this previously seen object. (The value is never NIL.) - ;; - ;; Except with list objects, the key and the value are always the same. In a - ;; list, the key will be some tail of the value. - (circularity-table (make-hash-table :test #'eq) :type hash-table)) - - -;;; This structure holds information about a circularity. -;;; -(defstruct circularity - ;; - ;; Kind of modification to make to create circularity. - (type nil :type (member :rplaca :rplacd :svset)) - ;; - ;; Object containing circularity. - object - ;; - ;; Index in object for circularity. - (index nil :type unsigned-byte) - ;; - ;; The object to be stored at Index in Object. This is that the key that we - ;; were using when we discovered the circularity. - value - ;; - ;; The value that was associated with Value in the CIRCULARITY-TABLE. This - ;; is the object that we look up in the EQ-TABLE to locate Value. - enclosing-object) - - -;;; A list of the Circularity structures for all of the circularities detected -;;; in the the current top-level call to Dump-Object. Setting this lobotomizes -;;; circularity detection as well, since circular dumping uses the table. -;;; -(defvar *circularities-detected*) - - -;;; Used to inhibit table access when dumping forms to be read by the cold -;;; loader. -;;; -(defvar *cold-load-dump* nil) - - -;;;; Utilities: - -;;; Dump-Byte -- Internal -;;; -;;; Write the byte B to the specified fasl-file stream. -;;; -(proclaim '(inline dump-byte)) -(defun dump-byte (b file) - (declare (type (unsigned-byte 8) b) (type fasl-file file)) - (write-byte b (fasl-file-stream file)) - (undefined-value)) - - -;;; Dump-FOP -- Internal -;;; -;;; Dump the FOP code for the named FOP to the specified fasl-file. -;;; -(defun dump-fop (fs file) - (declare (symbol fs) (type fasl-file file)) - (let ((val (get fs 'lisp::fop-code))) - (assert val () "Compiler bug: ~S not a legal fasload operator." fs) - (dump-byte val file)) - (undefined-value)) - - -;;; Dump-FOP* -- Internal -;;; -;;; Dump a FOP-Code along with an integer argument, choosing the FOP based -;;; on whether the argument will fit in a single byte. -;;; -(defmacro dump-fop* (n byte-fop word-fop file) - (once-only ((n-n n) - (n-file file)) - `(cond ((< ,n-n 256) - (dump-fop ',byte-fop ,n-file) - (dump-byte ,n-n ,n-file)) - (t - (dump-fop ',word-fop ,n-file) - (quick-dump-number ,n-n 4 ,n-file))))) - - -;;; Quick-Dump-Number -- Internal -;;; -;;; Dump Num to the fasl stream, represented by the specified number of -;;; bytes. -;;; -(defun quick-dump-number (num bytes file) - (declare (integer num) (type unsigned-byte bytes) (type fasl-file file)) - (let ((stream (fasl-file-stream file))) - (do ((n num (ash n -8)) - (i bytes (1- i))) - ((= i 0)) - (write-byte (logand n #xFF) stream))) - (undefined-value)) - - -;;; Dump-Push -- Internal -;;; -;;; Push the object at table offset Handle on the fasl stack. -;;; -(defun dump-push (handle file) - (declare (type unsigned-byte handle) (type fasl-file file)) - (dump-fop* handle lisp::fop-byte-push lisp::fop-push file) - (undefined-value)) - - -;;; Dump-Pop -- Internal -;;; -;;; Pop the object currently on the fasl stack top into the table, and -;;; return the table index, incrementing the free pointer. -;;; -(defun dump-pop (file) - (prog1 (fasl-file-table-free file) - (dump-fop 'lisp::fop-pop file) - (incf (fasl-file-table-free file)))) - - -;;; EQUAL-CHECK-TABLE -- Internal -;;; -;;; If X is in File's EQUAL-TABLE, then push the object and return T, -;;; otherwise NIL. If *COLD-LOAD-DUMP* is true, then do nothing and return -;;; NIL. -;;; -(defun equal-check-table (x file) - (declare (type fasl-file file)) - (unless *cold-load-dump* - (let ((handle (gethash x (fasl-file-equal-table file)))) - (cond (handle - (dump-push handle file) - t) - (t - nil))))) - - -;;; EQ-SAVE-OBJECT, EQUAL-SAVE-OBJECT -- Internal -;;; -;;; These functions are called after dumping an object to save the object in -;;; the table. The object (also passed in as X) must already be on the top of -;;; the FOP stack. If *COLD-LOAD-DUMP* is true, then we don't do anything. -;;; -(defun eq-save-object (x file) - (declare (type fasl-file file)) - (unless *cold-load-dump* - (let ((handle (dump-pop file))) - (setf (gethash x (fasl-file-eq-table file)) handle) - (dump-push handle file))) - (undefined-value)) -;;; -(defun equal-save-object (x file) - (declare (type fasl-file file)) - (unless *cold-load-dump* - (let ((handle (dump-pop file))) - (setf (gethash x (fasl-file-equal-table file)) handle) - (setf (gethash x (fasl-file-eq-table file)) handle) - (dump-push handle file))) - (undefined-value)) - - -;;; NOTE-POTENTIAL-CIRCULARITY -- Internal -;;; -;;; Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is true. -;;; This is called on objects that we are about to dump might have a circular -;;; path through them. -;;; -;;; The object must not currently be in this table, since the dumper should -;;; never be recursively called on a circular reference. Instead, the dumping -;;; function must detect the circularity and arrange for the dumped object to -;;; be patched. -;;; -(defun note-potential-circularity (x file) - (unless *cold-load-dump* - (let ((circ (fasl-file-circularity-table file))) - (assert (not (gethash x circ))) - (setf (gethash x circ) x))) - (undefined-value)) - - -;;; Fasl-Dump-Cold-Load-Form -- Interface -;;; -;;; Dump Form to a fasl file so that it evaluated at load time in normal -;;; load and at cold-load time in cold load. This is used to dump package -;;; frobbing forms. -;;; -(defun fasl-dump-cold-load-form (form file) - (declare (type fasl-file file)) - (dump-fop 'lisp::fop-normal-load file) - (let ((*cold-load-dump* t)) - (dump-object form file)) - (dump-fop 'lisp::fop-eval-for-effect file) - (dump-fop 'lisp::fop-maybe-cold-load file) - (undefined-value)) - - -;;;; Opening and closing: - -;;; Open-Fasl-File -- Interface -;;; -;;; Return a Fasl-File object for dumping to the named file. Some -;;; information about the source is specified by the string Where. -;;; -(defun open-fasl-file (name where) - (declare (type pathname name)) - (let* ((stream (open name :direction :output - :if-exists :new-version - :element-type '(unsigned-byte 8))) - (res (make-fasl-file :stream stream))) - (format stream - "FASL FILE output from ~A.~@ - Compiled ~A on ~A~@ - Compiler ~A, Lisp ~A~@ - Targeted for ~A, FASL code format ~D~%" - where - (ext:format-universal-time nil (get-universal-time)) - (machine-instance) compiler-version - (lisp-implementation-version) vm-version target-fasl-code-format) - ;; - ;; Terminate header. - (dump-byte 255 res) - ;; - ;; Specify code format. - (dump-fop 'lisp::fop-code-format res) - (dump-byte target-fasl-code-format res) - - res)) - - -;;; Close-Fasl-File -- Interface -;;; -;;; Close the specified Fasl-File, aborting the write if Abort-P is true. -;;; We do various sanity checks, then end the group. -;;; -(defun close-fasl-file (file abort-p) - (declare (type fasl-file file)) - (dump-fop 'lisp::fop-verify-empty-stack file) - (dump-fop 'lisp::fop-verify-table-size file) - (quick-dump-number (fasl-file-table-free file) 4 file) - (dump-fop 'lisp::fop-end-group file) - (close (fasl-file-stream file) :abort abort-p) - (undefined-value)) - - -;;;; Component (function) dumping: - -;;; Dump-Code-Object -- Internal -;;; -;;; Dump out the constant pool and code-vector for component, push the -;;; result in the table and return the offset. -;;; -;;; The only tricky thing is handling constant-pool references to functions. -;;; If we have already dumped the function, then we just push the code pointer. -;;; Otherwise, we must create back-patching information so that the constant -;;; will be set when the function is eventually dumped. This is a bit awkward, -;;; since we don't have the handle for the code object being dumped while we -;;; are dumping its constants. -;;; -;;; We dump a trap object as a placeholder for the code vector, which is -;;; actually filled in by the loader. -;;; -(defun dump-code-object (component code-vector code-length node-vector - nodes-length file) - (declare (type component component) (type fasl-file file) - (simple-vector node-vector) - (type unsigned-byte code-length nodes-length)) - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp)) - (num-consts (length constants))) - (collect ((patches)) - (dump-object (component-name component) file) - (dump-fop 'lisp::fop-misc-trap file) - - (let ((info (debug-info-for-component component node-vector - nodes-length))) - (dump-object info file) - (let ((info-handle (dump-pop file))) - (dump-push info-handle file) - (push info-handle (fasl-file-debug-info file)))) - - (do ((i %function-constants-constants-offset (1+ i))) - ((= i num-consts)) - (let ((entry (aref constants i))) - (etypecase entry - (constant - (dump-object (constant-value entry) file)) - (cons - (ecase (car entry) - (:entry - (let* ((info (leaf-info (cdr entry))) - (handle (gethash info (fasl-file-entry-table file)))) - (cond - (handle - (dump-push handle file)) - (t - (patches (cons info i)) - (dump-fop 'lisp::fop-misc-trap file))))) - (:label - (dump-object (+ (label-location (cdr entry)) - clc::i-vector-header-size) - file)))) - (null - (dump-fop 'lisp::fop-misc-trap file))))) - - (cond ((and (< num-consts #x100) (< code-length #x10000)) - (dump-fop 'lisp::fop-small-code file) - (dump-byte num-consts file) - (quick-dump-number code-length 2 file)) - (t - (dump-fop 'lisp::fop-code file) - (quick-dump-number num-consts 4 file) - (quick-dump-number code-length 4 file))) - - (write-string code-vector (fasl-file-stream file) :end code-length) - - (let ((handle (dump-pop file))) - (dolist (patch (patches)) - (push (cons handle (cdr patch)) - (gethash (car patch) (fasl-file-patch-table file)))) - handle)))) - - -;;; Dump-Fixups -- Internal -;;; -;;; Dump all the fixups. Currently there are only miscop fixups, and we -;;; always access them by name rather than number. There is no reason for -;;; using miscop numbers other than a minor load-time efficiency win. -;;; -(defun dump-fixups (code-handle fixups file) - (declare (type unsigned-byte code-handle) (list fixups) - (type fasl-file file)) - (dump-push code-handle file) - (dolist (fixup fixups) - (let ((offset (second fixup)) - (value (third fixup))) - (ecase (first fixup) - (:miscop - (assert (symbolp value)) - (dump-object value file) - (dump-fop 'lisp::fop-user-miscop-fixup file) - (quick-dump-number offset 4 file))))) - - (dump-fop 'lisp::fop-pop-for-effect file) - (undefined-value)) - - -;;; Dump-One-Entry -- Internal -;;; -;;; Dump a function-entry data structure corresponding to Entry to File. -;;; Code-Handle is the table offset of the code object for the component. -;;; -;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the cold -;;; loader can instantiate the definition at cold-load time, allowing forward -;;; references to functions in top-level forms. -;;; -(defun dump-one-entry (entry code-handle file) - (declare (type entry-info entry) (type unsigned-byte code-handle) - (type fasl-file file)) - (let ((name (entry-info-name entry))) - (dump-push code-handle file) - (dump-object (if (entry-info-closure-p entry) - system:%function-closure-entry-subtype - system:%function-entry-subtype) - file) - - (dump-object name file) - (dump-fop 'lisp::fop-misc-trap file) - (dump-object (+ (label-location (entry-info-offset entry)) - clc::i-vector-header-size) - file) - (dump-fop 'lisp::fop-misc-trap file) - (dump-object (entry-info-arguments entry) file) - (dump-object (entry-info-type entry) file) - (dump-fop 'lisp::fop-function-entry file) - (dump-byte 6 file) - - (let ((handle (dump-pop file))) - (when (and name (symbolp name)) - (dump-object name file) - (dump-push handle file) - (dump-fop 'lisp::fop-fset file)) - handle))) - - -;;; Alter-Code-Object -- Internal -;;; -;;; Alter the code object referenced by Code-Handle at the specified Offset, -;;; storing the object referenced by Entry-Handle. -;;; -(defun alter-code-object (code-handle offset entry-handle file) - (dump-push code-handle file) - (dump-push entry-handle file) - (dump-fop* offset lisp::fop-byte-alter-code lisp::fop-alter-code file) - (undefined-value)) - - -;;; Fasl-Dump-Component -- Interface -;;; -;;; Dump the code, constants, etc. for component. We pass in the assembler -;;; fixups, code vector and node info. -;;; -(defun fasl-dump-component (component code-vector code-length - node-vector nodes-length - fixups file) - (declare (type component component) (type unsigned-byte length) - (list fixups) (type fasl-file file)) - - (dump-fop 'lisp::fop-verify-empty-stack file) - (dump-fop 'lisp::fop-verify-table-size file) - (quick-dump-number (fasl-file-table-free file) 4 file) - - (let ((code-handle (dump-code-object component code-vector code-length - node-vector nodes-length file)) - (2comp (component-info component))) - (dump-fixups code-handle fixups file) - (dump-fop 'lisp::fop-verify-empty-stack file) - - (dolist (entry (ir2-component-entries 2comp)) - (let ((entry-handle (dump-one-entry entry code-handle file))) - (setf (gethash entry (fasl-file-entry-table file)) entry-handle) - - (let ((old (gethash entry (fasl-file-patch-table file)))) - (when old - (dolist (patch old) - (alter-code-object (car patch) (cdr patch) entry-handle file)) - (remhash entry (fasl-file-patch-table file))))))) - - (assert (zerop (hash-table-count (fasl-file-patch-table file)))) - - (undefined-value)) - - -;;; FASL-DUMP-TOP-LEVEL-LAMBDA-CALL -- Interface -;;; -;;; Dump a FOP-FUNCALL to call an already dumped top-level lambda at load -;;; time. -;;; -(defun fasl-dump-top-level-lambda-call (fun file) - (declare (type clambda fun) (type fasl-file file)) - (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file)))) - (assert handle) - (dump-push handle file) - (dump-fop 'lisp::fop-funcall-for-effect file) - (dump-byte 0 file)) - (undefined-value)) - - -;;; FASL-DUMP-SOURCE-INFO -- Interface -;;; -;;; Compute the correct list of DEBUG-SOURCE structures and backpatch all of -;;; the dumped DEBUG-INFO structures. We clear the FASL-FILE-DEBUG-INFO, -;;; so that subsequent components with different source info may be dumped. -;;; -(defun fasl-dump-source-info (info file) - (declare (type source-info info) (type fasl-file file)) - (let ((res (debug-source-for-info info))) - (dump-object res file) - (let ((res-handle (dump-pop file))) - (dolist (info-handle (fasl-file-debug-info file)) - (dump-push res-handle file) - (dump-fop 'lisp::fop-svset file) - (quick-dump-number info-handle 4 file) - (quick-dump-number 2 4 file)))) - - (setf (fasl-file-debug-info file) ()) - (undefined-value)) - - -;;;; Main entries to object dumping: - -;;; Dump-Non-Immediate-Object -- Internal -;;; -;;; This function deals with dumping objects that are complex enough so that -;;; we want to cache them in the table, rather than repeatedly dumping them. -;;; If the object is in the EQ-TABLE, then we push it, otherwise, we do a type -;;; dispatch to a type specific dumping function. The type specific branches -;;; do any appropriate EQUAL-TABLE check and table entry. -;;; -;;; When we go to dump the object, we enter it in the CIRCULARITY-TABLE. -;;; -(defun dump-non-immediate-object (x file) - (let ((index (gethash x (fasl-file-eq-table file)))) - (cond ((and index (not *cold-load-dump*)) - (dump-push index file)) - (t - (typecase x - (symbol (dump-symbol x file)) - (list - (unless (equal-check-table x file) - (dump-list x file) - (equal-save-object x file))) - (vector - (cond ((stringp x) - (unless (equal-check-table x file) - (dump-string x file) - (equal-save-object x file))) - ((subtypep (array-element-type x) - '(unsigned-byte 32)) - (dump-i-vector x file) - (eq-save-object x file)) - (t - (dump-vector x file) - (eq-save-object x file)))) - (array - (dump-array x file) - (eq-save-object x file)) - (number - (unless (equal-check-table x file) - (etypecase x - (ratio (dump-ratio x file)) - (complex (dump-complex x file)) - (long-float (dump-long-float x file)) - (integer (dump-integer x file))) - (equal-save-object x file))) -#| - (compiled-function - (dump-function x file) - (eq-save-object x file)) -|# - (t - (compiler-error - "This object cannot be dumped into a fasl file:~% ~S" - x)))))) - - (undefined-value)) - - -;;; Sub-Dump-Object -- Internal -;;; -;;; Dump an object of any type by dispatching to the correct type-specific -;;; dumping function. We pick off immediate objects, symbols and and magic -;;; lists here. Other objects are handled by Dump-Non-Immediate-Object. -;;; -;;; This is the function used for recursive calls to the fasl dumper. We don't -;;; worry about creating circularities here, since it is assumed that there is -;;; a top-level call to Dump-Object. -;;; -(defun sub-dump-object (x file) - (cond ((listp x) - (cond ((null x) (dump-fop 'lisp::fop-empty-list file)) - #| - ((eq (car x) '%eval-at-load-time) (load-time-eval x)) - |# - (t - (dump-non-immediate-object x file)))) - ((symbolp x) - (if (eq x t) - (dump-fop 'lisp::fop-truth file) - (dump-non-immediate-object x file))) - ((fixnump x) (dump-integer x file)) - ((characterp x) (dump-character x file)) - ((typep x 'short-float) (dump-short-float x file)) -#| Probably a bug to ever dump a trap object... - ((lisp::trap-object-p x) - (dump-fop 'lisp::fop-misc-trap file)) -|# - (t - (dump-non-immediate-object x file)))) - - -;;; Dump-Circularities -- Internal -;;; -;;; Dump stuff to backpatch already dumped objects. Infos is the list of -;;; Circularity structures describing what to do. The patching FOPs take the -;;; value to store on the stack. We compute this value by fetching the -;;; enclosing object from the table, and then CDR'ing it if necessary. -;;; -(defun dump-circularities (infos file) - (let ((table (fasl-file-eq-table file))) - (dolist (info infos) - (let* ((value (circularity-value info)) - (enclosing (circularity-enclosing-object info))) - (dump-push (gethash enclosing table) file) - (unless (eq enclosing value) - (do ((current enclosing (cdr current)) - (i 0 (1+ i))) - ((eq current value) - (dump-fop 'lisp::fop-nthcdr file) - (quick-dump-number i 4 file))))) - - (dump-fop (case (circularity-type info) - (:rplaca 'lisp::fop-rplaca) - (:rplacd 'lisp::fop-rplacd) - (:svset 'lisp::fop-svset)) - file) - (quick-dump-number (gethash (circularity-object info) table) 4 file) - (quick-dump-number (circularity-index info) 4 file)))) - - -;;; Dump-Object -- Interface -;;; -;;; Set up stuff for circularity detection, then dump an object. All shared -;;; and circular structure will be exactly preserved within a single call to -;;; Dump-Object. Sharing between objects dumped by separate calls is only -;;; preserved when convenient. -;;; -;;; We peek at the objec type so that we only pay the circular detection -;;; overhead on types of objects that might be circular. -;;; -(defun dump-object (x file) - (if (or (arrayp x) (consp x)) - (let ((*circularities-detected* ()) - (circ (fasl-file-circularity-table file))) - (clrhash circ) - (sub-dump-object x file) - (when *circularities-detected* - (dump-circularities *circularities-detected* file) - (clrhash circ))) - (sub-dump-object x file))) - - -#| -;;; Load-Time-Eval -- Internal -;;; -;;; This guy deals with the magical %Eval-At-Load-Time marker that -;;; #, turns into when the *compiler-is-reading* and a fasl file is being -;;; written. -;;; -(defun load-time-eval (x file) - (when *compile-to-lisp* - (compiler-error "#,~S in a bad place." (third x))) - (assemble-one-lambda (cadr x)) - (dump-fop 'lisp::fop-funcall file) - (dump-byte 0 file)) -|# - -;;;; Number Dumping: - -;;; Dump a ratio - -(defun dump-ratio (x file) - (sub-dump-object (numerator x) file) - (sub-dump-object (denominator x) file) - (dump-fop 'lisp::fop-ratio file)) - -;;; Or a complex... - -(defun dump-complex (x file) - (sub-dump-object (realpart x) file) - (sub-dump-object (imagpart x) file) - (dump-fop 'lisp::fop-complex file)) - -;;; Dump an integer. - -(defun dump-integer (n file) - (let* ((bytes (compute-bytes n))) - (cond ((= bytes 1) - (dump-fop 'lisp::fop-byte-integer file) - (dump-byte (logand #xFF n) file)) - ((< bytes 5) - (dump-fop 'lisp::fop-word-integer file) - (quick-dump-number n 4 file)) - ((< bytes 256) - (dump-fop 'lisp::fop-small-integer file) - (dump-byte bytes file) - (quick-dump-number n bytes file)) - (t (dump-fop 'lisp::fop-integer file) - (quick-dump-number bytes 4 file) - (quick-dump-number n bytes file))))) - -;;; 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 file) - (multiple-value-bind (f exponent sign) (decode-float x) - (let ((mantissa (truncate (scale-float (* f sign) (float-precision f))))) - (dump-fop 'lisp::fop-float file) - (dump-byte (1+ (integer-length exponent)) file) - (quick-dump-number exponent (compute-bytes exponent) file) - (dump-byte (1+ (integer-length mantissa)) file) - (quick-dump-number mantissa (compute-bytes mantissa) file)))) - -#| -(defun dump-single-float (x file) - (multiple-value-bind (f exponent sign) (decode-float x) - (let ((mantissa (truncate (scale-float (* f sign) (float-precision f))))) - (dump-fop 'lisp::fop-float file) - (dump-byte (1+ (integer-length exponent)) file) - (dump-byte exponent file) - (dump-byte (1+ (integer-length mantissa)) file) - (quick-dump-number mantissa (compute-bytes mantissa) file)))) -|# -;;; 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 file) - (multiple-value-bind (f exponent sign) (decode-float x) - (let ((mantissa (truncate (scale-float (* f sign) (float-precision f))))) - (dump-fop 'lisp::fop-float file) - (dump-byte (1+ (integer-length exponent)) file) - (quick-dump-number exponent (compute-bytes exponent) file) - (dump-byte (1+ (integer-length mantissa)) file) - (quick-dump-number mantissa (compute-bytes mantissa) file)))) - - -;;;; Symbol Dumping: - -;;; Dump-Package -- Internal -;;; -;;; Return the table index of Pkg, adding the package to the table if -;;; necessary. During cold load, we read the string as a normal string so that -;;; we can do the package lookup at cold load time. -;;; -(defun dump-package (pkg file) - (cond ((cdr (assoc pkg (fasl-file-packages file)))) - (t - (unless *cold-load-dump* - (dump-fop 'lisp::fop-normal-load file)) - (dump-string (package-name pkg) file) - (dump-fop 'lisp::fop-package file) - (unless *cold-load-dump* - (dump-fop 'lisp::fop-maybe-cold-load file)) - (let ((entry (dump-pop file))) - (push (cons pkg entry) (fasl-file-packages file)) - entry)))) - - -;;; Dump-Symbol -- Internal -;;; -;;; If we get here, it is assumed that the symbol isn't in the table, but we -;;; are responsible for putting it there when appropriate. To avoid too much -;;; special-casing, we always push the symbol in the table, but don't record -;;; that we have done so if *Cold-Load-Dump* is true. -;;; -(defun dump-symbol (s file) - (let* ((pname (symbol-name s)) - (pname-length (length pname)) - (pkg (symbol-package s))) - - (cond ((null pkg) - (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save - lisp::fop-uninterned-symbol-save file)) - ((eq pkg *package*) - (dump-fop* pname-length lisp::fop-small-symbol-save - lisp::fop-symbol-save file)) - ((eq pkg ext:*lisp-package*) - (dump-fop* pname-length lisp::fop-lisp-small-symbol-save - lisp::fop-lisp-symbol-save file)) - ((eq pkg ext:*keyword-package*) - (dump-fop* pname-length lisp::fop-keyword-small-symbol-save - lisp::fop-keyword-symbol-save file)) - ((< pname-length 256) - (dump-fop* (dump-package pkg file) - lisp::fop-small-symbol-in-byte-package-save - lisp::fop-small-symbol-in-package-save file) - (dump-byte pname-length file)) - (t - (dump-fop* (dump-package pkg file) - lisp::fop-symbol-in-byte-package-save - lisp::fop-symbol-in-package-save file) - (quick-dump-number pname-length 4 file))) - - (write-string pname (fasl-file-stream file)) - - (unless *cold-load-dump* - (setf (gethash s (fasl-file-eq-table file)) (fasl-file-table-free file))) - - (incf (fasl-file-table-free file))) - - (undefined-value)) - - -;;; Dumper for lists. - -;;; Dump-List -- Internal -;;; -;;; Dump a list, setting up patching information when there are -;;; circularities. We scan down the list, checking for CDR and CAR -;;; circularities. -;;; -;;; If there is a CDR circularity, we terminate the list with NIL and make a -;;; Circularity notation for the CDR of the previous cons. -;;; -;;; If there is no CDR circularity, then we mark the current cons and check for -;;; a CAR circularity. When there is a CAR circularity, we make the CAR NIL -;;; initially, arranging for the current cons to be patched later. -;;; -;;; Otherwise, we recursively call the dumper to dump the current element. -;;; -;;; Marking of the conses is inhibited when *cold-load-dump* is true. This -;;; inhibits all circularity detection. -;;; -(defun dump-list (list file) - (assert (and list - (not (gethash list (fasl-file-circularity-table file))))) - (do* ((l list (cdr l)) - (n 0 (1+ n)) - (circ (fasl-file-circularity-table file))) - ((atom l) - (cond ((null l) - (terminate-undotted-list n file)) - (t - (sub-dump-object l file) - (terminate-dotted-list n file)))) - - (let ((ref (gethash l circ))) - (when ref - (push (make-circularity :type :rplacd :object list :index (1- n) - :value l :enclosing-object ref) - *circularities-detected*) - (terminate-undotted-list n file) - (return))) - - (unless *cold-load-dump* - (setf (gethash l circ) list)) - - (let* ((obj (car l)) - (ref (gethash obj circ))) - (cond (ref - (push (make-circularity :type :rplaca :object list :index n - :value obj :enclosing-object ref) - *circularities-detected*) - (sub-dump-object nil file)) - (t - (sub-dump-object obj file)))))) - - -(defun terminate-dotted-list (n file) - (case n - (1 (dump-fop 'lisp::fop-list*-1 file)) - (2 (dump-fop 'lisp::fop-list*-2 file)) - (3 (dump-fop 'lisp::fop-list*-3 file)) - (4 (dump-fop 'lisp::fop-list*-4 file)) - (5 (dump-fop 'lisp::fop-list*-5 file)) - (6 (dump-fop 'lisp::fop-list*-6 file)) - (7 (dump-fop 'lisp::fop-list*-7 file)) - (8 (dump-fop 'lisp::fop-list*-8 file)) - (T (do ((nn n (- nn 255))) - ((< nn 256) - (dump-fop 'lisp::fop-list* file) - (dump-byte nn file)) - (dump-fop 'lisp::fop-list* file) - (dump-byte 255 file))))) - -;;; If N > 255, must build list with one list operator, then list* operators. - -(defun terminate-undotted-list (n file) - (case n - (1 (dump-fop 'lisp::fop-list-1 file)) - (2 (dump-fop 'lisp::fop-list-2 file)) - (3 (dump-fop 'lisp::fop-list-3 file)) - (4 (dump-fop 'lisp::fop-list-4 file)) - (5 (dump-fop 'lisp::fop-list-5 file)) - (6 (dump-fop 'lisp::fop-list-6 file)) - (7 (dump-fop 'lisp::fop-list-7 file)) - (8 (dump-fop 'lisp::fop-list-8 file)) - (T (cond ((< n 256) - (dump-fop 'lisp::fop-list file) - (dump-byte n file)) - (t (dump-fop 'lisp::fop-list file) - (dump-byte 255 file) - (do ((nn (- n 255) (- nn 255))) - ((< nn 256) - (dump-fop 'lisp::fop-list* file) - (dump-byte nn file)) - (dump-fop 'lisp::fop-list* file) - (dump-byte 255 file))))))) - -;;;; Array dumping: - -;;; Named G-vectors get their subtype field set at load time. - -(defun dump-vector (obj file) - (cond ((and (simple-vector-p obj) - (= (%primitive get-vector-subtype obj) - %g-vector-structure-subtype)) - (normal-dump-vector obj file) - (dump-fop 'lisp::fop-structure file)) - (t - (normal-dump-vector obj file)))) - -(defun normal-dump-vector (v file) - (note-potential-circularity v file) - (do ((index 0 (1+ index)) - (length (length v)) - (circ (fasl-file-circularity-table file))) - ((= index length) - (dump-fop* length lisp::fop-small-vector lisp::fop-vector file)) - (let* ((obj (aref v index)) - (ref (gethash obj circ))) - (cond (ref - (push (make-circularity :type :svset :object v :index index - :value obj :enclosing-object ref) - *circularities-detected*) - (sub-dump-object nil file)) - (t - (sub-dump-object obj file)))))) - -;;; Dump a string. - -(defun dump-string (s file) - (let ((length (length s))) - (dump-fop* length lisp::fop-small-string lisp::fop-string file) - (dotimes (i length) - (dump-byte (char-code (char s i)) file)))) - -;;; 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 file) - (unless (zerop (%primitive header-ref array %array-displacement-slot)) - (compiler-error - "Attempt to dump an array with a displacement, you lose big.")) - (let ((rank (array-rank array))) - (dotimes (i rank) - (dump-integer (array-dimension array i) file)) - (sub-dump-object (%primitive header-ref array %array-data-slot) file) - (dump-fop 'lisp::fop-array file) - (quick-dump-number rank 4 file))) - - -;;; DUMP-I-VECTOR -- Internal -;;; -;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size -;;; must be a directly supported I-vector element size, with no extra bits. -;;; -;;; If a byte vector, or if the native and target byte orderings are the same, -;;; then just write the bits. Otherwise, dispatch off of the target byte order -;;; and write the vector one element at a time. -;;; -(defun dump-i-vector (vec file) - (let* ((vec (if #+new-compiler (array-header-p vec) - #-new-compiler (%primitive complex-array-p vec) - (coerce vec 'simple-array) - vec)) - (ac (%primitive get-vector-access-code vec)) - (len (length vec)) - (size (ash 1 ac)) - (bytes (ash (+ (ash len ac) 7) -3))) - - (dump-fop 'lisp::fop-int-vector file) - (quick-dump-number len 4 file) - (dump-byte size file) - (cond ((or (eq target-byte-order native-byte-order) - (= size 8)) - (dotimes (i bytes) - (dump-byte (%primitive typed-vref 3 vec i) file))) - ((> size 8) - (ecase target-byte-order - (:little-endian - (dotimes (i len) - (let ((int (aref vec i))) - (quick-dump-number int (ash size -3) file)))) - (:big-endian - (dotimes (i len) - (let ((int (aref vec i))) - (do ((shift (- 8 size) (+ shift 8))) - ((plusp shift)) - (dump-byte (logand (ash int shift) #xFF) file))))))) - (t - (macrolet ((frob (initial step done) - `(let ((shift ,initial) - (byte 0)) - (dotimes (i len) - (let ((int (aref vec i))) - (setq byte (logior byte (ash int shift))) - (,step shift size)) - (when ,done - (dump-byte byte file) - (setq shift ,initial byte 0))) - (unless (= shift ,initial) (dump-byte byte file))))) - (ecase target-byte-order - (:little-endian - (frob 0 incf (= shift 8))) - (:big-endian - (let ((initial-shift (- 8 size))) - (frob initial-shift decf (minusp shift)))))))))) - - -;;; Dump a character. - -(defun dump-character (ch file) - (cond - ((string-char-p ch) - (dump-fop 'lisp::fop-short-character file) - (dump-byte (char-code ch) file)) - (t - (dump-fop 'lisp::fop-character file) - (dump-byte (char-code ch) file) - (dump-byte (char-bits ch) file) - (dump-byte (char-font ch) file)))) diff --git a/compiler/old-rt/fop.lisp b/compiler/old-rt/fop.lisp deleted file mode 100644 index 07a75553f2fb2827a2d60eca501fd9bcfe93ced7..0000000000000000000000000000000000000000 --- a/compiler/old-rt/fop.lisp +++ /dev/null @@ -1,14 +0,0 @@ -;;; -;;; Define new FOPs for bootstrapping... - -(in-package 'lisp) - -(eval-when (compile load eval) - - (clone-fop (fop-alter-code 140) (fop-byte-alter-code 141) - ) - - (define-fop (fop-function-entry 142) - ) - -); Eval-When (Compile load Eval) diff --git a/compiler/old-rt/genesis.lisp b/compiler/old-rt/genesis.lisp deleted file mode 100644 index cff8a12d8735722309eb5633272065ba3cf0c6f3..0000000000000000000000000000000000000000 --- a/compiler/old-rt/genesis.lisp +++ /dev/null @@ -1,1574 +0,0 @@ -;;; -*- Package: Lisp; Log: C.Log -*- - -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Core image builder for Spice Lisp. -;;; Written by Skef Wholey. Package hackery courtesy of Rob MacLachlan. -;;; -;;; We gobble up FASL files, building a virtual memory image in a collection -;;; of blocks in system table space. When we're done and wish to write out the -;;; file, we allocate a block large enough to hold the contents of the memory -;;; image, and twiddle the page map to map the parts of the image consecutively -;;; into this large block, which we then write out as a file. -;;; - -(in-package "LISP") - -;;; Hack version that accepts NFASL file type... - -#-new-compiler -(defun load (filename &key ((:verbose *load-verbose*) *load-verbose*) - ((:print *load-print-stuff*) *load-print-stuff*) - (if-does-not-exist :error)) - "Loads the file named by Filename into the Lisp environment. See manual - for details." - (let ((*package* *package*)) - (if (streamp filename) - (if (equal (stream-element-type filename) '(unsigned-byte 8)) - (fasload filename) - (sloload filename)) - (let* ((pn (merge-pathnames (pathname filename) - *default-pathname-defaults*)) - (tn (probe-file pn))) - (cond - (tn - (if (or (string-equal (pathname-type tn) "fasl") - (string-equal (pathname-type tn) "nfasl")) - (with-open-file (file tn - :direction :input - :element-type '(unsigned-byte 8)) - (fasload file)) - (with-open-file (file tn :direction :input) - (sloload file))) - t) - ((pathname-type pn) - (let ((stream (open pn :direction :input - :if-does-not-exist if-does-not-exist))) - (when stream - (sloload stream) - (close stream) - t))) - (t - (let* ((srcn (make-pathname :type "lisp" :defaults pn)) - (src (probe-file srcn)) - (objn (make-pathname :type "fasl" :defaults pn)) - (obj (probe-file objn))) - (cond - (obj - (cond ((and src (> (file-write-date src) - (file-write-date obj))) - (case *load-if-source-newer* - (:load-object - (warn "Loading object file ~A, which is~% ~ - older than the presumed source, ~A." - (namestring obj) - (namestring src)) - (load obj)) - (:load-source - (warn "Loading source file ~A, which is~% ~ - newer than the presumed object file, ~A." - (namestring src) - (namestring obj)) - (load src)) - (:compile - (compile-file (namestring src)) - (load obj)) - (:query - (if (y-or-n-p "Load source file ~A which is newer~% ~ - than presumed object file ~A? " - (namestring src) - (namestring obj)) - (load src) - (load obj))) - (T (error "*Load-if-source-newer* contains ~A which is not one of:~% ~ - :load-object, :load-source, :compile, or :query." - *load-if-source-newer*)))) - (T (load obj)))) - (t - (load srcn :if-does-not-exist if-does-not-exist)))))))))) - - -(eval-when (compile load eval) - (defconstant type-shift 11) - (defconstant type-space-shift 9) - (defconstant type-space-byte (byte 7 9)) - (defconstant high-data-byte (byte 11 16)) - (defconstant high-data-mask 511) - (defconstant space-right-shift -9) -) - -(defvar *external-references* () - "List of reference frobs made by assembler routines that have been cold loaded.") - -(defvar machine-code-buffer - (make-array 2048 :element-type '(unsigned-byte 8)) - "Buffer for machine code for genesis of the Romp") - -(defconstant cold-i-vector-header-size 8 - "Size of an i-vector.") - -(defvar *cold-map-file* nil) -(defvar *defined-functions* nil) - -;;; Head of list of functions to be called when the Lisp starts up. -;;; -(defvar current-init-functions-cons) - - -;;; True if we are in the cold loader. Used by FOP-MAYBE-COLD-LOAD in -;;; the normal loader. -;;; -(proclaim '(special *in-cold-load*)) - - -;;; Memory accessing. - -;;; The virtual address space is divided into 128 pieces. - -(defparameter number-of-spaces 512 "Number of pointer-type spaces.") - -;;; The initial size of spaces will be one megabyte. If we need more than this, -;;; the following constant will have to be changed. - -(defparameter space-size (ash 1 21) "Number of bytes in each space.") - -;;; Each space is represented as a structure containing the address of its -;;; data in system space and the number of bytes used so far in it. - -(defstruct (space (:print-function print-a-space)) - address - real-address - free-pointer) - -(defun print-a-space (space stream depth) - depth - (write-string "#<SPACE, address = " stream) - (prin1 (sap-int (space-address space)) stream) - (write-char #\> stream)) - -;;; The type codes: - -(eval-when (compile load eval) - (defparameter +-fixnum-ltype 0) - (defparameter gc-forward-ltype 1) - (defparameter trap-ltype 4) - (defparameter bignum-ltype 5) - (defparameter ratio-ltype 6) - (defparameter complex-ltype 7) - (defparameter short-float-low-ltype 8) - (defparameter short-float-high-ltype 9) - (defparameter short-float-4bit-ltype 4) - (defparameter long-float-ltype 10) - (defparameter string-ltype 11) - (defparameter bit-vector-ltype 12) - (defparameter integer-vector-ltype 13) - (defparameter code-ltype 14) - (defparameter general-vector-ltype 15) - (defparameter array-ltype 16) - (defparameter function-ltype 17) - (defparameter symbol-ltype 18) - (defparameter list-ltype 19) - (defparameter control-stack-ltype 20) - (defparameter binding-stack-ltype 21) - (defparameter assembly-code-ltype 0) - - (defparameter string-char-ltype 26) - (defparameter bitsy-char-ltype 27) - (defparameter values-marker-ltype 28) - (defparameter catch-all-ltype 29) - (defparameter --fixnum-ltype 31) - (defparameter smallest-ltype +-fixnum-ltype) - (defparameter largest-ltype binding-stack-ltype) - (defparameter first-pointer-ltype 0)) - -(defmacro space-to-highbits (space) - `(ash ,space 9)) - -;;; The subspace codes: - -(defparameter dynamic-space 0) -(defparameter static-space 2) -(defparameter read-only-space 3) - -;;; Lispobj-Shift is the number of places we shift left to convert an index -;;; into an offset we can do address calculation with. - -(defconstant lispobj-shift 2) - -;;; Lispobj-Size is the number of glomps it takes to represent a Lisp object. - -(defconstant lispobj-size 4) - -;;; Macros to construct space numbers from a type and subspace. - -(defmacro dynamic (type) - `(logior (ash ,type 2) dynamic-space)) - -(defmacro static (type) - `(logior (ash ,type 2) static-space)) - -(defmacro read-only (type) - `(logior (ash ,type 2) read-only-space)) - -;;; Used-Spaces is a list of the spaces we allocate stuff for. - -(defparameter used-spaces - (list (dynamic code-ltype) - (dynamic bit-vector-ltype) - (dynamic integer-vector-ltype) - (dynamic string-ltype) - (dynamic bignum-ltype) - (static bignum-ltype) - (dynamic long-float-ltype) - (dynamic complex-ltype) - (dynamic ratio-ltype) - (dynamic general-vector-ltype) - (dynamic function-ltype) - (dynamic array-ltype) - (dynamic symbol-ltype) - (static symbol-ltype) - (dynamic list-ltype) - (static list-ltype) - (dynamic trap-ltype) - (dynamic assembly-code-ltype))) - -;;; Memory is a vector of these spaces. If a space is non-existent or is not -;;; used in cold load, NIL will be stored in the corresponding location instead -;;; of a space structure. - -(defvar memory (make-array number-of-spaces)) - -(defparameter code-space (dynamic assembly-code-ltype)) - -(defvar *genesis-memory-initialized* nil) - -;;; In order to allow access of symbols that weren't dumped in normal load, we -;;; maintain a back-translation from handles to symbols. This is a vector of -;;; vectors, indexed first by space code, and then by the offset (in units of -;;; symbol size). -;;; -(defvar *space-to-symbol-array*) - - -(defun initialize-memory () - (unless *genesis-memory-initialized* - (setq *genesis-memory-initialized* t) - (setq *space-to-symbol-array* (make-array 4)) - (setf (svref *space-to-symbol-array* 0) (make-array 10000)) - (setf (svref *space-to-symbol-array* 1) nil) - (setf (svref *space-to-symbol-array* 2) (make-array 5000)) - (setf (svref *space-to-symbol-array* 3) (make-array 500)) - (do* ((spaces used-spaces (cdr spaces)) - (space (car spaces) (car spaces))) - ((null spaces)) - (declare (list spaces)) - (multiple-value-bind (hunk addr) - (get-valid-hunk - (if (= space (dynamic code-ltype)) - (ash space-size 3) - space-size)) - (setf (svref memory space) - (make-space :address (int-sap hunk) - :real-address (int-sap addr) - :free-pointer (cons (if (eq space code-space) - clc::romp-code-base - (space-to-highbits space)) - 0))))))) - - -(defun get-valid-hunk (size) - (let ((addr (do-validate 0 size -1))) - (values addr addr))) - -(defun initialize-spaces () - (do* ((spaces used-spaces (cdr spaces)) - (space (car spaces) (car spaces))) - ((null spaces)) - (declare (list spaces)) - (setf (space-free-pointer (svref memory space)) - (cons (if (eq space code-space) - clc::romp-code-base - (space-to-highbits space)) 0)))) - -;;; Since Spice Lisp objects are 32-bits wide, and Spice Lisp integers are only -;;; 28-bits wide, we use the following scheme to represent the 32-bit objects -;;; in the image being built. In the core image builder, we can have a handle -;;; on a 32-bit object, which is a cons of two 16-bit numbers, the high order -;;; word in the CAR, and the low order word in the CDR. We provide some macros -;;; to manipulate these handles. - -(defmacro handle-on (high low) - `(cons ,high ,low)) - -(defun handle-beyond (handle offset) - (let ((new (+ (cdr handle) offset))) - (if (> new 65535) - (cons (+ (car handle) (ash new -16)) (logand new 65535)) - (cons (car handle) new)))) - -(defun bump-handle (handle offset) - (let ((new (+ (cdr handle) offset))) - (if (> new 65535) - (setf (car handle) (+ (car handle) (ash new -16)) - (cdr handle) (logand new 65535)) - (setf (cdr handle) new)))) - -(defun copy-handle (handle) - (cons (car handle) (cdr handle))) - -(defun handle< (han1 han2) - (or (< (car han1) (car han2)) - (and (= (car han1) (car han2)) - (< (cdr han1) (cdr han2))))) - -;;; Handle-Offset is used to map a virtual address into an offset into the table -;;; of 16-bit words we're building of objects of that type. Blah blah. - -;;; The LDM is a byte-addressed machine, so we shift the offset bits right 1. - -(defun handle-offset (handle) - (logior (ash (logand (car handle) high-data-mask) 15) (ash (cdr handle) -1))) - -(defun handle-type (handle) - (ash (car handle) (- type-shift))) - -(defmacro build-object (type bits) - `(let ((bits ,bits)) - (handle-on (logior (ash ,type type-shift) (ldb high-data-byte bits)) - (logand bits 65535)))) - -(defmacro build-sub-object (type subtype bits) - `(let ((bits ,bits)) - (handle-on (logior (ash ,type type-shift) - (logior (ash ,subtype 8) (ldb (byte 8 16) bits))) - (logand bits 65535)))) - -(defparameter trap-handle - (handle-on (space-to-highbits (dynamic trap-ltype)) 0000) - "Handle on the trap object.") - -(defparameter nil-handle (handle-on (space-to-highbits (static list-ltype)) 0000) - "Handle on Nil.") - -(defparameter zero-handle (handle-on 0 0)) - -#| -(defmacro byte-swap-16 (object) - `(let ((obj ,object)) - (logior (ash (logand obj #xFF) 8) - (logand (ash obj -8) #xFF)))) -|# - -(defmacro byte-swap-16 (object) object) - -;;; Write-Memory writes the Object (identified by a handle) into the given -;;; Address (also a handle). - -(defun write-memory (address object) - (let* ((high (car address)) - (low (cdr address)) - (space-number (ldb type-space-byte high)) - (offset (handle-offset address)) - (space (svref memory space-number))) - (when (eq space-number code-space) - (decf offset (ash clc::romp-code-base 15))) - (if space - (if (handle< address (space-free-pointer space)) - (let ((saddress (space-address space))) - (%primitive 16bit-system-set saddress offset - (byte-swap-16 (car object))) - (%primitive 16bit-system-set saddress (1+ offset) - (byte-swap-16 (cdr object)))) - (error "No object at ~S,,~S has been allocated." high low)) - (error "The space for address ~S,,~S does not exist." high low)))) - -;;; Read-Memory returns a handle to an object read from the given Address. - -(defun read-memory (address) - (let* ((high (car address)) - (low (cdr address)) - (space-number (ldb type-space-byte high)) - (offset (handle-offset address)) - (space (svref memory space-number))) - (when (eq space-number code-space) - (decf offset (ash clc::romp-code-base 15))) - (if space - (if (handle< address (space-free-pointer space)) - (let ((saddress (space-address space))) - (handle-on (byte-swap-16 (%primitive 16bit-system-ref - saddress offset)) - (byte-swap-16 (%primitive 16bit-system-ref - saddress (1+ offset))))) - (error "No object at ~S,,~S has been allocated." high low)) - (error "The space for address ~S,,~S does not exist." high low)))) - -;;; Read-Indexed is used to read from g-vector-like things. - -(defun read-indexed (address index) - (read-memory (handle-beyond address - (+ (ash index lispobj-shift) lispobj-size)))) - -;;; Write-Indexed is used to write into g-vector-like things. - -(defun write-indexed (address index value) - (write-memory (handle-beyond address (+ (ash index lispobj-shift) lispobj-size)) - value)) - -;;; Allocating primitive objects. - -;;; Allocate-Boxed-Object returns a handle to an object allocated in the -;;; space of the given Space-Number with the given Length. No header words are -;;; initialized, and the Length should include the length of the header. The -;;; free pointer for the Space is incremented and (on the Perq) quadword alligned. - -(defun allocate-boxed-object (space-number length) - (let ((space (svref memory space-number))) - (if space - (let* ((start (space-free-pointer space)) - (result (copy-handle start))) - (bump-handle start (ash length lispobj-shift)) - result) - (error "Space ~S does not exist." space-number)))) - -;;; Allocate-Unboxed-Object returns a handle to an object allocated in the -;;; space of the given Space-Number with the given Byte-Size and Length in -;;; bytes of that size. The 2 unboxed object header words are initialized -;;; with the optional Subtype code. - -(defun allocate-unboxed-object (space-number byte-size size subtype) - (let ((space (svref memory space-number))) - (if space - (let* ((start (space-free-pointer space)) - (result (copy-handle start)) - (length (+ 2 (ceiling size (/ 32 byte-size))))) - (bump-handle start (ash length lispobj-shift)) - (write-memory result - (build-sub-object +-fixnum-ltype subtype length)) - (write-memory (handle-beyond result lispobj-size) - (handle-on (logior (ash (access-type byte-size) 12) - (logand (ash size -16) #xFFF)) - (logand size #xFFFF))) - result) - (error "Space ~S does not exist." space-number)))) - -;;; Access-Type returns the I-Vector access type for a given Byte-Size. - -(defun access-type (byte-size) - (let ((access-type (cdr (assoc byte-size '((1 . 0) (2 . 1) (4 . 2) - (8 . 3) (16 . 4) (32 . 5) - (64 . 6) (128 . 7)))))) - (if access-type access-type - (error "Invalid I-Vector byte size, ~S." byte-size)))) - -;;; I-Vector-To-Core copies the contents of the given unboxed thing into -;;; the virtual memory image in the space with the give Space-Number, returning -;;; a handle to the new object. - -(defun i-vector-to-core (space-number byte-size size subtype thing) - (let* ((dest (allocate-unboxed-object space-number byte-size size subtype)) - (byte-count (ash (ceiling size (/ 16 byte-size)) 1)) - (offset (handle-offset dest)) - (dest-byte-addr (+ offset offset 8))) - (%primitive byte-blt - thing 0 - (space-address (svref memory space-number)) - dest-byte-addr (+ dest-byte-addr byte-count)) - dest)) - -;;; Dump a dynamic string. - -(defun string-to-core (string) - (i-vector-to-core (dynamic string-ltype) 8 (length string) 0 string)) - -;;; Dump a bignum. -(defun bignum-to-core (n) - (let* ((words (1+ (ceiling (1+ (integer-length n)) 32))) - (handle (allocate-boxed-object (dynamic bignum-ltype) words))) - (declare (fixnum words)) - (write-memory handle (build-sub-object (if (< n 0) --fixnum-ltype - +-fixnum-ltype) - 0 words)) - (do ((i 1 (1+ i)) - (half 2 (+ half 2))) - ((= i words) - handle) - (declare (fixnum i half)) - (write-memory (handle-beyond handle (* lispobj-size i)) - (handle-on (%primitive 16bit-system-ref n half) - (%primitive 16bit-system-ref n (1+ half))))))) - -;;; Number-To-Core copies the given number to the virtual memory image, -;;; returning a handle to it. - -(defun number-to-core (thing) - (typecase thing - (fixnum (handle-on (logand (ash thing -16) 65535) - (logand thing 65535))) - (bignum (bignum-to-core thing)) - (short-float - (let ((fthing (%primitive make-fixnum thing))) - (handle-on (logior (ash short-float-4bit-ltype 12) - (%primitive logldb 12 16 fthing) - (if (< thing 0) #x800 0)) - (logand fthing #xFFFF)))) - (long-float - (let* ((handle (allocate-boxed-object (dynamic long-float-ltype) 3))) - (write-memory handle zero-handle) - (write-memory (handle-beyond handle lispobj-size) - (handle-on (%primitive 16bit-system-ref thing 2) - (%primitive 16bit-system-ref thing 3))) - (write-memory (handle-beyond handle (+ lispobj-size lispobj-size)) - (handle-on (%primitive 16bit-system-ref thing 4) - (%primitive 16bit-system-ref thing 5))) - handle)) - (t (error "~S isn't a cold-loadable number at all!" thing)))) - -;;; Allocate-G-Vector allocates a G-Vector of the given Length and writes -;;; the header word. - -(defun allocate-g-vector (space-number length &optional (subtype 0)) - (let* ((length (+ length 1)) - (dest (allocate-boxed-object space-number length))) - (write-memory dest (build-sub-object +-fixnum-ltype subtype length)) - dest)) - -;;; Cold-Set-Vector-Subtype frobs the subtype field of an already allocated -;;; G-Vector. - -(defun cold-set-vector-subtype (vector subtype) - (let ((handle (read-memory vector))) - (write-memory vector (build-sub-object +-fixnum-ltype subtype - (logior (logand high-data-mask - (car handle)) - (cdr handle)))) - vector)) - -;;; Allocate-Cons allocates a cons and fills it with the given stuff. - -(defun allocate-cons (space-number car cdr) - (let ((dest (allocate-boxed-object space-number 2))) - (write-memory dest car) - (write-memory (handle-beyond dest lispobj-size) cdr) - dest)) - -;;; Cold-Put -- Internal -;;; -;;; Add a property to a symbol in the core. Assumes it doesn't exist. -;;; -(defun cold-put (symbol indicator value) - (let ((plist-handle (handle-beyond symbol (* 2 lispobj-size)))) - (write-memory plist-handle - (allocate-cons - (dynamic list-ltype) indicator - (allocate-cons - (dynamic list-ltype) value - (read-memory plist-handle)))))) - -;;; Allocate-Symbol allocates a symbol and fills its print name cell and -;;; property list cell. - -(defparameter *cold-symbol-allocation-space* (dynamic symbol-ltype)) - -(defun allocate-symbol (name &optional (symbol nil defined)) - (declare (simple-string name)) - (let ((dest (allocate-boxed-object *cold-symbol-allocation-space* 5))) - (write-memory dest trap-handle) - (write-memory (handle-beyond dest lispobj-size) trap-handle) - (write-memory (handle-beyond dest (* 2 lispobj-size)) nil-handle) - (write-memory (handle-beyond dest (* 3 lispobj-size)) - (i-vector-to-core (dynamic string-ltype) 8 (length name) 0 name)) - (if defined - (add-symbol-to-handle-map dest symbol) - (write-memory (handle-beyond dest (* 4 lispobj-size)) nil-handle)) - dest)) - - -(defmacro cold-push (thing list) - "Generates code to push the Thing onto the given cold load List." - `(setq ,list (allocate-cons (dynamic list-ltype) ,thing ,list))) - - -;;;; Interning. - -;;; In order to avoid having to know about the package format, we -;;; build a data structure which we stick in *cold-symbols* that -;;; holds all interned symbols along with info about their packages. -;;; The data structure is a list of lists in the following format: -;;; (<make-package-arglist> -;;; <internal-symbols> -;;; <external-symbols> -;;; <imported-internal-symbols> -;;; <imported-external-symbols> -;;; <shadowing-symbols>) -;;; -;;; Package manipulation forms are dumped magically by the compiler -;;; so that we can eval them at Genesis time. An eval-for-effect fop -;;; is used, surrounded by fops that switch the fop table to the hot -;;; fop table and back. -;;; - -;;; An alist from packages to the list of symbols in that package to be -;;; dumped. -;;; -(defvar *cold-packages*) - - -;;; Symbols known to the microcode that must be allocated before all others. -;;; DON'T CHANGE the order of these UNLESS you know what you are doing. -(defparameter initial-symbols - '(t %sp-internal-apply %sp-internal-error %sp-software-interrupt-handler - %sp-internal-throw-tag %initial-function %link-table-header - current-allocation-space %sp-bignum/fixnum %sp-bignum/bignum - %sp-fixnum/bignum %sp-abs-ratio %sp-abs-complex %sp-negate-ratio - %sp-negate-complex %sp-integer+ratio %sp-ratio+ratio %sp-complex+number - %sp-number+complex %sp-complex+complex %sp-1+ratio %sp-1+complex - %sp-integer-ratio %sp-ratio-integer %sp-ratio-ratio %sp-complex-number - %sp-number-complex %sp-complex-complex %sp-1-ratio %sp-1-complex - %sp-integer*ratio %sp-ratio*ratio %sp-number*complex %sp-complex*number - %sp-complex*complex %sp-integer/ratio %sp-ratio/integer %sp-ratio/ratio - %sp-number/complex %sp-complex/number %sp-complex/complex - %sp-integer-truncate-ratio %sp-ratio-truncate-integer - %sp-ratio-truncate-ratio %sp-number-truncate-complex - %sp-complex-truncate-number %sp-complex-truncate-complex maybe-gc - lisp-environment-list call-lisp-from-c lisp-command-line-list - *nameserverport* *ignore-floating-point-underflow* - %sp-sin-rational %sp-sin-short %sp-sin-long %sp-sin-complex - %sp-cos-rational %sp-cos-short %sp-cos-long %sp-cos-complex - %sp-tan-rational %sp-tan-short %sp-tan-long %sp-tan-complex - %sp-atan-rational %sp-atan-short %sp-atan-long %sp-atan-complex - %sp-exp-rational %sp-exp-short %sp-exp-long %sp-exp-complex - %sp-log-rational %sp-log-short %sp-log-long %sp-log-complex - lisp::%sp-sqrt-rational lisp::%sp-sqrt-short - lisp::%sp-sqrt-long lisp::%sp-sqrt-complex - eval::*eval-stack-top* - )) - - -;;; Cold-Intern -- Internal -;;; -;;; Return a handle on an interned symbol. If necessary allocate -;;; the symbol and record which package the symbol was referenced in. -;;; When we allocate the symbol, make sure we record a reference to -;;; the symbol in the home package so that the package gets set. -;;; -(defun cold-intern (symbol package) - (let ((cold-info (get symbol 'cold-info))) - (unless cold-info - (cond ((eq (symbol-package symbol) package) - (let ((handle (allocate-symbol (symbol-name symbol) symbol))) - (when (eq package *keyword-package*) (write-memory handle handle)) - (setq cold-info (setf (get symbol 'cold-info) (cons handle nil))))) - (t - (cold-intern symbol (symbol-package symbol)) - (setq cold-info (get symbol 'cold-info))))) - (unless (memq package (cdr cold-info)) - (push package (cdr cold-info)) - (push symbol (cdr (or (assq package *cold-packages*) - (car (push (list package) *cold-packages*)))))) - (car cold-info))) - - -(defun add-symbol-to-handle-map (handle symbol) - (let* ((space (logand (ash (car handle) space-right-shift) #x3)) - (index (truncate (logior (ash (logand (car handle) #x007F) 16) - (logand (cdr handle) #xFFFF)) - 20)) - (vector (svref *space-to-symbol-array* space))) - (setf (svref vector index) symbol))) - - -(defun find-cold-symbol (handle) - (let* ((space (logand (ash (car handle) space-right-shift) #x3)) - (index (truncate (logior (ash (logand (car handle) #x007F) 16) - (logand (cdr handle) #xFFFF)) - 20)) - (vector (svref *space-to-symbol-array* space))) - (svref vector index))) - - -;;; Initialize-Symbols -- Internal -;;; -;;; Since the initial symbols must be allocated before we can intern -;;; anything else, we intern those here. We also set the values of T and Nil. -;;; -(defun initialize-symbols () - "Initilizes the cold load symbol-hacking data structures." - ;; Special case NIL. - (let ((*cold-symbol-allocation-space* (static list-ltype)) - (nil-fcn-handle (handle-beyond nil-handle lispobj-size))) - (cold-intern nil *lisp-package*) - (write-memory nil-fcn-handle nil-handle)) - (let ((*cold-symbol-allocation-space* (static symbol-ltype))) - (dolist (symbol initial-symbols) - (cold-intern symbol *lisp-package*))) - (write-memory nil-handle nil-handle) - (write-memory (cold-intern t *lisp-package*) (cold-intern t *lisp-package*))) - - -;;; Finish-Symbols -- Internal -;;; -;;; Scan over all the symbols referenced in each package in *cold-packages* -;;; making the apropriate entry in the *initial-symbols* data structure to -;;; intern the thing. -;;; -(defun finish-symbols () - (let ((res nil-handle)) - (dolist (cpkg *cold-packages*) - (let* ((pkg (car cpkg)) - (shadows (package-shadowing-symbols pkg))) - (let ((internal nil-handle) - (external nil-handle) - (imported-internal nil-handle) - (imported-external nil-handle) - (shadowing nil-handle)) - (dolist (sym (cdr cpkg)) - (let ((handle (car (get sym 'cold-info)))) - (multiple-value-bind (found where) - (find-symbol (symbol-name sym) pkg) - (unless (and where (eq found sym)) - (error "Symbol ~S is not available in ~S." sym pkg)) - (when (memq sym shadows) - (cold-push handle shadowing)) - (ecase where - (:internal - (if (eq (symbol-package sym) pkg) - (cold-push handle internal) - (cold-push handle imported-internal))) - (:external - (if (eq (symbol-package sym) pkg) - (cold-push handle external) - (cold-push handle imported-external))) - (:inherited))))) - (let ((r nil-handle)) - (cold-push shadowing r) - (cold-push imported-external r) - (cold-push imported-internal r) - (cold-push external r) - (cold-push internal r) - (cold-push (make-make-package-args pkg) r) - (cold-push r res))))) - - (write-memory (cold-intern '*initial-symbols* *lisp-package*) res))) - - -;;; Make-Make-Package-Args -- Internal -;;; -;;; Make a cold list that can be used as the arglist to make-package to -;;; make a similar package. -;;; -(defun make-make-package-args (package) - (let* ((use nil-handle) - (nicknames nil-handle) - (res nil-handle)) - (dolist (u (package-use-list package)) - (when (assoc u *cold-packages*) - (cold-push (string-to-core (package-name u)) use))) - (dolist (n (package-nicknames package)) - (cold-push (string-to-core n) nicknames)) - (cold-push (number-to-core (truncate (internal-symbol-count package) 0.8)) res) - (cold-push (cold-intern :internal-symbols *keyword-package*) res) - (cold-push (number-to-core (truncate (external-symbol-count package) 0.8)) res) - (cold-push (cold-intern :external-symbols *keyword-package*) res) - - (cold-push nicknames res) - (cold-push (cold-intern :nicknames *keyword-package*) res) - - (cold-push use res) - (cold-push (cold-intern :use *keyword-package*) res) - - (cold-push (string-to-core (package-name package)) res) - res)) - - -;;;; Static bignum initialization: - -;;; Initialize-bignums sets up the least-positive bignum and least-negative -;;; bignum in static bignum space. - -(defun initialize-bignums () - (let ((lpb-handle (allocate-boxed-object (static bignum-ltype) 2)) - (lnb-handle (allocate-boxed-object (static bignum-ltype) 2)) - (least-positive-bignum (1+ most-positive-fixnum)) - (least-negative-bignum (1- most-negative-fixnum))) - (write-memory lpb-handle (build-sub-object +-fixnum-ltype 0 2)) - (write-memory (handle-beyond lpb-handle 4) - (handle-on (ash least-positive-bignum -16) - (logand least-positive-bignum #xFFFF))) - (write-memory lnb-handle (build-sub-object --fixnum-ltype 0 2)) - (write-memory (handle-beyond lnb-handle 4) - (handle-on (ash least-negative-bignum -16) - (logand least-negative-bignum #xFFFF))))) - - -;;; Initialize-Trap-Object -- Internal -;;; -;;; Allocate the trap object and initialize it so that calls to it jump to -;;; the TRAP-ERROR-HANDLER routine. -;;; -(defun initialize-trap-object () - (let ((obj (allocate-g-vector (dynamic trap-ltype) 3)) - (addr (miscop-address 'clc::trap-error-handler))) - (write-indexed obj %function-code-slot - (handle-on (ldb (byte 16 16) addr) - (ldb (byte 16 0) addr))) - (write-indexed obj %function-offset-slot (number-to-core 0)))) - - -;;; Reading FASL files. - -(defvar cold-fop-functions (replace (make-array 256) fop-functions) - "FOP functions for cold loading.") - -(defvar normal-fop-functions) - -;;; Define-Cold-FOP -- Internal -;;; -;;; Like Define-FOP in load, but looks up the code, and stores into -;;; the cold-fop-functions vector. -;;; -(defmacro define-cold-fop ((name &optional (pushp t)) &rest forms) - (let ((fname (concat-pnames 'cold- name)) - (code (get name 'fop-code))) - (unless code (error "~S is not a defined fop." name)) - `(progn - (defun ,fname () - ,(if (eq pushp :nope) - `(progn ,@forms) - `(with-fop-stack ,pushp ,@forms))) - (setf (svref cold-fop-functions ,code) #',fname)))) - -;;; Clone-Cold-FOP -- Internal -;;; -;;; Clone a couple of cold fops. -;;; -(defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms) - `(progn - (macrolet ((clone-arg () '(read-arg 4))) - (define-cold-fop (,name ,pushp) ,@forms)) - (macrolet ((clone-arg () '(read-arg 1))) - (define-cold-fop (,small-name ,pushp) ,@forms)))) - -;;; Not-Cold-Fop -- Internal -;;; -;;; Define a fop to be undefined in cold load. -;;; -(defmacro not-cold-fop (name) - `(define-cold-fop (,name) - (error "~S is not supported in cold load." ',name))) - -;;;; Random cold fops... - -(define-cold-fop (fop-misc-trap) trap-handle) - -(define-cold-fop (fop-character) - (build-object bitsy-char-ltype (read-arg 3))) -(define-cold-fop (fop-short-character) - (build-object string-char-ltype (read-arg 1))) - -(define-cold-fop (fop-empty-list) nil-handle) -(define-cold-fop (fop-truth) (cold-intern 't *lisp-package*)) - -(define-cold-fop (fop-normal-load :nope) - (setq fop-functions normal-fop-functions)) - -(define-cold-fop (fop-maybe-cold-load :nope)) - -(define-cold-fop (fop-structure) - (cold-set-vector-subtype (pop-stack) 1)) - - -;;;; Loading symbols... - -;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns -;;; that symbol in the given Package. -;;; -(defun cold-load-symbol (size package) - (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 size) - (cold-intern (intern string package) package))) - -(clone-cold-fop (fop-symbol-save) - (fop-small-symbol-save) - (push-table (cold-load-symbol (clone-arg) *package*))) - -(macrolet ((frob (name pname-len package-len) - `(define-cold-fop (,name) - (let ((index (read-arg ,package-len))) - (push-table - (cold-load-symbol (read-arg ,pname-len) - (svref *current-fop-table* index))))))) - (frob fop-symbol-in-package-save 4 4) - (frob fop-small-symbol-in-package-save 1 4) - (frob fop-symbol-in-byte-package-save 4 1) - (frob fop-small-symbol-in-byte-package-save 1 1)) - -(clone-cold-fop (fop-lisp-symbol-save) - (fop-lisp-small-symbol-save) - (push-table (cold-load-symbol (clone-arg) *lisp-package*))) - -(clone-cold-fop (fop-keyword-symbol-save) - (fop-keyword-small-symbol-save) - (push-table (cold-load-symbol (clone-arg) *keyword-package*))) - -(clone-cold-fop (fop-uninterned-symbol-save) - (fop-uninterned-small-symbol-save) - (let* ((size (clone-arg)) - (name (make-string size))) - (read-n-bytes *fasl-file* name 0 size) - (let ((symbol (allocate-symbol name))) - (push-table symbol)))) - - -;;; Loading lists... - -;;; Cold-Stack-List makes a list of the top Length things on the Fop-Stack. -;;; The last cdr of the list is set to Last. - -(defmacro cold-stack-list (length last) - `(do* ((index ,length (1- index)) - (result ,last (allocate-cons (dynamic list-ltype) (pop-stack) result))) - ((= index 0) result) - (declare (fixnum index)))) - -(define-cold-fop (fop-list) - (cold-stack-list (read-arg 1) nil-handle)) -(define-cold-fop (fop-list*) - (cold-stack-list (read-arg 1) (pop-stack))) -(define-cold-fop (fop-list-1) - (cold-stack-list 1 nil-handle)) -(define-cold-fop (fop-list-2) - (cold-stack-list 2 nil-handle)) -(define-cold-fop (fop-list-3) - (cold-stack-list 3 nil-handle)) -(define-cold-fop (fop-list-4) - (cold-stack-list 4 nil-handle)) -(define-cold-fop (fop-list-5) - (cold-stack-list 5 nil-handle)) -(define-cold-fop (fop-list-6) - (cold-stack-list 6 nil-handle)) -(define-cold-fop (fop-list-7) - (cold-stack-list 7 nil-handle)) -(define-cold-fop (fop-list-8) - (cold-stack-list 8 nil-handle)) -(define-cold-fop (fop-list*-1) - (cold-stack-list 1 (pop-stack))) -(define-cold-fop (fop-list*-2) - (cold-stack-list 2 (pop-stack))) -(define-cold-fop (fop-list*-3) - (cold-stack-list 3 (pop-stack))) -(define-cold-fop (fop-list*-4) - (cold-stack-list 4 (pop-stack))) -(define-cold-fop (fop-list*-5) - (cold-stack-list 5 (pop-stack))) -(define-cold-fop (fop-list*-6) - (cold-stack-list 6 (pop-stack))) -(define-cold-fop (fop-list*-7) - (cold-stack-list 7 (pop-stack))) -(define-cold-fop (fop-list*-8) - (cold-stack-list 8 (pop-stack))) - - -;;;; Loading vectors... - -(clone-cold-fop (fop-string) - (fop-small-string) - (let* ((len (clone-arg)) - (string (make-string len))) - (read-n-bytes *fasl-file* string 0 len) - (i-vector-to-core (dynamic string-ltype) 8 len 0 string))) - -(clone-cold-fop (fop-vector) - (fop-small-vector) - (let ((size (clone-arg))) - (do ((index (1- size) (1- index)) - (result (allocate-g-vector (dynamic general-vector-ltype) size))) - ((< index 0) result) - (declare (fixnum index)) - (write-indexed result index (pop-stack))))) - - -(define-cold-fop (fop-int-vector) - (prepare-for-fast-read-byte *fasl-file* - (let* ((len (fast-read-u-integer 4)) - (size (fast-read-byte)) - (ac (1- (integer-length size))) - (res (%primitive alloc-i-vector len ac))) - (done-with-fast-read-byte) - (unless (and (<= ac 5) (= size (ash 1 ac))) - (error "Losing element size ~S." size)) - (read-n-bytes *fasl-file* res 0 (ash (+ (ash len ac) 7) -3)) - (i-vector-to-core (if (typep res 'simple-bit-vector) - (dynamic bit-vector-ltype) - (dynamic integer-vector-ltype)) - size len 0 res)))) - - -(not-cold-fop fop-uniform-vector) -(not-cold-fop fop-small-uniform-vector) -(not-cold-fop fop-uniform-int-vector) -(not-cold-fop fop-array) - - -;;;; Fixing up circularities. - -(define-cold-fop (fop-rplaca nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) - (write-memory (cold-nthcdr idx obj) (pop-stack)))) - -(define-cold-fop (fop-rplacd nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) - (write-memory (handle-beyond (cold-nthcdr idx obj) lispobj-size) - (pop-stack)))) - -(define-cold-fop (fop-svset nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) - (write-indexed obj idx (pop-stack)))) - -(define-cold-fop (fop-nthcdr t) - (cold-nthcdr (read-arg 4) (pop-stack))) - - -(defun cold-nthcdr (index obj) - (do ((i 0 (1+ i)) - (r obj)) - ((>= i index) r) - (setq r (read-memory (handle-beyond r lispobj-size))))) - - -;;;; Calling (or not calling). - -(not-cold-fop fop-alter) -(not-cold-fop fop-eval) -(not-cold-fop fop-eval-for-effect) -(not-cold-fop fop-funcall) - -(define-cold-fop (fop-funcall-for-effect nil) - (if (= (read-arg 1) 0) - (cold-push (pop-stack) current-init-functions-cons) - (error "Can't FOP-FUNCALL random stuff in cold load."))) - - - -;;; Loading assembler code: - - -(defun maybe-grow-machine-code-buffer (length) - (if (> length (length machine-code-buffer)) - (setq machine-code-buffer - (make-array (logand (+ length 2047) (lognot 2047)) - :element-type '(unsigned-byte 8))))) - - -;;; Define-Cold-Labels -- Internal -;;; -;;; Stick the addresses of some labels on the plists. We do this -;;; in the core being built as well so that the normal loader can -;;; load assembler code. %Loaded-Address is a byte offset. -;;; -(defun define-cold-labels (start external-labels) - (let ((prop (cold-intern '%loaded-address *lisp-package*))) - (dolist (lab external-labels) - (let ((addr (+ start (cdr lab))) - (name (car lab))) - (setf (get name '%address) addr) - (cold-put (cold-intern name (symbol-package name)) - prop (number-to-core (ash addr 1))))))) - - -(defun miscop-address (name) - (ash (or (get name '%address) - (error "Miscop ~A doesn't seem to be defined." name)) - 1)) - -(define-cold-fop (fop-assembler-routine t) - (let* ((code-start (copy-handle - (space-free-pointer - (svref memory code-space)))) - (start (- (ash (handle-offset code-start) 1) - (ash clc::romp-code-base 16))) - (code-length (read-arg 4))) - (declare (fixnum code-length)) - ;; Zap the code into the core image: - (maybe-grow-machine-code-buffer code-length) - (read-n-bytes *fasl-file* machine-code-buffer 0 code-length) - (%primitive byte-blt machine-code-buffer 0 - (space-real-address (svref memory code-space)) - start (+ start code-length)) - (bump-handle (space-free-pointer (svref memory code-space)) code-length) - code-start)) - - -;;; Fixup-Assembler-Code -- Internal -;;; -;;; Since we now always access miscops through their name, we don't need to -;;; discriminate between assembler routines and miscops. So we have one -;;; function that does both kinds of fixups. -;;; -(defun fixup-assembler-code () - (with-fop-stack nil - (let* ((external-references (pop-stack)) - (external-labels (pop-stack)) - (name (pop-stack)) - (code-start (pop-stack)) - (start (handle-offset code-start))) - (define-cold-labels start external-labels) - (push (cons name external-references) *external-references*)))) - -(define-cold-fop (fop-fixup-miscop-routine :nope) - (fixup-assembler-code)) - -(define-cold-fop (fop-fixup-assembler-routine :nope) - (fixup-assembler-code)) - -(not-cold-fop fop-fixup-user-miscop-routine) - - -;;; Loading functions... - - -;;; Cold-Load-Function loads a code object (constant pool and code vector). -;;; Box-Num objects are popped off the stack for the boxed storage section, -;;; then Code-Length bytes are read in and made into the code vector. - -(defun cold-load-function (box-num code-length) - (declare (fixnum box-num code-length)) - (with-fop-stack t - (let ((function (allocate-g-vector (dynamic function-ltype) box-num)) - (code (%primitive alloc-i-vector code-length 3))) - ;; - ;; Pop boxed stuff, storing it in the allocated function object. - (do ((index (1- box-num) (1- index))) - ((minusp index)) - (write-indexed function index (pop-stack))) - ;; - ;; Set Code object subtype. - (cold-set-vector-subtype function %function-constants-subtype) - ;; - ;; Read in code, dump it, and store code pointer. - (read-n-bytes *fasl-file* code 0 code-length) - (let ((code-handle (i-vector-to-core (dynamic code-ltype) - 8 code-length 1 code))) - (write-indexed function %function-code-slot code-handle)) - function))) - -(define-cold-fop (fop-code :nope) - (if (eql *current-code-format* c::target-fasl-code-format) - (cold-load-function (read-arg 4) (read-arg 4)) - (error "~S: Bad code format for this implementation" - *current-code-format*))) - -(define-cold-fop (fop-small-code :nope) - (if (eql *current-code-format* c::target-fasl-code-format) - (cold-load-function (read-arg 1) (read-arg 2)) - (error "~S: Bad code format for this implementation" - *current-code-format*))) - - -;;; Kind of like Cold-Load-Function, except that we set the Code and Constants -;;; slots from the Constants object that is our first stack argument. The -;;; subtype is set to the second stack argument. -;;; -;;; We make an entry in the *Defined-Functions* for benefit of the map file. -;;; If the entry's Name is a symbol (meaning the function is a DEFUN), then -;;; dump that name, otherwise we say UNKNOWN-FUNCTION. -;;; -(define-cold-fop (fop-function-entry) - (let* ((box-num (read-arg 1)) - (function (allocate-g-vector (dynamic function-ltype) box-num))) - ;; - ;; Pop boxed things, storing them in the allocated function object. - (do ((index (1- box-num) (1- index))) - ((minusp index)) - (write-indexed function index (pop-stack))) - ;; - ;; Set the subtype of the function object. The subtype should be a small - ;; fixnum, so its value is the cdr of the handle... - (cold-set-vector-subtype function (cdr (pop-stack))) - - (let* ((constants-handle (pop-stack)) - (code-handle (read-indexed constants-handle %function-code-slot)) - (offset-handle (read-indexed function %function-offset-slot)) - (offset (logior (ash (car offset-handle) 16) (cdr offset-handle)))) - (write-indexed function %function-code-slot code-handle) - (write-indexed function %function-entry-constants-slot constants-handle) - - (let ((name-handle (read-indexed function %function-name-slot))) - (push (list (if (= (handle-type name-handle) symbol-ltype) - (find-cold-symbol name-handle) - 'unknown-function) - function - (handle-beyond code-handle offset)) - *defined-functions*))) - - function)) - - -(define-cold-fop (fop-fset nil) - (let ((function (pop-stack))) - (write-memory (handle-beyond (pop-stack) lispobj-size) function))) - - -(define-cold-fop (fop-user-miscop-fixup) - (let* ((name (find-cold-symbol (pop-stack))) - (function-object (pop-stack)) - (offset (read-arg 4)) - (miscop-address (miscop-address name)) - (addr-high (ldb (byte 16 16) miscop-address)) - (addr-low (ldb (byte 16 0) miscop-address)) - (code-handle (read-indexed function-object %function-code-slot))) - - (bump-handle code-handle (+ cold-i-vector-header-size offset)) - (let ((inst (read-memory code-handle))) - (write-memory code-handle - (handle-on (logior (logand (car inst) #xFF00) - (logand addr-high #xFF)) - addr-low))) - function-object)) - - -;;; Modify a slot in a Constants object. -;;; -(clone-cold-fop (fop-alter-code nil) (fop-byte-alter-code) - (let ((value (pop-stack)) - (code (pop-stack)) - (index (clone-arg))) - (write-indexed code index value))) - - -;;; Loading numbers... - -(define-cold-fop (fop-float :nope) - (fop-float) - (with-fop-stack t (number-to-core (pop-stack)))) - -(clone-cold-fop (fop-integer) - (fop-small-integer) - (number-to-core (load-s-integer (clone-arg)))) - -(define-cold-fop (fop-word-integer) - (number-to-core (load-s-integer 4))) - -(define-cold-fop (fop-byte-integer) - (let ((byte (load-s-integer 1))) - (build-object (if (< byte 0) --fixnum-ltype +-fixnum-ltype) byte))) - -(define-cold-fop (fop-ratio) - (let ((dest (allocate-boxed-object (dynamic ratio-ltype) 2)) - (den (pop-stack))) - (write-memory dest (pop-stack)) - (write-memory (handle-beyond dest lispobj-size) den) - dest)) - -(define-cold-fop (fop-complex) - (let ((dest (allocate-boxed-object (dynamic complex-ltype) 2)) - (im (pop-stack))) - (write-memory dest (pop-stack)) - (write-memory (handle-beyond dest lispobj-size) im) - dest)) - - - -;;; Resolving all the assembler routines' references. - -(defmacro create-assembler-handle (address) - `(handle-on (logior (ash ,assembly-code-ltype type-shift) - (logand (ash ,address -15) high-data-mask)) - (logand (ash ,address 1) #xFFFF))) - -;;; Recall that the format of a reference is (How Label Location), -;;; where How is one of JI, BI, BA, or L, Label is the label's name, and -;;; Location is the location of the reference. These things are stored on -;;; the list *external-references* as (Name . References), where Name is -;;; the name of the referencing routine, and References is a list of references -;;; in the above format. - -(defun resolve-references () - (dolist (reflist *external-references*) - (let ((address (get (car reflist) '%address))) - (dolist (refs (cdr reflist)) - (let ((how (car refs)) - (label (get (cadr refs) '%address)) - (location (caddr refs))) - (if (null label) - (format t "~A references ~A, which has not been defined.~%" - (car reflist) (cadr refs)) - (ecase how - (clc::ji - (resolve-ji-reference (car reflist) address (cadr refs) - label location)) - (clc::bi - (resolve-bi-reference (car reflist) address (cadr refs) - label location)) - (clc::ba - (resolve-ba-reference (car reflist) address (cadr refs) - label location))))))))) - - -(defun resolve-ji-reference (routine-name address label-name label location) - (let* ((handle (handle-beyond (create-assembler-handle address) - (ash location 1))) - (offset (- label (handle-offset handle))) - (inst (read-memory handle))) - (if (or (< offset #x-80) (> offset #x7F)) - (format t "Offset #X~X out of JI range for ~A to reference ~A.~%" - offset routine-name label-name)) - (write-memory handle - (handle-on (logior (logand (car inst) #xFF00) - (logand offset #xFF)) - (cdr inst))))) - -(defun resolve-bi-reference (routine-name address label-name label location) - (let* ((handle (handle-beyond (create-assembler-handle address) - (ash location 1))) - (offset (- label (handle-offset handle))) - (inst (read-memory handle))) - (if (or (< offset #x-80000) (> offset #x7FFFF)) - (format t "Offset #X~X out of BI range for ~A to reference ~A.~%" - offset routine-name label-name)) - (write-memory handle (handle-on (logior (logand (car inst) #xFFF0) - (logand (ash offset -16) #xF)) - (logand offset #xFFFF))))) - -(defun resolve-ba-reference (routine-name address label-name label location) - (let* ((handle (handle-beyond (create-assembler-handle address) - (ash location 1))) - (l-handle (create-assembler-handle label)) - (l-addr (ash (logior (ash (car l-handle) 15) (cdr l-handle)) -1)) - (inst (read-memory handle))) - (if (> l-addr #xFFFFFF) - (format t "Address #X~X is out of BA range for ~A to reference ~A.~%" - l-addr routine-name label-name)) - (write-memory handle - (handle-on (logior (logand (car inst) #xFF00) - (logand (ash l-addr -16) #xFF)) - (logand l-addr #xFFFF))))) - -;;; Writing the core file. - -;;; We assume here that the directory will fit on one page, make the -;;; alloc table be the first data page, and make the escape routine table -;;; the second data page. So the length of the file is the length of all -;;; of the stuff in the used spaces plus 3 pages. - -(eval-when (compile load eval) - (defconstant offset-to-page-shift -13) - (defconstant page-to-offset-shift 13) - (defconstant process-page-shift -4) - (defconstant extra-pages 1) - (defconstant alloc-table-data-start 4096) - (defconstant alloc-table-page (ash (ash clc::romp-data-base 16) offset-to-page-shift)) - (defconstant interrupt-routine-offset (+ 2048 132)) -) - -(defun write-initial-core-file (name) - (format t "[Building Initial Core File in file ~S: ~%" name) - (force-output t) - (let ((data-pages (1+ extra-pages)) - (nonempty-spaces 0) - (byte-length 0)) - (do ((spaces used-spaces (cdr spaces))) - ((null spaces) (setq byte-length (ash data-pages page-to-offset-shift))) - (let ((free (handle-offset - (space-free-pointer (svref memory (car spaces)))))) - (when (eq (car spaces) code-space) - (decf free (ash clc::romp-code-base 15))) - (when (> free 0) - (incf nonempty-spaces) - (incf data-pages (1+ (ash free (1+ offset-to-page-shift))))))) - (multiple-value-bind (hunk addr) (get-valid-hunk byte-length) - (setq hunk (int-sap hunk)) - (setq addr (int-sap addr)) - ;; Write the CORE file password. - (%primitive 16bit-system-set hunk 0 (byte-swap-16 #x+434F)) - (%primitive 16bit-system-set hunk 1 (byte-swap-16 #x+5245)) - ;; Write the directory header entry. - (%primitive 16bit-system-set hunk 2 0) - (%primitive 16bit-system-set hunk 3 (byte-swap-16 3841)) - (%primitive 16bit-system-set hunk 4 0) - (%primitive 16bit-system-set hunk 5 - (byte-swap-16 (+ 2 (* 3 (+ nonempty-spaces extra-pages))))) - ;; First, an entry for the alloc table. - (%primitive 16bit-system-set hunk 6 0) ; Data page - (%primitive 16bit-system-set hunk 7 0) - (%primitive 16bit-system-set hunk 8 - (byte-swap-16 (logand (ash alloc-table-page -16) #xFFFF))) - (%primitive 16bit-system-set hunk 9 - (byte-swap-16 (logand alloc-table-page #xFFFF))) - (%primitive 16bit-system-set hunk 10 0) - (%primitive 16bit-system-set hunk 11 (byte-swap-16 1)) ; Page count - ;; Construct the alloc table, with both free and clean pointers. - (do ((space (ash first-pointer-ltype 2) (1+ space))) - ((> space (+ (ash largest-ltype 2) 3))) - (let ((alloc-index (+ alloc-table-data-start (ash space 2)))) - (cond ((svref memory space) - (let ((free (space-free-pointer (svref memory space)))) - (when (eq space code-space) - (handle-on (- (car free) clc::romp-code-base) - (cdr free))) - (%primitive 16bit-system-set hunk alloc-index - (byte-swap-16 (car free))) - (%primitive 16bit-system-set hunk (+ alloc-index 1) - (byte-swap-16 (cdr free))) - (%primitive 16bit-system-set hunk (+ alloc-index 2) - (byte-swap-16 (ash space type-space-shift))) - (%primitive 16bit-system-set hunk (+ alloc-index 3) 0))) - (t - (%primitive 16bit-system-set hunk alloc-index - (byte-swap-16 (ash space type-space-shift))) - (%primitive 16bit-system-set hunk (+ alloc-index 1) 0) - (%primitive 16bit-system-set hunk (+ alloc-index 2) - (byte-swap-16 (ash space type-space-shift))) - (%primitive 16bit-system-set hunk (+ alloc-index 3) 0))))) - - (let ((index (+ alloc-table-data-start - (ash interrupt-routine-offset -1))) - (addr (miscop-address 'clc::interrupt-routine))) - (%primitive 16bit-system-set hunk index - (byte-swap-16 (ldb (byte 16 16) addr))) - (%primitive 16bit-system-set hunk (1+ index) - (byte-swap-16 (ldb (byte 16 0) addr)))) - - ;; Then, write entries for each space. - (do ((spaces used-spaces (cdr spaces)) - (index 12) - (data-page extra-pages)) - ((null spaces) - ;; Finally, the end of header code. - (%primitive 16bit-system-set hunk index 0) - (%primitive 16bit-system-set hunk (+ index 1) (byte-swap-16 3840)) - (%primitive 16bit-system-set hunk (+ index 2) 0) - (%primitive 16bit-system-set hunk (+ index 3) (byte-swap-16 2))) - (let* ((space (car spaces)) - (free (handle-offset - (space-free-pointer (svref memory space))))) - (if (> free 0) - (let ((page-count (1+ (ash free (1+ offset-to-page-shift)))) - (process-page (ash space process-page-shift)) - (process-page-low (ash (logand space (1- (ash 1 (- process-page-shift)))) - (+ 16 process-page-shift)))) - (when (eq space code-space) - (let ((ppage (ash (ash clc::romp-code-base 16) offset-to-page-shift))) - (setq process-page (ash ppage -16)) - (setq process-page-low (logand ppage #xFFFF))) - (decf page-count (ash (ash clc::romp-code-base 16) offset-to-page-shift))) - ;; Make the directory entry. - (%primitive 16bit-system-set hunk index 0) - (%primitive 16bit-system-set hunk (+ index 1) - (byte-swap-16 data-page)) - (%primitive 16bit-system-set hunk (+ index 2) - (byte-swap-16 process-page)) - (%primitive 16bit-system-set hunk (+ index 3) - (byte-swap-16 process-page-low)) - (%primitive 16bit-system-set hunk (+ index 4) 0) - (%primitive 16bit-system-set hunk (+ index 5) - (byte-swap-16 page-count)) - (format t " ~S page~:P, page ~S, from space #X~X.~%" - page-count (1+ data-page) space) - ;; Move the words into the file. - (%primitive byte-blt (space-real-address (svref memory space)) - 0 addr - (ash (1+ data-page) page-to-offset-shift) - (+ (ash (1+ data-page) page-to-offset-shift) - (ash page-count page-to-offset-shift))) - (incf data-page page-count) - (incf index 6))))) - (let ((name (predict-name name nil))) - (format t "Writing ~A.~%" name) - (multiple-value-bind (fd err) (mach:unix-creat name #o644) - (when (null fd) - (error "Open on ~A failed, unix error ~S." - name (mach:get-unix-error-msg err))) - (multiple-value-bind (res err) (mach:unix-write fd addr 0 byte-length) - (when (null res) - (error "Write of core file ~S failed, unix error ~S." - name (mach:get-unix-error-msg err)))) - (unless (eq (mach:unix-close fd) T) - (error "Close of core file ~S failed, unix error ~S." - name (mach:get-unix-error-msg err))))) - (write-line "Done!]") - t))) - - -;;; Top level. - - -(defun clean-up-genesis () - (when (boundp '*cold-packages*) - (dolist (p *cold-packages*) - (dolist (symbol (cdr p)) - (remprop symbol 'cold-info)))) - (setq *defined-functions* nil) - (setq *external-references* nil) - (setq *cold-packages* ()) - (setq *cold-map-file* nil) - (setq current-init-functions-cons nil-handle)) - - -(defun genesis (file-list core-name &optional map-file) - "Builds a kernel Lisp image from the .FASL files specified in the given - File-List and writes it to a file named by Core-Name." - (fresh-line) - (clean-up-genesis) - (when (eq map-file t) - (setq map-file (make-pathname :defaults core-name :type "map"))) - - (when map-file - (setq *cold-map-file* (open map-file :direction :output - :if-exists :supersede)) - (format *cold-map-file* "Map file for ~A:" core-name)) - (initialize-memory) - (initialize-spaces) - (initialize-symbols) - (initialize-bignums) - (dolist (file file-list) - (write-line file) - (let* ((normal-fop-functions fop-functions) - (fop-functions cold-fop-functions) - (*in-cold-load* t)) - (load file))) - (initialize-trap-object) - (finish-symbols) - (resolve-references) - (write-memory (cold-intern '*lisp-initialization-functions* *lisp-package*) - current-init-functions-cons) - (write-map-file) - (write-initial-core-file core-name)) - - -;;;; Writing the map file: - - -(defun write-map-file () - (when *cold-map-file* - (let* ((file *cold-map-file*) - (reflist *external-references*) - (*print-pretty* nil) - (*print-case* :upcase)) - (declare (stream file)) - (format file "~%~|Functions defined in core image:~%~%") - (dolist (info (nreverse *defined-functions*)) - (let ((name (first info)) - (funobj (second info)) - (code (third info))) - (format file "~X,,~4,'0X ~X,,~4,'0X ~S~%" - (car funobj) (cdr funobj) - (car code) (cdr code) - name))) - - (format file "~%~|Assembler routine locations:~%~%") - (let ((refs NIL)) - (dolist (ref reflist) (push (car ref) refs)) - (setq refs - (sort refs #'(lambda (x y) - (< (get x '%address) (get y '%address))))) - (dolist (ref refs) - (format file "~X ~50S~%" (ash (get ref '%address) 1) ref)))) - (close *cold-map-file*))) diff --git a/compiler/old-rt/memory.lisp b/compiler/old-rt/memory.lisp deleted file mode 100644 index 3459222b56bbd6fe33275eccbcabdb6d80a05925..0000000000000000000000000000000000000000 --- a/compiler/old-rt/memory.lisp +++ /dev/null @@ -1,147 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the RT definitions of some general purpose memory -;;; reference VOPs inherited by basic memory reference operations. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to -;;; be read or written is a property of the VOP used. Cell-Setf is similar to -;;; Cell-Set, but delivers the new value as the result. -;;; -(define-vop (cell-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:variant-vars offset) - (:policy :fast-safe) - (:generator 4 - (loadw value object offset))) -;;; -(define-vop (cell-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:variant-vars offset) - (:policy :fast-safe) - (:generator 4 - (storew value object offset))) -;;; -(define-vop (cell-setf) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg) - :target result)) - (:results (result :scs (descriptor-reg any-reg))) - (:variant-vars offset) - (:policy :fast-safe) - (:generator 4 - (storew value object offset) - (unless (location= value result) - (inst lr result value)))) - -;;; Define-Cell-Accessors -- Interface -;;; -;;; Define accessor VOPs for some cells in an object. If the operation name -;;; is NIL, then that operation isn't defined. If the translate function is -;;; null, then we don't define a translation. -;;; -(defmacro define-cell-accessors (offset ref-op ref-trans set-op set-trans) - `(progn - ,@(when ref-op - `((define-vop (,ref-op cell-ref) - (:variant ,offset) - ,@(when ref-trans - `((:translate ,ref-trans)))))) - ,@(when set-op - `((define-vop (,set-op cell-setf) - (:variant ,offset) - ,@(when set-trans - `((:translate ,set-trans)))))))) - - -;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the -;;; offset is constant at compile time, but varies for different uses. We add -;;; in the stardard g-vector overhead. -;;; -(define-vop (slot-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:info offset) - (:generator 4 - (load-slot value object offset))) -;;; -(define-vop (slot-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:info offset) - (:generator 4 - (store-slot value object offset))) - - - -;;;; Indexed references: - - -;;; Define-Indexer -- Internal -;;; -;;; Define some VOPs for indexed memory reference. Unless the index is -;;; constant, we must compute an intermediate result in a boxed temporary, -;;; since the RT doesn't have any indexed addressing modes. This means that GC -;;; has to adjust the "raw" pointer in Index-Temp by observing that Index-Temp -;;; points within Object-Temp. After we are done, we clear Index-Temp so that -;;; we don't raw pointers lying around. -;;; -(defmacro define-indexer (name write-p op shift) - `(define-vop (,name) - (:args (object :scs (descriptor-reg) :target object-temp) - (index :scs (any-reg descriptor-reg short-immediate - unsigned-immediate) - :target index-temp) - ,@(when write-p - '((value :scs (any-reg descriptor-reg) :target result)))) - (:results (,(if write-p 'result 'value) - :scs (any-reg descriptor-reg))) - (:variant-vars offset) - (:temporary (:scs (descriptor-reg) - :from (:argument 0)) - object-temp) - (:temporary (:scs (descriptor-reg) - :from (:argument 1)) - index-temp) - (:policy :fast-safe) - (:generator 5 - (sc-case index - ((short-immediate unsigned-immediate) - (,op value object (+ (tn-value index) offset))) - (t - (unless (location= object object-temp) - (inst lr object-temp object)) - (unless (location= index index-temp) - (inst lr index-temp index)) - - ,@(unless (zerop shift) - `((inst sli index-temp ,shift))) - - (inst a index-temp object-temp) - (,op value index-temp offset) - (loadi index-temp 0))) - - ,@(when write-p - `((unless (location= value result) - (inst lr result value))))))) - -(define-indexer word-index-ref nil loadw 2) -(define-indexer word-index-set t storew 2) -(define-indexer halfword-index-ref nil loadh 1) -(define-indexer signed-halfword-index-ref nil loadha 1) -(define-indexer halfword-index-set t storeha 1) -(define-indexer byte-index-ref nil loadc 0) -(define-indexer byte-index-set t storec 0) diff --git a/compiler/old-rt/miscop.lisp b/compiler/old-rt/miscop.lisp deleted file mode 100644 index 0ae46651270fe85c5a2fead46e02d175a2df15f4..0000000000000000000000000000000000000000 --- a/compiler/old-rt/miscop.lisp +++ /dev/null @@ -1,197 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; We have a few general-purpose VOPs that are used to implement all the -;;; miscop VOPs using the variant mechanism. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -(define-vop (miscop) - (:temporary (:sc any-reg :offset 0 - :from (:eval 0) :to (:eval 1)) - nl0) - (:temporary (:sc any-reg :offset 1 - :from (:eval 0) :to (:eval 1)) - a0) - (:temporary (:sc any-reg :offset 2 - :from (:eval 0) :to (:eval 1)) - nl1) - (:temporary (:sc any-reg :offset 3 - :from (:eval 0) :to (:eval 1)) - a1) - (:temporary (:sc any-reg :offset 4 - :from (:eval 0) :to (:eval 1)) - a3) - (:temporary (:sc any-reg :offset 5 - :from (:eval 0) :to (:eval 1)) - a2) - (:temporary (:sc any-reg :offset 15 - :from (:eval 0) :to (:eval 1)) - misc-pc) - (:note "miscop call") - (:variant-vars miscop-name) - (:vop-var vop) - (:save-p :compute-only) - (:policy :safe)) - -(eval-when (compile load eval) - (defconstant reg-arg-count 4) - (defconstant arg-names '(x y z arg3 arg4 arg5 arg6 arg7 arg8)) - (defconstant temp-names '(a0 a1 a2 a3 s3 s4 s5 s6 s7)) - (defconstant temp-offsets '(1 3 5 4 3 4 5 6 7)) - (defconstant result-names '(r r1 r2 r3 r4 r5 r6 r7 r8)) -); eval-when (compile load eval) - - -;;; Make-Miscop -- Internal -;;; -;;; Make a miscop with the specified numbers of arguments and results, -;;; conditional flag, etc. -;;; -(defmacro make-miscop (nargs nresults &key conditional) - (collect ((args) - (results) - (temps) - (arg-moves) - (result-moves)) - (let ((max-ops (max nargs nresults))) - (dotimes (i nargs) - (let ((arg (elt arg-names i)) - (temp (elt temp-names i))) - (args - `(,arg :target ,temp :scs (any-reg descriptor-reg))) - (arg-moves - (if (>= i reg-arg-count) - `(store-stack-tn ,temp ,arg) - `(unless (location= ,arg ,temp) - (inst lr ,temp ,arg)))))) - - (dotimes (i nresults) - (let ((result (elt result-names i)) - (temp (elt temp-names i))) - (results - `(,result :scs (any-reg descriptor-reg))) - (result-moves - (if (>= i reg-arg-count) - `(load-stack-tn ,result ,temp) - `(unless (location= ,result ,temp) - (inst lr ,result ,temp)))))) - - (dotimes (i (max nargs nresults)) - (temps - `(:temporary (:sc ,(if (>= i reg-arg-count) 'stack 'any-reg) - :offset ,(elt temp-offsets i) - :from ,(if (>= i nargs) '(:eval 0) `(:argument ,i)) - :to ,(if (>= i nresults) '(:eval 1) `(:result ,i)) - ,@(unless (>= i nresults) - `(:target ,(elt result-names i)))) - ,(elt temp-names i)))) - - `(define-vop (,(miscop-name nargs nresults conditional) miscop) - (:args ,@(args)) - ,@(unless conditional `((:results ,@(results)))) - ,@(temps) - ,@(when conditional - '((:conditional t) - (:variant-vars miscop-name condition) - (:info target not-p))) - (:ignore nl0 nl1 misc-pc - ,@(if (>= max-ops reg-arg-count) - () - (subseq temp-names max-ops reg-arg-count))) - (:generator 20 - ,@(arg-moves) - (inst miscop miscop-name) - (note-this-location vop :known-return) - ,@(result-moves) - ,@(when conditional - '((if not-p - (inst bnb condition target) - (inst bb condition target))))))))) - -(make-miscop 1 0 :conditional t) -(make-miscop 2 0 :conditional t) - -(make-miscop 0 0) -(make-miscop 1 0) -(make-miscop 2 0) -(make-miscop 3 0) -(make-miscop 4 0) - -(make-miscop 0 1) -(make-miscop 1 1) -(make-miscop 2 1) -(make-miscop 3 1) -(make-miscop 4 1) -(make-miscop 5 1) - -(make-miscop 0 2) -(make-miscop 1 2) -(make-miscop 2 2) -(make-miscop 3 2) -(make-miscop 4 2) -(make-miscop 5 2) - -(make-miscop 1 3) - -(define-vop (effectless-unaffected-one-arg-miscop one-arg-miscop) - (:effects) - (:affected)) - -(define-vop (effectless-unaffected-two-arg-miscop two-arg-miscop) - (:effects) - (:affected)) - -(define-vop (n-arg-miscop zero-arg-miscop) - (:args (passed-args :more t)) - (:ignore passed-args a1 a2 a3 nl1 misc-pc) - (:info nargs) - (:generator 40 - (inst miscopx miscop-name) - (inst cal nl0 zero-tn nargs) - (note-this-location vop :known-return) - (unless (location= r a0) - (inst lr r a0)))) - -(define-vop (n-arg-two-value-miscop zero-arg-two-value-miscop) - (:args (passed-args :more t)) - (:ignore passed-args a2 a3 nl1 misc-pc) - (:info nargs) - (:generator 40 - (inst miscopx miscop-name) - (inst cal nl0 zero-tn nargs) - (note-this-location vop :known-return) - (unless (location= r a0) - (inst lr r a0)) - (unless (location= r1 a1) - (inst lr r1 a1)))) - - -;;;; ILLEGAL-MOVE - -;;; This VOP is emitted when we attempt to do a move between incompatible -;;; primitive types. We signal an error, and ignore the result (which is -;;; specified only to terminate its lifetime.) -;;; -(define-vop (illegal-move three-arg-miscop) - (:args (x :scs (any-reg descriptor-reg) :target a1) - (y-type :scs (any-reg descriptor-reg) :target a2)) - (:variant-vars) - (:ignore r a3 nl0 nl1 misc-pc) - (:generator 666 - (loadi a0 clc::error-object-not-type) - (unless (location= x a1) - (inst lr a1 x)) - (unless (location= y-type a2) - (inst lr a2 y-type)) - (inst miscop 'clc::error2) - (note-this-location vop :internal-error))) diff --git a/compiler/old-rt/move.lisp b/compiler/old-rt/move.lisp deleted file mode 100644 index a57106bd69fe63ef265c743fa0e09abdef6e2170..0000000000000000000000000000000000000000 --- a/compiler/old-rt/move.lisp +++ /dev/null @@ -1,101 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the RT VM definition of operand loading/saving and -;;; the Move VOP. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; Move functions: - -(define-move-function (load-immediate 1) (node x y) - ((short-immediate unsigned-immediate immediate random-immediate) - (any-reg descriptor-reg)) - (let ((val (tn-value x))) - (etypecase val - (integer - (loadi y val)) - (null - (inst cau y zero-tn clc::nil-16)) - ((member t) - (inst cau y zero-tn clc::t-16))))) - -(define-move-function (load-string-char 1) (node x y) - ((immediate-string-char) (string-char-reg)) - (loadi y (char-code (tn-value x)))) - -(define-move-function (load-tagged-string-char 2) (node x y) - ((immediate-string-char) (any-reg descriptor-reg)) - (loadi y (char-code (tn-value x))) - (inst oiu y y (ash system:%string-char-type clc::type-shift-16))) - -(define-move-function (load-constant 5) (node x y) - ((constant) (any-reg descriptor-reg)) - (load-slot y env-tn (tn-offset x))) - -(define-move-function (load-stack 5) (node x y) - ((stack) (any-reg descriptor-reg) - (string-char-stack) (string-char-reg)) - (load-stack-tn y x)) - -(define-move-function (store-stack 5) (node x y) - ((any-reg descriptor-reg) (stack) - (string-char-reg) (string-char-stack)) - (store-stack-tn y x)) - - -;;;; Move and Move-Argument VOPs: - - -;;; The Move VOP is used for doing arbitrary moves when there is no -;;; type-specific move/coerce operation. -;;; -(define-vop (move) - (:args (x :target y - :scs (any-reg descriptor-reg) - :load-if (not (location= x y)))) - (:results (y :scs (any-reg descriptor-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (unless (location= x y) - (inst lr y x)))) - - -;;; Make Move the check VOP for T so that type check generation doesn't think -;;; it is a hairy type. This also allows checking of a few of the values in a -;;; continuation to fall out. -;;; -(primitive-type-vop move (:check) t) - - -;;; The Move-Argument VOP is used for moving descriptor values into another -;;; frame for argument or known value passing. -;;; -(define-vop (move-argument) - (:args (x :target y - :scs (any-reg descriptor-reg)) - (fp :scs (descriptor-reg) - :load-if (not (sc-is y any-reg descriptor-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - ((any-reg descriptor-reg) - (unless (location= x y) - (inst lr y x))) - (stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-argument :move-argument - (any-reg descriptor-reg) - (any-reg descriptor-reg)) diff --git a/compiler/old-rt/nlx.lisp b/compiler/old-rt/nlx.lisp deleted file mode 100644 index 93dacbfe2810cb06042364cc7df7acfac272ab8d..0000000000000000000000000000000000000000 --- a/compiler/old-rt/nlx.lisp +++ /dev/null @@ -1,221 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the definitions of VOPs used for non-local exit -;;; (throw, lexical exit, etc.) -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; MAKE-NLX-SP-TN -- Interface -;;; -;;; Make an environment-live stack TN for saving the SP for NLX entry. -;;; -(defun make-nlx-sp-tn (env) - (environment-live-tn - (make-representation-tn *any-primitive-type* stack-arg-scn) - env)) - - -;;; Save and restore dynamic environment. -;;; -;;; These VOPs are used in the reentered function to restore the appropriate -;;; dynamic environment. Currently we only save the Current-Catch and binding -;;; stack pointer. We don't need to save/restore the current unwind-protect, -;;; since unwind-protects are implicitly processed during unwinding. If there -;;; were any additional stacks, then this would be the place to restore the top -;;; pointers. - - -;;; Make-Dynamic-State-TNs -- Interface -;;; -;;; Return a list of TNs that can be used to snapshot the dynamic state for -;;; use with the Save/Restore-Dynamic-Environment VOPs. -;;; -(defun make-dynamic-state-tns () - (make-n-tns 3 *any-primitive-type*)) - -(define-vop (save-dynamic-state) - (:results (catch :scs (descriptor-reg)) - (special :scs (descriptor-reg)) - (eval :scs (descriptor-reg))) - (:generator 13 - (load-global catch clc::current-catch-block) - (inst lr special bs-tn) - (inst cau eval zero-tn clc::t-16) - (inst l eval eval (+ clc::*eval-stack-top*-offset clc::symbol-value)))) - -(define-vop (restore-dynamic-state one-arg-no-value-miscop) - (:args (catch :scs (descriptor-reg)) - (special :scs (descriptor-reg) :target a0) - (eval :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:variant-vars) - (:generator 10 - (store-global catch clc::current-catch-block temp) - (inst cau temp zero-tn clc::t-16) - (inst st eval temp (+ clc::*eval-stack-top*-offset clc::symbol-value)) - (let ((skip (gen-label))) - (inst c special bs-tn) - (inst bb :eq skip) - (unless (location= special a0) - (inst lr a0 special)) - (inst miscop 'clc::unbind-to-here) - (emit-label skip)))) - -(define-vop (current-stack-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (inst lr res sp-tn))) - - -;;;; Unwind miscop VOPs: - -(define-vop (unwind three-arg-no-value-miscop) - (:variant 'clc::unwind) - (:translate %continue-unwind)) - -(define-vop (throw three-arg-no-value-miscop) - (:variant 'clc::throw)) - - -;;;; Unwind block hackery: - -;;; Compute the address of the catch block from its TN, then store into the -;;; block the current Fp, Env, Unwind-Protect, and the entry PC. -;;; -(define-vop (make-unwind-block) - (:args (tn) - (entry-offset :scs (any-reg descriptor-reg))) - (:results (block :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :target block) result) - (:generator 22 - (inst ai result fp-tn (* (tn-offset tn) 4)) - (load-global temp clc::current-unwind-protect-block) - (storew temp result system:%unwind-block-current-uwp) - (storew fp-tn result system:%unwind-block-current-fp) - (storew env-tn result system:%unwind-block-current-env) - (storew entry-offset result system:%unwind-block-entry-pc) - (unless (location= result block) - (inst lr block result)))) - - -;;; Like Make-Unwind-Block, except that we also store in the specified tag, and -;;; link the block into the Current-Catch list. -;;; -(define-vop (make-catch-block) - (:args (tn) - (tag :scs (any-reg descriptor-reg)) - (entry-offset :scs (any-reg descriptor-reg))) - (:results (block :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :target block) result) - (:generator 44 - (inst ai result fp-tn (* (tn-offset tn) 4)) - (load-global temp clc::current-unwind-protect-block) - (storew temp result system:%unwind-block-current-uwp) - (storew fp-tn result system:%unwind-block-current-fp) - (storew env-tn result system:%unwind-block-current-env) - (storew entry-offset result system:%unwind-block-entry-pc) - - (storew tag result system:%catch-block-tag) - (load-global temp clc::current-catch-block) - (storew temp result system:%catch-block-previous-catch) - (store-global result clc::current-catch-block temp) - - (unless (location= result block) - (inst lr block result)))) - - -;;; Just set the current unwind-protect to TN's address. This instantiates an -;;; unwind block as an unwind-protect. -;;; -(define-vop (set-unwind-protect) - (:args (tn)) - (:temporary (:scs (descriptor-reg)) temp new-uwp) - (:generator 7 - (inst ai new-uwp fp-tn (* (tn-offset tn) 4)) - (store-global new-uwp clc::current-unwind-protect-block temp))) - - -(define-vop (unlink-unwind-block) - (:temporary (:scs (descriptor-reg)) block temp) - (:variant-vars global slot) - (:policy :fast-safe) - (:generator 17 - (load-global block global) - (loadw block block slot) - (store-global block global temp))) - -(define-vop (unlink-catch-block unlink-unwind-block) - (:variant clc::current-catch-block system:%catch-block-previous-catch) - (:translate %catch-breakup)) - -(define-vop (unlink-unwind-protect unlink-unwind-block) - (:variant clc::current-unwind-protect-block system:%unwind-block-current-uwp) - (:translate %unwind-protect-breakup)) - - -;;;; NLX entry VOPs: -;;; -;;; We can't just make these miscop variants, since they take funny wired -;;; operands. -;;; - -(define-vop (nlx-entry two-arg-no-value-miscop) - (:args (top :scs (descriptor-reg) - :target a0) - (start) - (count)) - (:results (values :more t)) - (:info nvals) - (:ignore start count values nl0 nl1 a2 a3 misc-pc) - (:variant-vars) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (note-this-location vop :non-local-exit) - (unless (location= a0 top) - (inst lr a0 top)) - (inst miscopx 'clc::nlx-entry-default-values) - (inst cal a1 zero-tn nvals))) - - -(define-vop (nlx-entry-multiple two-arg-two-value-miscop) - (:args (top :scs (descriptor-reg) - :target a0) - (start) - (count)) - (:ignore start count nl0 nl1 a2 a3 misc-pc) - (:variant-vars) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (note-this-location vop :non-local-exit) - (unless (location= a0 top) - (inst lr a0 top)) - (inst miscop 'clc::nlx-entry-receive-values) - (unless (location= a0 r) - (inst lr r a0)) - (unless (location= a1 r1) - (inst lr r1 a1)))) - - -;;; This VOP is just to force the TNs used in the cleanup onto the stack. -;;; -(define-vop (uwp-entry) - (:save-p :force-to-stack) - (:results (block) (start) (count)) - (:ignore block start count) - (:vop-var vop) - (:generator 0 - (note-this-location vop :non-local-exit))) diff --git a/compiler/old-rt/odump.lisp b/compiler/old-rt/odump.lisp deleted file mode 100644 index 33e557e3427b411247a82e3c840f8e2aa1c97f88..0000000000000000000000000000000000000000 --- a/compiler/old-rt/odump.lisp +++ /dev/null @@ -1,852 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; -;;; This file contains stuff that knows about dumping code both to files to -;;; the running Lisp. -;;; -(in-package 'c) - -(proclaim '(special compiler-version)) - -(import '(system:%primitive system:%array-data-slot - system:%array-displacement-slot - system:%g-vector-structure-subtype - system:%function-constants-constants-offset)) - - - -;;;; Fasl dumper state: - -;;; The Fasl-File structure represents everything we need to know about dumping -;;; to a fasl file. We need to objectify the state, since the fasdumper must -;;; be reentrant. -;;; -(defstruct (fasl-file - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (format stream "#<Fasl-File ~S>" - (namestring (fasl-file-stream s)))))) - ;; - ;; The stream we dump to. - (stream nil :type stream) - ;; - ;; A hashtable we use to keep track of dumped constants so that we can get - ;; them from the table rather than dumping them again. - (table (make-hash-table :test #'equal) :type hash-table) - ;; - ;; The table's current free pointer: the next offset to be used. - (table-free 0 :type unsigned-byte) - ;; - ;; Alist (Package . Offset) of the table offsets for each package we have - ;; currently located. - (packages () :type list) - ;; - ;; Table mapping from the Entry-Info structures for dumped XEPs to the table - ;; offsets of the corresponding code pointers. - (entry-table (make-hash-table :test #'eq) :type hash-table) - ;; - ;; Table holding back-patching info for forward references to XEPs. The key - ;; is the Entry-Info structure for the XEP, and the value is a list of conses - ;; (<code-handle> . <offset>), where <code-handle> is the offset in the table - ;; of the code object needing to be patched, and <offset> is the offset that - ;; must be patched. - (patch-table (make-hash-table :test #'eq) :type hash-table) - ;; - ;; A list of the table handles for all of the DEBUG-INFO structures dumped in - ;; this file. These structures must be back-patched with source location - ;; information when the compilation is complete. - (debug-info () :type list) - ;; - ;; Used to keep track of objects that we are in the process of dumping so that - ;; circularities can be preserved. The key is the object that we have - ;; previously seen, and the value is the object that we reference in the table - ;; to find this previously seen object. (The value is never NIL.) - ;; - ;; Except with list objects, the key and the value are always the same. In a - ;; list, the key will be some tail of the value. - ;; - (circularity-table (make-hash-table :test #'eq) :type hash-table) - ;; - ;; A list of the Circularity structures for all of the circiuarities detected - ;; in the the current top-level call to Dump-Object. - (circularities nil :type list)) - - -;;; This structure holds information about a circularity. -;;; -(defstruct circularity - ;; - ;; Kind of modification to make to create circularity. - (type nil :type (member :rplaca :rplacd :svset)) - ;; - ;; Object containing circularity. - object - ;; - ;; Index in object for circularity. - (index nil :type unsigned-byte) - ;; - ;; The object to be stored at Index in Object. This is that the key that we - ;; were using when we discovered the circularity. - value - ;; - ;; The value that was associated with Value in the CIRCULARITY-TABLE. This - ;; is the object that we look up in the table to locate Value. - enclosing-object) - - -;;;; Utilities: - -;;; Dump-Byte -- Internal -;;; -;;; Write the byte B to the specified fasl-file stream. -;;; -(proclaim '(inline dump-byte)) -(defun dump-byte (b file) - (declare (type (unsigned-byte 8) b) (type fasl-file file)) - (write-byte b (fasl-file-stream file)) - (undefined-value)) - - -;;; Dump-FOP -- Internal -;;; -;;; Dump the FOP code for the named FOP to the specified fasl-file. -;;; -(defun dump-fop (fs file) - (declare (symbol fs) (type fasl-file file)) - (let ((val (get fs 'lisp::fop-code))) - (assert val () "Compiler bug: ~S not a legal fasload operator." fs) - (dump-byte val file)) - (undefined-value)) - - -;;; Dump-FOP* -- Internal -;;; -;;; Dump a FOP-Code along with an integer argument, choosing the FOP based -;;; on whether the argument will fit in a single byte. -;;; -(defmacro dump-fop* (n byte-fop word-fop file) - (once-only ((n-n n) - (n-file file)) - `(cond ((< ,n-n 256) - (dump-fop ',byte-fop ,n-file) - (dump-byte ,n-n ,n-file)) - (t - (dump-fop ',word-fop ,n-file) - (quick-dump-number ,n-n 4 ,n-file))))) - - -;;; Quick-Dump-Number -- Internal -;;; -;;; Dump Num to the fasl stream, represented by the specified number of -;;; bytes. -;;; -(defun quick-dump-number (num bytes file) - (declare (type unsigned-byte num bytes) (type fasl-file file)) - (let ((stream (fasl-file-stream file))) - (do ((n num (ash n -8)) - (i bytes (1- i))) - ((= i 0)) - (write-byte (logand n #xFF) stream))) - (undefined-value)) - - -;;; Dump-Push -- Internal -;;; -;;; Push the object at table offset Handle on the fasl stack. -;;; -(defun dump-push (handle file) - (declare (type unsigned-byte handle) (type fasl-file file)) - (dump-fop* handle lisp::fop-byte-push lisp::fop-push file) - (undefined-value)) - - -;;; Dump-Pop -- Internal -;;; -;;; Pop the object currently on the fasl stack top into the table, and -;;; return the table index, incrementing the free pointer. -;;; -(defun dump-pop (file) - (prog1 (fasl-file-table-free file) - (dump-fop 'lisp::fop-pop file) - (incf (fasl-file-table-free file)))) - - -;;; Used to inhibit table access when dumping forms to be read by the cold -;;; loader. -;;; -(defvar *cold-load-dump* nil) - -;;; Fasl-Dump-Cold-Load-Form -- Interface -;;; -;;; Dump Form to a fasl file so that it evaluated at load time in normal -;;; load and at cold-load time in cold load. This is used to dump package -;;; frobbing forms. -;;; -(defun fasl-dump-cold-load-form (form file) - (declare (type fasl-file file)) - (dump-fop 'lisp::fop-normal-load file) - (let ((*cold-load-dump* t)) - (dump-object form file)) - (dump-fop 'lisp::fop-eval-for-effect file) - (dump-fop 'lisp::fop-maybe-cold-load file) - (undefined-value)) - - -;;;; Opening and closing: - -;;; Open-Fasl-File -- Interface -;;; -;;; Return a Fasl-File object for dumping to the named file. Some -;;; information about the source is specified by the string Where. -;;; -(defun open-fasl-file (name where) - (declare (type pathname name)) - (let* ((stream (open name :direction :output - :if-exists :new-version - :element-type '(unsigned-byte 8))) - (res (make-fasl-file :stream stream))) - (format stream - "FASL FILE output from ~A.~@ - Compiled ~A on ~A~@ - Compiler ~A, Lisp ~A~@ - Targeted for ~A, FASL code format ~D~%" - where - (ext:format-universal-time nil (get-universal-time)) - (machine-instance) compiler-version - (lisp-implementation-version) vm-version target-fasl-code-format) - ;; - ;; Terminate header. - (dump-byte 255 res) - ;; - ;; Specify code format. - (dump-fop 'lisp::fop-code-format res) - (dump-byte target-fasl-code-format res) - - res)) - - -;;; Close-Fasl-File -- Interface -;;; -;;; Close the specified Fasl-File, aborting the write if Abort-P is true. -;;; We do various sanity checks, then end the group. -;;; -(defun close-fasl-file (file abort-p) - (declare (type fasl-file file)) - (dump-fop 'lisp::fop-verify-empty-stack file) - (dump-fop 'lisp::fop-verify-table-size file) - (quick-dump-number (fasl-file-table-free file) 4 file) - (dump-fop 'lisp::fop-end-group file) - (close (fasl-file-stream file) :abort abort-p) - (undefined-value)) - - -;;;; Component (function) dumping: - - -;;; Dump-Code-Object -- Internal -;;; -;;; Dump out the constant pool and code-vector for component, push the -;;; result in the table and return the offset. -;;; -;;; The only tricky thing is handling constant-pool references to functions. -;;; If we have already dumped the function, then we just push the code pointer. -;;; Otherwise, we must create back-patching information so that the constant -;;; will be set when the function is eventually dumped. This is a bit awkward, -;;; since we don't have the handle for the code object being dumped while we -;;; are dumping its constants. -;;; -;;; We dump a trap object as a placeholder for the code vector, which is -;;; actually filled in by the loader. -;;; -(defun dump-code-object (component code-vector code-length node-vector - nodes-length file) - (declare (type component component) (type fasl-file file) - (simple-vector node-vector) - (type unsigned-byte code-length nodes-length)) - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp)) - (num-consts (length constants))) - (collect ((patches)) - (dump-object (component-name component) file) - (dump-fop 'lisp::fop-misc-trap file) - - (let ((info (debug-info-for-component component node-vector - nodes-length))) - (dump-object info file) - (let ((info-handle (dump-pop file))) - (dump-push info-handle file) - (push info-handle (fasl-file-debug-info file)))) - - (do ((i %function-constants-constants-offset (1+ i))) - ((= i num-consts)) - (let ((entry (aref constants i))) - (etypecase entry - (constant - (dump-object (constant-value entry) file)) - (cons - (ecase (car entry) - (:entry - (let* ((info (leaf-info (cdr entry))) - (handle (gethash info (fasl-file-entry-table file)))) - (cond - (handle - (dump-push handle file)) - (t - (patches (cons info i)) - (dump-fop 'lisp::fop-misc-trap file))))) - (:label - (dump-object (+ (label-location (cdr entry)) - clc::i-vector-header-size) - file)))) - (null - (dump-fop 'lisp::fop-misc-trap file))))) - - (cond ((and (< num-consts #x100) (< code-length #x10000)) - (dump-fop 'lisp::fop-small-code file) - (dump-byte num-consts file) - (quick-dump-number code-length 2 file)) - (t - (dump-fop 'lisp::fop-code file) - (quick-dump-number num-consts 4 file) - (quick-dump-number code-length 4 file))) - - (write-string code-vector (fasl-file-stream file) :end code-length) - - (let ((handle (dump-pop file))) - (dolist (patch (patches)) - (push (cons handle (cdr patch)) - (gethash (car patch) (fasl-file-patch-table file)))) - handle)))) - - -;;; Dump-Fixups -- Internal -;;; -;;; Dump all the fixups. Currently there are only miscop fixups, and we -;;; always access them by name rather than number. There is no reason for -;;; using miscop numbers other than a minor load-time efficiency win. -;;; -(defun dump-fixups (code-handle fixups file) - (declare (type unsigned-byte code-handle) (list fixups) - (type fasl-file file)) - (dump-push code-handle file) - (dolist (fixup fixups) - (let ((offset (second fixup)) - (value (third fixup))) - (ecase (first fixup) - (:miscop - (assert (symbolp value)) - (dump-object value file) - (dump-fop 'lisp::fop-user-miscop-fixup file) - (quick-dump-number offset 4 file))))) - - (dump-fop 'lisp::fop-pop-for-effect file) - (undefined-value)) - - -;;; Dump-One-Entry -- Internal -;;; -;;; Dump a function-entry data structure corresponding to Entry to File. -;;; Code-Handle is the table offset of the code object for the component. -;;; -;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the cold -;;; loader can instantiate the definition at cold-load time, allowing forward -;;; references to functions in top-level forms. -;;; -(defun dump-one-entry (entry code-handle file) - (declare (type entry-info entry) (type unsigned-byte code-handle) - (type fasl-file file)) - (let ((name (entry-info-name entry))) - (dump-push code-handle file) - (dump-object (if (entry-info-closure-p entry) - system:%function-closure-entry-subtype - system:%function-entry-subtype) - file) - - (dump-object name file) - (dump-fop 'lisp::fop-misc-trap file) - (dump-object (+ (label-location (entry-info-offset entry)) - clc::i-vector-header-size) - file) - (dump-fop 'lisp::fop-misc-trap file) - (dump-object (entry-info-arguments entry) file) - (dump-object (entry-info-type entry) file) - (dump-fop 'lisp::fop-function-entry file) - (dump-byte 6 file) - - (let ((handle (dump-pop file))) - (when (and name (symbolp name)) - (dump-object name file) - (dump-push handle file) - (dump-fop 'lisp::fop-fset file)) - handle))) - - -;;; Alter-Code-Object -- Internal -;;; -;;; Alter the code object referenced by Code-Handle at the specified Offset, -;;; storing the object referenced by Entry-Handle. -;;; -(defun alter-code-object (code-handle offset entry-handle file) - (dump-push code-handle file) - (dump-push entry-handle file) - (dump-fop* offset lisp::fop-byte-alter-code lisp::fop-alter-code file) - (undefined-value)) - - -;;; Fasl-Dump-Component -- Interface -;;; -;;; Dump the code, constants, etc. for component. Code-Vector is a vector -;;; holding the assembled code. Length is the number of elements of Vector -;;; that are actually in use. If the component is a top-level component, then -;;; the top-level lambda will be called after the component is loaded. -;;; -(defun fasl-dump-component (component code-vector code-length - node-vector nodes-length - fixups file) - (declare (type component component) (type unsigned-byte length) - (list fixups) (type fasl-file file)) - - (dump-fop 'lisp::fop-verify-empty-stack file) - (dump-fop 'lisp::fop-verify-table-size file) - (quick-dump-number (fasl-file-table-free file) 4 file) - - (let ((code-handle (dump-code-object component code-vector code-length - node-vector nodes-length file)) - (2comp (component-info component))) - (dump-fixups code-handle fixups file) - (dump-fop 'lisp::fop-verify-empty-stack file) - - (dolist (entry (ir2-component-entries 2comp)) - (let ((entry-handle (dump-one-entry entry code-handle file))) - (setf (gethash entry (fasl-file-entry-table file)) entry-handle) - - (let ((old (gethash entry (fasl-file-patch-table file)))) - (when old - (dolist (patch old) - (alter-code-object (car patch) (cdr patch) entry-handle file)) - (remhash entry (fasl-file-patch-table file))))))) - - (assert (zerop (hash-table-count (fasl-file-patch-table file)))) - - (undefined-value)) - - -;;; Call-Top-Level-Lambda -- Interface -;;; -;;; Dump a FOP-FUNCALL to call an already dumped top-level lambda at load -;;; time. -;;; -(defun call-top-level-lambda (fun file) - (declare (type clambda fun) (type fasl-file file)) - (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file)))) - (assert handle) - (dump-push handle file) - (dump-fop 'lisp::fop-funcall-for-effect file) - (dump-byte 0 file)) - (undefined-value)) - - -;;; FASL-DUMP-SOURCE-INFO -- Interface -;;; -;;; Compute the correct list of DEBUG-SOURCE structures and backpatch all of -;;; the dumped DEBUG-INFO structures. We clear the FASL-FILE-DEBUG-INFO, -;;; so that subsequent components with different source info may be dumped. -;;; -(defun fasl-dump-source-info (info file) - (declare (type source-info info) (type fasl-file file)) - (let ((res (debug-source-for-info info))) - (dump-object res file) - (let ((res-handle (dump-pop file))) - (dolist (info-handle (fasl-file-debug-info file)) - (dump-push res-handle file) - (dump-fop 'lisp::fop-svset file) - (quick-dump-number info-handle 4 file) - (quick-dump-number 2 4 file)))) - - (setf (fasl-file-debug-info file) ()) - (undefined-value)) - - -;;; Dump-Circularities -- Internal -;;; -;;; Dump stuff to backpatch already dumped objects. Infos is the list of -;;; Circularity structures describing what to do. The patching FOPs take the -;;; value to store on the stack. We compute this value by fetching the -;;; enclosing object from the table, and then CDR'ing it if necessary. -;;; -(defun dump-circularities (infos) - (dolist (info infos) - (let* ((value (circularity-value info)) - (enclosing (circularity-enclosing-object info))) - (dump-fop* (gethash enclosing *table-table*) - lisp::fop-byte-push lisp::fop-push) - (unless (eq enclosing value) - (do ((current enclosing (cdr current)) - (i 0 (1+ i))) - ((eq current value) - (dump-fop 'lisp::fop-nthcdr) - (quick-dump-number i 4))))) - - (dump-fop (case (circularity-type info) - (:rplaca 'lisp::fop-rplaca) - (:rplacd 'lisp::fop-rplacd) - (:svset 'lisp::fop-svset))) - (quick-dump-number (gethash (circularity-object info) *table-table*) 4) - (quick-dump-number (circularity-index info) 4))) - - -;;; Dump-Object -- Internal -;;; -;;; Dump an object of any type. This function dispatches to the correct -;;; type-specific dumping function. For non-trivial objects, we check to see -;;; if the object has already been dumped (and is in the table). Symbols are a -;;; special case, since we have -SAVE variants. -;;; -(defun dump-object (x file) - (declare (type fasl-file file)) - (cond - ((null x) - (dump-fop 'lisp::fop-empty-list file)) - ((eq x t) - (dump-fop 'lisp::fop-truth file)) - ((typep x 'fixnum) (dump-integer x file)) - (t - (let ((index (gethash x (fasl-file-table file)))) - (cond - ((and index (not *cold-load-dump*)) - (dump-push index file)) - ((symbolp x) - (dump-symbol x file)) - (t - (typecase x - (list - (dump-list x file)) - (vector - (cond ((stringp x) (dump-string x file)) - ((subtypep (array-element-type x) '(unsigned-byte 16)) - (dump-i-vector x file)) - (t - (dump-vector x file)))) - (array (dump-array x file)) - (number - (etypecase x - (ratio (dump-ratio x file)) - (complex (dump-complex x file)) - (float (dump-float x file)) - (integer (dump-integer x file)))) - (character - (dump-character x file)) - (t - (compiler-error-message - "This object cannot be dumped into a fasl file:~% ~S" - x) - (dump-fop 'lisp::fop-misc-trap file))) - ;; - ;; If wasn't in the table, put it there... - (unless *cold-load-dump* - (let ((handle (dump-pop file))) - (dump-push handle file) - (setf (gethash x (fasl-file-table file)) handle))))))))) - - -#| -;;; Load-Time-Eval -- Internal -;;; -;;; This guy deals with the magical %Eval-At-Load-Time marker that -;;; #, turns into when the *compiler-is-reading* and a fasl file is being -;;; written. -;;; -(defun load-time-eval (x file) - (when *compile-to-lisp* - (clc-error "#,~S in a bad place." (third x))) - (assemble-one-lambda (cadr x)) - (dump-fop 'lisp::fop-funcall file) - (dump-byte 0 file)) -|# - - -;;;; Number Dumping: - -;;; Dump a ratio - -(defun dump-ratio (x file) - (dump-object (numerator x) file) - (dump-object (denominator x) file) - (dump-fop 'lisp::fop-ratio file)) - -;;; Or a complex... - -(defun dump-complex (x file) - (dump-object (realpart x) file) - (dump-object (imagpart x) file) - (dump-fop 'lisp::fop-complex file)) - -;;; Dump an integer. - - -;;; Compute how many bytes it will take to represent signed integer N. - -(defun compute-bytes (n) - (truncate (+ (integer-length n) 8) 8)) - - -(defun dump-integer (n file) - (let* ((bytes (compute-bytes n))) - (cond ((= bytes 1) - (dump-fop 'lisp::fop-byte-integer file) - (dump-byte n file)) - ((< bytes 5) - (dump-fop 'lisp::fop-word-integer file) - (quick-dump-number n 4 file)) - ((< bytes 256) - (dump-fop 'lisp::fop-small-integer file) - (dump-byte bytes file) - (quick-dump-number n bytes file)) - (t - (dump-fop 'lisp::fop-integer file) - (quick-dump-number bytes 4 file) - (quick-dump-number n bytes file))))) - - -(defun dump-float (x file) - (multiple-value-bind (f exponent sign) (decode-float x) - (let ((mantissa (truncate (scale-float (* f sign) (float-precision f))))) - (dump-fop 'lisp::fop-float file) - (dump-byte (1+ (integer-length exponent)) file) - (quick-dump-number exponent (compute-bytes exponent) file) - (dump-byte (1+ (integer-length mantissa)) file) - (quick-dump-number mantissa (compute-bytes mantissa) file)))) - - -;;;; Symbol Dumping: - - -;;; Dump-Package -- Internal -;;; -;;; Return the table index of Pkg, adding the package to the table if -;;; necessary. During cold load, we read the string as a normal string so that -;;; we can do the package lookup at cold load time. -;;; -(defun dump-package (pkg file) - (cond ((cdr (assoc pkg (fasl-file-packages file)))) - (t - (unless *cold-load-dump* - (dump-fop 'lisp::fop-normal-load file)) - (dump-string (package-name pkg) file) - (dump-fop 'lisp::fop-package file) - (unless *cold-load-dump* - (dump-fop 'lisp::fop-maybe-cold-load file)) - (let ((entry (dump-pop file))) - (push (cons pkg entry) (fasl-file-packages file)) - entry)))) - - -;;; Dump-Symbol -- Internal -;;; -;;; If we get here, it is assumed that the symbol isn't in the table, but we -;;; are responsible for putting it there when appropriate. To avoid too much -;;; special-casing, we always push the symbol in the table, but forget that we -;;; have done so if *Cold-Load-Dump* is true. -;;; -(defun dump-symbol (s file) - (let* ((pname (symbol-name s)) - (pname-length (length pname)) - (pkg (symbol-package s))) - - (cond ((null pkg) - (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save - lisp::fop-uninterned-symbol-save file)) - ((eq pkg *package*) - (dump-fop* pname-length lisp::fop-small-symbol-save - lisp::fop-symbol-save file)) - ((eq pkg ext:*lisp-package*) - (dump-fop* pname-length lisp::fop-lisp-small-symbol-save - lisp::fop-lisp-symbol-save file)) - ((eq pkg ext:*keyword-package*) - (dump-fop* pname-length lisp::fop-keyword-small-symbol-save - lisp::fop-keyword-symbol-save file)) - ((< pname-length 256) - (dump-fop* (dump-package pkg file) - lisp::fop-small-symbol-in-byte-package-save - lisp::fop-small-symbol-in-package-save file) - (dump-byte pname-length file)) - (t - (dump-fop* (dump-package pkg file) - lisp::fop-symbol-in-byte-package-save - lisp::fop-symbol-in-package-save file) - (quick-dump-number pname-length 4 file))) - - (write-string pname (fasl-file-stream file)) - - (unless *cold-load-dump* - (setf (gethash s (fasl-file-table file)) (fasl-file-table-free file))) - - (incf (fasl-file-table-free file))) - - (undefined-value)) - - -;;; Dumper for lists. - -(defun dump-list (list file) - (do ((l list (cdr l)) - (n 0 (1+ n))) - ((atom l) - (cond ((null l) - (terminate-undotted-list n file)) - (t (dump-object l file) - (terminate-dotted-list n file)))) - (dump-object (car l) file))) - - -(defun terminate-dotted-list (n file) - (case n - (1 (dump-fop 'lisp::fop-list*-1 file)) - (2 (dump-fop 'lisp::fop-list*-2 file)) - (3 (dump-fop 'lisp::fop-list*-3 file)) - (4 (dump-fop 'lisp::fop-list*-4 file)) - (5 (dump-fop 'lisp::fop-list*-5 file)) - (6 (dump-fop 'lisp::fop-list*-6 file)) - (7 (dump-fop 'lisp::fop-list*-7 file)) - (8 (dump-fop 'lisp::fop-list*-8 file)) - (T (do ((nn n (- nn 255))) - ((< nn 256) - (dump-fop 'lisp::fop-list* file) - (dump-byte nn file)) - (dump-fop 'lisp::fop-list* file) - (dump-byte 255 file))))) - -;;; If N > 255, must build list with one list operator, then list* operators. - -(defun terminate-undotted-list (n file) - (case n - (1 (dump-fop 'lisp::fop-list-1 file)) - (2 (dump-fop 'lisp::fop-list-2 file)) - (3 (dump-fop 'lisp::fop-list-3 file)) - (4 (dump-fop 'lisp::fop-list-4 file)) - (5 (dump-fop 'lisp::fop-list-5 file)) - (6 (dump-fop 'lisp::fop-list-6 file)) - (7 (dump-fop 'lisp::fop-list-7 file)) - (8 (dump-fop 'lisp::fop-list-8 file)) - (T (cond ((< n 256) - (dump-fop 'lisp::fop-list file) - (dump-byte n file)) - (t (dump-fop 'lisp::fop-list file) - (dump-byte 255 file) - (do ((nn (- n 255) (- nn 255))) - ((< nn 256) - (dump-fop 'lisp::fop-list* file) - (dump-byte nn file)) - (dump-fop 'lisp::fop-list* file) - (dump-byte 255 file))))))) - -;;;; Array dumping: - -;;; Named G-vectors get their subtype field set at load time. - -(defun dump-vector (obj file) - (cond ((and (simple-vector-p obj) - (= (%primitive get-vector-subtype obj) - %g-vector-structure-subtype)) - (normal-dump-vector obj file) - (dump-fop 'lisp::fop-structure file)) - (t - (normal-dump-vector obj file)))) - -(defun normal-dump-vector (v file) - (do ((index 0 (1+ index)) - (length (length v))) - ((= index length) - (dump-fop* length lisp::fop-small-vector lisp::fop-vector file)) - (dump-object (aref v index) file))) - -;;; Dump a string. - -(defun dump-string (s file) - (let ((length (length s))) - (dump-fop* length lisp::fop-small-string lisp::fop-string file) - (dotimes (i length) - (dump-byte (char-code (char s i)) file)))) - - -;;; 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 file) - (unless (zerop (%primitive header-ref array %array-displacement-slot)) - (compiler-error-message "Cannot dump displaced array:~% ~S" array) - (dump-fop 'lisp::fop-misc-trap file) - (return-from dump-array nil)) - - (let ((rank (array-rank array))) - (dotimes (i rank) - (dump-integer (array-dimension array i) file)) - (dump-object (%primitive header-ref array %array-data-slot) file) - (dump-fop 'lisp::fop-array file) - (quick-dump-number rank 4 file))) - - -;;; Dump-I-Vector -- Internal -;;; -;;; Dump an I-Vector using the Guy Steele memorial fasl-operation. -;;; -(defun dump-i-vector (vec file) - (let* ((len (length vec)) - (ac (%primitive get-vector-access-code - (if #-new-compiler (%primitive complex-array-p vec) - #+new-compiler (array-header-p vec) - (%primitive header-ref vec %array-data-slot) - vec))) - (size (ash 1 ac)) - (count (ceiling size 8)) - (ints-per-entry (floor (* count 8) size))) - (declare (fixnum len ac size count ints-per-entry)) - (dump-fop 'lisp::fop-int-vector file) - (quick-dump-number len 4 file) - (dump-byte size file) - (dump-byte count file) - (if (> ints-per-entry 1) - (do ((prev 0 end) - (end ints-per-entry (the fixnum (+ end ints-per-entry)))) - ((>= end len) - (unless (= prev len) - (do ((pos (* (1- ints-per-entry) size) (- pos size)) - (idx prev (1+ idx)) - (res 0)) - ((= idx len) - (dump-byte res file)) - (setq res (dpb (aref vec idx) (byte size pos) res))))) - (declare (fixnum prev end)) - (do* ((idx prev (1+ idx)) - (res 0)) - ((= idx end) - (dump-byte res file)) - (declare (fixnum idx)) - (setq res (logior (ash res size) (aref vec idx))))) - (dotimes (i len) - (declare (fixnum i)) - (quick-dump-number (aref vec i) count file))))) - - -;;; Dump a character. - -(defun dump-character (ch file) - (cond - ((string-char-p ch) - (dump-fop 'lisp::fop-short-character file) - (dump-byte (char-code ch) file)) - (t - (dump-fop 'lisp::fop-character file) - (dump-byte (char-code ch) file) - (dump-byte (char-bits ch) file) - (dump-byte (char-font ch) file)))) diff --git a/compiler/old-rt/parms.lisp b/compiler/old-rt/parms.lisp deleted file mode 100644 index 1cd2889a54507679553fdf05b92fe955bf5df149..0000000000000000000000000000000000000000 --- a/compiler/old-rt/parms.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains some parameterizations of various VM attributes for -;;; the RT. This file is separate from other stuff so that it can be compiled -;;; and loaded earlier. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(eval-when (compile load eval) - -;;; Maximum number of SCs allowed. -;;; -(defconstant sc-number-limit 32) - -;;; The number of references that a TN must have to offset the overhead of -;;; saving the TN across a call. -;;; -(defconstant register-save-penalty 3) - - -;;;; Assembler parameters: - -;;; The length of the smallest addressable unit on the target -;;; machine. -;;; -(defparameter *word-length* 8) - -;;; Convert-Byte-List -- Internal -;;; -;;; Convert-Byte-List take a list of byte specifiers that define a field -;;; and returns a list of byte specifiers that can be used to take apart -;;; the value to be placed in that field. This is somewhat architecture -;;; dependent because of differences in byte ordering conventions. - -(defun convert-byte-list (byte-list) - (let ((offset (byte-position (first byte-list)))) - (mapcar #'(lambda (byte) - (byte (byte-size byte) (- (byte-position byte) offset))) - byte-list))) - - -;;;; Other parameters: - -;;; The number representing the fasl-code format emit code in. -;;; -(defparameter target-fasl-code-format 6) - -;;; The version string for the implementation dependent code. -;;; -(defparameter vm-version "IBM RT PC/Mach 0.0") - - -;;; The byte ordering of the target implementation. -;;; -(defparameter target-byte-order :big-endian) - -;;; -;;; The native byte ordering (should come from somewhere else once -;;; bootstrapped.) -(defconstant native-byte-order :big-endian) - -;;; The byte ordering of the target implementation. -;;; -(defparameter target-byte-order :big-endian) - -;;; -;;; The native byte ordering (should come from somewhere else once -;;; bootstrapped.) -(defconstant native-byte-order :big-endian) - -); Eval-When (Compile Load Eval) diff --git a/compiler/old-rt/pred.lisp b/compiler/old-rt/pred.lisp deleted file mode 100644 index ba3e1ae22b0e09ba2432298f3b4d3ef1a54b8a32..0000000000000000000000000000000000000000 --- a/compiler/old-rt/pred.lisp +++ /dev/null @@ -1,48 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of predicate VOPs for the RT. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; The Branch VOP. - -;;; The unconditional branch, emitted when we can't drop through to the desired -;;; destination. Dest is the continuation we transfer control to. -;;; -(define-vop (branch) - (:info dest) - (:generator 5 - (inst bnb :pz dest))) - - -;;;; Conditional VOPs: - -;if-true (???), if-eql, ... - -(define-vop (if-eq) - (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:translate eq) - (:generator 3 - (inst c x y) - (if not-p - (inst bnb :eq target) - (inst bb :eq target)))) - - -(define-vop (if-eql two-arg-conditional-miscop) - (:variant 'eql :eq) - (:translate eql)) diff --git a/compiler/old-rt/print.lisp b/compiler/old-rt/print.lisp deleted file mode 100644 index 24fe117ad8664fbf01eeb1fd7d2e3fc6546ae9a2..0000000000000000000000000000000000000000 --- a/compiler/old-rt/print.lisp +++ /dev/null @@ -1,27 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Debugging versions of Print, Write-String and Read-Char that call -;;; miscops. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(define-vop (print one-arg-miscop) - (:variant 'print)) - -(define-vop (read-char zero-arg-miscop) - (:variant 'read-char)) - -(define-vop (write-string three-arg-miscop) - (:variant 'write-string)) - -(define-vop (halt zero-arg-miscop) - (:variant 'clc::halt)) diff --git a/compiler/old-rt/subprim.lisp b/compiler/old-rt/subprim.lisp deleted file mode 100644 index 84d015b6f729d70dceea40487b4c5d24f85caef5..0000000000000000000000000000000000000000 --- a/compiler/old-rt/subprim.lisp +++ /dev/null @@ -1,164 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; Linkage information for standard miscops, both primitive and -;;; sub-primitive. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; Subprimitive miscops: - -#| Inline versions exist, and we can't currently support multiple -implementations, since they are accessed through %primitive. - -(define-miscop 16bit-system-ref (s i)) -(define-miscop 16bit-system-set (s i v)) -(define-miscop 8bit-system-ref (s i)) -(define-miscop 8bit-system-set (s i v)) -|# - -(define-miscop active-call-frame ()) -(define-miscop active-catch-frame ()) -(define-miscop alloc-array (n)) -(define-miscop alloc-bit-vector (n)) -(define-miscop alloc-code (n)) -(define-miscop alloc-function (n)) -(define-miscop alloc-g-vector (n i)) -(define-miscop alloc-i-vector (n a)) -(define-miscop alloc-static-g-vector (len)) -(define-miscop alloc-string (n)) -(define-miscop bit-bash (v1 v2 res op) :results ()) -(define-miscop break-return (stack) :results ()) -(define-miscop call-foreign (cfcn args nargs)) -#|Inline implementation... -(define-miscop check-<= (n l)) -|# -(define-miscop collect-garbage () :results ()) -(define-miscop current-binding-pointer ()) -(define-miscop current-stack-pointer ()) -(define-miscop dynamic-space-in-use ()) -(define-miscop error0 (code) :results ()) -(define-miscop error1 (code x) :results ()) -(define-miscop error2 (code x y) :results ()) -(define-miscop find-character (string start end character)) -(define-miscop find-character-with-attribute (a b c d e)) -(define-miscop float-long (x)) -(define-miscop float-short (x)) -(define-miscop get-allocation-space ()) -(define-miscop get-space (x)) -(define-miscop get-type (x)) -(define-miscop get-vector-access-code (v)) -#|Inline implementation... -(define-miscop get-vector-subtype (v)) -|# -(define-miscop halt ()) -#|Inline implementation... -(define-miscop header-length (x)) -(define-miscop header-ref (x i)) -(define-miscop header-set (x i v)) -|# -(define-miscop logdpb (v s p n)) -(define-miscop logldb (s p n)) -(define-miscop long-float-ref (l i)) -(define-miscop long-float-set (l i x)) -(define-miscop lsh (n b)) -(define-miscop make-complex (re im)) -(define-miscop make-immediate-type (obj type)) -(define-miscop make-ratio (num den)) -(define-miscop negate (n)) -(define-miscop newspace-bit ()) -(define-miscop pointer-system-set (s i p)) -(define-miscop purify () :results ()) -(define-miscop putf (x y z)) -(define-miscop read-binding-stack (b)) -(define-miscop read-control-stack (f)) -(define-miscop reset-c-stack (sp) :results ()) -(define-miscop return-to-c (sp value) :results ()) -(define-miscop sap-system-ref (s i)) -(define-miscop save (x y z)) -(define-miscop set-allocation-space (space) :results ()) -(define-miscop set-c-procedure-pointer (s o v)) -(define-miscop set-call-frame (p)) -(define-miscop set-catch-frame (x)) -(define-miscop set-vector-subtype (v x)) -(define-miscop shrink-vector (v n)) -#|Inline implementation... -(define-miscop signed-16bit-system-ref (s i)) -|# -(define-miscop signed-32bit-system-ref (s i)) -(define-miscop signed-32bit-system-set (s i v) :translate (setf sap-ref-32)) -(define-miscop sxhash-simple-string (string)) -(define-miscop sxhash-simple-substring (string length)) -(define-miscop syscall0 (n) :results (res err)) -(define-miscop syscall1 (n x) :results (res err)) -(define-miscop syscall2 (n x y) :results (res err)) -(define-miscop syscall3 (n x y z) :results (res err)) -(define-miscop syscall4 (n x y z xx) :results (res err)) -(define-miscop typed-vref (a v i)) -(define-miscop typed-vset (a v i x)) -(define-miscop unbind-to-here (x) :results ()) -(define-miscop unix-fork (code-ptr) :results (res err)) -(define-miscop unix-pipe () :results (res err)) -(define-miscop unix-wait () :results (res err)) -(define-miscop unix-write (fd buf offset len) :results (res err)) -(define-miscop unsigned-32bit-system-ref (s i) :translate sap-ref-32) -(define-miscop vector-length (vec)) -(define-miscop write-binding-stack (b v)) -(define-miscop write-control-stack (f v)) - -(define-vop (syscall n-arg-two-value-miscop) - (:variant 'clc::syscall)) - -(def-primitive-translator float-single (x) - `(%primitive float-short ,x)) - - -;;;; Primitive miscops: - -(defknown ext:assq (t list) list (foldable flushable)) -(defknown ext:memq (t list) list (foldable flushable)) - -(define-miscop abs (num) :translate abs) -(define-miscop alloc-symbol (name) :translate make-symbol) -(define-miscop ash (i n) :translate ash) -(define-miscop assq (key alist) :translate ext:assq) -(define-miscop atan (x) :translate atan) -(define-miscop cos (x) :translate cos) -(define-miscop decode-float (f) :results (frac exp sign) :translate decode-float) -(define-miscop exp (x) :translate exp) -(define-miscop gcd (x y) :translate gcd) -(define-miscop get-real-time () :translate get-internal-real-time) -(define-miscop get-run-time () :translate get-internal-run-time) -(define-miscop integer-length (i) :translate integer-length) -(define-miscop last (l) :translate last) -(define-miscop log (n) :translate log) -(define-miscop logcount (i) :translate logcount) -(define-miscop memq (item list) :translate ext:memq) -(define-miscop nthcdr (n l) :translate nthcdr) -(define-miscop put (sym prop val) :translate %put) -(define-miscop sap-int (sap) :translate sap-int) -(define-miscop scale-float (f exp) :translate scale-float) -(define-miscop sin (x) :translate sin) -(define-miscop sqrt (x) :translate sqrt) -(define-miscop tan (x) :translate tan) - -(define-vop (list n-arg-miscop) - (:variant 'list)) - -(define-vop (list* n-arg-miscop) - (:variant 'list*)) - -;;; Continuation to allow %sp-byte-blt for now... -(defknown lisp::%sp-byte-blt (t index t index index) void ()) -(define-miscop byte-blt (src src-start dst dst-start dst-end) - :translate lisp::%sp-byte-blt) - diff --git a/compiler/old-rt/system.lisp b/compiler/old-rt/system.lisp deleted file mode 100644 index bf4dd20b4df1636bcaa7fc56b78b2170b7300d16..0000000000000000000000000000000000000000 --- a/compiler/old-rt/system.lisp +++ /dev/null @@ -1,172 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; RT VM definitions of various system hacking operations. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(define-vop (pointer+) - (:args (ptr :scs (descriptor-reg)) - (offset :scs (any-reg descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:policy :fast-safe) - (:generator 1 - (inst cas res offset ptr))) - -(define-vop (sap+ pointer+) - (:translate sap+)) - -(define-vop (pointer-) - (:args (ptr1 :scs (descriptor-reg) :target temp) - (ptr2 :scs (descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:temporary (:sc any-reg - :from (:argument 0) - :to (:result 0) - :target res) - temp) - (:generator 1 - (unless (location= ptr1 temp) - (inst lr temp ptr1)) - (inst s temp ptr2) - (unless (location= temp res) - (inst lr res temp)))) - -(define-vop (vector-word-length) - (:args (vec :scs (descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadw res vec clc::g-vector-header-words) - (inst niuo res res clc::g-vector-words-mask-16))) - -(define-vop (int-sap) - (:args (x :scs (any-reg descriptor-reg) :target res)) - (:results (res :scs (any-reg descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:translate int-sap) - (:policy :fast-safe) - (:generator 6 - (unless (location= res x) - (inst lr res x)) - (let ((fixp (gen-label))) - (test-simple-type res temp fixp t system:%bignum-type) - (loadw res x (/ clc::bignum-header-size 4)) - (emit-label fixp)))) - - -(macrolet ((frob (name cond) - `(progn - (def-primitive-translator ,name (x y) `(,',name ,x ,y)) - (defknown ,name (t t) boolean (movable foldable flushable)) - (define-vop (,name pointer-compare) - (:translate ,name) - (:variant ,cond))))) - (frob pointer< :lt) - (frob pointer> :gt)) - -(define-vop (check-op) - (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg descriptor-reg))) - (:variant-vars condition not-p error) - (:vop-var vop) - (:save-p :compute-only) - (:policy :fast-safe) - (:generator 3 - (inst c x y) - (let ((target (generate-error-code vop error x y))) - (if not-p - (inst bb condition target) - (inst bnb condition target))))) - -(define-vop (check<= check-op) - (:variant :gt t clc::error-not-<=) - (:translate check<=)) - -(define-vop (check= check-op) - (:variant :eq nil clc::error-not-=) - (:translate check=)) - -(def-primitive-translator make-fixnum (x) - `(%primitive make-immediate-type ,x system:%+-fixnum-type)) - -(define-vop (make-immediate-type) - (:args (val :scs (any-reg descriptor-reg)) - (type :scs (any-reg descriptor-reg short-immediate - unsigned-immediate) - :target temp)) - (:results (res :scs (any-reg descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:generator 2 - (sc-case type - ((short-immediate unsigned-immediate) - (inst niuo res val clc::type-not-mask-16) - (let ((code (tn-value type))) - (check-type code (unsigned-byte 5)) - (unless (zerop code) - (inst oiu res res (ash code clc::type-shift-16))))) - (t - (unless (location= type temp) - (inst lr temp type)) - (inst niuo res val clc::type-not-mask-16) - (inst sli16 temp clc::type-shift-16) - (inst o res temp))))) - - -(define-vop (16bit-system-ref halfword-index-ref) - (:translate sap-ref-16) - (:variant 0)) - -(define-vop (signed-16bit-system-ref signed-halfword-index-ref) - (:variant 0)) - -(define-vop (16bit-system-set halfword-index-set) - (:translate (setf sap-ref-16)) - (:variant 0)) - -(define-vop (8bit-system-ref byte-index-ref) - (:translate sap-ref-8) - (:variant 0)) - -(define-vop (8bit-system-set byte-index-set) - (:translate (setf sap-ref-8)) - (:variant 0)) - - -(define-vop (current-sp) - (:results (val :scs (any-reg descriptor-reg))) - (:generator 1 - (inst lr val sp-tn))) - -;;; This guy makes sure that there aren't any random garbage pointers lying -;;; around in registers by clearing all of the boxed registers. Our allocating -;;; all of the boxed registers as temporaries will prevent any TNs from being -;;; packed in those registers at the time this VOP is invoked. -;;; -(define-vop (clear-registers) - (:temporary (:sc any-reg :offset 1) a0) - (:temporary (:sc any-reg :offset 3) a1) - (:temporary (:sc any-reg :offset 5) a2) - (:temporary (:sc any-reg :offset 4) t0) - (:temporary (:sc any-reg :offset 7) l0) - (:temporary (:sc any-reg :offset 8) l1) - (:temporary (:sc any-reg :offset 9) l2) - (:temporary (:sc any-reg :offset 10) l3) - (:temporary (:sc any-reg :offset 11) l4) - (:generator 10 - (inst lis a0 0) - (inst lis a1 0) - (inst lis a2 0) - (inst lis t0 0) - (inst lis l0 0) - (inst lis l1 0) - (inst lis l2 0) - (inst lis l3 0) - (inst lis l4 0))) diff --git a/compiler/old-rt/type-vops.lisp b/compiler/old-rt/type-vops.lisp deleted file mode 100644 index 85bb1ed1454bd9369bad3858ccbf65f602645145..0000000000000000000000000000000000000000 --- a/compiler/old-rt/type-vops.lisp +++ /dev/null @@ -1,287 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of type testing and checking VOPs -;;; for the RT. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;;; Simple type checking and testing: -;;; -;;; These types are represented by a single type code, so are easily -;;; open-coded as non-shifting type test. - -(define-vop (check-simple-type) - (:args - (value :target result - :scs (any-reg descriptor-reg))) - (:results - (result :scs (any-reg descriptor-reg))) - (:variant-vars type-code error-code) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:generator 4 - (let ((err-lab (generate-error-code vop error-code value))) - (test-simple-type value temp err-lab t type-code) - (unless (location= value result) - (inst lr result value))))) - -(define-vop (simple-type-predicate) - (:args - (value :scs (any-reg descriptor-reg))) - (:conditional) - (:info target not-p) - (:variant-vars type-code) - (:policy :fast-safe) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:generator 4 - (test-simple-type value temp target not-p type-code))) - - -(macrolet ((frob (pred-name check-name ptype type-code error-code) - `(progn - (define-vop (,pred-name simple-type-predicate) - (:variant ,type-code) - (:translate ,pred-name)) - - ,@(when check-name - `((define-vop (,check-name check-simple-type) - (:variant ,type-code ,error-code)) - (primitive-type-vop ,check-name (:check) ,ptype)))))) - - (frob array-header-p nil nil system:%array-type nil) - - (frob simple-string-p check-simple-string simple-string - system:%string-type clc::error-object-not-simple-string) - - (frob simple-vector-p check-simple-vector simple-vector - system:%general-vector-type clc::error-object-not-simple-vector) - - (frob simple-bit-vector-p check-simple-bit-vector simple-bit-vector - system:%bit-vector-type clc::error-object-not-simple-bit-vector) - - (frob functionp check-function function - system:%function-type clc::error-illegal-function) - - (frob listp check-list list system:%list-type clc::error-not-list) - - (frob long-float-p check-long-float long-float - system:%long-float-type clc::error-object-not-long-float) - - (frob %string-char-p check-string-char string-char - system:%string-char-type clc::error-object-not-string-char) - - (frob bignump nil bignum system:%bignum-type nil) - (frob ratiop nil ratio system:%ratio-type nil) - (frob complexp nil complex system:%complex-type nil)) - -#| -simple-integer-vector-p? -|# - - - -;;;; Type checking and testing via miscops: -;;; -;;; These operations seem too complex to be worth open-coding. - -(macrolet ((frob (name) - `(define-vop (,name one-arg-conditional-miscop) - (:translate ,name) - (:variant ',name :eq)))) - (frob vectorp) - (frob stringp) - (frob bit-vector-p)) - - -;;;; Hairy type tests: -;;; -;;; These types are represented by a union of type codes. -;;; - -(define-vop (hairy-type-predicate) - (:args - (obj :scs (any-reg descriptor-reg) - :target temp)) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:scs (any-reg) - :type fixnum - :from (:argument 0)) - temp)) - -(define-vop (check-hairy-type) - (:args - (obj :scs (any-reg descriptor-reg) - :target res)) - (:results - (res :scs (any-reg descriptor-reg))) - (:temporary (:scs (any-reg) :type fixnum) temp) - (:vop-var vop) - (:save-p :compute-only)) - - -(macrolet ((frob (pred-name check-name error-code &rest types) - (let ((cost (* (+ (length types) - (count-if #'consp types)) - 4))) - `(progn - ,@(when pred-name - `((define-vop (,pred-name hairy-type-predicate) - (:translate ,pred-name) - (:generator ,cost - (test-hairy-type obj temp target not-p ,@types))))) - - ,@(when check-name - `((define-vop (,check-name check-hairy-type) - (:generator ,cost - (let ((err-lab (generate-error-code - vop ,error-code obj))) - (test-hairy-type obj temp err-lab t ,@types)) - (unless (location= obj res) - (inst lr res obj)))))))))) - - (frob nil check-function-or-symbol clc::error-object-not-function-or-symbol - system:%function-type system:%symbol-type) - - (frob arrayp nil nil (system:%string-type system:%array-type)) - - (frob numberp nil nil - system:%+-fixnum-type system:%--fixnum-type - (system:%bignum-type system:%long-float-type)) - - (frob rationalp nil nil - system:%+-fixnum-type system:%--fixnum-type - system:%ratio-type system:%bignum-type) - - (frob floatp nil nil (system:%short-+-float-type system:%long-float-type)) - - (frob integerp nil nil - system:%+-fixnum-type system:%--fixnum-type system:%bignum-type) - - (frob characterp nil nil system:%bitsy-char-type system:%string-char-type) - - (frob fixnump check-fixnum clc::error-object-not-fixnum - system:%+-fixnum-type system:%--fixnum-type) - - (frob short-float-p check-short-float clc::error-object-not-short-float - system:%short---float-type system:%short-+-float-type)) - -(primitive-type-vop check-fixnum (:check) fixnum) -(primitive-type-vop check-short-float (:check) short-float) - - -;;;; List/symbol types: - - -;;; symbolp (or symbol (eq nil)) -;;; consp (and list (not (eq nil))) - -(define-vop (list-symbol-predicate) - (:args - (obj :scs (any-reg descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:type random :scs (non-descriptor-reg)) temp))) - -(define-vop (check-list-symbol check-hairy-type) - (:temporary (:type random :scs (non-descriptor-reg)) temp)) - - -(macrolet ((frob (pred-name check-name error-code &rest body) - `(progn - (define-vop (,pred-name list-symbol-predicate) - (:translate ,pred-name) - (:generator 12 - ,@body)) - (define-vop (,check-name check-list-symbol) - (:generator 12 - (let ((target (generate-error-code vop ,error-code obj)) - (not-p t)) - ,@body - (unless (location= obj res) - (inst lr res obj)))))))) - - (frob symbolp check-symbol clc::error-not-symbol - (let* ((drop-thru (gen-label)) - (in-lab (if not-p drop-thru target))) - (test-simple-type obj temp in-lab nil system:%symbol-type) - (test-special-value obj temp nil target not-p) - (emit-label drop-thru))) - - (frob consp check-cons clc::error-object-not-cons - (let* ((drop-thru (gen-label)) - (out-lab (if not-p target drop-thru))) - (test-simple-type obj temp out-lab t system:%list-type) - (test-special-value obj temp nil target (not not-p)) - (emit-label drop-thru)))) - - -;;;; Function coercion: - -;;; If not a function, get the symbol value and test for that being a function. -;;; Since we test for a function rather than the unbound marker, this works on -;;; NIL. -;;; -(define-vop (fast-safe-coerce-to-function) - (:args (thing :scs (descriptor-reg) - :target res)) - (:results (res :scs (descriptor-reg))) - (:node-var node) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg)) thing-temp) - (:generator 0 - (let ((not-fun-lab (gen-label)) - (done-lab (gen-label))) - (test-simple-type thing temp not-fun-lab t system:%function-type) - (unless (location= thing res) - (inst lr res thing)) - (emit-label done-lab) - - (unassemble - (assemble-elsewhere node - (emit-label not-fun-lab) - (inst lr thing-temp thing) - (loadw res thing (/ clc::symbol-definition 4)) - (test-simple-type res temp done-lab nil system:%function-type) - (error-call clc::error-symbol-undefined thing-temp)))))) - - -(define-vop (coerce-to-function) - (:args (thing :scs (descriptor-reg) - :target res)) - (:results (res :scs (descriptor-reg))) - (:node-var node) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg)) thing-temp) - (:generator 0 - (let ((not-fun-lab (gen-label)) - (done-lab (gen-label)) - (not-sym-lab (gen-label))) - (test-simple-type thing temp not-fun-lab t system:%function-type) - (unless (location= thing res) - (inst lr res thing)) - (emit-label done-lab) - - (unassemble - (assemble-elsewhere node - (emit-label not-fun-lab) - (test-simple-type thing temp not-sym-lab t system:%symbol-type) - (inst lr thing-temp thing) - (loadw res thing (/ clc::symbol-definition 4)) - (test-simple-type res temp done-lab nil system:%function-type) - (error-call clc::error-symbol-undefined thing-temp) - - (emit-label not-sym-lab) - (error-call clc::error-object-not-function-or-symbol thing)))))) diff --git a/compiler/old-rt/values.lisp b/compiler/old-rt/values.lisp deleted file mode 100644 index 0e857351621dac1dd82e7f8f9a1e15b6b73a8931..0000000000000000000000000000000000000000 --- a/compiler/old-rt/values.lisp +++ /dev/null @@ -1,64 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the implementation of unknown-values VOPs. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(define-vop (reset-stack-pointer) - (:args (ptr :scs (any-reg descriptor-reg))) - (:generator 1 - (inst lr sp-tn ptr))) - - -;;; Push some values onto the stack, returning the start and number of values -;;; pushed as results. It is assumed that the Vals are wired to the standard -;;; argument locations. Nvals is the number of values to push. -;;; -;;; The generator cost is pseudo-random. We could get it right by defining a -;;; bogus SC that reflects the costs of the memory-to-memory moves for each -;;; operand, but this seems unworthwhile. -;;; -(define-vop (push-values) - (:args - (vals :more t)) - (:results - (start :scs (descriptor-reg)) - (count :scs (any-reg descriptor-reg))) - (:info nvals) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) - :to (:result 0) - :target start) - start-temp) - (:generator 20 - (inst lr start-temp sp-tn) - (inst cal sp-tn sp-tn (* nvals 4)) - (do ((val vals (tn-ref-across val)) - (i 0 (1+ i))) - ((null val)) - (let ((tn (tn-ref-tn val))) - (sc-case tn - (descriptor-reg - (storew tn start-temp i)) - (stack - (load-stack-tn temp tn) - (storew temp start-temp i))))) - (unless (location= start-temp start) - (inst lr start start-temp)) - (loadi count nvals))) - - -;;; Push a list of values on the stack, returning Start and Count as used in -;;; unknown values continuations. -;;; -(define-vop (values-list one-arg-two-value-miscop) - (:variant 'clc::values-list)) diff --git a/compiler/old-rt/vm-tran.lisp b/compiler/old-rt/vm-tran.lisp deleted file mode 100644 index 507223e7404f907b33960008e76c61361efe85f3..0000000000000000000000000000000000000000 --- a/compiler/old-rt/vm-tran.lisp +++ /dev/null @@ -1,103 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains impelemtentation-dependent transforms, IR2 convert -;;; methods, etc. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;; We need to define these predicates, since the TYPEP source transform picks -;;; whichever predicate was defined last when there are multiple predicates for -;;; equivalent types. -;;; -(def-source-transform single-float-p (x) `(short-float-p ,x)) -(def-source-transform double-float-p (x) `(long-float-p ,x)) - - -;;; Some hacks to let us implement structures as simple-vectors without -;;; confusing type inference too much. -;;; -(def-builtin-type 'structure-vector - (make-named-type :name 'structure-vector - :supertypes '(structure-vector t) - :subclasses '(structure))) - -(defknown structure-vector-p (t) boolean) - -(define-type-predicate structure-vector-p structure-vector) - -(def-source-transform structurep (x) - (once-only ((n-x x)) - `(and (structure-vector-p ,n-x) - (eql (%primitive get-vector-subtype ,n-x) - system:%g-vector-structure-subtype)))) - -(define-vop (structure-vector-p simple-vector-p) - (:translate structure-vector-p)) - -#-new-compiler -(set 'lisp::type-pred-alist - (adjoin (cons 'structure-vector 'simple-vector-p) - (symbol-value 'lisp::type-pred-alist) - :key #'car)) - -(def-source-transform compiled-function-p (x) - `(functionp ,x)) - -(def-source-transform char-int (x) - `(truly-the char-int (%primitive make-fixnum ,x))) - - -;;;; Funny function implementations: - -;;; Convert these funny functions into a %Primitive use, letting %Primitive -;;; deal with evaluating the "Fixed" codegen-info arguments. -;;; -(def-source-transform %more-arg-context (&rest foo) - `(%primitive more-arg-context ,@foo)) -;;; -(def-source-transform %verify-argument-count (&rest foo) - `(%primitive verify-argument-count ,@foo)) - - -;;; Error funny functions: -;;; -;;; Mark these as as not returning by using TRULY-THE NIL. - -(def-source-transform %type-check-error (obj type) - `(truly-the nil (%primitive error2 clc::error-object-not-type ,obj ,type))) - -(def-source-transform %odd-keyword-arguments-error () - '(truly-the nil (%primitive error0 clc::error-odd-keyword-arguments))) - -(def-source-transform %unknown-keyword-argument-error (key) - `(truly-the nil (%primitive error1 clc::error-unknown-keyword-argument ,key))) - -(def-source-transform %argument-count-error (&rest foo) - `(truly-the nil (%primitive argument-count-error ,@foo))) - - -;;;; Syscall: - -(def-primitive-translator syscall (&rest args) `(%syscall ,@args)) -(defknown %syscall (&rest t) *) - -(defoptimizer (%syscall ir2-convert) ((&rest args) node block) - (let* ((refs (move-tail-full-call-args node block)) - (cont (node-cont node)) - (res (continuation-result-tns - cont - (list *any-primitive-type* *any-primitive-type*)))) - (vop* syscall node block - (refs) - ((first res) (second res) nil) - (length args)) - (move-continuation-result node block res cont))) diff --git a/compiler/old-rt/vm-type.lisp b/compiler/old-rt/vm-type.lisp deleted file mode 100644 index 608b34f2b8caaf3824b7bad5cddc5e08e632e9ab..0000000000000000000000000000000000000000 --- a/compiler/old-rt/vm-type.lisp +++ /dev/null @@ -1,137 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains implementation-dependent parts of the type support -;;; code. This is stuff which deals with the mapping from types defined in -;;; Common Lisp to types actually supported by an implementation. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;;; Implementation dependent deftypes: - -;;; Make double-float a synonym for long-float, single-float for Short-Float. -;;; This is be expanded before the translator gets a chance, so we will get -;;; precedence. -;;; -(deftype double-float (&optional low high) - `(long-float ,low ,high)) -;;; -(deftype single-float (&optional low high) - `(short-float ,low ,high)) - -;;; Compiled-function is the same as function in this implementation. -;;; -(deftype compiled-function () 'function) - -;;; -;;; An index into an integer. -(deftype bit-index () `(integer 0 ,most-positive-fixnum)) -;;; -;;; Offset argument to Ash (a signed bit index). -(deftype ash-index () 'fixnum) -;;; -;;; A lexical environment for macroexpansion. -(deftype lexical-environment () '(or list lisp::lexical-environment)) -;;; -;;; A full lexical environment. -(deftype full-lexical-environment () 'lisp::lexical-environment) -;;; -;;; Worst case values for float attributes. -;;; ### long-float exponent range seems to be this, but I don't know why. -;;; Perhaps IEEE double uses some of the negative exponents for NAN, etc? -;;; -(deftype float-exponent () '(integer -1021 1024)) -(deftype float-digits () '(unsigned-byte 6)) -(deftype float-radix () '(integer 2 2)) -;;; -;;; A code for Boole. -(deftype boole-code () '(unsigned-byte 4)) -;;; -;;; A byte-specifier. -(deftype byte-specifier () 'cons) -;;; -;;; Result of Char-Int... -(deftype char-int () '(unsigned-byte 16)) -;;; -;;; Legal character bit names: -(deftype bit-names () '(member :control :meta :super :hyper)) -;;; -;;; Pathname pieces, as returned by the PATHNAME-xxx functions. -(deftype pathname-host () '(or simple-string null)); Host not really supported... -(deftype pathname-device () '(or simple-string (member :absolute nil))) -(deftype pathname-directory () '(or simple-vector null)) -(deftype pathname-name () '(or simple-string null)) -(deftype pathname-type () '(or simple-string null)) -(deftype pathname-version () '(or simple-string (member nil :newest))) -;;; -;;; Internal time format. Not a fixnum (blag...) -(deftype internal-time () 'unsigned-byte) - - -;;;; Hooks into type system: - -;;; The kinds of specialised array that actually exist in this implementation. -;;; -(defparameter specialized-array-element-types - '(bit (unsigned-byte 2) (unsigned-byte 4) (unsigned-byte 8) (unsigned-byte 16) - (unsigned-byte 32) string-char)) - -;;; Float-Format-Name -- Internal -;;; -;;; Return the symbol that describes the format of Float. -;;; -(proclaim '(function float-format-name (float) symbol)) -(defun float-format-name (x) - (etypecase x - (short-float 'short-float) - (long-float 'long-float))) - -;;; Specialize-Array-Type -- Internal -;;; -;;; This function is called when the type code wants to find out how an -;;; array will actually be implemented. We set the Specialized-Element-Type to -;;; correspond to the actual specialization used in this implementation. -;;; -(proclaim '(function specialize-array-type (array-type) array-type)) -(defun specialize-array-type (type) - (let ((eltype (array-type-element-type type))) - - (setf (array-type-specialized-element-type type) - (if (eq eltype *wild-type*) - *wild-type* - (dolist (stype-name specialized-array-element-types - (specifier-type 't)) - (let ((stype (specifier-type stype-name))) - (when (csubtypep eltype stype) - (return stype)))))) - - type)) - - -;;; Hairy-Type-Check-Template -- Interface -;;; -;;; If Type has a CHECK-xxx template, but doesn't have a corresponding -;;; primitive-type, then return the template's name. Otherwise, return NIL. -;;; -(defun hairy-type-check-template (type) - (declare (type ctype type)) - (typecase type - (named-type - (case (named-type-name type) - (cons 'check-cons) - (symbol 'check-symbol) - (t nil))) - (union-type - (if (type= type (specifier-type '(or function symbol))) - 'check-function-or-symbol - nil)) - (t - nil))) diff --git a/compiler/old-rt/vm.lisp b/compiler/old-rt/vm.lisp deleted file mode 100644 index 963bce79d916a73c2d7152d6921f80faeb5432b7..0000000000000000000000000000000000000000 --- a/compiler/old-rt/vm.lisp +++ /dev/null @@ -1,386 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; This file contains the VM definition for the RT. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; SB and SC definition: - -(define-storage-base registers :finite :size 16) -(define-storage-base stack :unbounded :size 8) -(define-storage-base constant :non-packed) -(define-storage-base immediate-constant :non-packed) - -;;; -;;; Non-immediate constants in the constant pool. -(define-storage-class constant 6 constant) - -;;; Immediate numeric constants. A constant TN will be created in the -;;; most restrictive SC possible: -;;; -;;; short-immediate = (unsigned-byte 4) -;;; Self-explanatory: short-immediate operands on the RT are unsigned. -;;; -;;; unsigned-immediate = (unsigned-byte 15) -;;; Used for unsigned immediate operands. 15 instead of 16 so that this -;;; is a subtype of Immediate. -;;; -;;; immediate = (integer #x7FFF #x-7FFF) -;;; The funny lower bound guarantees that the negation of an immediate -;;; is still an immediate. -;;; -(define-storage-class short-immediate 7 immediate-constant) -(define-storage-class unsigned-immediate 8 immediate-constant) -(define-storage-class immediate 9 immediate-constant) - -;;; Allows simple loading of unboxed string-chars. -;;; -(define-storage-class immediate-string-char 10 immediate-constant) - -;;; Objects that are easier to create using immediate loads than to fetch -;;; from the constant pool, but which aren't directly usable as immediate -;;; operands. These are only recognized by move VOPs. -;;; -(define-storage-class random-immediate 11 immediate-constant) - -;;; -;;; Descriptor objects stored on the stack. -(define-storage-class stack 4 stack) - -;;; -;;; Untagged string-chars stored on the stack. -(define-storage-class string-char-stack 5 stack) - -;;; -;;; Objects that can be stored in any register (immediate objects). -(define-storage-class any-reg 0 registers - :locations (0 1 2 3 4 5 7 8 9 10 11 15) - :constant-scs (constant short-immediate unsigned-immediate immediate - immediate-string-char random-immediate) - :save-p t - :alternate-scs (stack)) - -;;; -;;; Pointer objects that must be seen by GC. -(define-storage-class descriptor-reg 1 registers - :locations (1 3 4 5 7 8 9 10 11 15) - :constant-scs (constant short-immediate unsigned-immediate immediate - immediate-string-char random-immediate) - :save-p t - :alternate-scs (stack)) - -;;; -;;; Objects that must not be seen by GC (unboxed numbers). -(define-storage-class non-descriptor-reg 2 registers - :locations (0 2)) - -;;; -;;; String-chars represented without tag bits (looks like a fixnum). -(define-storage-class string-char-reg 3 registers - :locations (0 1 2 3 4 5 7 8 9 10 11 15) - :constant-scs (immediate-string-char) - :save-p t - :alternate-scs (string-char-stack)) - -;;; A catch or unwind block. -;;; -(define-storage-class catch-block 12 stack - :element-size system:%catch-block-size) - - -;;;; Primitive type definition: -;;; -;;; For now, the primitive types we support are primarily for discrimination -;;; rather than representation selection. - -(def-primitive-type t (descriptor-reg)) -(defvar *any-primitive-type* (primitive-type-or-lose 't)) - -(def-primitive-type simple-string (descriptor-reg)) -(def-primitive-type simple-vector (descriptor-reg)) -(def-primitive-type simple-bit-vector (descriptor-reg)) - -(def-primitive-type string-char (string-char-reg any-reg)) -(def-primitive-type fixnum (any-reg)) -(def-primitive-type short-float (any-reg)) -(def-primitive-type long-float (descriptor-reg)) -(def-primitive-type bignum (descriptor-reg)) -(def-primitive-type ratio (descriptor-reg)) -(def-primitive-type complex (descriptor-reg)) -(def-primitive-type function (descriptor-reg)) - -;;; We make List a primitive type, since it is useful for discrimination of -;;; generic sequence function arguments. This means that Cons and Symbol can't -;;; be primitive types. -(def-primitive-type list (descriptor-reg)) - -;;; Dummy primitive type for catch block TNs. -(def-primitive-type catch-block (catch-block) :type nil) - - -;;; Primitive-Type-Of -- Interface -;;; -;;; Return the most restrictive primitive type that contains Object. -;;; -(defun primitive-type-of (object) - (let ((type (ctype-of object))) - (cond ((not (member-type-p type)) (primitive-type type)) - ((equal (member-type-members type) '(nil)) - (primitive-type-or-lose 'list)) - (t *any-primitive-type*)))) - - -;;; PRIMITIVE-TYPE -- Interface -;;; -;;; Return the primitive type corresponding to a type descriptor structure. -;;; If a fixnum or an interesting simple vector, then return the appropriate -;;; type, otherwise return *any-primitive-type*. The second value is true when -;;; the primitive type is exactly equivalent to the argument Lisp type. -;;; -;;; In a bootstrapping situation, we should be careful to use the correct -;;; values for the system parameters. -;;; -;;; Note: DEFUN-CACHED caches this translation; If the primitive type -;;; translation is ever changed (due to hardware configuration switches, etc.), -;;; then PRIMITIVE-TYPE-CACHE-CLEAR must be called to clear old cached -;;; information. -;;; -(defun-cached (primitive-type - :hash-function (lambda (x) - (logand (cache-hash-eq x) #x1FF)) - :hash-bits 9 - :values 2 - :default (values nil :empty)) - ((type eq)) - (declare (type ctype type)) - (etypecase type - (named-type - (case (named-type-name type) - ((t bignum ratio string-char function) - (values (primitive-type-or-lose (named-type-name type)) t)) - (cons - (values (primitive-type-or-lose 'list) nil)) - (standard-char - (values (primitive-type-or-lose 'string-char) nil)) - (t - (values *any-primitive-type* nil)))) - (member-type - (let* ((members (member-type-members type)) - (res (primitive-type-of (first members)))) - (dolist (mem (rest members) (values res nil)) - (unless (eq (primitive-type-of mem) res) - (return (values *any-primitive-type* nil)))))) - (numeric-type - (if (not (eq (numeric-type-complexp type) :real)) - (values *any-primitive-type* nil) - (case (numeric-type-class type) - (integer - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (if (and hi lo - (>= lo most-negative-fixnum) - (<= hi most-positive-fixnum)) - (values (primitive-type-or-lose 'fixnum) - (and (= lo most-negative-fixnum) - (= hi most-positive-fixnum))) - (values *any-primitive-type* nil)))) - (t - (values *any-primitive-type* nil))))) - (array-type - (if (array-type-complexp type) - (values *any-primitive-type* nil) - (let ((dims (array-type-dimensions type)) - (etype (array-type-specialized-element-type type))) - (if (and (consp dims) (null (rest dims))) - (let ((len-wild (eq (first dims) '*))) - (case (type-specifier etype) - (string-char - (values (primitive-type-or-lose 'simple-string) - len-wild)) - (bit - (values (primitive-type-or-lose 'simple-bit-vector) - len-wild)) - ((t) - (values (primitive-type-or-lose 'simple-vector) - len-wild)) - (t - (values *any-primitive-type* nil)))) - (values *any-primitive-type* nil))))) - (union-type - (if (type= type (specifier-type 'list)) - (values (primitive-type-or-lose 'list) t) - (let ((types (union-type-types type))) - (multiple-value-bind (res exact) - (primitive-type (first types)) - (dolist (type (rest types) (values res exact)) - (multiple-value-bind (ptype ptype-exact) - (primitive-type type) - (unless ptype-exact (setq exact nil)) - (unless (eq ptype res) - (return (values *any-primitive-type* nil))))))))) - (function-type (values (primitive-type-or-lose 'function) t)) - (ctype - (values *any-primitive-type* nil)))) - - -;;;; Totally magical registers: - -;;; Pointer to the current frame: -(defparameter fp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset 13)) - -;;; Pointer to the current constant pool: -(defparameter env-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset 14)) - -;;; Pointer to the stack top: -(defparameter sp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset 6)) - -;;; Binding stack pointer: -(defparameter bs-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset 12)) - -;;; TN with 0 offset, used for 0/reg args when we want 0. -(defparameter zero-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset 0)) - - -;;;; Side-effect classes: - -(def-boolean-attribute vop - ;; - ;; Nothing for now... - any - ) - - -;;;; Constant creation: - -;;; Immediate-Constant-SC -- Interface -;;; -;;; If value can be represented as an immediate constant, then return the -;;; appropriate SC number, otherwise return NIL. -;;; -(defun immediate-constant-sc (value) - (typecase value - ((unsigned-byte 4) - (sc-number-or-lose 'short-immediate)) - ((unsigned-byte 15) - (sc-number-or-lose 'unsigned-immediate)) - ((integer #x-7FFF #x7FFF) - (sc-number-or-lose 'immediate)) - ((or fixnum (member nil t)) - (sc-number-or-lose 'random-immediate)) - (t - ;; - ;; ### hack around bug in (typep x 'string-char) - (if (and (characterp value) (string-char-p value)) - (sc-number-or-lose 'immediate-string-char) - nil)))) - - -;;;; Function call parameters: -;;; - -;;; The SC numbers for register and stack arguments/return values. -;;; -(defconstant register-arg-scn (sc-number-or-lose 'descriptor-reg)) -(defconstant stack-arg-scn (sc-number-or-lose 'stack)) - -;;; Offsets of special registers... -;;; -(eval-when (compile load eval) - (defconstant return-pc-offset 15) - (defconstant env-offset 14) - (defconstant argument-count-offset 0) - (defconstant argument-pointer-offset 11) - (defconstant old-fp-offset 10) - (defconstant sp-offset 6) - (defconstant call-name-offset 9)) - -;;; Offsets of special stack frame locations... -;;; -(eval-when (compile load eval) - (defconstant old-fp-save-offset 0) - (defconstant return-pc-save-offset 1) - (defconstant env-save-offset 2)) - - -(defparameter nargs-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset argument-count-offset)) - -(defparameter old-fp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset old-fp-offset)) - -(defparameter pc-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset return-pc-offset)) - - -(eval-when (compile load eval) - -;;; The offsets within the register-arg SC that we pass values in, first -;;; value first. -;;; -(defconstant register-arg-offsets '(1 3 5)) - -;;; The number of arguments/return values passed in registers. -;;; -(defconstant register-arg-count 3) - -;;; The fourth register argument (used only in miscop calls). -;;; -(defconstant a3-offset 4) - -); Eval-When (Compile Load Eval) - - -;;; A list of TNs describing the register arguments. -;;; -(defparameter register-argument-tns - (mapcar #'(lambda (n) - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset n)) - register-arg-offsets)) - - -;;; LOCATION-PRINT-NAME -- Interface -;;; -;;; This function is called by debug output routines that want a pretty name -;;; for a TN's location. It returns a thing that can be printed with PRINC. -;;; -(defun location-print-name (tn) - (declare (type tn tn)) - (let ((sb (sb-name (sc-sb (tn-sc tn))))) - (if (eq sb 'registers) - (svref '#(NL0 A0 NL1 A1 A3 A2 SP L0 L1 L2 L3 L4 - BS CONT ENV PC) - (tn-offset tn)) - (format nil "~A~D" (char (string sb) 0) (tn-offset tn))))) diff --git a/compiler/pack.lisp b/compiler/pack.lisp deleted file mode 100644 index 87a0c985c68d65f6ff0a72c2595ddc581b55a446..0000000000000000000000000000000000000000 --- a/compiler/pack.lisp +++ /dev/null @@ -1,1555 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/pack.lisp,v 1.45 1992/05/03 21:45:55 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the implementation independent code for Pack phase in -;;; the compiler. Pack is responsible for assigning TNs to storage allocations -;;; or "register allocation". -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;; Some parameters controlling which optimizations we attempt (for debugging.) -;;; -(defparameter pack-assign-costs t) -(defparameter pack-optimize-saves t) -(defparameter pack-save-once t) - - -;;;; Conflict determination: - - -;;; Offset-Conflicts-In-SB -- Internal -;;; -;;; Return true if the element at the specified offset in SB has a conflict -;;; with TN: -;;; -- If an component-live TN (:component kind), then iterate over all the -;;; blocks. If the element at Offset is used anywhere in any of the -;;; component's blocks (always-live /= 0), then there is a conflict. -;;; -- If TN is global (Confs true), then iterate over the blocks TN is live in -;;; (using TN-Global-Conflicts). If the TN is live everywhere in the block -;;; (:Live), then there is a conflict if the element at offset is used -;;; anywhere in the block (Always-Live /= 0). Otherwise, we use the local -;;; TN number for TN in block to find whether TN has a conflict at Offset in -;;; that block. -;;; -- If TN is local, then we just check for a conflict in the block it is -;;; local to. -;;; -(defun offset-conflicts-in-sb (tn sb offset) - (declare (type tn tn) (type finite-sb sb) (type index offset)) - (let ((confs (tn-global-conflicts tn)) - (kind (tn-kind tn))) - (cond - ((eq kind :component) - (let ((loc-live (svref (finite-sb-always-live sb) offset))) - (dotimes (i (ir2-block-count *compile-component*) nil) - (when (/= (sbit loc-live i) 0) - (return t))))) - (confs - (let ((loc-confs (svref (finite-sb-conflicts sb) offset)) - (loc-live (svref (finite-sb-always-live sb) offset))) - (do ((conf confs (global-conflicts-tn-next conf))) - ((null conf) - nil) - (let* ((block (global-conflicts-block conf)) - (num (ir2-block-number block))) - (if (eq (global-conflicts-kind conf) :live) - (when (/= (sbit loc-live num) 0) - (return t)) - (when (/= (sbit (svref loc-confs num) - (global-conflicts-number conf)) - 0) - (return t))))))) - (t - (/= (sbit (svref (svref (finite-sb-conflicts sb) offset) - (ir2-block-number (tn-local tn))) - (tn-local-number tn)) - 0))))) - - -;;; Conflicts-In-SC -- Internal -;;; -;;; Return true if TN has a conflict in SC at the specified offset. -;;; -(defun conflicts-in-sc (tn sc offset) - (declare (type tn tn) (type sc sc) (type index offset)) - (let ((sb (sc-sb sc))) - (dotimes (i (sc-element-size sc) nil) - (when (offset-conflicts-in-sb tn sb (+ offset i)) - (return t))))) - - -;;; Add-Location-Conflicts -- Internal -;;; -;;; Add TN's conflicts into the conflicts for the location at Offset in SC. -;;; We iterate over each location in TN, adding to the conflicts for that -;;; location: -;;; -- If TN is a :Component TN, then iterate over all the blocks, setting -;;; all of the local conflict bits and the always-live bit. This records a -;;; conflict with any TN that has a LTN number in the block, as well as with -;;; :Always-Live and :Environment TNs. -;;; -- If TN is global, then iterate over the blocks TN is live in. In -;;; addition to setting the always-live bit to represent the conflict with -;;; TNs live throughout the block, we also set bits in the local conflicts. -;;; If TN is :Always-Live in the block, we set all the bits, otherwise we or -;;; in the local conflict bits. -;;; -- If the TN is local, then we just do the block it is local to, setting -;;; always-live and OR'ing in the local conflicts. -;;; -(defun add-location-conflicts (tn sc offset) - (declare (type tn tn) (type sc sc) (type index offset)) - (let ((confs (tn-global-conflicts tn)) - (sb (sc-sb sc)) - (kind (tn-kind tn))) - (dotimes (i (sc-element-size sc)) - (let* ((this-offset (+ offset i)) - (loc-confs (svref (finite-sb-conflicts sb) this-offset)) - (loc-live (svref (finite-sb-always-live sb) this-offset))) - (cond - ((eq kind :component) - (dotimes (num (ir2-block-count *compile-component*) nil) - (setf (sbit loc-live num) 1) - (set-bit-vector (svref loc-confs num)))) - (confs - (do ((conf confs (global-conflicts-tn-next conf))) - ((null conf)) - (let* ((block (global-conflicts-block conf)) - (num (ir2-block-number block)) - (local-confs (svref loc-confs num))) - (declare (type local-tn-bit-vector local-confs)) - (setf (sbit loc-live num) 1) - (if (eq (global-conflicts-kind conf) :live) - (set-bit-vector local-confs) - (bit-ior local-confs (global-conflicts-conflicts conf) t))))) - (t - (let ((num (ir2-block-number (tn-local tn)))) - (setf (sbit loc-live num) 1) - (bit-ior (the local-tn-bit-vector (svref loc-confs num)) - (tn-local-conflicts tn) t)))))))) - - -;;; IR2-BLOCK-COUNT -- Internal -;;; -;;; Return the total number of IR2 blocks in Component. -;;; -(defun ir2-block-count (component) - (declare (type component component)) - (do ((2block (block-info (block-next (component-head component))) - (ir2-block-next 2block))) - ((null 2block) - (error "What? No ir2 blocks have a non-nil number?")) - (when (ir2-block-number 2block) - (return (1+ (ir2-block-number 2block)))))) - - -;;; Init-SB-Vectors -- Internal -;;; -;;; Ensure that the conflicts vectors for each :Finite SB are large enough -;;; for the number of blocks allocated. Also clear any old conflicts and reset -;;; the current size to the initial size. -;;; -(defun init-sb-vectors (component) - (let ((nblocks (ir2-block-count component))) - (dolist (sb (backend-sb-list *backend*)) - (unless (eq (sb-kind sb) :non-packed) - (let* ((conflicts (finite-sb-conflicts sb)) - (always-live (finite-sb-always-live sb)) - (max-locs (length conflicts))) - (unless (zerop max-locs) - (let ((current-size (length (the simple-vector - (svref conflicts 0))))) - (when (> nblocks current-size) - (let ((new-size (max nblocks (* current-size 2)))) - (dotimes (i (length conflicts)) - (let ((new-vec (make-array new-size))) - (dotimes (j new-size) - (setf (svref new-vec j) - (make-array local-tn-limit :element-type 'bit))) - (setf (svref conflicts i) new-vec)) - (setf (svref always-live i) - (make-array new-size :element-type 'bit)))))) - - (dotimes (i (length conflicts)) - (let ((conf (svref conflicts i))) - (dotimes (j (length conf)) - (clear-bit-vector (svref conf j)))) - (clear-bit-vector (svref always-live i))))) - - (setf (finite-sb-current-size sb) (sb-size sb)) - (setf (finite-sb-last-offset sb) 0))))) - - -;;; Grow-SC -- Internal -;;; -;;; Expand the :Unbounded SB backing SC by either the initial size or the SC -;;; element size, whichever is larger. If Needed-Size is larger, then use that -;;; size. -;;; -(defun grow-sc (sc &optional (needed-size 0)) - (declare (type sc sc)) - (let* ((sb (sc-sb sc)) - (size (finite-sb-current-size sb)) - (inc (max (sb-size sb) - (+ (sc-element-size sc) - (- (* (ceiling size (sc-alignment sc)) - (sc-alignment sc)) - size)) - (- needed-size size))) - (new-size (+ size inc)) - (conflicts (finite-sb-conflicts sb)) - (block-size (if (zerop (length conflicts)) - (ir2-block-count *compile-component*) - (length (the simple-vector (svref conflicts 0)))))) - (assert (eq (sb-kind sb) :unbounded)) - - (when (> new-size (length conflicts)) - (let ((new-conf (make-array new-size))) - (replace new-conf conflicts) - (do ((i size (1+ i))) - ((= i new-size)) - (let ((loc-confs (make-array block-size))) - (dotimes (j block-size) - (setf (svref loc-confs j) - (make-array local-tn-limit - :initial-element 0 - :element-type 'bit))) - (setf (svref new-conf i) loc-confs))) - (setf (finite-sb-conflicts sb) new-conf)) - - (let ((new-live (make-array new-size))) - (replace new-live (finite-sb-always-live sb)) - (do ((i size (1+ i))) - ((= i new-size)) - (setf (svref new-live i) - (make-array block-size - :initial-element 0 - :element-type 'bit))) - (setf (finite-sb-always-live sb) new-live)) - - (let ((new-tns (make-array new-size :initial-element nil))) - (replace new-tns (finite-sb-live-tns sb)) - (fill (finite-sb-live-tns sb) nil) - (setf (finite-sb-live-tns sb) new-tns))) - - (setf (finite-sb-current-size sb) new-size)) - (undefined-value)) - - -;;; This variable is true whenever we are in pack (and thus the per-SB -;;; conflicts information is in use.) -;;; -(defvar *in-pack* nil) - - -;;; Pack-Before-GC-Hook -- Internal -;;; -;;; In order to prevent the conflict data structures from growing -;;; arbitrarily large, we clear them whenever a GC happens and we aren't -;;; currently in pack. We revert to the initial number of locations and 0 -;;; blocks. -;;; -(defun pack-before-gc-hook () - (unless *in-pack* - (dolist (sb (backend-sb-list *backend*)) - (unless (eq (sb-kind sb) :non-packed) - (let ((size (sb-size sb))) - (fill nil (finite-sb-always-live sb)) - (setf (finite-sb-always-live sb) - (make-array size :initial-element #*)) - - (fill nil (finite-sb-conflicts sb)) - (setf (finite-sb-conflicts sb) - (make-array size :initial-element '#())) - - (fill nil (finite-sb-live-tns sb)) - (setf (finite-sb-live-tns sb) - (make-array size :initial-element nil)))))) - (undefined-value)) - -(pushnew 'pack-before-gc-hook ext:*before-gc-hooks*) - - -;;;; Internal errors: - -;;; NO-LOAD-FUNCTION-ERROR -- Internal -;;; -;;; Give someone a hard time because there isn't any load function defined -;;; to move from Src to Dest. -;;; -(defun no-load-function-error (src dest) - (let* ((src-sc (tn-sc src)) - (src-name (sc-name src-sc)) - (dest-sc (tn-sc dest)) - (dest-name (sc-name dest-sc))) - (cond ((eq (sb-kind (sc-sb src-sc)) :non-packed) - (unless (member src-sc (sc-constant-scs dest-sc)) - (error "Loading from an invalid constant SC?~@ - VM definition inconsistent, try recompiling.")) - (error "No load function defined to load SC ~S ~ - from its constant SC ~S." - dest-name src-name)) - ((member src-sc (sc-alternate-scs dest-sc)) - (error "No load function defined to load SC ~S from its ~ - alternate SC ~S." - dest-name src-name)) - ((member dest-sc (sc-alternate-scs src-sc)) - (error "No load function defined to save SC ~S in its ~ - alternate SC ~S." - src-name dest-name)) - (t - (error "Loading to/from SCs that aren't alternates?~@ - VM definition inconsistent, try recompiling."))))) - - -;;; FAILED-TO-PACK-ERROR -- Internal -;;; -;;; Called when we failed to pack TN. If Restricted is true, then we we -;;; restricted to pack TN in its SC. -;;; -(defun failed-to-pack-error (tn restricted) - (declare (type tn tn)) - (let* ((sc (tn-sc tn)) - (scs (cons sc (sc-alternate-scs sc)))) - (cond - (restricted - (error "Failed to pack restricted TN ~S in its SC ~S." - tn (sc-name sc))) - (t - (assert (not (find :unbounded scs - :key #'(lambda (x) (sb-kind (sc-sb x)))))) - (let ((ptype (tn-primitive-type tn))) - (cond - (ptype - (assert (member (sc-number sc) (primitive-type-scs ptype))) - (error "SC ~S doesn't have any :Unbounded alternate SCs, but is~@ - a SC for primitive-type ~S." - (sc-name sc) (primitive-type-name ptype))) - (t - (error "SC ~S doesn't have any :Unbounded alternate SCs." - (sc-name sc)))))))) - (undefined-value)) - - -;;; DESCRIBE-TN-USE -- Internal -;;; -;;; Return a list of format arguments describing how TN is used in Op's VOP. -;;; -(defun describe-tn-use (loc tn op) - (let* ((vop (tn-ref-vop op)) - (args (vop-args vop)) - (results (vop-results vop)) - (name (with-output-to-string (stream) - (print-tn tn stream))) - temp) - (cond - ((setq temp (position-in #'tn-ref-across tn args :key #'tn-ref-tn)) - `("~2D: ~A (~:R argument)" ,loc ,name ,(1+ temp))) - ((setq temp (position-in #'tn-ref-across tn results :key #'tn-ref-tn)) - `("~2D: ~A (~:R result)" ,loc ,name ,(1+ temp))) - ((setq temp (position-in #'tn-ref-across tn args :key #'tn-ref-load-tn)) - `("~2D: ~A (~:R argument load TN)" ,loc ,name ,(1+ temp))) - ((setq temp (position-in #'tn-ref-across tn results :key - #'tn-ref-load-tn)) - `("~2D: ~A (~:R result load TN)" ,loc ,name ,(1+ temp))) - ((setq temp (position-in #'tn-ref-across tn (vop-temps vop) - :key #'tn-ref-tn)) - `("~2D: ~A (temporary ~A)" ,loc ,name - ,(operand-parse-name (elt (vop-parse-temps - (vop-parse-or-lose - (vop-info-name (vop-info vop)))) - temp)))) - ((eq (tn-kind tn) :component) - `("~2D: ~A (component live)" ,loc ,name)) - (t - `("~2D: not referenced?" ,loc))))) - - -;;; FAILED-TO-PACK-LOAD-TN-ERROR -- Internal -;;; -;;; If load TN packing fails, try to give a helpful error message. We find -;;; a TN in each location that conflicts, and print it. -;;; -(defun failed-to-pack-load-tn-error (scs op) - (declare (list scs) (type tn-ref op)) - (collect ((used) - (unused)) - (dolist (sc scs) - (let* ((sb (sc-sb sc)) - (confs (finite-sb-live-tns sb))) - (assert (eq (sb-kind sb) :finite)) - (dolist (el (sc-locations sc)) - (let ((conf (load-tn-conflicts-in-sc op sc el t))) - (if conf - (used (describe-tn-use el conf op)) - (loop for i from el - as victim = (svref confs i) - repeat (sc-element-size sc) do - (when (and victim (eq (tn-kind victim) :component)) - (used (describe-tn-use el victim op)) - (return t)) - finally (unused el))))))) - - (multiple-value-bind (arg-p n more-p costs load-scs incon) - (get-operand-info op) - (declare (ignore costs load-scs)) - (assert (not more-p)) - (error "Unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~ - for the ~:R ~:[result~;argument~] to~@ - the ~S VOP,~@ - ~:[since all SC elements are in use:~:{~%~@?~}~%~;~ - ~:*but these SC elements are not in use:~% ~S~%Bug?~*~]~ - ~:[~;~@ - Current cost info inconsistent with that in effect at compile ~ - time. Recompile.~%Compilation order may be incorrect.~]" - (mapcar #'sc-name scs) - n arg-p - (vop-info-name (vop-info (tn-ref-vop op))) - (unused) (used) - incon))) - (undefined-value)) - - -;;; NO-LOAD-SCS-ALLOWED-BY-PRIMITIVE-TYPE-ERROR -- Internal -;;; -;;; Called when none of the SCs that we can load Op into are allowed by Op's -;;; primitive-type. -;;; -(defun no-load-scs-allowed-by-primitive-type-error (ref) - (declare (type tn-ref ref)) - (let* ((tn (tn-ref-tn ref)) - (ptype (tn-primitive-type tn))) - (multiple-value-bind (arg-p pos more-p costs load-scs incon) - (get-operand-info ref) - (declare (ignore costs)) - (assert (not more-p)) - (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~ - ~% ~S,~@ - since the TN's primitive type ~S doesn't allow any of the SCs~@ - allowed by the operand restriction:~% ~S~ - ~:[~;~@ - Current cost info inconsistent with that in effect at compile ~ - time. Recompile.~%Compilation order may be incorrect.~]" - tn pos arg-p - (template-name (vop-info (tn-ref-vop ref))) - (primitive-type-name ptype) - (mapcar #'sc-name (listify-restrictions load-scs)) - incon))) - (undefined-value)) - - -;;;; Register saving: - -;;; Original-TN -- Internal -;;; -;;; If a save TN, return the saved TN, otherwise return TN. Useful for -;;; getting the conflicts of a TN that might be a save TN. -;;; -(defun original-tn (tn) - (declare (type tn tn)) - (if (member (tn-kind tn) '(:save :save-once :specified-save)) - (tn-save-tn tn) - tn)) - - -;;; Note-Spilled-TN -- Internal -;;; -;;; Do stuff to note that TN is spilled at VOP for the debugger's benefit. -;;; -(defun note-spilled-tn (tn vop) - (when (and (tn-leaf tn) (vop-save-set vop)) - (let ((2comp (component-info *compile-component*))) - (setf (gethash tn (ir2-component-spilled-tns 2comp)) t) - (pushnew tn (gethash vop (ir2-component-spilled-vops 2comp))))) - (undefined-value)) - - -;;; Pack-Save-TN -- Internal -;;; -;;; Make a save TN for TN, pack it, and return it. We copy various conflict -;;; information from the TN so that pack does the right thing. -;;; -(defun pack-save-tn (tn) - (declare (type tn tn)) - (let ((res (make-tn 0 :save nil nil))) - (dolist (alt (sc-alternate-scs (tn-sc tn)) - (error "No unbounded alternate for SC ~S." - (sc-name (tn-sc tn)))) - (when (eq (sb-kind (sc-sb alt)) :unbounded) - (setf (tn-save-tn tn) res) - (setf (tn-save-tn res) tn) - (setf (tn-sc res) alt) - (pack-tn res t) - (return res))))) - - -;;; EMIT-OPERAND-LOAD -- Internal -;;; -;;; Find the load function for moving from Src to Dest and emit a -;;; MOVE-OPERAND VOP with that function as its info arg. -;;; -(defun emit-operand-load (node block src dest before) - (declare (type node node) (type ir2-block block) - (type tn src dest) (type (or vop null) before)) - (emit-load-template node block - (template-or-lose 'move-operand *backend*) - src dest - (list (or (svref (sc-move-functions (tn-sc dest)) - (sc-number (tn-sc src))) - (no-load-function-error src dest))) - before) - (undefined-value)) - - -;;; REVERSE-FIND-VOP -- Internal -;;; -;;; Find the preceding use of the VOP NAME in the emit order, starting with -;;; VOP. We must find the VOP in the same IR1 block. -;;; -(defun reverse-find-vop (name vop) - (do* ((block (vop-block vop) (ir2-block-prev block)) - (last vop (ir2-block-last-vop block))) - (nil) - (assert (eq (ir2-block-block block) (ir2-block-block (vop-block vop)))) - (do ((current last (vop-prev current))) - ((null current)) - (when (eq (vop-info-name (vop-info current)) name) - (return-from reverse-find-vop current))))) - - -;;; Save-Complex-Writer-TN -- Internal -;;; -;;; For TNs that have other than one writer, we save the TN before each -;;; call. If a local call (MOVE-ARGS is :LOCAL-CALL), then we scan back for -;;; the ALLOCATE-FRAME VOP, and emit the save there. This is necessary because -;;; in a self-recursive local call, the registers holding the current arguments -;;; may get trashed by setting up the call arguments. The ALLOCATE-FRAME VOP -;;; marks a place at which the values are known to be good. -;;; -(defun save-complex-writer-tn (tn vop) - (let ((save (or (tn-save-tn tn) - (pack-save-tn tn))) - (node (vop-node vop)) - (block (vop-block vop)) - (next (vop-next vop))) - (when (eq (tn-kind save) :specified-save) - (setf (tn-kind save) :save)) - (assert (eq (tn-kind save) :save)) - (emit-operand-load node block tn save - (if (eq (vop-info-move-args (vop-info vop)) - :local-call) - (reverse-find-vop 'allocate-frame vop) - vop)) - (emit-operand-load node block save tn next))) - - -;;; FIND-SINGLE-WRITER -- Internal -;;; -;;; Return a VOP after which is an o.k. place to save the value of TN. For -;;; correctness, it is only required that this location be after any possible -;;; write and before any possible restore location. -;;; -;;; In practice, we return the unique writer VOP, but give up if the TN is -;;; ever read by a VOP with MOVE-ARGS :LOCAL-CALL. This prevents us from being -;;; confused by non-tail local calls. -;;; -;;; When looking for writes, we have to ignore uses of MOVE-OPERAND, since they -;;; will correspond to restores that we have already done. -;;; -(defun find-single-writer (tn) - (declare (type tn tn)) - (do ((write (tn-writes tn) (tn-ref-next write)) - (res nil)) - ((null write) - (when (and res - (loop for read = (tn-reads tn) then (tn-ref-next read) - while read - never (eq (vop-info-move-args - (vop-info - (tn-ref-vop read))) - :local-call))) - (tn-ref-vop res))) - - (unless (eq (vop-info-name (vop-info (tn-ref-vop write))) - 'move-operand) - (when res (return nil)) - (setq res write)))) - - -;;; Save-Single-Writer-TN -- Internal -;;; -;;; Try to save TN at a single location. If we succeed, return T, otherwise -;;; NIL. -;;; -(defun save-single-writer-tn (tn) - (declare (type tn tn)) - (let* ((old-save (tn-save-tn tn)) - (save (or old-save (pack-save-tn tn))) - (writer (find-single-writer tn))) - (when (and writer - (or (not old-save) - (eq (tn-kind old-save) :specified-save))) - (emit-operand-load (vop-node writer) (vop-block writer) - tn save (vop-next writer)) - (setf (tn-kind save) :save-once) - t))) - - -;;; RESTORE-SINGLE-WRITER-TN -- Internal -;;; -;;; Restore a TN with a :SAVE-ONCE save TN. -;;; -(defun restore-single-writer-tn (tn vop) - (declare (type tn) (type vop vop)) - (let ((save (tn-save-tn tn))) - (assert (eq (tn-kind save) :save-once)) - (emit-operand-load (vop-node vop) (vop-block vop) save tn (vop-next vop))) - (undefined-value)) - - -;;; BASIC-SAVE-TN -- Internal -;;; -;;; Save a single TN that needs to be saved, choosing save-once if -;;; appropriate. This is also called by SPILL-AND-PACK-LOAD-TN. -;;; -(defun basic-save-tn (tn vop) - (declare (type tn tn) (type vop vop)) - (let ((save (tn-save-tn tn))) - (cond ((and save (eq (tn-kind save) :save-once)) - (restore-single-writer-tn tn vop)) - ((save-single-writer-tn tn) - (restore-single-writer-tn tn vop)) - (t - (save-complex-writer-tn tn vop)))) - (undefined-value)) - - -;;; Emit-Saves -- Internal -;;; -;;; Scan over the VOPs in Block, emiting saving code for TNs noted in the -;;; codegen info that are packed into saved SCs. -;;; -(defun emit-saves (block) - (declare (type ir2-block block)) - (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop)) - (when (eq (vop-info-save-p (vop-info vop)) t) - (do-live-tns (tn (vop-save-set vop) block) - (when (and (sc-save-p (tn-sc tn)) - (not (eq (tn-kind tn) :component))) - (basic-save-tn tn vop))))) - - (undefined-value)) - - -;;;; Optimized saving: - - -;;; SAVE-IF-NECESSARY -- Internal -;;; -;;; Save TN if it isn't a single-writer TN that has already been saved. If -;;; multi-write, we insert the save Before the specified VOP. Context is a VOP -;;; used to tell which node/block to use for the new VOP. -;;; -(defun save-if-necessary (tn before context) - (declare (type tn tn) (type (or vop null) before) (type vop context)) - (let ((save (tn-save-tn tn))) - (when (eq (tn-kind save) :specified-save) - (setf (tn-kind save) :save)) - (assert (member (tn-kind save) '(:save :save-once))) - (unless (eq (tn-kind save) :save-once) - (or (save-single-writer-tn tn) - (emit-operand-load (vop-node context) (vop-block context) - tn save before)))) - (undefined-value)) - - -;;; RESTORE-TN -- Internal -;;; -;;; Load the TN from its save location, allocating one if necessary. The -;;; load is inserted Before the specifier VOP. Context is a VOP used to tell -;;; which node/block to use for the new VOP. -;;; -(defun restore-tn (tn before context) - (declare (type tn tn) (type (or vop null) before) (type vop context)) - (let ((save (or (tn-save-tn tn) (pack-save-tn tn)))) - (emit-operand-load (vop-node context) (vop-block context) - save tn before)) - (undefined-value)) - - -(eval-when (compile eval) - -;;; SAVE-NOTE-READ -- Internal -;;; -;;; Do stuff to note a read of TN, for OPTIMIZED-EMIT-SAVES-BLOCK. -;;; -(defmacro save-note-read (tn) - `(let* ((tn ,tn) - (num (tn-number tn))) - (when (and (sc-save-p (tn-sc tn)) - (zerop (sbit restores num)) - (not (eq (tn-kind tn) :component))) - (setf (sbit restores num) 1) - (push tn restores-list)))) - -); Eval-When (Compile Eval) - -;;; OPTIMIZED-EMIT-SAVES-BLOCK -- Internal -;;; -;;; Start scanning backward at the end of Block, looking which TNs are live -;;; and looking for places where we have to save. We manipulate two sets: -;;; SAVES and RESTORES. -;;; -;;; SAVES is a set of all the TNs that have to be saved because they are -;;; restored after some call. We normally delay saving until the beginning of -;;; the block, but we must save immediately if we see a write of the saved TN. -;;; We also immediately save all TNs and exit when we see a -;;; NOTE-ENVIRONMENT-START VOP, since saves can't be done before the -;;; environment is properly initialized. -;;; -;;; RESTORES is a set of all the TNs read (and not written) between here and -;;; the next call, i.e. the set of TNs that must be restored when we reach the -;;; next (earlier) call VOP. Unlike SAVES, this set is cleared when we do -;;; the restoring after a call. Any TNs that were in RESTORES are moved into -;;; SAVES to ensure that they are saved at some point. -;;; -;;; SAVES and RESTORES are represented using both a list and a bit-vector so -;;; that we can quickly iterate and test for membership. The incoming Saves -;;; and Restores args are used for computing these sets (the initial contents -;;; are ignored.) -;;; -;;; When we hit a VOP with :COMPUTE-ONLY Save-P (an internal error -;;; location), we pretend that all live TNs were read, unless (= speed 3), in -;;; which case we mark all the TNs that are live but not restored as spilled. -;;; -(defun optimized-emit-saves-block (block saves restores) - (declare (type ir2-block block) (type simple-bit-vector saves restores)) - (let ((1block (ir2-block-block block)) - (saves-list ()) - (restores-list ()) - (skipping nil)) - (clear-bit-vector saves) - (clear-bit-vector restores) - (do-live-tns (tn (ir2-block-live-in block) block) - (when (and (sc-save-p (tn-sc tn)) - (not (eq (tn-kind tn) :component))) - (let ((num (tn-number tn))) - (setf (sbit restores num) 1) - (push tn restores-list)))) - - (do ((block block (ir2-block-prev block)) - (prev nil block)) - ((not (eq (ir2-block-block block) 1block)) - (assert (not skipping)) - (dolist (save saves-list) - (let ((start (ir2-block-start-vop prev))) - (save-if-necessary save start start))) - prev) - (do ((vop (ir2-block-last-vop block) (vop-prev vop))) - ((null vop)) - (let ((info (vop-info vop))) - (case (vop-info-name info) - (allocate-frame - (assert skipping) - (setq skipping nil)) - (note-environment-start - (assert (not skipping)) - (dolist (save saves-list) - (save-if-necessary save (vop-next vop) vop)) - (return-from optimized-emit-saves-block block))) - - (unless skipping - (do ((write (vop-results vop) (tn-ref-across write))) - ((null write)) - (let* ((tn (tn-ref-tn write)) - (num (tn-number tn))) - (unless (zerop (sbit restores num)) - (setf (sbit restores num) 0) - (setq restores-list (delete tn restores-list))) - (unless (zerop (sbit saves num)) - (setf (sbit saves num) 0) - (save-if-necessary tn (vop-next vop) vop) - (setq saves-list (delete tn saves-list)))))) - - (case (vop-info-save-p info) - ((t) - (dolist (tn restores-list) - (restore-tn tn (vop-next vop) vop) - (let ((num (tn-number tn))) - (when (zerop (sbit saves num)) - (push tn saves-list) - (setf (sbit saves num) 1)))) - (setq restores-list nil) - (clear-bit-vector restores)) - (:compute-only - (cond ((policy (vop-node vop) (= speed 3)) - (do-live-tns (tn (vop-save-set vop) block) - (when (zerop (sbit restores (tn-number tn))) - (note-spilled-tn tn vop)))) - (t - (do-live-tns (tn (vop-save-set vop) block) - (save-note-read tn)))))) - - (if (eq (vop-info-move-args info) :local-call) - (setq skipping t) - (do ((read (vop-args vop) (tn-ref-across read))) - ((null read)) - (save-note-read (tn-ref-tn read))))))))) - - -;;; OPTIMIZED-EMIT-SAVES -- Internal -;;; -;;; Like EMIT-SAVES, only different. We avoid redundant saving within the -;;; block, and don't restore values that aren't used before the next call. -;;; This function is just the top-level loop over the blocks in the component, -;;; which locates blocks that need saving done. -;;; -(defun optimized-emit-saves (component) - (declare (type component component)) - (let* ((gtn-count (1+ (ir2-component-global-tn-counter - (component-info component)))) - (saves (make-array gtn-count :element-type 'bit)) - (restores (make-array gtn-count :element-type 'bit)) - (block (ir2-block-prev (block-info (component-tail component)))) - (head (block-info (component-head component)))) - (loop - (when (eq block head) (return)) - (when (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop) nil) - (when (eq (vop-info-save-p (vop-info vop)) t) - (return t))) - (setq block (optimized-emit-saves-block block saves restores))) - (setq block (ir2-block-prev block))))) - - -;;; ASSIGN-TN-COSTS -- Internal -;;; -;;; Iterate over the normal TNs, finding the cost of packing on the stack in -;;; units of the number of references. We count all references as +1, and -;;; subtract out REGISTER-SAVE-PENALTY for each place where we would have to -;;; save a register. -;;; -(defun assign-tn-costs (component) - (do-ir2-blocks (block component) - (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop)) - (when (eq (vop-info-save-p (vop-info vop)) t) - (do-live-tns (tn (vop-save-set vop) block) - (decf (tn-cost tn) (backend-register-save-penalty *backend*)))))) - - (do ((tn (ir2-component-normal-tns (component-info component)) - (tn-next tn))) - ((null tn)) - (let ((cost (tn-cost tn))) - (declare (fixnum cost)) - (do ((ref (tn-reads tn) (tn-ref-next ref))) - ((null ref)) - (incf cost)) - (do ((ref (tn-writes tn) (tn-ref-next ref))) - ((null ref)) - (incf cost)) - (setf (tn-cost tn) cost)))) - - -;;;; Targeting: - -;;; Target-If-Desirable -- Internal -;;; -;;; Link the TN-Refs Read and Write together using the TN-Ref-Target when -;;; this seems like a good idea. Currently we always do, as this increases the -;;; sucess of load-TN targeting. -;;; -(defun target-if-desirable (read write) - (declare (type tn-ref read write)) - (setf (tn-ref-target read) write) - (setf (tn-ref-target write) read)) - - -;;; Check-OK-Target -- Internal -;;; -;;; If TN can be packed into SC so as to honor a preference to Target, then -;;; return the offset to pack at, otherwise return NIL. Target must be already -;;; packed. We can honor a preference if: -;;; -- Target's location is in SC's locations. -;;; -- The element sizes of the two SCs are the same. -;;; -- TN doesn't conflict with target's location. -;;; -(defun check-ok-target (target tn sc) - (declare (type tn target tn) (type sc sc) (inline member)) - (let* ((loc (tn-offset target)) - (target-sc (tn-sc target)) - (target-sb (sc-sb target-sc))) - (declare (type index loc)) - (if (and (eq target-sb (sc-sb sc)) - (or (eq (sb-kind target-sb) :unbounded) - (member loc (sc-locations sc))) - (= (sc-element-size target-sc) (sc-element-size sc)) - (not (conflicts-in-sc tn sc loc)) - (zerop (mod loc (sc-alignment sc)))) - loc - nil))) - - -;;; Find-OK-Target-Offset -- Internal -;;; -;;; Scan along the target path from TN, looking at readers or writers. When -;;; we find a packed TN, return Check-OK-Target of that TN. If there is no -;;; target, or if the TN has multiple readers (writers), then we return NIL. -;;; We also always return NIL after 10 iterations to get around potential -;;; circularity problems. -;;; -(macrolet ((frob (slot) - `(let ((count 10) - (current tn)) - (declare (type index count)) - (loop - (let ((refs (,slot current))) - (unless (and (plusp count) refs (not (tn-ref-next refs))) - (return nil)) - (let ((target (tn-ref-target refs))) - (unless target (return nil)) - (setq current (tn-ref-tn target)) - (when (tn-offset current) - (return (check-ok-target current tn sc))) - (decf count))))))) - (defun find-ok-target-offset (tn sc) - (declare (type tn tn) (type sc sc)) - (or (frob tn-reads) - (frob tn-writes)))) - - - -;;;; Location selection: - -;;; Select-Location -- Internal -;;; -;;; Select some location for TN in SC, returning the offset if we succeed, -;;; and NIL if we fail. We start scanning at the Last-Offset in an attempt -;;; to distribute the TNs across all storage. -;;; -;;; We call Offset-Conflicts-In-SB directly, rather than using Conflicts-In-SC. -;;; This allows us to more efficient in packing multi-location TNs: we don't -;;; have to multiply the number of tests by the TN size. This falls out -;;; natually, since we have to be aware of TN size anyway so that we don't call -;;; Conflicts-In-SC on a bogus offset. -;;; -;;; We give up on finding a location after our current pointer has wrapped -;;; twice. This will result in testing some locations twice in the case that -;;; we fail, but is simpler than trying to figure out the soonest failure -;;; point. -;;; -;;; We also give up without bothering to wrap if the current size isn't large -;;; enough to hold a single element of element-size without bothering to wrap. -;;; If it doesn't fit this iteration, it won't fit next. -;;; -;;; ### Note that we actually try to pack as many consecutive TNs as possible -;;; in the same location, since we start scanning at the same offset that the -;;; last TN was successfully packed in. This is a weakening of the scattering -;;; hueristic that was put in to prevent restricted VOP temps from hogging all -;;; of the registers. This way, all of these temps probably end up in one -;;; register. -;;; -(defun select-location (tn sc &optional use-reserved-locs) - (declare (type tn tn) (type sc sc) (inline member)) - (let* ((sb (sc-sb sc)) - (element-size (sc-element-size sc)) - (alignment (sc-alignment sc)) - (size (finite-sb-current-size sb)) - (start-offset (finite-sb-last-offset sb))) - (let ((current-start (* (the index (ceiling start-offset alignment)) - alignment)) - (wrap-p nil)) - (declare (type index current-start)) - (loop - (when (> (+ current-start element-size) size) - (cond ((or wrap-p (> element-size size)) - (return nil)) - (t - (setq current-start 0) - (setq wrap-p t)))) - - (if (or (eq (sb-kind sb) :unbounded) - (and (member current-start (sc-locations sc)) - (or use-reserved-locs - (not (member current-start - (sc-reserve-locations sc)))))) - (dotimes (i element-size - (return-from select-location current-start)) - (let ((offset (+ current-start i))) - (when (offset-conflicts-in-sb tn sb offset) - (setq current-start - (* (the index (ceiling (1+ offset) alignment)) - alignment)) - (return)))) - (incf current-start alignment)))))) - - -;;;; Load TN packing: - - -;;; These variables indicate the last location at which we computed the -;;; Live-TNs. They hold the Block and VOP values that were passed to -;;; Compute-Live-TNs. -;;; -(defvar *live-block*) -(defvar *live-vop*) - -;;; If we unpack some TNs, then we mark all affected blocks by sticking them in -;;; this hash-table. This is initially null. We create the hashtable if we do -;;; any unpacking. -;;; -(defvar *repack-blocks*) -(declaim (type (or hash-table null) *repack-blocks*)) - -;;; Init-Live-TNs -- Internal -;;; -;;; Set the Live-TNs vectors in all :Finite SBs to represent the TNs live at -;;; the end of Block. -;;; -(defun init-live-tns (block) - (dolist (sb (backend-sb-list *backend*)) - (when (eq (sb-kind sb) :finite) - (fill (finite-sb-live-tns sb) nil))) - - (do-live-tns (tn (ir2-block-live-in block) block) - (let* ((sc (tn-sc tn)) - (sb (sc-sb sc))) - (when (eq (sb-kind sb) :finite) - (loop for offset from (tn-offset tn) - repeat (sc-element-size sc) do - (setf (svref (finite-sb-live-tns sb) offset) tn))))) - - (setq *live-block* block) - (setq *live-vop* (ir2-block-last-vop block)) - - (undefined-value)) - - -;;; Compute-Live-TNs -- Internal -;;; -;;; Set the Live-TNs in :Finite SBs to represent the TNs live immediately -;;; after the evaluation of VOP in Block, excluding results of the VOP. If VOP -;;; is null, then compute the live TNs at the beginning of the block. -;;; Sequential calls on the same block must be in reverse VOP order. -;;; -(defun compute-live-tns (block vop) - (declare (type ir2-block block) (type vop vop)) - (unless (eq block *live-block*) - (init-live-tns block)) - - (do ((current *live-vop* (vop-prev current))) - ((eq current vop) - (do ((res (vop-results vop) (tn-ref-across res))) - ((null res)) - (let* ((tn (tn-ref-tn res)) - (sc (tn-sc tn)) - (sb (sc-sb sc))) - (when (eq (sb-kind sb) :finite) - (loop for offset from (tn-offset tn) - repeat (sc-element-size sc) do - (setf (svref (finite-sb-live-tns sb) offset) nil)))))) - (do ((ref (vop-refs current) (tn-ref-next-ref ref))) - ((null ref)) - (let ((ltn (tn-ref-load-tn ref))) - (when ltn - (let* ((sc (tn-sc ltn)) - (sb (sc-sb sc))) - (when (eq (sb-kind sb) :finite) - (let ((tns (finite-sb-live-tns sb))) - (loop for offset from (tn-offset ltn) - repeat (sc-element-size sc) do - (assert (null (svref tns offset))))))))) - - (let* ((tn (tn-ref-tn ref)) - (sc (tn-sc tn)) - (sb (sc-sb sc))) - (when (eq (sb-kind sb) :finite) - (let ((tns (finite-sb-live-tns sb))) - (loop for offset from (tn-offset tn) - repeat (sc-element-size sc) do - (if (tn-ref-write-p ref) - (setf (svref tns offset) nil) - (let ((old (svref tns offset))) - (assert (or (null old) (eq old tn)) (old tn)) - (setf (svref tns offset) tn))))))))) - - (setq *live-vop* vop) - (undefined-value)) - - -;;; LOAD-TN-OFFSET-CONFLICTS-IN-SB -- Internal -;;; -;;; Kind of like Offset-Conflicts-In-SB, except that it uses the VOP refs to -;;; determine whether a Load-TN for OP could be packed in the specified -;;; location, disregarding conflicts with TNs not referenced by this VOP. -;;; There is a conflict if either: -;;; 1] The reference is a result, and the same location is either: -;;; -- Used by some other result. -;;; -- Used in any way after the reference (exclusive). -;;; 2] The reference is an argument, and the same location is either: -;;; -- Used by some other argument. -;;; -- Used in any way before the reference (exclusive). -;;; -;;; In 1 (and 2) above, the first bullet corresponds to result-result -;;; (and argument-argument) conflicts. We need this case because there aren't -;;; any TN-REFs to represent the implicit reading of results or writing of -;;; arguments. -;;; -;;; The second bullet corresponds conflicts with temporaries or between -;;; arguments and results. -;;; -;;; We consider both the TN-REF-TN and the TN-REF-LOAD-TN (if any) to be -;;; referenced simultaneously and in the same way. This causes load-TNs to -;;; appear live to the beginning (or end) of the VOP, as appropriate. -;;; -;;; We return a conflicting TN if there is a conflict. -;;; -(defun load-tn-offset-conflicts-in-sb (op sb offset) - (declare (type tn-ref op) (type finite-sb sb) (type index offset)) - (assert (eq (sb-kind sb) :finite)) - (let ((vop (tn-ref-vop op))) - (labels ((tn-overlaps (tn) - (let ((sc (tn-sc tn)) - (tn-offset (tn-offset tn))) - (when (and (eq (sc-sb sc) sb) - (<= tn-offset offset) - (< offset - (the index - (+ tn-offset (sc-element-size sc))))) - tn))) - (same (ref) - (let ((tn (tn-ref-tn ref)) - (ltn (tn-ref-load-tn ref))) - (or (tn-overlaps tn) - (and ltn (tn-overlaps ltn))))) - (is-op (ops) - (do ((ops ops (tn-ref-across ops))) - ((null ops) nil) - (let ((found (same ops))) - (when (and found (not (eq ops op))) - (return found))))) - (is-ref (refs end) - (do ((refs refs (tn-ref-next-ref refs))) - ((eq refs end) nil) - (let ((found (same refs))) - (when found (return found)))))) - (declare (inline is-op is-ref tn-overlaps)) - (if (tn-ref-write-p op) - (or (is-op (vop-results vop)) - (is-ref (vop-refs vop) op)) - (or (is-op (vop-args vop)) - (is-ref (tn-ref-next-ref op) nil)))))) - - -;;; LOAD-TN-CONFLICTS-IN-SC -- Internal -;;; -;;; Iterate over all the elements in the SB that would be allocated by -;;; allocating a TN in SC at Offset, checking for conflict with load-TNs or -;;; other TNs (live in the LIVE-TNS, which must be set up.) We also return -;;; true if there aren't enough locations after Offset to hold a TN in SC. -;;; If Ignore-Live is true, then we ignore the live-TNs, considering only -;;; references within Op's VOP. -;;; -;;; We return a conflicting TN, or :OVERFLOW if the TN won't fit. -;;; -(defun load-tn-conflicts-in-sc (op sc offset ignore-live) - (let* ((sb (sc-sb sc)) - (size (finite-sb-current-size sb))) - (loop for i from offset - repeat (sc-element-size sc) - thereis (or (when (>= i size) :overflow) - (and (not ignore-live) - (svref (finite-sb-live-tns sb) offset)) - (load-tn-offset-conflicts-in-sb op sb i))))) - - -;;; Find-Load-TN-Target -- Internal -;;; -;;; If a load-TN for Op is targeted to a legal location in SC, then return -;;; the offset, otherwise return NIL. We see if the target of the operand is -;;; packed, and try that location. There isn't any need to chain down the -;;; target path, since everything is packed now. -;;; -;;; We require the target to be in SC (and not merely to overlap with SC). -;;; This prevents SC information from being lost in load TNs (we won't pack a -;;; load TN in ANY-REG when it is targeted to a DESCRIPTOR-REG.) This -;;; shouldn't hurt the code as long as all relevant overlapping SCs are allowed -;;; in the operand SC restriction. -;;; -(defun find-load-tn-target (op sc) - (declare (inline member)) - (let ((target (tn-ref-target op))) - (when target - (let* ((tn (tn-ref-tn target)) - (loc (tn-offset tn))) - (if (and (eq (tn-sc tn) sc) - (member (the index loc) (sc-locations sc)) - (not (load-tn-conflicts-in-sc op sc loc nil))) - loc - nil))))) - - -;;; Select-Load-Tn-Location -- Internal -;;; -;;; Select a legal location for a load TN for Op in SC. We just iterate -;;; over the SC's locations. If we can't find a legal location, return NIL. -;;; -(defun select-load-tn-location (op sc) - (declare (type tn-ref op) (type sc sc)) - (dolist (loc (sc-locations sc) nil) - (unless (load-tn-conflicts-in-sc op sc loc nil) - (return loc)))) - - -(defevent unpack-tn "Unpacked a TN to satisfy operand SC restriction.") - -;;; UNPACK-TN -- Internal -;;; -;;; Make TN's location the same as for its save TN (allocating a save TN if -;;; necessary.) Delete any save/restore code that has been emitted thus far. -;;; Mark all blocks containing references as needing to be repacked. -;;; -(defun unpack-tn (tn) - (event unpack-tn) - (let ((stn (or (tn-save-tn tn) - (pack-save-tn tn)))) - (setf (tn-sc tn) (tn-sc stn)) - (setf (tn-offset tn) (tn-offset stn)) - (flet ((zot (refs) - (do ((ref refs (tn-ref-next ref))) - ((null ref)) - (let ((vop (tn-ref-vop ref))) - (if (eq (vop-info-name (vop-info vop)) 'move-operand) - (delete-vop vop) - (setf (gethash (vop-block vop) *repack-blocks*) t)))))) - (zot (tn-reads tn)) - (zot (tn-writes tn)))) - - (undefined-value)) - -(defevent unpack-fallback "Unpacked some random operand TN.") - -;;; UNPACK-FOR-LOAD-TN -- Internal -;;; -;;; Called by Pack-Load-TN where there isn't any location free that we can -;;; pack into. What we do is move some live TN in one of the specified SCs to -;;; memory, then mark this block all blocks that reference the TN as needing -;;; repacking. If we suceed, we throw to UNPACKED-TN. If we fail, we return -;;; NIL. -;;; -;;; We can unpack any live TN that appears in the NORMAL-TNs list (isn't wired -;;; or restricted.) We prefer to unpack TNs that are not used by the VOP. If -;;; we can't find any such TN, then we unpack some random argument or result -;;; TN. The only way we can fail is if all locations in SC are used by -;;; load-TNs or temporaries in VOP. -;;; -(defun unpack-for-load-tn (sc op) - (declare (type sc sc) (type tn-ref op)) - (let ((sb (sc-sb sc)) - (normal-tns (ir2-component-normal-tns - (component-info *compile-component*))) - (node (vop-node (tn-ref-vop op))) - (fallback nil)) - (flet ((unpack-em (victims) - (unless *repack-blocks* - (setq *repack-blocks* (make-hash-table :test #'eq))) - (setf (gethash (vop-block (tn-ref-vop op)) *repack-blocks*) t) - (dolist (victim victims) - (event unpack-tn node) - (unpack-tn victim)) - (throw 'unpacked-tn nil))) - (dolist (loc (sc-locations sc)) - (declare (type index loc)) - (block SKIP - (collect ((victims nil adjoin)) - (loop for i from loc - as victim = (svref (finite-sb-live-tns sb) i) - repeat (sc-element-size sc) do - (when victim - (unless (find-in #'tn-next victim normal-tns) - (return-from SKIP)) - (victims victim))) - - (let ((conf (load-tn-conflicts-in-sc op sc loc t))) - (cond ((not conf) - (unpack-em (victims))) - ((eq conf :overflow)) - ((not fallback) - (cond ((find conf (victims)) - (setq fallback (victims))) - ((find-in #'tn-next conf normal-tns) - (setq fallback (list conf)))))))))) - - (when fallback - (event unpack-fallback node) - (unpack-em fallback)))) - - nil) - - -;;; Pack-Load-TN -- Internal -;;; -;;; Try to pack a load TN in the SCs indicated by Load-SCs. If we run out -;;; of SCs, then we unpack some TN and try again. We return the packed load -;;; TN. -;;; -;;; Note: we allow a Load-TN to be packed in the target location even if that -;;; location is in a SC not allowed by the primitive type. (The SC must still -;;; be allowed by the operand restriction.) This makes move VOPs more -;;; efficient, since we won't do a move from the stack into a non-descriptor -;;; any-reg though a descriptor argument load-TN. This does give targeting -;;; some real semantics, making it not a pure advisory to pack. It allows pack -;;; to do some packing it wouldn't have done before. -;;; -(defun pack-load-tn (load-scs op) - (declare (type sc-vector load-scs) (type tn-ref op)) - (let ((vop (tn-ref-vop op))) - (compute-live-tns (vop-block vop) vop)) - - (let* ((tn (tn-ref-tn op)) - (ptype (tn-primitive-type tn)) - (scs (svref load-scs (sc-number (tn-sc tn))))) - (let ((current-scs scs) - (allowed ())) - (loop - (cond - ((null current-scs) - (unless allowed - (no-load-scs-allowed-by-primitive-type-error op)) - (dolist (sc allowed) - (unpack-for-load-tn sc op)) - (failed-to-pack-load-tn-error allowed op)) - (t - (let* ((sc (svref (backend-sc-numbers *backend*) (pop current-scs))) - (target (find-load-tn-target op sc))) - (when (or target (sc-allowed-by-primitive-type sc ptype)) - (let ((loc (or target - (select-load-tn-location op sc)))) - (when loc - (let ((res (make-tn 0 :load nil sc))) - (setf (tn-offset res) loc) - (return res)))) - (push sc allowed))))))))) - - -;;; Check-Operand-Restrictions -- Internal -;;; -;;; Scan a list of load-SCs vectors and a list of TN-Refs threaded by -;;; TN-Ref-Across. When we find a reference whose TN doesn't satisfy the -;;; restriction, we pack a Load-TN and load the operand into it. If a load-tn -;;; has already been allocated, we can assume that the restriction is -;;; satisfied. -;;; -(proclaim '(inline check-operand-restrictions)) -(defun check-operand-restrictions (scs ops) - (declare (list scs) (type (or tn-ref null) ops)) - (do ((scs scs (cdr scs)) - (op ops (tn-ref-across op))) - ((null scs)) - (let* ((load-tn (tn-ref-load-tn op)) - (load-scs (svref (car scs) - (sc-number (tn-sc (or load-tn (tn-ref-tn op))))))) - (if load-tn - (assert (eq load-scs t)) - (unless (eq load-scs t) - (setf (tn-ref-load-tn op) (pack-load-tn (car scs) op)))))) - (undefined-value)) - - -;;; Pack-Load-TNs -- Internal -;;; -;;; Scan the VOPs in Block, looking for operands whose SC restrictions -;;; aren't statisfied. We do the results first, since they are evaluated -;;; later, and our conflict analysis is a backward scan. -;;; -(defun pack-load-tns (block) - (catch 'unpacked-tn - (do ((vop (ir2-block-last-vop block) (vop-prev vop))) - ((null vop)) - (let ((info (vop-info vop))) - (check-operand-restrictions (vop-info-result-load-scs info) - (vop-results vop)) - (check-operand-restrictions (vop-info-arg-load-scs info) - (vop-args vop))))) - (undefined-value)) - - -;;; Pack-TN -- Internal -;;; -;;; Attempt to pack TN in all possible SCs, first in the SC chosen by -;;; representation selection, then in the alternate SCs in the order they were -;;; specified in the SC definition. If the TN-COST is negative, then we -;;; don't attempt to pack in SCs that must be saved. If Restricted, then we -;;; can only pack in TN-SC, not in any Alternate-SCs. -;;; -;;; If we are attempting to pack in the SC of the save TN for a TN with a -;;; :SPECIFIED-SAVE TN, then we pack in that location, instead of allocating a -;;; new stack location. -;;; -(defun pack-tn (tn restricted) - (declare (type tn tn)) - (let* ((original (original-tn tn)) - (fsc (tn-sc tn)) - (alternates (unless restricted (sc-alternate-scs fsc))) - (save (tn-save-tn tn)) - (specified-save-sc - (when (and save - (eq (tn-kind save) :specified-save)) - (tn-sc save)))) - - (do ((sc fsc (pop alternates))) - ((null sc) - (failed-to-pack-error tn restricted)) - (when (eq sc specified-save-sc) - (unless (tn-offset save) - (pack-tn save nil)) - (setf (tn-offset tn) (tn-offset save)) - (setf (tn-sc tn) (tn-sc save)) - (return)) - (when (or restricted - (not (and (minusp (tn-cost tn)) (sc-save-p sc)))) - (let ((loc (or (find-ok-target-offset original sc) - (select-location original sc) - (and restricted - (select-location original sc t)) - (when (eq (sb-kind (sc-sb sc)) :unbounded) - (grow-sc sc) - (or (select-location original sc) - (error "Failed to pack after growing SC?")))))) - (when loc - (add-location-conflicts original sc loc) - (setf (tn-sc tn) sc) - (setf (tn-offset tn) loc) - (return)))))) - - (undefined-value)) - - -;;; Pack-Wired-TN -- Internal -;;; -;;; Pack a wired TN, checking that the offset is in bounds for the SB, and -;;; that the TN doesn't conflict with some other TN already packed in that -;;; location. If the TN is wired to a location beyond the end of a :Unbounded -;;; SB, then grow the SB enough to hold the TN. -;;; -;;; ### Checking for conflicts is disabled for :SPECIFIED-SAVE TNs. This is -;;; kind of a hack to make specifying wired stack save locations for local call -;;; arguments (such as OLD-FP) work, since the caller and callee OLD-FP save -;;; locations may conflict when the save locations don't really (due to being -;;; in different frames.) -;;; -(defun pack-wired-tn (tn) - (declare (type tn tn)) - (let* ((sc (tn-sc tn)) - (sb (sc-sb sc)) - (offset (tn-offset tn)) - (end (+ offset (sc-element-size sc))) - (original (original-tn tn))) - (when (> end (finite-sb-current-size sb)) - (unless (eq (sb-kind sb) :unbounded) - (error "~S wired to a location that is out of bounds." tn)) - (grow-sc sc end)) - (when (and (not (eq (tn-kind tn) :specified-save)) - (conflicts-in-sc original sc offset)) - (error "~S wired to a location that it conflicts with." tn)) - (add-location-conflicts original sc offset))) - - -(defevent repack-block "Repacked a block due to TN unpacking.") - -;;; Pack -- Interface -;;; -(defun pack (component) - (assert (not *in-pack*)) - (let ((*in-pack* t) - (optimize (policy nil (or (>= speed cspeed) (>= space cspeed)))) - (2comp (component-info component))) - (init-sb-vectors component) - ;; - ;; Call the target functions. - (do-ir2-blocks (block component) - (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop)) - (let ((target-fun (vop-info-target-function (vop-info vop)))) - (when target-fun - (funcall target-fun vop))))) - - ;; - ;; Pack wired TNs first. - (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn))) - ((null tn)) - (pack-wired-tn tn)) - ;; - ;; Pack restricted component TNs. - (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn))) - ((null tn)) - (when (eq (tn-kind tn) :component) - (pack-tn tn t))) - ;; - ;; Pack other restricted TNs. - (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn))) - ((null tn)) - (unless (tn-offset tn) - (pack-tn tn t))) - ;; - ;; Assign costs to normal TNs so we know which ones should always be - ;; packed on the stack. - (when (and optimize pack-assign-costs) - (assign-tn-costs component)) - ;; - ;; Pack normal TNs in the order that they appear in the code. This - ;; should have some tendency to pack important TNs first, since control - ;; analysis favors the drop-through. This should also help targeting, - ;; since we will pack the target TN soon after we determine the location - ;; of the targeting TN. - (do-ir2-blocks (block component) - (let ((ltns (ir2-block-local-tns block))) - (do ((i (1- (ir2-block-local-tn-count block)) (1- i))) - ((minusp i)) - (declare (fixnum i)) - (let ((tn (svref ltns i))) - (unless (or (null tn) (eq tn :more) (tn-offset tn)) - (pack-tn tn nil)))))) - ;; - ;; Pack any leftover normal TNs. This is to deal with :MORE TNs, which - ;; could possibly not appear in any local TN map. - (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn))) - ((null tn)) - (unless (tn-offset tn) - (pack-tn tn nil))) - ;; - ;; Do load TN packing and emit saves. - (let ((*repack-blocks* nil)) - (let ((*live-block* nil) - (*live-vop* nil)) - (cond ((and optimize pack-optimize-saves) - (optimized-emit-saves component) - (do-ir2-blocks (block component) - (pack-load-tns block))) - (t - (do-ir2-blocks (block component) - (emit-saves block) - (pack-load-tns block))))) - (when *repack-blocks* - (loop - (when (zerop (hash-table-count *repack-blocks*)) (return)) - (let ((*live-block* nil) - (*live-vop* nil)) - (maphash #'(lambda (block v) - (declare (ignore v)) - (remhash block *repack-blocks*) - (event repack-block) - (pack-load-tns block)) - *repack-blocks*))))) - - (undefined-value))) diff --git a/compiler/profile.lisp b/compiler/profile.lisp deleted file mode 100644 index 34319b5cba9bda24887feff0e5ddc5920c9a7be3..0000000000000000000000000000000000000000 --- a/compiler/profile.lisp +++ /dev/null @@ -1,88 +0,0 @@ -;;; -*- Package: C -*- -(in-package "C") - -(use-package "PROFILE") -(declaim (ftype (function (t t t) *) ir1-top-level)) -(declaim (ftype (function (t) *) find-initial-dfo)) -(declaim (ftype (function (t) *) find-dfo)) -(declaim (ftype (function (t) *) local-call-analyze)) -(declaim (ftype (function (t) *) delete-block)) -(declaim (ftype (function (t) *) join-successor-if-possible)) -(declaim (ftype (function (t) *) ir1-optimize-block)) -(declaim (ftype (function (t) *) flush-dead-code)) -(declaim (ftype (function (t) *) generate-type-checks)) -(declaim (ftype (function (t) *) constraint-propagate)) -(declaim (ftype (function (t) *) pre-environment-analyze-top-level)) -(declaim (ftype (function (t) *) environment-analyze)) -(declaim (ftype (function (t) *) gtn-analyze)) -(declaim (ftype (function (t t) *) control-analyze)) -(declaim (ftype (function (t) *) ltn-analyze)) -(declaim (ftype (function (t) *) stack-analyze)) -(declaim (ftype (function (t) *) ir2-convert)) -(declaim (ftype (function (t) *) copy-propagate)) -(declaim (ftype (function (t) *) select-representations)) -(declaim (ftype (function (t) *) lifetime-analyze)) -(declaim (ftype (function (t) *) delete-unreferenced-tns)) -(declaim (ftype (function (t) *) pack)) -(declaim (ftype (function (t) *) generate-code)) -(declaim (ftype (function (t t t t t t) *) fasl-dump-component)) -(declaim (ftype (function (t) *) clear-ir2-info)) -(declaim (ftype (function (t) *) macerate-ir1-component)) -(declaim (ftype (function (t) *) merge-top-level-lambdas)) -(declaim (ftype (function (t t) *) note-failed-optimization)) -(declaim (ftype (function () *) clear-stuff)) -(declaim (ftype (function (t) *) read-source-form)) -(declaim (ftype (function (t t) *) fasl-dump-source-info)) -(declaim (ftype (function (t t) *) fasl-dump-top-level-lambda-call)) - -(profile ir1-top-level - find-initial-dfo - find-dfo - local-call-analyze - delete-block - join-successor-if-possible - ir1-optimize-block - flush-dead-code - generate-type-checks - constraint-propagate - pre-environment-analyze-top-level - environment-analyze - gtn-analyze - control-analyze - ltn-analyze - stack-analyze - ir2-convert - copy-propagate - select-representations - - lifetime-analyze -#| - lifetime-pre-pass - lifetime-flow-analysis - reset-current-conflict - lifetime-post-pass -|# - delete-unreferenced-tns - pack -#| - pack-wired-tn - pack-tn - pack-load-tns - assign-tn-costs - optimized-emit-saves - emit-saves -|# - generate-code - fasl-dump-component - clear-ir2-info - macerate-ir1-component - merge-top-level-lambdas - note-failed-optimization - clear-stuff - read-source-form - fasl-dump-source-info - fasl-dump-top-level-lambda-call -; check-life-consistency -; check-ir1-consistency -; check-ir2-consistency - ) diff --git a/compiler/pseudo-vops.lisp b/compiler/pseudo-vops.lisp deleted file mode 100644 index 2b23852ed7531321757c367be292d2d8a5c95883..0000000000000000000000000000000000000000 --- a/compiler/pseudo-vops.lisp +++ /dev/null @@ -1,43 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/pseudo-vops.lisp,v 1.7 1992/06/04 16:13:14 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains definitions of VOPs used as internal markers by the -;;; compiler. Since they don't emit any code, they should be portable. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; Notes the place at which the environment is properly initialized, for -;;; debug-info purposes. -;;; -(define-vop (note-environment-start) - (:info start-lab) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (emit-label start-lab) - (note-debug-location vop start-lab :non-local-entry))) - - -;;; Call a move function. Used for register save/restore and spilling. -;;; -(define-vop (move-operand) - (:args (x)) - (:results (y)) - (:info name) - (:vop-var vop) - (:generator 0 - (funcall (symbol-function name) vop x y))) - diff --git a/compiler/represent.lisp b/compiler/represent.lisp deleted file mode 100644 index 11d958a61e9f5a2c9a03f0c29b8c46de88350b1b..0000000000000000000000000000000000000000 --- a/compiler/represent.lisp +++ /dev/null @@ -1,722 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/represent.lisp,v 1.32 1992/02/24 05:50:28 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the implementation independent code for the -;;; representation selection phase in the compiler. Representation selection -;;; decides whether to use non-descriptor representations for objects and emits -;;; the appropriate representation-specific move and coerce vops. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;;; Error routines: -;;; -;;; Problems in the VM definition often show up here, so we try to be as -;;; implementor-friendly as possible. -;;; - -;;; GET-OPERAND-INFO -- Interface -;;; -;;; Given a TN ref for a VOP argument or result, return these values: -;;; 1] True if the operand is an argument, false otherwise. -;;; 2] The ordinal position of the operand. -;;; 3] True if the operand is a more operand, false otherwise. -;;; 4] The costs for this operand. -;;; 5] The load-scs vector for this operand (NIL if more-p.) -;;; 6] True if the costs or SCs in the VOP-INFO are inconsistent with the -;;; currently record ones. -;;; -(defun get-operand-info (ref) - (declare (type tn-ref ref)) - (let* ((arg-p (not (tn-ref-write-p ref))) - (vop (tn-ref-vop ref)) - (info (vop-info vop))) - (flet ((frob (refs costs load more-cost) - (do ((refs refs (tn-ref-across refs)) - (costs costs (cdr costs)) - (load load (cdr load)) - (n 0 (1+ n))) - ((null costs) - (assert more-cost) - (values arg-p - (+ n - (or (position-in #'tn-ref-across ref refs) - (error "Couldn't find REF?")) - 1) - t - more-cost - nil - nil)) - (when (eq refs ref) - (let ((parse (vop-parse-or-lose (vop-info-name info) - *backend*))) - (multiple-value-bind - (ccosts cscs) - (compute-loading-costs - (elt (if arg-p - (vop-parse-args parse) - (vop-parse-results parse)) - n) - arg-p) - - (return - (values arg-p - (1+ n) - nil - (car costs) - (car load) - (not (and (equalp ccosts (car costs)) - (equalp cscs (car load)))))))))))) - (if arg-p - (frob (vop-args vop) (vop-info-arg-costs info) - (vop-info-arg-load-scs info) - (vop-info-more-arg-costs info)) - (frob (vop-results vop) (vop-info-result-costs info) - (vop-info-result-load-scs info) - (vop-info-more-result-costs info)))))) - - -;;; LISTIFY-RESTRICTIONS -- Interface -;;; -;;; Convert a load-costs vector to the list of SCs allowed by the operand -;;; restriction. -;;; -(defun listify-restrictions (restr) - (declare (type sc-vector restr)) - (collect ((res)) - (dotimes (i sc-number-limit) - (when (eq (svref restr i) t) - (res (svref (backend-sc-numbers *backend*) i)))) - (res))) - - -;;; BAD-COSTS-ERROR -- Internal -;;; -;;; Try to give a helpful error message when Ref has no cost specified for -;;; some SC allowed by the TN's primitive-type. -;;; -(defun bad-costs-error (ref) - (declare (type tn-ref ref)) - (let* ((tn (tn-ref-tn ref)) - (ptype (tn-primitive-type tn))) - (multiple-value-bind (arg-p pos more-p costs load-scs incon) - (get-operand-info ref) - (collect ((losers)) - (dolist (scn (primitive-type-scs ptype)) - (unless (svref costs scn) - (losers (svref (backend-sc-numbers *backend*) scn)))) - - (unless (losers) - (error "Representation selection flamed out for no obvious reason.~@ - Try again after recompiling the VM definition.")) - - (error "~S is not valid as the ~:R ~:[result~;argument~] to the~@ - ~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@ - ~:[which cannot be coerced or loaded into the allowed SCs:~ - ~% ~S~;~*~]~:[~;~@ - Current cost info inconsistent with that in effect at compile ~ - time. Recompile.~%Compilation order may be incorrect.~]" - tn pos arg-p - (template-name (vop-info (tn-ref-vop ref))) - (primitive-type-name ptype) - (mapcar #'sc-name (losers)) - more-p - (unless more-p - (mapcar #'sc-name (listify-restrictions load-scs))) - incon))))) - - -;;; BAD-COERCE-ERROR -- Internal -;;; -;;; Try to give a helpful error message when we fail to do a coercion -;;; for some reason. -;;; -(defun bad-coerce-error (op) - (declare (type tn-ref op)) - (let* ((op-tn (tn-ref-tn op)) - (op-sc (tn-sc op-tn)) - (op-scn (sc-number op-sc)) - (ptype (tn-primitive-type op-tn)) - (write-p (tn-ref-write-p op))) - (multiple-value-bind (arg-p pos more-p costs load-scs incon) - (get-operand-info op) - (declare (ignore costs more-p)) - (collect ((load-lose) - (no-move-scs) - (move-lose)) - (dotimes (i sc-number-limit) - (let ((i-sc (svref (backend-sc-numbers *backend*) i))) - (when (eq (svref load-scs i) t) - (cond ((not (sc-allowed-by-primitive-type i-sc ptype)) - (load-lose i-sc)) - ((not (find-move-vop op-tn write-p i-sc ptype - #'sc-move-vops)) - (let ((vops (if write-p - (svref (sc-move-vops op-sc) i) - (svref (sc-move-vops i-sc) op-scn)))) - (if vops - (dolist (vop vops) (move-lose (template-name vop))) - (no-move-scs i-sc)))) - (t - (error "Representation selection flamed out for no ~ - obvious reason.")))))) - - (unless (or (load-lose) (no-move-scs) (move-lose)) - (error "Representation selection flamed out for no obvious reason.~@ - Try again after recompiling the VM definition.")) - - (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~ - ~% ~S~%Primitive type: ~S~@ - SC restrictions:~% ~S~@ - ~@[The primitive type disallows these loadable SCs:~% ~S~%~]~ - ~@[No move VOPs are defined to coerce to these allowed SCs:~ - ~% ~S~%~]~ - ~@[These move VOPs couldn't be used due to operand type ~ - restrictions:~% ~S~%~]~ - ~:[~;~@ - Current cost info inconsistent with that in effect at compile ~ - time. Recompile.~%Compilation order may be incorrect.~]" - op-tn pos arg-p - (template-name (vop-info (tn-ref-vop op))) - (primitive-type-name ptype) - (mapcar #'sc-name (listify-restrictions load-scs)) - (mapcar #'sc-name (load-lose)) - (mapcar #'sc-name (no-move-scs)) - (move-lose) - incon))))) - - -;;; BAD-MOVE-ARG-ERROR -- Internal -;;; -(defun bad-move-arg-error (val pass) - (declare (type tn val pass)) - (error "No :MOVE-ARGUMENT VOP defined to move ~S (SC ~S) to ~ - ~S (SC ~S.)" - val (sc-name (tn-sc val)) - pass (sc-name (tn-sc pass)))) - - -;;;; VM Consistency Checking: -;;; -;;; We do some checking of the consistency of the VM definition at load -;;; time. - -;;; CHECK-MOVE-FUNCTION-CONSISTENCY -- Interface -;;; -(defun check-move-function-consistency () - (dotimes (i sc-number-limit) - (let ((sc (svref (backend-sc-numbers *backend*) i))) - (when sc - (let ((moves (sc-move-functions sc))) - (dolist (const (sc-constant-scs sc)) - (unless (svref moves (sc-number const)) - (warn "No move function defined to load SC ~S from constant ~ - SC ~S." - (sc-name sc) (sc-name const)))) - - (dolist (alt (sc-alternate-scs sc)) - (unless (svref moves (sc-number alt)) - (warn "No move function defined to load SC ~S from alternate ~ - SC ~S." - (sc-name sc) (sc-name alt))) - (unless (svref (sc-move-functions alt) i) - (warn "No move function defined to save SC ~S to alternate ~ - SC ~S." - (sc-name sc) (sc-name alt))))))))) - - -;;;; Representation selection: - -;;; VOPs that we ignore in initial cost computation. We ignore SET in the -;;; hopes that nobody is setting specials inside of loops. We ignore -;;; TYPE-CHECK-ERROR because we don't want the possibility of error to bias the -;;; result. Notes are suppressed for T-C-E as well, since we don't need to -;;; worry about the efficiency of that case. -;;; -(defconstant ignore-cost-vops '(set type-check-error)) -(defconstant suppress-note-vops '(type-check-error)) - -(declaim (start-block select-tn-representation)) - -;;; ADD-REPRESENTATION-COSTS -- Local -;;; -;;; We special-case the move VOP, since using this costs for the normal MOVE -;;; would spuriously encourage descriptor representations. We won't actually -;;; need to coerce to descriptor and back, since we will replace the MOVE with -;;; a specialized move VOP. What we do is look at the other operand. If its -;;; representation has already been chosen (e.g. if it is wired), then we use -;;; the appropriate move costs, otherwise we just ignore the references. -;;; -(defun add-representation-costs (refs scs costs - ops-slot costs-slot more-costs-slot - write-p) - (do ((ref refs (tn-ref-next ref))) - ((null ref)) - (flet ((add-costs (cost) - (dolist (scn scs) - (let ((res (svref cost scn))) - (unless res - (bad-costs-error ref)) - (incf (svref costs scn) res))))) - (let* ((vop (tn-ref-vop ref)) - (info (vop-info vop))) - (case (vop-info-name info) - (#.ignore-cost-vops) - (move - (let ((rep (tn-sc - (tn-ref-tn - (if write-p - (vop-args vop) - (vop-results vop)))))) - (when rep - (if write-p - (dolist (scn scs) - (let ((res (svref (sc-move-costs - (svref (backend-sc-numbers *backend*) - scn)) - (sc-number rep)))) - (when res - (incf (svref costs scn) res)))) - (dolist (scn scs) - (let ((res (svref (sc-move-costs rep) scn))) - (when res - (incf (svref costs scn) res)))))))) - (t - (do ((cost (funcall costs-slot info) (cdr cost)) - (op (funcall ops-slot vop) (tn-ref-across op))) - ((null cost) - (add-costs (funcall more-costs-slot info))) - (when (eq op ref) - (add-costs (car cost)) - (return)))))))) - (undefined-value)) - - -;;; SELECT-TN-REPRESENTATION -- Internal -;;; -;;; Return the best representation for a normal TN. SCs is a list of the SC -;;; numbers of the SCs to select from. Costs is a scratch vector. -;;; -;;; What we do is sum the costs for each reference to TN in each of the -;;; SCs, and then return the SC having the lowest cost. -;;; -(defun select-tn-representation (tn scs costs) - (declare (type tn tn) (type sc-vector costs) - (inline add-representation-costs)) - (dolist (scn scs) - (setf (svref costs scn) 0)) - - - (add-representation-costs (tn-reads tn) scs costs - #'vop-args #'vop-info-arg-costs - #'vop-info-more-arg-costs - nil) - (add-representation-costs (tn-writes tn) scs costs - #'vop-results #'vop-info-result-costs - #'vop-info-more-result-costs - t) - - (let ((min most-positive-fixnum) - (min-scn nil)) - (dolist (scn scs) - (let ((cost (svref costs scn))) - (when (< cost min) - (setq min cost) - (setq min-scn scn)))) - - (svref (backend-sc-numbers *backend*) min-scn))) - -(declaim (end-block)) - - -;;; NOTE-NUMBER-STACK-TN -- Internal -;;; -;;; Prepare for the possibility of a TN being allocated on the number stack -;;; by setting NUMBER-STACK-P in all functions that TN is referenced in and in -;;; all the functions in their tail sets. Refs is a TN-Refs list of references -;;; to the TN. -;;; -(defun note-number-stack-tn (refs) - (declare (type (or tn-ref null) refs)) - - (do ((ref refs (tn-ref-next ref))) - ((null ref)) - (let* ((lambda (block-home-lambda - (ir2-block-block - (vop-block (tn-ref-vop ref))))) - (tails (lambda-tail-set lambda))) - (flet ((frob (fun) - (setf (ir2-environment-number-stack-p - (environment-info - (lambda-environment fun))) - t))) - (frob lambda) - (when tails - (dolist (fun (tail-set-functions tails)) - (frob fun)))))) - - (undefined-value)) - - -;;; GET-OPERAND-NAME -- Internal -;;; -;;; If TN is a variable, return the name. If TN is used by a VOP emitted -;;; for a return, then return a string indicating this. Otherwise, return NIL. -;;; -(defun get-operand-name (tn arg-p) - (declare (type tn tn)) - (let* ((actual (if (eq (tn-kind tn) :alias) (tn-save-tn tn) tn)) - (reads (tn-reads tn)) - (leaf (tn-leaf actual))) - (cond ((lambda-var-p leaf) (leaf-name leaf)) - ((and (not arg-p) reads - (return-p (vop-node (tn-ref-vop reads)))) - "<return value>") - (t - nil)))) - - -;;; DO-COERCE-EFFICIENCY-NOTE -- Internal -;;; -;;; If policy indicates, give an efficiency note for doing the a coercion -;;; Vop, where Op is the operand we are coercing for and Dest-TN is the -;;; distinct destination in a move. -;;; -(defun do-coerce-efficiency-note (vop op dest-tn) - (declare (type vop-info vop) (type tn-ref op) (type (or tn null) dest-tn)) - (let* ((note (or (template-note vop) (template-name vop))) - (cost (template-cost vop)) - (op-vop (tn-ref-vop op)) - (op-node (vop-node op-vop)) - (op-tn (tn-ref-tn op)) - (*compiler-error-context* op-node)) - (cond ((eq (tn-kind op-tn) :constant)) - ((policy op-node (<= speed brevity) (<= space brevity))) - ((member (template-name (vop-info op-vop)) suppress-note-vops)) - ((null dest-tn) - (let* ((op-info (vop-info op-vop)) - (op-note (or (template-note op-info) - (template-name op-info))) - (arg-p (not (tn-ref-write-p op))) - (name (get-operand-name op-tn arg-p)) - (pos (1+ (or (position-in #'tn-ref-across op - (if arg-p - (vop-args op-vop) - (vop-results op-vop))) - (error "Couldn't fine op? Bug!"))))) - (compiler-note - "Doing ~A (cost ~D)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~ - The ~:R ~:[result~;argument~] of ~A." - note cost name arg-p name - pos arg-p op-note))) - (t - (compiler-note "Doing ~A (cost ~D)~@[ from ~S~]~@[ to ~S~]." - note cost (get-operand-name op-tn t) - (get-operand-name dest-tn nil))))) - (undefined-value)) - - -;;; FIND-MOVE-VOP -- Internal -;;; -;;; Find a move VOP to move from the operand OP-TN to some other -;;; representation corresponding to OTHER-SC and OTHER-PTYPE. Slot is the SC -;;; slot that we grab from (move or move-argument). Write-P indicates that OP -;;; is a VOP result, so OP is the move result and other is the arg, otherwise -;;; OP is the arg and other is the result. -;;; -;;; If an operand is of primitive type T, then we use the type of the other -;;; operand instead, effectively intersecting the argument and result type -;;; assertions. This way, a move VOP can restrict whichever operand makes more -;;; sense, without worrying about which operand has the type info. -;;; -(defun find-move-vop (op-tn write-p other-sc other-ptype slot) - (declare (type tn op-tn) (type sc other-sc) - (type primitive-type other-ptype) - (type function slot)) - (let* ((op-sc (tn-sc op-tn)) - (op-scn (sc-number op-sc)) - (other-scn (sc-number other-sc)) - (any-ptype (backend-any-primitive-type *backend*)) - (op-ptype (tn-primitive-type op-tn))) - (let ((other-ptype (if (eq other-ptype any-ptype) op-ptype other-ptype)) - (op-ptype (if (eq op-ptype any-ptype) other-ptype op-ptype))) - (dolist (info (if write-p - (svref (funcall slot op-sc) other-scn) - (svref (funcall slot other-sc) op-scn)) - nil) - (when (and (operand-restriction-ok - (first (template-arg-types info)) - (if write-p other-ptype op-ptype) - :tn op-tn :t-ok nil) - (operand-restriction-ok - (first (template-result-types info)) - (if write-p op-ptype other-ptype) - :t-ok nil)) - (return info)))))) - - -;;; EMIT-COERCE-VOP -- Internal -;;; -;;; Emit a coercion VOP for Op Before the specifed VOP or die trying. SCS -;;; is the operand's LOAD-SCS vector, which we use to determine what SCs the -;;; VOP will accept. We pick any acceptable coerce VOP, since it practice it -;;; seems uninteresting to have more than one applicable. -;;; -;;; What we do is look at each SC allowed by both the operand restriction -;;; and the operand primitive-type, and see if there is a move VOP which moves -;;; between the operand's SC and load SC. If we find such a VOP, then we make -;;; a TN having the load SC as the representation. -;;; -;;; Dest-TN is the TN that we are moving to, for a move or move-arg. This -;;; is only for efficiency notes. -;;; -;;; If the TN is an unused result TN, then we don't actually emit the move; -;;; we just change to the right kind of TN. -;;; -(defun emit-coerce-vop (op dest-tn scs before) - (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before) - (type (or tn null) dest-tn)) - (let* ((op-tn (tn-ref-tn op)) - (ptype (tn-primitive-type op-tn)) - (write-p (tn-ref-write-p op)) - (vop (tn-ref-vop op)) - (node (vop-node vop)) - (block (vop-block vop))) - (dotimes (i sc-number-limit (bad-coerce-error op)) - (let ((i-sc (svref (backend-sc-numbers *backend*) i))) - (when (and (eq (svref scs i) t) - (sc-allowed-by-primitive-type i-sc ptype)) - (let ((res (find-move-vop op-tn write-p i-sc ptype #'sc-move-vops))) - (when res - (when (>= (vop-info-cost res) *efficiency-note-cost-threshold*) - (do-coerce-efficiency-note res op dest-tn)) - (let ((temp (make-representation-tn ptype i))) - (change-tn-ref-tn op temp) - (cond - ((not write-p) - (emit-move-template node block res op-tn temp before)) - ((and (null (tn-reads op-tn)) - (eq (tn-kind op-tn) :normal))) - (t - (emit-move-template node block res temp op-tn before)))) - (return)))))))) - - -;;; COERCE-SOME-OPERANDS -- Internal -;;; -;;; Scan some operands and call EMIT-COERCE-VOP on any for which we can't -;;; load the operand. The coerce VOP is inserted Before the specified VOP. -;;; Dest-TN is the destination TN if we are doing a move or move-arg, and is -;;; NIL otherwise. This is only used for efficiency notes. -;;; -(proclaim '(inline coerce-some-operands)) -(defun coerce-some-operands (ops dest-tn load-scs before) - (declare (type (or tn-ref null) ops) (list load-scs) - (type (or tn null) dest-tn) (type (or vop null) before)) - (do ((op ops (tn-ref-across op)) - (scs load-scs (cdr scs))) - ((null scs)) - (unless (svref (car scs) - (sc-number (tn-sc (tn-ref-tn op)))) - (emit-coerce-vop op dest-tn (car scs) before))) - (undefined-value)) - - -;;; COERCE-VOP-OPERANDS -- Internal -;;; -;;; Emit coerce VOPs for the args and results, as needed. -;;; -(defun coerce-vop-operands (vop) - (declare (type vop vop)) - (let ((info (vop-info vop))) - (coerce-some-operands (vop-args vop) nil (vop-info-arg-load-scs info) vop) - (coerce-some-operands (vop-results vop) nil (vop-info-result-load-scs info) - (vop-next vop))) - (undefined-value)) - - -;;; EMIT-ARG-MOVES -- Internal -;;; -;;; Iterate over the more operands to a call VOP, emitting move-arg VOPs and -;;; any necessary coercions. We determine which FP to use by looking at the -;;; MOVE-ARGS annotation. If the vop is a :LOCAL-CALL, we insert any needed -;;; coercions before the ALLOCATE-FRAME so that lifetime analysis doesn't get -;;; confused (since otherwise, only passing locations are written between A-F -;;; and call.) -;;; -(defun emit-arg-moves (vop) - (let* ((info (vop-info vop)) - (node (vop-node vop)) - (block (vop-block vop)) - (how (vop-info-move-args info)) - (args (vop-args vop)) - (fp-tn (tn-ref-tn args)) - (nfp-tn (if (eq how :local-call) - (tn-ref-tn (tn-ref-across args)) - nil)) - (pass-locs (first (vop-codegen-info vop))) - (prev (vop-prev vop))) - (do ((val (do ((arg args (tn-ref-across arg)) - (req (template-arg-types info) (cdr req))) - ((null req) arg)) - (tn-ref-across val)) - (pass pass-locs (cdr pass))) - ((null val) - (assert (null pass))) - (let* ((val-tn (tn-ref-tn val)) - (pass-tn (first pass)) - (pass-sc (tn-sc pass-tn)) - (res (find-move-vop val-tn nil pass-sc - (tn-primitive-type pass-tn) - #'sc-move-arg-vops))) - (unless res - (bad-move-arg-error val-tn pass-tn)) - - (change-tn-ref-tn val pass-tn) - (let* ((this-fp - (cond ((not (sc-number-stack-p pass-sc)) fp-tn) - (nfp-tn) - (t - (assert (eq how :known-return)) - (setq nfp-tn (make-number-stack-pointer-tn)) - (setf (tn-sc nfp-tn) - (svref (backend-sc-numbers *backend*) - (first (primitive-type-scs - (tn-primitive-type nfp-tn))))) - (emit-context-template - node block - (template-or-lose 'compute-old-nfp *backend*) - nfp-tn vop) - (assert (not (sc-number-stack-p (tn-sc nfp-tn)))) - nfp-tn))) - (new (emit-move-arg-template node block res val-tn this-fp - pass-tn vop)) - (after - (cond ((eq how :local-call) - (assert (eq (vop-info-name (vop-info prev)) - 'allocate-frame)) - prev) - (prev (vop-next prev)) - (t - (ir2-block-start-vop block))))) - (coerce-some-operands (vop-args new) pass-tn - (vop-info-arg-load-scs res) - after))))) - (undefined-value)) - - -;;; EMIT-MOVES-AND-COERCIONS -- Internal -;;; -;;; Scan the IR2 looking for move operations that need to be replaced with -;;; special-case VOPs and emitting coercion VOPs for operands of normal VOPs. -;;; We delete moves to TNs that are never read at this point, rather than -;;; possibly converting them to some expensive move operation. -;;; -(defun emit-moves-and-coercions (block) - (declare (type ir2-block block)) - (do ((vop (ir2-block-start-vop block) - (vop-next vop))) - ((null vop)) - (let ((info (vop-info vop)) - (node (vop-node vop)) - (block (vop-block vop))) - (cond - ((eq (vop-info-name info) 'move) - (let* ((args (vop-args vop)) - (x (tn-ref-tn args)) - (y (tn-ref-tn (vop-results vop))) - (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y) - #'sc-move-vops))) - (cond ((and (null (tn-reads y)) - (eq (tn-kind y) :normal)) - (delete-vop vop)) - ((eq res info)) - (res - (when (>= (vop-info-cost res) - *efficiency-note-cost-threshold*) - (do-coerce-efficiency-note res args y)) - (emit-move-template node block res x y vop) - (delete-vop vop)) - (t - (coerce-vop-operands vop))))) - ((vop-info-move-args info) - (emit-arg-moves vop)) - (t - (coerce-vop-operands vop)))))) - - -;;; NOTE-IF-NUMBER-STACK -- Internal -;;; -;;; If TN is in a number stack SC, make all the right annotations. Note -;;; that this should be called after TN has been referenced, since it must -;;; iterate over the referencing environments. -;;; -(proclaim '(inline note-if-number-stack)) -(defun note-if-number-stack (tn 2comp restricted) - (declare (type tn tn) (type ir2-component 2comp)) - (when (if restricted - (eq (sb-name (sc-sb (tn-sc tn))) 'non-descriptor-stack) - (sc-number-stack-p (tn-sc tn))) - (unless (ir2-component-nfp 2comp) - (setf (ir2-component-nfp 2comp) (make-nfp-tn))) - (note-number-stack-tn (tn-reads tn)) - (note-number-stack-tn (tn-writes tn))) - (undefined-value)) - - -;;; SELECT-REPRESENTATIONS -- Interface -;;; -;;; Entry to representation selection. First we select the representation -;;; for all normal TNs, setting the TN-SC. After selecting the TN -;;; representations, we set the SC for all :ALIAS TNs to be the representation -;;; chosen for the original TN. We then scan all the IR2, emitting any -;;; necessary coerce and move-arg VOPs. Finally, we scan all TNs looking for -;;; ones that might be placed on the number stack, noting this so that the -;;; number-FP can be allocated. This must be done last, since references in -;;; new environments may be introduced by MOVE-ARG insertion. -;;; -(defun select-representations (component) - (let ((costs (make-array sc-number-limit)) - (2comp (component-info component))) - - (do ((tn (ir2-component-normal-tns 2comp) - (tn-next tn))) - ((null tn)) - (assert (tn-primitive-type tn)) - (unless (tn-sc tn) - (let* ((scs (primitive-type-scs (tn-primitive-type tn))) - (sc (if (rest scs) - (select-tn-representation tn scs costs) - (svref (backend-sc-numbers *backend*) (first scs))))) - (assert sc) - (setf (tn-sc tn) sc)))) - - (do ((alias (ir2-component-alias-tns 2comp) - (tn-next alias))) - ((null alias)) - (setf (tn-sc alias) (tn-sc (tn-save-tn alias)))) - - (do-ir2-blocks (block component) - (emit-moves-and-coercions block)) - - (macrolet ((frob (slot restricted) - `(do ((tn (,slot 2comp) (tn-next tn))) - ((null tn)) - (note-if-number-stack tn 2comp ,restricted)))) - (frob ir2-component-normal-tns nil) - (frob ir2-component-wired-tns t) - (frob ir2-component-restricted-tns t))) - - (undefined-value)) diff --git a/compiler/rt/afpa.lisp b/compiler/rt/afpa.lisp deleted file mode 100644 index 45395b94c3448bd221af8124668c0007e17b9b98..0000000000000000000000000000000000000000 --- a/compiler/rt/afpa.lisp +++ /dev/null @@ -1,486 +0,0 @@ -;;; -*- 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.4 1992/03/09 20:37:26 wlott 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-gtr #b00) -(defconstant afpa-compare-eql #b01) -(defconstant afpa-compare-lss #b10) -(defconstant afpa-compare-unordered #b11) - -;;; ### Note: the following status register constants are totally bogus (are -;;; actually for the mc68881, and exist only to make some code compile without -;;; errors. -;;; -;;; Encoding of float exceptions in the FLOATING-POINT-MODES result. This is -;;; also the encoding used in the mc68881 accrued exceptions. -;;; -(defconstant float-inexact-trap-bit (ash 1 0)) -(defconstant float-divide-by-zero-trap-bit (ash 1 1)) -(defconstant float-underflow-trap-bit (ash 1 2)) -(defconstant float-overflow-trap-bit (ash 1 3)) -(defconstant float-invalid-trap-bit (ash 1 4)) - -(defconstant float-round-to-nearest 0) -(defconstant float-round-to-zero 1) -(defconstant float-round-to-negative 2) -(defconstant float-round-to-positive 3) - -;;; Positions of bits in the FLOATING-POINT-MODES result. -;;; -(defconstant float-rounding-mode (byte 2 0)) -(defconstant float-sticky-bits (byte 5 2)) -(defconstant float-traps-byte (byte 5 7)) -(defconstant float-exceptions-byte (byte 5 12)) -(defconstant float-fast-bit 0) - - -;;;; 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 fp-temp 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))) - - -;;;; 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))) diff --git a/compiler/rt/alloc.lisp b/compiler/rt/alloc.lisp deleted file mode 100644 index b0802c9f347785d2f5737fdcc993824a88aac112..0000000000000000000000000000000000000000 --- a/compiler/rt/alloc.lisp +++ /dev/null @@ -1,139 +0,0 @@ -;;; -*- Package: rt -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/alloc.lisp,v 1.4 1991/10/22 16:43:17 wlott Exp $ -;;; -;;; Allocation VOPs for the IBM RT port. -;;; -;;; Written by William Lott. -;;; Converted by Bill Chiles. -;;; - -(in-package "RT") - - - -;;;; LIST and LIST* - -(define-vop (list-or-list*) - (:args (things :more t)) - (:temporary (:scs (descriptor-reg) :type list) ptr) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) - res) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) - (:temporary (:scs (word-pointer-reg)) alloc) - (:info num) - (:results (result :scs (descriptor-reg))) - (:variant-vars star) - (:policy :safe) - (:generator 0 - (cond ((zerop num) - (move result null-tn)) - ((and star (= num 1)) - (move result (tn-ref-tn things))) - (t - (macrolet - ((store-car (tn list &optional (slot cons-car-slot)) - `(let ((reg - (sc-case ,tn - ((any-reg descriptor-reg) ,tn) - (null null-tn) - (control-stack - (load-stack-tn temp ,tn) - temp)))) - (storew reg ,list ,slot list-pointer-type)))) - (let ((cons-cells (if star (1- num) num))) - (pseudo-atomic (ndescr) - (load-symbol-value alloc *allocation-pointer*) - (inst cal res alloc list-pointer-type) - (inst cal alloc alloc (* (pad-data-block cons-size) - cons-cells)) - (store-symbol-value alloc *allocation-pointer*) - (move ptr res) - (dotimes (i (1- cons-cells)) - (store-car (tn-ref-tn things) ptr) - (setf things (tn-ref-across things)) - (inst cal ptr ptr (pad-data-block cons-size)) - (storew ptr ptr - (- cons-cdr-slot cons-size) - list-pointer-type)) - (store-car (tn-ref-tn things) ptr) - (cond (star - (setf things (tn-ref-across things)) - (store-car (tn-ref-tn things) ptr cons-cdr-slot)) - (t - (storew null-tn ptr - cons-cdr-slot list-pointer-type))) - (assert (null (tn-ref-across things))) - (move result res)) - (load-symbol-value ndescr *internal-gc-trigger*) - (inst tlt ndescr alloc))))))) - -(define-vop (list list-or-list*) - (:variant nil)) - -(define-vop (list* list-or-list*) - (:variant t)) - - - -;;;; Special purpose inline allocators. - -(define-vop (allocate-code-object) - (:args (boxed-arg :scs (any-reg)) - (unboxed-arg :scs (any-reg) :target unboxed)) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:temporary (:scs (word-pointer-reg)) alloc) - (:temporary (:scs (any-reg) :from (:argument 0)) boxed) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) - (:generator 100 - (inst li ndescr (lognot lowtag-mask)) - (inst cal boxed boxed-arg (fixnum (1+ vm:code-trace-table-offset-slot))) - (inst n boxed ndescr) - (move unboxed unboxed-arg) - (inst sr unboxed word-shift) - (inst a unboxed lowtag-mask) - (inst n unboxed ndescr) - (pseudo-atomic (ndescr) - (load-symbol-value alloc *allocation-pointer*) - (inst cal result alloc other-pointer-type) - (inst cas alloc boxed alloc) - (inst cas alloc unboxed alloc) - (store-symbol-value alloc *allocation-pointer*) - (move ndescr boxed) - (inst sl ndescr (- type-bits word-shift)) - (inst oil ndescr code-header-type) - (storew ndescr result 0 other-pointer-type) - (storew unboxed result code-code-size-slot other-pointer-type) - (storew null-tn result code-entry-points-slot other-pointer-type) - (storew null-tn result code-debug-info-slot other-pointer-type)) - (load-symbol-value ndescr *internal-gc-trigger*) - (inst tlt ndescr alloc))) - -(define-vop (make-symbol) - (:args (name :scs (descriptor-reg) :to :eval)) - (:temporary (:scs (sap-reg)) temp) - (:temporary (:scs (word-pointer-reg)) alloc) - (:results (result :scs (descriptor-reg) :from :argument)) - (:policy :fast-safe) - (:translate make-symbol) - (:generator 37 - (with-fixed-allocation (result temp alloc symbol-header-type symbol-size) - (inst li temp unbound-marker-type) - (storew temp result symbol-value-slot other-pointer-type) - (storew temp result symbol-function-slot other-pointer-type) - (storew temp result symbol-setf-function-slot other-pointer-type) - (inst cai temp (make-fixup "undefined_tramp" :foreign)) - (storew temp result symbol-raw-function-addr-slot - other-pointer-type) - (storew null-tn result symbol-plist-slot other-pointer-type) - (storew name result symbol-name-slot other-pointer-type) - (storew null-tn result symbol-package-slot other-pointer-type)))) diff --git a/compiler/rt/arith.lisp b/compiler/rt/arith.lisp deleted file mode 100644 index 66e7eda64a951307f7144438d83890d194ead5cb..0000000000000000000000000000000000000000 --- a/compiler/rt/arith.lisp +++ /dev/null @@ -1,920 +0,0 @@ -;;; -*- Package: RT; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/arith.lisp,v 1.10 1991/06/13 16:37:48 wlott Exp $ -;;; -;;; This file contains the VM definition arithmetic VOPs for the IBM RT. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by Bill Chiles. -;;; - -(in-package "RT") - - - -;;;; Unary operations. - -(define-vop (fixnum-unop) - (:args (x :scs (any-reg))) - (:results (res :scs (any-reg))) - (:note "inline fixnum arithmetic") - (:arg-types tagged-num) - (:result-types tagged-num) - (:policy :fast-safe)) - -(define-vop (signed-unop) - (:args (x :scs (signed-reg))) - (:results (res :scs (signed-reg))) - (:note "inline (signed-byte 32) arithmetic") - (:arg-types signed-num) - (:result-types signed-num) - (:policy :fast-safe)) - -(define-vop (fast-negate/fixnum fixnum-unop) - (:translate %negate) - (:generator 1 - (inst neg res x))) - -(define-vop (fast-negate/signed signed-unop) - (:translate %negate) - (:generator 2 - (inst neg res x))) - -(define-vop (fast-lognot/fixnum fixnum-unop) - (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target res) - temp) - (:translate lognot) - (:generator 2 - (inst li temp (fixnum -1)) - (inst x temp x) - (move res temp))) - -(define-vop (fast-lognot/signed signed-unop) - (:translate lognot) - (:generator 1 - (inst not res x))) - - - -;;;; Binary fixnum operations (+, -, LOGIOR, LOGAND, LOGXOR). - -;;; Assume that any constant operand is the second arg... - -(define-vop (fast-fixnum-binop) - (:args (x :target r :scs (any-reg)) - (y :scs (any-reg immediate) :to :save)) - (:arg-types tagged-num tagged-num) - (:temporary (:scs (any-reg)) temp) - (:results (r :scs (any-reg))) - (:result-types tagged-num) - (:note "inline fixnum arithmetic") - (:effects) - (:affected) - (:policy :fast-safe)) - -(define-vop (fast-unsigned-binop) - (:args (x :target r :scs (unsigned-reg)) - (y :scs (unsigned-reg immediate) :to :save)) - (:arg-types unsigned-num unsigned-num) - (:temporary (:scs (any-reg)) temp) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:note "inline (unsigned-byte 32) arithmetic") - (:effects) - (:affected) - (:policy :fast-safe)) - -(define-vop (fast-signed-binop) - (:args (x :target r :scs (signed-reg)) - (y :scs (signed-reg immediate) :to :save)) - (:arg-types signed-num signed-num) - (:temporary (:scs (any-reg)) temp) - (:results (r :scs (signed-reg))) - (:result-types signed-num) - (:note "inline (signed-byte 32) arithmetic") - (:effects) - (:affected) - (:policy :fast-safe)) - -(eval-when (compile eval) - -(defmacro define-binop (translate cost op &body imm-body) - `(progn - (define-vop (,(intern (concatenate 'simple-string - "FAST-" - (string translate) - "/FIXNUM=>FIXNUM")) - fast-fixnum-binop) - (:translate ,translate) - (:generator ,cost - (sc-case y - (any-reg - (move r x) - (inst ,op r y)) - (immediate - (let ((value (fixnum (tn-value y)))) - ,@imm-body))))) - (define-vop (,(intern (concatenate 'simple-string - "FAST-" - (string translate) - "/SIGNED=>SIGNED")) - fast-signed-binop) - (:translate ,translate) - (:generator ,(1+ cost) - (sc-case y - (signed-reg - (move r x) - (inst ,op r y)) - (immediate - (let ((value (tn-value y))) - ,@imm-body))))) - (define-vop (,(intern (concatenate 'simple-string - "FAST-" - (string translate) - "/UNSIGNED=>UNSIGNED")) - fast-unsigned-binop) - (:translate ,translate) - (:generator ,(1+ cost) - (sc-case y - (unsigned-reg - (move r x) - (inst ,op r y)) - (immediate - (let ((value (tn-value y))) - ,@imm-body))))))) - -) ;EVAL-WHEN - - -(define-binop + 3 a - (cond ((typep value '(signed-byte 16)) - (inst a r x value)) - (t - (move r x) - (inst li temp value) - (inst a r temp)))) - -(define-binop - 3 s - (cond ((typep value '(signed-byte 16)) - (inst s r x value)) - (t - (move r x) - (inst li temp value) - (inst s r temp)))) - -(define-binop logior 2 o - (let ((low (ldb (byte 16 0) value)) - (high (ldb (byte 16 16) value))) - (cond ((zerop value) - (move r x)) - ((zerop low) - (inst oiu r x high)) - ((zerop high) - (inst oil r x low)) - (t - (inst oil r x low) - (inst oiu r r high))))) - -(define-binop logxor 2 x - (let ((low (ldb (byte 16 0) value)) - (high (ldb (byte 16 16) value))) - (cond ((zerop value) - (move r x)) - ((zerop low) - (inst xiu r x high)) - ((zerop high) - (inst xil r x low)) - (t - (inst xil r x low) - (inst xiu r r high))))) - -(define-binop logand 1 n - (let ((low (ldb (byte 16 0) value)) - (high (ldb (byte 16 16) value))) - (cond ((= low high #xFFFF) - (move r x)) - ((zerop low) - (inst niuz r x high)) - ((= low #xFFFF) - (inst niuo r x high)) - ((zerop high) - (inst nilz r x low)) - ((= high #xFFFF) - (inst nilo r x low)) - (t - (inst nilo r x low) - (inst niuo r r high))))) - - - -;;;; Binary fixnum operations. - -(define-vop (fast-ash) - (:note "inline ASH") - (:args (number :scs (signed-reg unsigned-reg) :to (:result 0) :target result) - (amount-arg :scs (signed-reg immediate) :target amount)) - (:arg-types (:or signed-num unsigned-num) signed-num) - (:results (result :scs (signed-reg unsigned-reg))) - (:result-types (:or signed-num unsigned-num)) - (:translate ash) - (:policy :fast-safe) - (:temporary (:sc non-descriptor-reg :from (:argument 1)) amount) - (:generator 12 - (sc-case amount-arg - (signed-reg - (let ((positive (gen-label)) - (shift-right (gen-label)) - (done (gen-label))) - ;; Copy the amount and check to see if it's positive. - (inst oil amount amount-arg 0) - (inst bnc :lt positive) - - ;; We want to shift to the right, so make the amount positive. - (inst neg amount) - (inst c amount 32) - ;; If less than 32, do the shifting. - (inst bc :lt shift-right) - ;; 32 or greater, we just shift by 31. - (inst li amount 31) - (emit-label shift-right) - (move result number) - (inst bx done) - (sc-case number - (signed-reg - (inst sar result amount)) - (unsigned-reg - (inst sr result amount))) - - (emit-label positive) - ;; The result-type assures us that this shift will not overflow. - (move result number) - (inst sl result amount) - - (emit-label done))) - - (immediate - (let ((amount (tn-value amount-arg))) - (cond ((minusp amount) - (sc-case number - (unsigned-reg - (move result number) - (inst sr result (min (- amount) 31))) - (t - (move result number) - (inst sar result (min (- amount) 31))))) - (t - (move result number) - (inst sl result (min amount 31))))))))) - - -;;; SIGNED-BYTE-32-LEN -- VOP. -;;; -;;; Common Lisp INTEGER-LENGTH. Due to the definition of this operation, -;;; (integer-length x) == (integer-length (lognot x)). -;;; We determine the result by using the RT's count-leading-zeros which only -;;; works on the zeros in the lower half of a word, so we have to use it on -;;; the upperhalf and lowerhalf of number separately and do a little addition -;;; (actually, subtraction from the right values) to get the length. -;;; -(define-vop (signed-byte-32-len) - (:translate integer-length) - (:note "inline (signed-byte 32) integer-length") - (:policy :fast-safe) - (:args (arg :scs (signed-reg))) - (:arg-types signed-num) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) number) - (:temporary (:scs (non-descriptor-reg) :from (:eval 0)) temp) - (:generator 16 - (let ((upper-not-zero (gen-label)) - (count (gen-label))) - ;; Move arg and tell us if number is positive. - (inst oil number arg 0) - (inst bnc :lt count) - ;; Number is negative, so logically negate it to compute length. - (inst not number) - (emit-label count) - ;; Shift the upperhalf down and see if there are any 1's in it. - (move temp number) - (inst sr temp 16) - (inst bncx :eq upper-not-zero) - (inst li res 32) - ;; Upper half is all 0's, so get ready to subtract leading 0's in - ;; the lowerhalf from 16 to determine integer length. - (inst li res 16) - (move temp number) - (emit-label upper-not-zero) - ;; Here temp contains the upperhalf if not all 0's or the lowerhalf. - ;; Res contains the appropriate value (32 or 16) from which to subtract - ;; the number of leading 0's in temp to determine integer length. - (inst clz temp) - (inst s res temp)))) - -;;; UNSIGNED-BYTE-32-COUNT -- VOP. -;;; -;;; To count the 1's in number, count how many times you can do the following: -;;; AND number and the result of subtracting 1 from number. -;;; Set number to the result of the AND operation. -;;; This subtract and AND clears the lowest 1 in number, so when number becomes -;;; zero, you're done. -;;; -(define-vop (unsigned-byte-32-count) - (:translate logcount) - (:note "inline (unsigned-byte 32) logcount") - (:policy :fast-safe) - (:args (arg :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) number temp) - (:generator 14 - (let ((loop (gen-label)) - (done (gen-label))) - ;; Move arg and tell us if number is zero, in which case res is 0. - (inst oil number arg 0) - (inst bcx :eq done) - (inst li res 0) - ;; Count 1's in number. - (emit-label loop) - (move temp number) - (inst s temp 1) - (inst n number temp) - (inst bncx :eq loop) - (inst a res (fixnum 1)) - ;; We're done and res already has result. - (emit-label done)))) - - - -;;;; Binary conditional VOPs: - -(define-vop (fast-conditional) - (:conditional) - (:info target not-p) - (:effects) - (:affected) - (:policy :fast-safe)) - -(define-vop (fast-conditional/fixnum fast-conditional) - (:args (x :scs (any-reg)) - (y :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison")) - -(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg))) - ;; Leave room in the signed field for - (:arg-types tagged-num (:constant (signed-byte 14))) - (:info target not-p y)) - -(define-vop (fast-conditional/signed fast-conditional) - (:args (x :scs (signed-reg)) - (y :scs (signed-reg))) - (:arg-types signed-num signed-num) - (:note "inline (signed-byte 32) comparison")) - -(define-vop (fast-conditional-c/signed fast-conditional/signed) - (:args (x :scs (signed-reg))) - (:arg-types signed-num (:constant (signed-byte 16))) - (:info target not-p y)) - -(define-vop (fast-conditional/unsigned fast-conditional) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:note "inline (unsigned-byte 32) comparison")) - -(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num (:constant (unsigned-byte 15))) - (:info target not-p y)) - - -(defmacro define-conditional-vop (translate &rest generator) - `(progn - ,@(mapcar #'(lambda (suffix cost signed) - (unless (and (member suffix '(/fixnum -c/fixnum)) - (eq translate 'eql)) - `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" - translate suffix)) - ,(intern - (format nil "~:@(FAST-CONDITIONAL~A~)" - suffix))) - (:translate ,translate) - (:generator ,cost - (let* ((signed ,signed) - (-c/fixnum ,(eq suffix '-c/fixnum)) - (y (if -c/fixnum (fixnum y) y))) - ,@generator))))) - '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) - ;; All these really take six cycles, but we decrease the -c/... - ;; cost to prefer these VOPs since we avoid doing - ;; load-immediates. Then the first two are decreased by by one - ;; more to prefer comparing the fixnum representation directly. - '(5 4 6 5 6 5) - '(t t t t nil nil)))) - -(define-conditional-vop < - (if signed - (inst c x y) - (inst cl x y)) - (if not-p - (inst bnc :lt target) - (inst bc :lt target))) - -(define-conditional-vop > - (if signed - (inst c x y) - (inst cl x y)) - (if not-p - (inst bnc :gt target) - (inst bc :gt target))) - -;;; This only handles EQL of restricted integers, so it's simple. -;;; -(define-conditional-vop eql - (declare (ignore signed)) - (inst c x y) - (if not-p - (inst bnc :eq target) - (inst bc :eq target))) - - -;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a -;;; known fixnum. -;;; - -(define-vop (fast-eql/fixnum fast-conditional) - (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg))) - (:arg-types * tagged-num) - (:note "inline fixnum comparison") - (:translate eql) - (:ignore temp) - (:generator 4 - (inst c x y) - (if not-p - (inst bnc :eq target) - (inst bc :eq target)))) - -(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg descriptor-reg))) - (:arg-types * (:constant (signed-byte 14))) - (:info target not-p y) - (:translate eql) - (:generator 3 - (inst c x (fixnum y)) - (if not-p - (inst bnc :eq target) - (inst bc :eq target)))) - - - -;;;; 32-bit logical operations - -(define-vop (32bit-logical) - (:args (x :scs (unsigned-reg) :target r) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg) :from (:argument 0))) - (:result-types unsigned-num) - (:policy :fast-safe)) - -(define-vop (32bit-logical-not 32bit-logical) - (:translate 32bit-logical-not) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:generator 1 - (inst not r x))) - -(define-vop (32bit-logical-and 32bit-logical) - (:translate 32bit-logical-and) - (:generator 1 - (move r x) - (inst n r y))) - -(deftransform 32bit-logical-nand ((x y) (* *)) - '(32bit-logical-not (32bit-logical-and x y))) - -(define-vop (32bit-logical-or 32bit-logical) - (:translate 32bit-logical-or) - (:generator 1 - (move r x) - (inst o r y))) - -(deftransform 32bit-logical-nor ((x y) (* *)) - '(32bit-logical-not (32bit-logical-or x y))) - -(define-vop (32bit-logical-xor 32bit-logical) - (:translate 32bit-logical-xor) - (:generator 1 - (move r x) - (inst x r y))) - -(deftransform 32bit-logical-eqv ((x y) (* *)) - '(32bit-logical-not (32bit-logical-xor x y))) - -(deftransform 32bit-logical-andc1 ((x y) (* *)) - '(32bit-logical-and (32bit-logical-not x) y)) - -(deftransform 32bit-logical-andc2 ((x y) (* *)) - '(32bit-logical-and x (32bit-logical-not y))) - -(deftransform 32bit-logical-orc1 ((x y) (* *)) - '(32bit-logical-or (32bit-logical-not x) y)) - -(deftransform 32bit-logical-orc2 ((x y) (* *)) - '(32bit-logical-or x (32bit-logical-not y))) - -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg) :target r :to (:eval 0)) - (amount :scs (signed-reg) :target temp)) - (:temporary (:scs (signed-reg) :from (:argument 1)) temp) - (:arg-types unsigned-num tagged-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "SHIFT-TOWARDS-START") - (:generator 1 - (move temp amount) - (inst nilz temp #x1f) - (move r num) - (inst sl r temp))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "SHIFT-TOWARDS-END") - (:generator 1 - (move temp amount) - (inst nilz temp #x1f) - (move r num) - (inst sr r temp))) - - - - -;;;; Bignum stuff. - -(define-vop (bignum-length get-header-data) - (:translate bignum::%bignum-length) - (:policy :fast-safe)) - -(define-vop (bignum-set-length set-header-data) - (:translate bignum::%bignum-set-length) - (:policy :fast-safe)) - -(define-vop (bignum-ref word-index-ref) - (:variant vm:bignum-digits-offset vm:other-pointer-type) - (:translate bignum::%bignum-ref) - (:results (value :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (bignum-set word-index-set) - (:variant vm:bignum-digits-offset vm:other-pointer-type) - (:translate bignum::%bignum-set) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg immediate)) - (value :scs (unsigned-reg))) - (:arg-types t positive-fixnum unsigned-num) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (digit-0-or-plus) - (:translate bignum::%digit-0-or-plusp) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (result :scs (descriptor-reg))) - (:generator 7 - (let ((done (gen-label))) - (inst c digit 0) - (inst bcx :lt done) - (move result null-tn) - (load-symbol result 't) - (emit-label done)))) - -(define-vop (add-w/carry) - (:translate bignum::%add-with-carry) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg) :target result) - (b :scs (unsigned-reg)) - (carry-in :scs (any-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg) :from (:argument 0)) - (carry :scs (unsigned-reg))) - (:result-types unsigned-num positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :to (:argument 2)) temp) - (:generator 5 - ;; Set the carry condition bit. - (inst a temp carry-in -1) - ;; Add A & B. - (move result a) - (inst ae result b) - ;; Set carry to the condition bit. - ;; Add zero to zero and see if we get a one. - (inst li carry 0) - (inst ae carry carry))) - -(define-vop (sub-w/borrow) - (:translate bignum::%subtract-with-borrow) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg) :target result) - (b :scs (unsigned-reg)) - (borrow-in :scs (any-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg) :from (:argument 0)) - (borrow :scs (unsigned-reg) :from :eval)) - (:result-types unsigned-num positive-fixnum) - (:temporary (:scs (non-descriptor-reg) - :from (:argument 0) :to (:argument 2)) temp) - (:generator 5 - (move result a) - ;; Set the carry condition bit. - ;; Borrow-in is zero if there was a borrow, one if there was no borrow. - ;; The RT has the same sense with its C0 condition bit. - (inst a temp borrow-in -1) - (inst se result b) - ;; Set borrow to 0 if the carry condition bit is zero, or to 1 otherwise. - (inst li borrow 0) - (inst ae borrow borrow))) - -(define-vop (bignum-mult-and-add-3-arg) - (:translate bignum::%multiply-and-add) - (:policy :fast-safe) - (:vop-var vop) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg)) - (carry-in :scs (unsigned-reg unsigned-stack) :to (:eval 1))) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp) - (:temporary (:scs (unsigned-reg) :to (:result 0) :target high-res) high) - (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1) - :target low-res) low) - (:results (high-res :scs (unsigned-reg)) - (low-res :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 76 - ;; Do the multiply. - (unsigned-multiply x y high low) - - ;; Add the carry-in. - (sc-case carry-in - (unsigned-stack - (load-stack-tn temp carry-in vop) - (inst a low temp)) - (unsigned-reg - (inst a low carry-in))) - (inst ae high 0) - (move high-res high) - (move low-res low))) - -(define-vop (bignum-mult-and-add-4-arg) - (:translate bignum::%multiply-and-add) - (:vop-var vop) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg)) - (prev :scs (unsigned-reg unsigned-stack) :to (:eval 1)) - (carry-in :scs (unsigned-reg unsigned-stack) :to (:eval 1))) - (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp) - (:temporary (:scs (unsigned-reg) :to (:result 0) :target high-res) high) - (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1) - :target low-res) low) - (:results (high-res :scs (unsigned-reg)) - (low-res :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 81 - ;; Do the multiply. - (unsigned-multiply x y high low) - - ;; Add the carry-in. - (sc-case carry-in - (unsigned-stack - (load-stack-tn temp carry-in vop) - (inst a low temp)) - (unsigned-reg - (inst a low carry-in))) - (inst ae high 0) - - ;; Add in digit from accumulating result. - (sc-case carry-in - (unsigned-stack - (load-stack-tn temp prev vop) - (inst a low temp)) - (unsigned-reg - (inst a low prev))) - (inst ae high 0) - (move high-res high) - (move low-res low))) - -(define-vop (bignum-mult) - (:translate bignum::%multiply) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num) - (:results (high :scs (unsigned-reg) :from :load) - (low :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 74 - ;; Do the multiply. - (unsigned-multiply x y high low))) - -;;; UNSIGNED-MULTIPLY -- Internal. -;;; -;;; The RT has a signed multiply. To unsigned-multiply bignum digits, we use -;;; the following identity: -;;; signed-interpretation -;;; = unsigned-interpretation - (sign-bit)(2^32) -;;; ==> -;;; ui = si + (sb)(2^32) -;;; This gives us the following equation: -;;; (ui1) (ui2) = [si1 + (sb1)(2^32)] [si2 + (sb2)(2^32)] -;;; (ui1) (ui2) = (si1) (si2) -;;; + [(sb1)(si2) + (sb2)(si1)] (2^32) -;;; + (sb1)(sb2)(2^32) -;;; Inspection and the fact that the result must fit into 64 bits reveals that -;;; the third time can always be ignored. -;;; -(defun unsigned-multiply (x y high low) - ;; Setup system register for multiply. - (inst mtmqscr x) - - ;; Do the multiply. - ;; Subtract high from high to set it to zero and to set the C0 condition - ;; bit appropriately for the m instruction. - (inst s high high) - (dotimes (i 16) - (inst m high y)) - ;; Adjust high word of result for unsigned multiply. - ;; If x is negative, add in y. If y is negative, add in x. - (let ((x-pos (gen-label)) - (y-pos (gen-label))) - (inst c x 0) - (inst bnc :lt x-pos) - (inst a high y) - (emit-label x-pos) - (inst c y 0) - (inst bnc :lt y-pos) - (inst a high x) - (emit-label y-pos)) - - ;; Get the low 32 bits of the product. - (inst mfmqscr low)) - - -(define-vop (bignum-lognot) - (:translate bignum::%lognot) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst not r x))) - -(define-vop (fixnum-to-digit) - (:translate bignum::%fixnum-to-digit) - (:policy :fast-safe) - (:args (fixnum :scs (any-reg) :target digit)) - (:arg-types tagged-num) - (:results (digit :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (move digit fixnum) - (inst sar digit 2))) - -;;; BIGNUM-FLOOR -- VOP. -;;; -;;; The way the bignum code uses this allows us to ignore dividing by 0, 1, or -;;; -1. Furthermore, we always divided a positive high:low value by a positive -;;; divisor value. This means we don't have to worry about using the RT's -;;; signed divide instruction to get an unsigned division result. -;;; -;;; We are going to copy the GENERIC-TRUNCATE assembly routine to implement -;;; this since FLOOR and TRUNCATE return the same values for positive -;;; arguments. However, we do modify it slightly to make use of the positive -;;; nature of the arguments. -;;; -(define-vop (bignum-floor) - (:translate bignum::%floor) - (:policy :fast-safe) - (:args (dividend-high :scs (unsigned-reg) :target rem) - (dividend-low :scs (unsigned-reg)) - (divisor :scs (unsigned-reg) :to (:eval 1))) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:results (quo :scs (unsigned-reg)) - (rem :scs (unsigned-reg) :from (:eval 0))) - (:result-types unsigned-num unsigned-num) - (:generator 44 - (inst mtmqscr dividend-low) - (move rem dividend-high) - (dotimes (i 32) - (inst d rem divisor)) - ;; Check preliminary remainder by considering signs of rem and divisor. - ;; This is an extra step to account for the non-restoring divide-step instr. - ;; We don't actually have to check this since the d instruction set :c0 - ;; when the signs of rem and divisor are the same. - (let ((rem-okay (gen-label))) - (inst bc :c0 rem-okay) - (inst a rem divisor) - (emit-label rem-okay)) - - (let ((move-results (gen-label))) - ;; The RT gives us some random division concept, but we're writing - ;; TRUNCATE. The fixup involves adding one to the quotient and - ;; subtracting the divisor from the remainder under certain - ;; circumstances (for this VOP, as opposed to the assembly routine, - ;; this boils down to one test): - ;; - ;; IF the remainder is equal to the divisor, we can obviously take - ;; one more divisor out of the dividend, so do it. - (inst c rem divisor) - (inst bnc :eq move-results) ;Just fall through to do it. - - ;; Add 1 to quotient and subtract divisor from remainder. - (inst mfmqscr quo) - (inst inc quo 1) - (inst s rem divisor) - - (emit-label move-results)) - - (inst mfmqscr quo))) - - -;;; SIGNIFY-DIGIT -- VOP. -;;; -;;; This is supposed to make digit into a fixnum which is signed. We just -;;; move it here, letting the compiler's operand motion stuff make this -;;; result into a fixnum. -;;; -(define-vop (signify-digit) - (:translate bignum::%fixnum-digit-with-correct-sign) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg) :target res)) - (:arg-types unsigned-num) - (:results (res :scs (signed-reg))) - (:result-types signed-num) - (:generator 1 - (move res digit))) - -(define-vop (digit-ashr) - (:translate bignum::%ashr) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg) :target result) - (count :scs (unsigned-reg immediate))) - (:arg-types unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg) :from (:argument 0))) - (:result-types unsigned-num) - (:generator 2 - (move result digit) - (inst sar result - (sc-case count - (unsigned-reg count) - (immediate (tn-value count)))))) - -(define-vop (digit-lshr digit-ashr) - (:translate bignum::%digit-logical-shift-right) - (:generator 2 - (move result digit) - (inst sr result - (sc-case count - (unsigned-reg count) - (immediate (tn-value count)))))) - -(define-vop (digit-ashl digit-ashr) - (:translate bignum::%ashl) - (:generator 2 - (move result digit) - (inst sl result - (sc-case count - (unsigned-reg count) - (immediate (tn-value count)))))) - - - -;;;; Static functions. - -(define-static-function two-arg-gcd (x y) :translate gcd) -(define-static-function two-arg-lcm (x y) :translate lcm) - -(define-static-function two-arg-/ (x y) :translate /) - -(define-static-function %negate (x) :translate %negate) - -(define-static-function two-arg-and (x y) :translate logand) -(define-static-function two-arg-ior (x y) :translate logior) -(define-static-function two-arg-xor (x y) :translate logxor) diff --git a/compiler/rt/array.lisp b/compiler/rt/array.lisp deleted file mode 100644 index dabac38c3b3dcc6198fe1e77547f29603889e491..0000000000000000000000000000000000000000 --- a/compiler/rt/array.lisp +++ /dev/null @@ -1,584 +0,0 @@ -;;; -*- Package: RT; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/array.lisp,v 1.10 1992/01/29 20:22:12 ram Exp $ -;;; -;;; This file contains the IBM RT definitions for array operations. -;;; -;;; Written by William Lott and Bill Chiles. -;;; - -(in-package "RT") - - - -;;;; Allocator for the array header. - -(define-vop (make-array-header) - (:translate make-array-header) - (:policy :fast-safe) - (:args (type :scs (any-reg descriptor-reg)) - (rank :scs (any-reg descriptor-reg))) - (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) - (:temporary (:sc word-pointer-reg) alloc) - (:results (result :scs (descriptor-reg))) - (:generator 0 - (pseudo-atomic (ndescr) - ;; Take free pointer and make descriptor pointer for the result. Just - ;; add in the three low-tag bits since alloc ptr is dual-word aligned, - ;; and its three low bits are zero. - (load-symbol-value alloc *allocation-pointer*) - (inst cal header alloc vm:other-pointer-type) - (inst cal alloc alloc - (+ (* vm:array-dimensions-offset vm:word-bytes) - vm:lowtag-mask)) - ;; Rank is the dimensions as a fixnum which happens to be the number of - ;; bytes (by the machine's interpretation) we need to add to the alloc - ;; ptr. - (inst cas alloc rank alloc) - (inst nilo alloc (logand #xFFFF (lognot vm:lowtag-mask))) - (store-symbol-value alloc *allocation-pointer*) - (inst cal ndescr rank (fixnum (1- vm:array-dimensions-offset))) - ;; Shift the fixnum representation of the length, then OR in the fixnum - ;; rep of the type code, and then shift off the two extra fixnum zeros. - (inst sl ndescr vm:type-bits) - (inst o ndescr type) - (inst sr ndescr 2) - (storew ndescr header 0 vm:other-pointer-type)) - (load-symbol-value ndescr *internal-gc-trigger*) - (inst tlt ndescr alloc) - (move result header))) - - - -;;;; Additional accessors and setters for the array header. - -(defknown lisp::%array-dimension (t fixnum) fixnum - (flushable)) -(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum - ()) - -(define-vop (%array-dimension word-index-ref) - (:translate lisp::%array-dimension) - (:policy :fast-safe) - (:variant vm:array-dimensions-offset vm:other-pointer-type)) - -(define-vop (%set-array-dimension word-index-set) - (:translate lisp::%set-array-dimension) - (:policy :fast-safe) - (:variant vm:array-dimensions-offset vm:other-pointer-type)) - - - -(defknown lisp::%array-rank (t) fixnum (flushable)) - -;;; ARRAY-RANK-VOP -- VOP. -;;; -;;; The length of the array header manifests the rank of the array. We fetch -;;; the header word, extract the length, and subtract off the start of the -;;; dimension slots. -;;; -(define-vop (array-rank-vop) - (:translate lisp::%array-rank) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :type random :target res) temp) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadw temp x 0 vm:other-pointer-type) - (inst sr temp vm:type-bits) - (inst s temp (1- vm:array-dimensions-offset)) - (inst sl temp 2) - (move res temp))) - - - -;;;; Bounds checking routine. - -(define-vop (check-bound) - (:translate %check-bound) - (:policy :fast-safe) - (:args (array :scs (descriptor-reg)) - (bound :scs (any-reg descriptor-reg)) - (index :scs (any-reg descriptor-reg) :target result)) - (:results (result :scs (any-reg descriptor-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (let ((error (generate-error-code vop invalid-array-index-error - array bound index))) - (inst c index bound) - (inst bnc :lt error) - (move result index)))) - - - -;;;; 32-bit, 16-bit, and 8-bit vectors. - -;;; We build these variants on top of VOP's defined in memory.lisp. These -;;; vectors' elements are represented in integer registers and are built out of -;;; 8, 16, or 32 bit elements. - -(eval-when (compile eval) -(defmacro def-data-vector-frobs (type variant element-type &rest scs) - `(progn - (define-vop (,(intern (concatenate 'simple-string - "DATA-VECTOR-REF/" - (string type))) - ,(intern (concatenate 'simple-string - (string variant) - "-REF"))) - (:note "inline array access") - (:variant vm:vector-data-offset vm:other-pointer-type) - (:translate data-vector-ref) - (:arg-types ,type positive-fixnum) - (:results (value :scs ,scs)) - (:result-types ,element-type)) - (define-vop (,(intern (concatenate 'simple-string - "DATA-VECTOR-SET/" - (string type))) - ,(intern (concatenate 'simple-string - (string variant) - "-SET"))) - (:note "inline array store") - (:variant vm:vector-data-offset vm:other-pointer-type) - (:translate data-vector-set) - (:arg-types ,type positive-fixnum ,element-type) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg immediate)) - (value :scs ,scs)) - (:results (result :scs ,scs)) - (:result-types ,element-type)))) -) ;EVAL-WHEN - -(def-data-vector-frobs simple-string byte-index - base-char base-char-reg) -(def-data-vector-frobs simple-vector word-index - * descriptor-reg any-reg) - -(def-data-vector-frobs simple-array-unsigned-byte-8 byte-index - positive-fixnum unsigned-reg) -(def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index - positive-fixnum unsigned-reg) -(def-data-vector-frobs simple-array-unsigned-byte-32 word-index - unsigned-num unsigned-reg) - - - -;;;; Integer vectors with 1, 2, and 4 bit elements. - -(eval-when (compile eval) - -(defmacro def-small-data-vector-frobs (type bits) - (let* ((elements-per-word (floor vm:word-bits bits)) - (bit-shift (1- (integer-length elements-per-word)))) - `(progn - (define-vop (,(symbolicate 'data-vector-ref/ type)) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (value :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) - (:generator 20 - (move temp index) - (inst sr temp ,bit-shift) - (inst sl temp 2) - (move lip object) - (inst a lip temp) - (loadw result lip vm:vector-data-offset vm:other-pointer-type) - (inst nilz temp index ,(1- elements-per-word)) - (inst xil temp ,(1- elements-per-word)) - ,@(unless (= bits 1) - `((inst sl temp ,(1- (integer-length bits))))) - (inst sr result temp) - (inst nilz result ,(1- (ash 1 bits))) - (move value result) - (inst sl value 2))) - (define-vop (,(symbolicate 'data-vector-ref-c/ type)) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:arg-types ,type (:constant index)) - (:temporary (:scs (interior-reg)) lip) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 15 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (setf extra (logxor extra (1- ,elements-per-word))) - (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) - vm:other-pointer-type))) - (cond ((typep offset '(signed-byte 16)) - ;; Use the load with immediate offset if possible. - (inst l result offset)) - (t - ;; Load the upper half of the offset in one instruction - ;; and add the lower half as an immediate offset in - ;; the load. NOTE: if bit 15 is on, the load will sign- - ;; extend it, so we have to add 1 to the upper half now - ;; to counter the effect of the -1 from the sign-extension. - (inst cau lip object - (if (logbitp 15 offset) - (1+ (ash offset -16)) - (ash offset -16))) - (inst l result lip (logand #xFFFF offset))))) - (unless (zerop extra) - (inst sr result (* extra ,bits))) - (unless (= extra ,(1- elements-per-word)) - (inst n result ,(1- (ash 1 bits))))))) - (define-vop (,(symbolicate 'data-vector-set/ type)) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:vop-var vop) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - ;; Normally, we would take the next arg in an unsigned-reg too. - ;; This caused a discrimination problem in the compiler for - ;; choosing a move function. Since this VOP uses so many - ;; non-descriptor registers anyway which has been a hassle, we - ;; just removed unsigned-reg. - (index :scs (any-reg) :to (:eval 1)) - (value :scs (unsigned-reg immediate) - :load-if (not (sc-is value unsigned-stack)) - :target value-save)) - (:arg-types ,type positive-fixnum positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (unsigned-stack) :from (:argument 2)) value-save) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg) :from (:argument 2) - :to (:result 0)) temp) - (:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:result 0)) - old) - (:temporary (:scs (non-descriptor-reg) :from (:eval 1) :to (:result 0)) - shift) - (:generator 25 - (when (sc-is value unsigned-reg) - (storew value (current-nfp-tn vop) (tn-offset value-save))) - (move temp index) - (inst sr temp - (sc-case index - ;; In addition to dividing the index to map it to - ;; a number of words to skip, shift off the fixnum tag - ;; bits too. - (any-reg ,(+ bit-shift 2)) - ;; No extraneous bits in this case. - (unsigned-reg ,bit-shift))) - (inst sl temp 2) - (move lip object) - (inst a lip temp) - (loadw old lip vm:vector-data-offset vm:other-pointer-type) - (sc-case index - (unsigned-reg - (inst nilz shift index ,(1- elements-per-word)) - ,@(unless (= bits 1) - `((inst sl shift ,(1- (integer-length bits)))))) - (any-reg - (inst nilz shift index ,(ash (1- elements-per-word) 2)) - ,@(unless (= bits 4) - `((inst sr shift ,(- 3 (integer-length bits))))))) - (inst xil shift ,(1- elements-per-word)) - - ;; Unless our immediate is all 1's, zero the destination bits. - (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) - (inst li temp ,(1- (ash 1 bits))) - (inst sl temp shift) - (inst not temp) - (inst n old temp)) - ;; Unless the value is zero, really deposit it. - (unless (and (sc-is value immediate) - (zerop (tn-value value))) - (sc-case value - (immediate - (inst li temp (logand (tn-value value) ,(1- (ash 1 bits))))) - ((unsigned-reg unsigned-stack) - (loadw temp (current-nfp-tn vop) - (tn-offset (if (sc-is value unsigned-stack) - value - value-save))) - (inst nilz temp ,(1- (ash 1 bits))))) - (inst sl temp shift) - (inst o old temp)) - (storew old lip vm:vector-data-offset vm:other-pointer-type) - (sc-case value - (immediate - (inst li result (tn-value value))) - ((unsigned-reg unsigned-stack) - (loadw result (current-nfp-tn vop) - (tn-offset (if (sc-is value unsigned-stack) - value - value-save))))))) - (define-vop (,(symbolicate 'data-vector-set-c/ type)) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs (unsigned-reg immediate) :target result)) - (:arg-types ,type (:constant index) positive-fixnum) - (:temporary (:scs (interior-reg)) lip) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp old) - (:generator 20 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (setf extra (logxor extra (1- ,elements-per-word))) - (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) - vm:other-pointer-type))) - (cond ((typep offset '(signed-byte 16)) - ;; Use the load with immediate offset if possible. - (inst l old offset)) - (t - ;; Load the upper half of the offset in one instruction - ;; and add the lower half as an immediate offset in - ;; the load. NOTE: if bit 15 is on, the load will sign- - ;; extend it, so we have to add 1 to the upper half now - ;; to counter the effect of the -1 from the sign-extension. - (inst cau lip object - (if (logbitp 15 offset) - (1+ (ash offset -16)) - (ash offset -16))) - (inst l old lip (logand #xFFFF offset))))) - ;; Unless our immediate is all 1's, zero the destination bits. - (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) - (inst li temp - (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits)))) - (inst n old temp)) - ;; Unless the value is zero, really deposit it. - (unless (and (sc-is value immediate) - (zerop (tn-value value))) - (sc-case value - (immediate - (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits))) - (* extra ,bits)))) - ;; Isn't this test silly, or the otherwise branch doesn't - ;; work anyway???? - (cond ((< value #x10000) - (inst oil old (logand #xFF value)) - (inst oiu old (logand #xFF00 value))) - (t - (inst li temp value) - (inst o old temp))))) - (unsigned-reg - (move temp value) - ;; Shouldn't we do this to check the size of the value? - (inst nilz temp ,(1- (ash 1 bits))) - (inst sl temp (* extra ,bits)) - (inst o old temp)))) - (storew old object vm:vector-data-offset vm:other-pointer-type) - (sc-case value - (immediate - (inst li result (tn-value value))) - (unsigned-reg - (move result value))))))))) - -) ;EVAL-WHEN - -(def-small-data-vector-frobs simple-bit-vector 1) -(def-small-data-vector-frobs simple-array-unsigned-byte-2 2) -(def-small-data-vector-frobs simple-array-unsigned-byte-4 4) - - - -;;;; Float vectors. - -#-afpa(progn -(define-vop (data-vector-ref/simple-array-mc68881-single-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-single-float positive-fixnum) - (:results (value :scs (mc68881-single-reg))) - (:result-types mc68881-single-float) - (:temporary (:sc sap-reg :from :eval) scratch) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (inst cas lip object index) - (inst inc lip (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst mc68881-load value lip :single scratch))) - -(define-vop (data-vector-set/simple-array-mc68881-single-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (mc68881-single-reg) :target result)) - (:arg-types simple-array-single-float positive-fixnum mc68881-single-float) - (:results (result :scs (mc68881-single-reg))) - (:result-types mc68881-single-float) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc sap-reg :from :eval) scratch) - (:generator 20 - (inst cas lip object index) - (inst inc lip (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst mc68881-store value lip :single scratch) - (unless (location= result value) - (inst mc68881-move result value scratch)))) - -(define-vop (data-vector-ref/simple-array-mc68881-double-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-double-float positive-fixnum) - (:results (value :scs (mc68881-double-reg))) - (:result-types mc68881-double-float) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc sap-reg :from :eval) scratch) - (:generator 20 - (inst cas lip object index) - (inst cas lip lip index) - (inst inc lip (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst mc68881-load value lip :double scratch))) - -(define-vop (data-vector-set/simple-array-mc68881-double-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (mc68881-double-reg) :target result)) - (:arg-types simple-array-double-float positive-fixnum mc68881-double-float) - (:results (result :scs (mc68881-double-reg))) - (:result-types mc68881-double-float) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc sap-reg :from :eval) scratch) - (:generator 20 - (inst cas lip object index) - (inst cas lip lip index) - (inst inc lip (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst mc68881-store value lip :double scratch) - (unless (location= result value) - (inst mc68881-move result value scratch)))) -) - -#+afpa(progn -(define-vop (data-vector-ref/simple-array-afpa-single-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-single-float positive-fixnum) - (:results (value :scs (afpa-single-reg))) - (:result-types afpa-single-float) - (:temporary (:sc sap-reg :from :eval) scratch) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (inst cas lip object index) - (inst inc lip (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst afpa-load value lip :single scratch) - (inst afpa-noop scratch))) - -(define-vop (data-vector-set/simple-array-afpa-single-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (afpa-single-reg) :target result)) - (:arg-types simple-array-single-float positive-fixnum afpa-single-float) - (:results (result :scs (afpa-single-reg))) - (:result-types afpa-single-float) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc sap-reg :from :eval) scratch) - (:generator 20 - (inst cas lip object index) - (inst inc lip (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst afpa-store value lip :single scratch) - (inst afpa-noop scratch) - (unless (location= result value) - (inst afpa-move result value :single scratch)))) - -(define-vop (data-vector-ref/simple-array-afpa-double-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-double-float positive-fixnum) - (:results (value :scs (afpa-double-reg))) - (:result-types afpa-double-float) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc sap-reg :from :eval) scratch) - (:generator 20 - (inst cas lip object index) - (inst cas lip lip index) - (inst inc lip (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst afpa-load value lip :double scratch) - (inst afpa-noop scratch))) - -(define-vop (data-vector-set/simple-array-afpa-double-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (afpa-double-reg) :target result)) - (:arg-types simple-array-double-float positive-fixnum afpa-double-float) - (:results (result :scs (afpa-double-reg))) - (:result-types afpa-double-float) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc sap-reg :from :eval) scratch) - (:generator 20 - (inst cas lip object index) - (inst cas lip lip index) - (inst inc lip (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst afpa-store value lip :double scratch) - (inst afpa-noop scratch) - (unless (location= result value) - (inst afpa-move result value :double scratch)))) -) - - -;;;; Raw bits without regard to vector type. - -(define-vop (raw-bits word-index-ref) - (:note "raw-bits VOP") - (:translate %raw-bits) - (:results (value :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant 0 vm:other-pointer-type)) - -(define-vop (set-raw-bits word-index-set) - (:note "setf raw-bits VOP") - (:translate %set-raw-bits) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg immediate)) - (value :scs (unsigned-reg))) - (:arg-types * positive-fixnum unsigned-num) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant 0 vm:other-pointer-type)) - - - -;;;; Vector subtype frobs. - -(define-vop (get-vector-subtype get-header-data)) -(define-vop (set-vector-subtype set-header-data)) diff --git a/compiler/rt/c-call.lisp b/compiler/rt/c-call.lisp deleted file mode 100644 index e893edd3e270d81f7bc8b76a59fb78fb54fd1c11..0000000000000000000000000000000000000000 --- a/compiler/rt/c-call.lisp +++ /dev/null @@ -1,217 +0,0 @@ -;;; -*- 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/c-call.lisp,v 1.10 1992/03/25 16:14:44 wlott Exp $ -;;; -;;; This file contains the VOPs and other necessary machine specific support -;;; routines for call-out to C. -;;; -;;; Written by William Lott. -;;; Converted by Bill Chiles. -;;; - -(in-package "RT") -(use-package "ALIEN") -(use-package "ALIEN-INTERNALS") - - - -;;;; Make-call-out-tns and support stuff. - -(defun c-call-wired-tn (primitive-type sc-name offset) - (make-wired-tn (primitive-type-or-lose primitive-type) - (sc-number-or-lose sc-name) - offset)) - - -(defstruct arg-state - (offset 0)) - -(defun int-arg (state prim-type stack-sc) - ;; C expects 4 register args and the 5th arg at the top of the stack. - ;; We can't put args in registers, because we need those registers - ;; for something else. So we put them just beyond the end of the - ;; stack and the trampoline code will move them into place. - (let ((frame-size (arg-state-offset state))) - (setf (arg-state-offset state) (1+ frame-size)) - (c-call-wired-tn prim-type stack-sc frame-size))) - -(defun int-result (state prim-type reg-sc) - (let ((reg-num (arg-state-offset state))) - (setf (arg-state-offset state) (1+ reg-num)) - (c-call-wired-tn prim-type reg-sc reg-num))) - -(def-alien-type-method (integer :arg-tn) (type state) - (if (alien-integer-type-signed type) - (int-arg state 'signed-byte-32 'signed-stack) - (int-arg state 'unsigned-byte-32 'unsigned-stack))) - -(def-alien-type-method (integer :result-tn) (type state) - (if (alien-integer-type-signed type) - (int-result state 'signed-byte-32 'signed-reg) - (int-result state 'unsigned-byte-32 'unsigned-reg))) - -(def-alien-type-method (system-area-pointer :arg-tn) (type state) - (declare (ignore type)) - (int-arg state 'system-area-pointer 'sap-stack)) - -(def-alien-type-method (system-area-pointer :result-tn) (type state) - (declare (ignore type)) - (int-result state 'system-area-pointer 'sap-reg)) - -(def-alien-type-method (values :result-tn) (type state) - (mapcar #'(lambda (type) - (invoke-alien-type-method :result-tn type state)) - (alien-values-type-values type))) - -(def-vm-support-routine make-call-out-tns (type) - (declare (type alien-function-type type)) - (let ((arg-state (make-arg-state))) - (collect ((arg-tns)) - (dolist (arg-type (alien-function-type-arg-types type)) - (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) - (values (c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset) - (* (arg-state-offset arg-state) word-bytes) - (arg-tns) - (invoke-alien-type-method - :result-tn - (alien-function-type-result-type type) - (make-arg-state :offset nl0-offset)))))) - - -;;;; Deftransforms to convert uses of %alien-funcall into cononical form. - -(deftransform %alien-funcall ((function type &rest args) - (t * &rest t)) - (assert (c::constant-continuation-p type)) - (let* ((type (c::continuation-value type)) - (arg-types (alien-function-type-arg-types type)) - (result-type (alien-function-type-result-type type))) - (assert (= (length arg-types) (length args))) - (if (some #'alien-double-float-type-p arg-types) - (collect ((new-args) (lambda-vars) (new-arg-types)) - (dolist (type arg-types) - (let ((arg (gensym))) - (lambda-vars arg) - (typecase type - (alien-double-float-type - (new-args `(double-float-high-bits ,arg)) - (new-args `(double-float-low-bits ,arg)) - (new-arg-types (parse-alien-type '(signed 32))) - (new-arg-types (parse-alien-type '(unsigned 32)))) - (t - (new-args arg) - (new-arg-types type))))) - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (%alien-funcall function - ',(make-alien-function-type - :arg-types (new-arg-types) - :result-type result-type) - ,@(new-args)))) - (c::give-up)))) - -(deftransform %alien-funcall ((function type &rest args) - (* t &rest t)) - (assert (c::constant-continuation-p type)) - (let* ((type (c::continuation-value type)) - (arg-types (alien-function-type-arg-types type)) - (result-type (alien-function-type-result-type type))) - (assert (= (length arg-types) (length args))) - (flet ((make-arg-name-list () - (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) - arg-types))) - (typecase result-type - (alien-double-float-type - (let ((arg-names (make-arg-name-list))) - `(lambda (function type ,@arg-names) - (declare (ignore type)) - (multiple-value-bind - (hi lo) - (%alien-funcall function - ',(make-alien-function-type - :arg-types arg-types - :result-type - (let ((*values-type-okay* t)) - (parse-alien-type - '(values (signed 32) - (unsigned 32))))) - ,@arg-names) - (make-double-float hi lo))))) - (alien-single-float-type - (let ((arg-names (make-arg-name-list))) - `(lambda (function type ,@arg-names) - (declare (ignore type)) - (make-single-float - (%alien-funcall function - ',(parse-alien-type - `(function (signed 32) ,@arg-types)) - ,@arg-names))))) - (t - (c::give-up)))))) - - -;;;; Vops. - - -(define-vop (foreign-symbol-address) - (:translate foreign-symbol-address) - (:policy :fast-safe) - (:args) - (:arg-types (:constant simple-string)) - (:info foreign-symbol) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst cai res (make-fixup (concatenate 'simple-string "_" foreign-symbol) - :foreign)))) - -(define-vop (call-out) - (:args (function :scs (sap-reg) :target nl0) - (args :more t)) - (:results (results :more t)) - (:ignore args results) - (:save-p t) - (:temporary (:sc any-reg :offset nl0-offset - :from (:argument 0) :to (:result 0)) nl0) - (:temporary (:sc any-reg :offset lra-offset) lra) - (:temporary (:sc any-reg :offset code-offset) code) - (:temporary (:scs (sap-reg) :to (:result 0)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:vop-var vop) - (:generator 0 - (let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (move nl0 function) - (when cur-nfp - (store-stack-tn cur-nfp nfp-save)) - (inst compute-lra-from-code lra code lra-label) - (inst cai temp (make-fixup "call_into_c" :foreign)) - (inst b temp) - - (align vm:lowtag-bits) - (emit-label lra-label) - (inst lra-header-word) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - -(define-vop (alloc-number-stack-space) - (:info amount) - (:results (result :scs (sap-reg any-reg))) - (:generator 0 - (unless (zerop amount) - (inst cal nsp-tn nsp-tn (- (logandc2 (+ amount 7) 7)))) - (move result nsp-tn))) - -(define-vop (dealloc-number-stack-space) - (:info amount) - (:policy :fast-safe) - (:generator 0 - (unless (zerop amount) - (inst cal nsp-tn nsp-tn (logandc2 (+ amount 7) 7))))) diff --git a/compiler/rt/call.lisp b/compiler/rt/call.lisp deleted file mode 100644 index 8b530e978a267a82d16230efe1f8e9d21ef772d3..0000000000000000000000000000000000000000 --- a/compiler/rt/call.lisp +++ /dev/null @@ -1,1158 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of function call for the IBM RT. -;;; -;;; Written by Rob MacLachlan, William Lott, and Bill Chiles. -;;; - -(in-package "RT") - - - -;;;; Interfaces to IR2 conversion: - -;;; STANDARD-ARGUMENT-LOCATION -- Interface. -;;; -;;; Return a wired TN describing the N'th full call argument passing location. -;;; -(def-vm-support-routine standard-argument-location (n) - (declare (type unsigned-byte n)) - (if (< n register-arg-count) - (make-wired-tn *any-primitive-type* - register-arg-scn - (elt register-arg-offsets n)) - (make-wired-tn *any-primitive-type* - control-stack-arg-scn n))) - -;;; MAKE-RETURN-PC-PASSING-LOCATION -- Interface. -;;; -;;; Make a passing location TN for a local call return-PC. If standard is -;;; true, then use the standard (full call) location, otherwise use any legal -;;; location. Even in the non-standard case, this may be restricted by a -;;; desire to use a subroutine call instruction. -;;; -;;; These are *any-primitive-type* since LRA's are descriptor objects. -;;; -(def-vm-support-routine make-return-pc-passing-location (standard) - (if standard - (make-wired-tn *any-primitive-type* register-arg-scn lra-offset) - (make-restricted-tn *any-primitive-type* register-arg-scn))) - -;;; MAKE-OLD-FP-PASSING-LOCATION -- Interface. -;;; -;;; Similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a location to supply -;;; the old control FP. This is (obviously) wired in the standard convention, -;;; but is totally unrestricted in non-standard conventions, since we can -;;; always fetch it off of the stack using the arg pointer. -;;; -;;; These are *word-pointer-type* since FP's are word aligned pointers, -;;; so the low tow bits are zero. -;;; -(def-vm-support-routine make-old-fp-passing-location (standard) - (if standard - (make-wired-tn *word-pointer-type* immediate-arg-scn ocfp-offset) - (make-normal-tn *word-pointer-type*))) - -;;; MAKE-OLD-FP-SAVE-LOCATION, MAKE-RETURN-PC-SAVE-LOCATION -- Interface. -;;; -;;; Make the TN's used to hold the old control FP and return-PC within the -;;; current function. We treat these specially so that the debugger can find -;;; them at a known location. -;;; -;;; ### Fix to use specified save TNs... -;;; -;;; See comments for MAKE-RETURN-PC-PASSING-LOCATION and M-O-FP-P-L. -;;; -(def-vm-support-routine make-old-fp-save-location (env) - (specify-save-tn - (environment-debug-live-tn (make-normal-tn *word-pointer-type*) env) - (make-wired-tn *word-pointer-type* - control-stack-arg-scn - ocfp-save-offset))) -;;; -(def-vm-support-routine make-return-pc-save-location (env) - (specify-save-tn - (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env) - (make-wired-tn *any-primitive-type* - control-stack-arg-scn - lra-save-offset))) - -;;; MAKE-ARGUMENT-COUNT-LOCATION -- Interface. -;;; -;;; Make a TN for the standard argument count passing location. We only need -;;; to make the standard location, since a count is never passed when we are -;;; using non-standard conventions. -;;; -(def-vm-support-routine make-argument-count-location () - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) - - -;;; MAKE-NFP-TN -- Interface. -;;; -;;; Make a TN to hold the number-stack frame pointer. This is allocated once -;;; per component, and is component-live. -;;; -(def-vm-support-routine make-nfp-tn () - (component-live-tn - (make-wired-tn *word-pointer-type* immediate-arg-scn nfp-offset))) - -;;; MAKE-STACK-POINTER-TN -- Interface. -;;; -;;; This is of fixnum type because stack pointers are word aligned on our -;;; byte-addressable machine, so they have fixnum tag bits inherently. Also, -;;; GC doesn't need to fix these since the stack doesn't move. -;;; -(def-vm-support-routine make-stack-pointer-tn () - (make-normal-tn *word-pointer-type*)) - -;;; MAKE-NUMBER-STACK-POINTER-TN -- Interface. -;;; -(def-vm-support-routine make-number-stack-pointer-tn () - (make-normal-tn *word-pointer-type*)) - -;;; MAKE-UNKNOWN-VALUES-LOCATIONS -- Interface. -;;; -;;; Return a list of TN's that can be used to represent an unknown-values -;;; continuation within a function. The first one is a stack pointer TN, and -;;; the second is an argument count TN. -;;; -(def-vm-support-routine make-unknown-values-locations () - (list (make-stack-pointer-tn) - (make-normal-tn *fixnum-primitive-type*))) - - -;;; SELECT-COMPONENT-FORMAT -- Interface. -;;; -;;; This function is called by the Entry-Analyze phase, allowing VM-dependent -;;; initialization of the IR2-Component structure. We push placeholder entries -;;; in the Constants to leave room for additional noise in the code object -;;; header. -;;; -(def-vm-support-routine select-component-format (component) - (declare (type component component)) - (dotimes (i code-constants-offset) - (vector-push-extend nil - (ir2-component-constants (component-info component)))) - (undefined-value)) - - - -;;;; Frame hackery: - -;;; CURRENT-FP -- VOP. -;;; -;;; Used for setting up the OCFP in local call. -;;; -(define-vop (current-fp) - ;; Stack pointers look like fixnums, and GC doesn't need to fix them. - (:results (val :scs (word-pointer-reg))) - (:generator 1 - (move val cfp-tn))) - -;;; COMPUTE-OLD-NFP -- VOP. -;;; -;;; A returner uses this for computing the returnee's NFP for use in -;;; known-values return. Only works assuming there is no variable size stuff -;;; on the nstack. -;;; -(define-vop (compute-old-nfp) - (:results (val :scs (word-pointer-reg) - :load-if (current-nfp-tn vop))) - (:vop-var vop) - (:generator 1 - (let ((nfp (current-nfp-tn vop))) - ;; We know nfp is in a register. - (when nfp - ;; The number stack grows down in memory, so the old-nfp is greater - ;; than the current one -- add a positive number. - (inst cal val nfp - (component-non-descriptor-stack-usage)))))) - -;;; XEP-ALLOCATE-FRAME -- VOP. -;;; -;;; This is the first VOP invoked by the compiler at every entry point for a -;;; component. It sets up to be dual-word aligned (because of our low-tag -;;; bits), emits the header-word for the function data-block, and emits any -;;; extra words for data about the function (such as debug-info, its name, -;;; etc.). Then it emits instructions to allocate whatever room the function -;;; will need on the control stack. -;;; -(define-vop (xep-allocate-frame) - (:info start-lab) - (:vop-var vop) - (:generator 1 - ;; Make sure the label is aligned. - (align vm:lowtag-bits) - (emit-label start-lab) - ;; Allocate function header. - (inst function-header-word) - (dotimes (i (1- vm:function-header-code-offset)) - (inst word 0)) - ;; The start of the actual code. A pointer to here is stored in symbols - ;; for named call. Make CODE point to the component from this pointer. - (let ((entry-point (gen-label))) - (emit-label entry-point) - (inst compute-code-from-fn code-tn lip-tn entry-point)) - ;; Caller has set FP to the beginning of the callee's frame. - (inst cal csp-tn cfp-tn - (* vm:word-bytes (sb-allocated-size 'control-stack))) - (let ((nfp-tn (current-nfp-tn vop))) - (when nfp-tn - (inst cal nsp-tn nsp-tn - (- (component-non-descriptor-stack-usage))) - (move nfp-tn nsp-tn))))) - -;;; ALLOCATE-FRAME -- VOP. -;;; -;;; The compiler invokes this in local call for the caller. -;;; -(define-vop (allocate-frame) - (:results (res :scs (word-pointer-reg)) - (nfp :scs (word-pointer-reg) - :load-if (ir2-environment-number-stack-p callee))) - (:info callee) - (:generator 2 - (move res csp-tn) - (inst cal csp-tn csp-tn - (* vm:word-bytes (sb-allocated-size 'control-stack))) - (when (ir2-environment-number-stack-p callee) - (inst cal nsp-tn nsp-tn - (- (component-non-descriptor-stack-usage))) - (move nfp nsp-tn)))) - -;;; ALLOCATE-FULL-CALL-FRAME -- VOP. -;;; -;;; Allocate a partial frame for passing stack arguments in a full call. Nargs -;;; is the number of arguments passed. If no stack arguments are passed, then -;;; we don't have to do anything. The compiler only invokes this for the -;;; caller. -;;; -(define-vop (allocate-full-call-frame) - (:info nargs) - (:results (res :scs (word-pointer-reg) - :load-if (> nargs register-arg-count))) - (:generator 2 - (when (> nargs register-arg-count) - (move res csp-tn) - (inst cal csp-tn csp-tn (* nargs vm:word-bytes))))) - - - - -;;; DEFAULT-UNKNOWN-VALUES -- Internal. -;;; -;;; Emit code needed at the return-point from an unknown-values call to get or -;;; default a desired, fixed number of values. Values is the head of the -;;; TN-Ref list for the locations that the values are to be received into. -;;; Nvals is the number of values that are to be received (should equal the -;;; length of Values). -;;; -;;; Move-Temp is a Descriptor-Reg TNs used as a temporary. -;;; -;;; This code exploits the fact that in the unknown-values convention, a single -;;; value return returns at the return PC + 4, whereas a return of other than -;;; one value returns directly at the return PC. -;;; -;;; If 0 or 1 values are expected, then we just emit an instruction to reset -;;; the SP (which will only be executed when other than 1 value is returned.) -;;; -;;; In the general case, we have to do three things: -;;; -- Default unsupplied register values. This need only be done when a -;;; single value is returned, since register values are defaulted by the -;;; called in the non-single case. -;;; -- Default unsupplied stack values. This needs to be done whenever there -;;; are stack values. -;;; -- Reset SP. This must be done whenever other than 1 value is returned, -;;; regardless of the number of values desired. -;;; -;;; The general-case code looks like this: -#| - br regs-defaulted ; Skip if MVs - cau a1 0 nil-16 ; Default register values - ... - loadi nargs 1 ; Force defaulting of stack values - lr args sp ; Set up args for SP resetting - -regs-defaulted - cau nil-temp 0 nil-16 ; Cache nil - - cmpi nargs 3 ; If 4'th value unsupplied... - blex default-value-4 ; jump to default code - loadw move-temp ocfp-tn 3 ; Move value to correct location. - store-stack-tn val4-tn move-temp - - cmpi nargs 4 ; Check 5'th value, etc. - blex default-value-5 - loadw move-temp ocfp-tn 4 - store-stack-tn val5-tn move-temp - - ... - -defaulting-done - lr sp args ; Reset SP. -<end of code> - -<elsewhere> -default-value-4 - store-stack-tn val4-tn nil-temp ; Nil out 4'th value. - -default-value-5 - store-stack-tn val5-tn nil-temp ; Nil out 5'th value. - - ... - - br defaulting-done -|# -;;; -(defun default-unknown-values (values nvals move-temp lra-label) - (declare (type (or tn-ref null) values) - (type unsigned-byte nvals) (type tn move-temp)) - (cond - ((<= nvals 1) - ;; Don't use MOVE. Use a known 32-bit long instruction, so the returner - ;; can know how many bytes we used here in the multiple-value return case. - ;; The returner wants to add a known quantity to LRA indicating how many - ;; values it returned. - (inst cal csp-tn ocfp-tn 0) - (inst compute-code-from-lra code-tn code-tn lra-label)) - (t - (let ((regs-defaulted (gen-label)) - (defaulting-done (gen-label)) - (default-stack-vars (gen-label))) - ;; Branch off to the MV case. - ;; The returner has setup value registers and NARGS, and OCFP points to - ;; any stack values. - ;; Use a known 32-bit long instruction, so the returner can know how many - ;; bytes we used here in the multiple-value return case. The returner - ;; wants to add a known quantity to LRA indicating how many values it - ;; returned. - (inst bnb :pz regs-defaulted) - ;; - ;; Do the single value case. - ;; Fill in some n-1 registers with nil to get to a consistent state with - ;; having gotten multiple values, so the code after regs-defaulted can - ;; be the same for both cases. - (do ((i 1 (1+ i)) - (val (tn-ref-across values) (tn-ref-across val))) - ((= i (min nvals register-arg-count))) - (move (tn-ref-tn val) null-tn)) - ;; Set OCFP to CSP and (maybe) jump to the code that defaults (i.e. - ;; NILs out) all the values that would come from the stack. We have - ;; to set OCFP because the stack defaulting stuff is going to set CSP - ;; to OCFP when it gets done to clear any values off the stack, and we - ;; don't want that to trash CSP. - (when (> nvals register-arg-count) - (inst bx default-stack-vars)) - (move ocfp-tn csp-tn) - - (emit-label regs-defaulted) - - (when (> nvals register-arg-count) - (collect ((defaults)) - (do ((i register-arg-count (1+ i)) - (val (do ((i 0 (1+ i)) - (val values (tn-ref-across val))) - ((= i register-arg-count) val)) - (tn-ref-across val))) - ((null val)) - - (let ((default-lab (gen-label)) - (tn (tn-ref-tn val))) - (defaults (cons default-lab tn)) - (inst c nargs-tn (fixnum i)) - (inst bnbx :gt default-lab) - (loadw move-temp ocfp-tn i) - (store-stack-tn move-temp tn))) - - (emit-label defaulting-done) - - (assemble (*elsewhere*) - (emit-label default-stack-vars) - (dolist (def (defaults)) - (emit-label (car def)) - (store-stack-tn null-tn (cdr def))) - (inst b defaulting-done)))) - - (inst compute-code-from-lra code-tn code-tn lra-label) - (move csp-tn ocfp-tn)))) - (undefined-value)) - - - -;;;; Unknown values receiving: - -;;; Receive-Unknown-Values -- Internal -;;; -;;; Emit code needed at the return point for an unknown-values call for an -;;; arbitrary number of values. -;;; -;;; We do the single and non-single cases with no shared code: there doesn't -;;; seem to be any potential overlap, and receiving a single value is more -;;; important efficiency-wise. -;;; -;;; When there is a single value, we just push it on the stack, returning -;;; the old SP and 1. -;;; -;;; When there is a variable number of values, we move all of the argument -;;; registers onto the stack, and return Args and Nargs. -;;; -;;; Args and Nargs are TNs wired to the named locations. We must -;;; explicitly allocate these TNs, since their lifetimes overlap with the -;;; results Start and Count (also, it's nice to be able to target them). -;;; -(defun receive-unknown-values (args nargs start count lra-label) - (declare (type tn args nargs start count)) - (let ((variable-values (gen-label)) - (done (gen-label))) - ;; Use a known 32-bit long instruction, so the returner can know how many - ;; bytes we used here in the multiple-value return case. The returner - ;; wants to add a known quantity to LRA indicating how many values it - ;; returned. - (inst bnb :pz variable-values) - ;; Here's the return point for the single-value return. - (inst compute-code-from-lra code-tn code-tn lra-label) - (inst inc csp-tn vm:word-bytes) - (storew (first register-arg-tns) csp-tn -1) - (inst cal start csp-tn -4) - (inst li count (fixnum 1)) - - (emit-label done) - - (assemble (*elsewhere*) - (emit-label variable-values) - (inst compute-code-from-lra code-tn code-tn lra-label) - (do ((arg register-arg-tns (rest arg)) - (i 0 (1+ i))) - ((null arg)) - (storew (first arg) args i)) - (move start args) - (move count nargs) - (inst b done))) - (undefined-value)) - - -;;; UNKNOWN-VALUES-RECEIVER -- VOP. -;;; -;;; This is inherited by unknown values receivers. The main thing this handles -;;; is allocation of the result temporaries. This has to be included for in -;;; any VOP using RECEIVE-UNKNOWN-VALUES. -;;; -(define-vop (unknown-values-receiver) - (:results - (start :scs (word-pointer-reg)) - (count :scs (any-reg))) - (:temporary (:sc descriptor-reg :offset ocfp-offset - :from :eval :to (:result 0)) - values-start) - (:temporary (:sc any-reg :offset nargs-offset - :from :eval :to (:result 1)) - nvals)) - - - -;;;; Local call with unknown values convention return: - -;;; Non-TR local call for a fixed number of values passed according to the -;;; unknown values convention. -;;; -;;; Args are the argument passing locations, which are specified only to -;;; terminate their lifetimes in the caller. -;;; -;;; Values are the return value locations (wired to the standard passing -;;; locations). -;;; -;;; Save is the save info, which we can ignore since saving has been done. -;;; Return-PC is the TN that the return PC should be passed in. -;;; Target is a continuation pointing to the start of the called function. -;;; Nvals is the number of values received. -;;; -(define-vop (call-local) - (:args (fp :scs (word-pointer-reg control-stack)) - (nfp :scs (word-pointer-reg control-stack)) - (args :more t)) - (:results (values :more t)) - (:save-p t) - (:move-args :local-call) - (:info arg-locs callee target nvals) - (:ignore arg-locs args nfp) - (:vop-var vop) - (:temporary (:scs (descriptor-reg)) move-temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:generator 5 - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn cur-nfp nfp-save)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (maybe-load-stack-tn callee-nfp nfp))) - (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label) - (inst b target) - (emit-return-pc label) - (note-this-location vop :unknown-return) - (default-unknown-values values nvals move-temp label) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - - -;;; Non-TR local call for a variable number of return values passed according -;;; to the unknown values convention. The results are the start of the values -;;; glob and the number of values received. -;;; -(define-vop (multiple-call-local unknown-values-receiver) - (:args (fp :scs (word-pointer-reg control-stack)) - (nfp :scs (word-pointer-reg control-stack)) - (args :more t)) - (:save-p t) - (:move-args :local-call) - (:info save callee target) - (:ignore args save) - (:vop-var vop) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:generator 20 - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn cur-nfp nfp-save)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (maybe-load-stack-tn callee-nfp nfp))) - (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label) - (inst b target) - (emit-return-pc label) - (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count label) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - - -;;;; Local call with known values return: - -;;; Non-TR local call with known return locations. Known-value return works -;;; just like argument passing in local call. -;;; -(define-vop (known-call-local) - (:args (fp :scs (word-pointer-reg control-stack)) - (nfp :scs (word-pointer-reg control-stack)) - (args :more t)) - (:results (res :more t)) - (:move-args :local-call) - (:save-p t) - (:info save callee target) - (:ignore args res save) - (:vop-var vop) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:generator 5 - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn cur-nfp nfp-save)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (maybe-load-stack-tn callee-nfp nfp))) - (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label) - (inst b target) - (emit-return-pc label) - (note-this-location vop :known-return) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - -;;; Return from known values call. We receive the return locations as -;;; arguments to terminate their lifetimes in the returning function. We -;;; restore FP and CSP and jump to the Return-PC. -;;; -(define-vop (known-return) - (:args (old-fp :scs (word-pointer-reg control-stack)) - (return-pc-arg :scs (descriptor-reg control-stack) - :target return-pc) - (vals :more t)) - (:temporary (:scs (interior-reg) :type interior) lip) - (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc) - (:move-args :known-return) - (:info val-locs) - (:ignore val-locs vals) - (:vop-var vop) - (:generator 6 - (move csp-tn cfp-tn) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst cal nsp-tn cur-nfp - (component-non-descriptor-stack-usage)))) - (maybe-load-stack-tn return-pc return-pc-arg) - ;; Skip over a word, the LRA header, and subtract out low-tag bits. - (inst cal lip return-pc (- vm:word-bytes vm:other-pointer-type)) - (inst bx lip) - (maybe-load-stack-tn cfp-tn old-fp))) - - - -;;;; Full call: -;;; -;;; There is something of a cross-product effect with full calls. Different -;;; versions are used depending on whether we know the number of arguments or -;;; the name of the called function, and whether we want fixed values, unknown -;;; values, or a tail call. -;;; -;;; In full call, the arguments are passed creating a partial frame on the -;;; stack top and storing stack arguments into that frame. On entry to the -;;; callee, this partial frame is pointed to by FP. If there are no stack -;;; arguments, we don't bother allocating a partial frame, and instead set FP -;;; to SP just before the call. - -;;; Define-Full-Call -- Internal. -;;; -;;; This macro helps in the definition of full call VOPs by avoiding code -;;; replication in defining the cross-product VOPs. -;;; -;;; Name is the name of the VOP to define. -;;; -;;; Named is true if the first argument is a symbol whose global function -;;; definition is to be called. -;;; -;;; Return is either :Fixed, :Unknown or :Tail: -;;; -- If :Fixed, then the call is for a fixed number of values, returned in -;;; the standard passing locations (passed as result operands). -;;; -- If :Unknown, then the result values are pushed on the stack, and the -;;; result values are specified by the Start and Count as in the -;;; unknown-values continuation representation. -;;; -- If :Tail, then do a tail-recursive call. No values are returned. -;;; The Old-Fp and Return-PC are passed as the second and third arguments. -;;; -;;; In non-tail calls, the pointer to the stack arguments is passed as the last -;;; fixed argument. If Variable is false, then the passing locations are -;;; passed as a more arg. Variable is true if there are a variable number of -;;; arguments passed on the stack. Variable cannot be specified with :Tail -;;; return. TR variable argument call is implemented separately. -;;; -;;; When variable is false, the compiler actually has already invoked VOP's to -;;; explicitly move arguments into their passing locations. Hence the VOP -;;; argument args (which is :more t) is actually ignored. We pass it into the -;;; call VOP's for lifetime analysis, and the TN references it represents stand -;;; in at the call site for the references to those TN's where the callee -;;; actually reads them. -;;; -;;; In tail call with fixed arguments, the passing locations are passed as a -;;; more arg, but there is no new-FP, since the arguments have been set up in -;;; the current frame. -;;; -(eval-when (compile eval) -(defmacro define-full-call (name named return variable) - (assert (not (and variable (eq return :tail)))) - `(define-vop (,name - ,@(when (eq return :unknown) - '(unknown-values-receiver))) - (:args - ,@(unless (eq return :tail) - '((new-fp :scs (word-pointer-reg) :to :eval))) - - ,(if named - '(name :scs (descriptor-reg) :target name-pass) - '(arg-fun :scs (descriptor-reg) :target lexenv)) - - ,@(when (eq return :tail) - '((old-fp :scs (word-pointer-reg) :target old-fp-pass) - (return-pc :scs (descriptor-reg control-stack) - :target return-pc-pass))) - - ,@(unless variable '((args :more t :scs (descriptor-reg))))) - - ,@(when (eq return :fixed) - '((:results (values :more t)))) - - ,@(unless (eq return :tail) - `((:save-p t) - ,@(unless variable - '((:move-args :full-call))))) - - (:vop-var vop) - (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(nargs)) - ,@(when (eq return :fixed) '(nvals))) - - (:ignore - ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(args))) - - (:temporary (:sc descriptor-reg - :offset ocfp-offset - :from (:argument 1) - :to :eval) - old-fp-pass) - - (:temporary (:sc descriptor-reg - :offset lra-offset - :from (:argument ,(if (eq return :tail) 2 1)) - :to :eval) - return-pc-pass) - - ,@(if named - `((:temporary (:sc descriptor-reg :offset cname-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - name-pass)) - - `((:temporary (:sc descriptor-reg :offset lexenv-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - lexenv) - (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) - function))) - - - (:temporary (:sc descriptor-reg :offset nargs-offset :to :eval) - nargs-pass) - - ,@(when variable - (mapcar #'(lambda (name offset) - `(:temporary (:sc descriptor-reg - :offset ,offset - :to :eval) - ,name)) - register-arg-names register-arg-offsets)) - ,@(when (eq return :fixed) - '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) - - ,@(unless (eq return :tail) - '((:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) - - (:temporary (:scs (interior-reg) :type interior) lip) - - (:generator ,(+ (if named 5 0) - (if variable 19 1) - (if (eq return :tail) 0 10) - 15 - (if (eq return :unknown) 25 0)) - - (let ((cur-nfp (current-nfp-tn vop)) - ,@(unless (eq return :tail) - '((lra-label (gen-label))))) - - ,@(if variable - ;; Compute the number of arguments and move some of the arguments - ;; from the stack to the argument registers. - `((move nargs-pass csp-tn) - ;; This computes a byte difference, but due to the number of - ;; bytes per word and out fixnum tags, this leaves a fixnum - ;; word count for the callee. - (inst s nargs-pass new-fp) - ,@(let ((index -1)) - (mapcar #'(lambda (name) - `(loadw ,name new-fp ,(incf index))) - register-arg-names))) - `((inst li nargs-pass (fixnum nargs)))) - - - ,@(if named - `((move name-pass name) - (loadw lip name-pass vm:symbol-raw-function-addr-slot - vm:other-pointer-type)) - `((move lexenv arg-fun) - (loadw function lexenv vm:closure-function-slot - vm:function-pointer-type) - (inst cal lip function (- (ash vm:function-header-code-offset - vm:word-shift) - vm:function-pointer-type)))) - - ,@(if (eq return :tail) - '((move old-fp-pass old-fp) - (maybe-load-stack-tn return-pc-pass return-pc) - (when cur-nfp - (inst cal nsp-tn cur-nfp - (component-non-descriptor-stack-usage))) - (inst b lip)) - `((inst compute-lra-from-code - return-pc-pass code-tn lra-label) - (move old-fp-pass cfp-tn) - (when cur-nfp - (store-stack-tn cur-nfp nfp-save)) - ,(if variable - '(move cfp-tn new-fp) - '(if (> nargs register-arg-count) - (move cfp-tn new-fp) - (move cfp-tn csp-tn))) - (inst b lip) - (emit-return-pc lra-label))) - - ,@(ecase return - (:fixed - '((note-this-location vop :unknown-return) - (default-unknown-values values nvals move-temp lra-label) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)))) - (:unknown - '((note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count - lra-label) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)))) - (:tail)))))) -) ;EVAL-WHEN - -(define-full-call call nil :fixed nil) -(define-full-call call-named t :fixed nil) -(define-full-call multiple-call nil :unknown nil) -(define-full-call multiple-call-named t :unknown nil) -(define-full-call tail-call nil :tail nil) -(define-full-call tail-call-named t :tail nil) - -(define-full-call call-variable nil :fixed t) -(define-full-call multiple-call-variable nil :unknown t) - - -;;; Defined separately, since needs special code that BLT's the arguments -;;; down. -;;; -(define-vop (tail-call-variable) - (:args (args-arg :scs (word-pointer-reg) :target args) - (function-arg :scs (descriptor-reg) :target lexenv) - (old-fp-arg :scs (word-pointer-reg) :target old-fp) - (lra-arg :scs (descriptor-reg) :target lra)) - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) - (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) - (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp) - (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) - (:temporary (:scs (any-reg) :from :eval) temp) - (:vop-var vop) - (:generator 75 - ;; Move these into the passing locations if they are not already there. - (move args args-arg) - (move lexenv function-arg) - (move old-fp old-fp-arg) - (move lra lra-arg) - - ;; Clear the number stack if anything is there. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst cal nsp-tn cur-nfp - (component-non-descriptor-stack-usage)))) - - ;; And jump to the assembly-routine that moves the arguments for us. - (inst bala (make-fixup 'really-tail-call-variable :assembly-routine)))) - - - -;;;; Unknown values return: - - -;;; Do unknown-values return of a fixed number of values. The Values are -;;; required to be set up in the standard passing locations. Nvals is the -;;; number of values returned. -;;; -;;; If returning a single value, then deallocate the current frame, restore -;;; FP and jump to the single-value entry at Return-PC + 4. -;;; -;;; If returning other than one value, then load the number of values returned, -;;; NIL out unsupplied values registers, restore FP and return at Return-PC. -;;; When there are stack values, we must initialize the argument pointer to -;;; point to the beginning of the values block (which is the beginning of the -;;; current frame.) -;;; -(define-vop (return) - (:args - (old-fp :scs (word-pointer-reg)) - (return-pc :scs (descriptor-reg) :to (:eval 1)) - (values :more t)) - (:ignore values) - (:info nvals) - (:temporary (:sc any-reg :offset a0-offset :from (:eval 0) :to (:eval 1)) - a0) - (:temporary (:sc any-reg :offset a1-offset :from (:eval 0) :to (:eval 1)) - a1) - (:temporary (:sc any-reg :offset a2-offset :from (:eval 0) :to (:eval 1)) - a2) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) - (:temporary (:scs (interior-reg) :type interior) lip) - (:vop-var vop) - (:generator 6 - (cond ((= nvals 1) - ;; Clear the stacks. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst cal nsp-tn cur-nfp - (component-non-descriptor-stack-usage)))) - (move csp-tn cfp-tn) - ;; Reset the frame pointer. - (move cfp-tn old-fp) - ;; Out of here. - ;; The return-pc (LRA) has other-pointer lowtag bits. Also, in the - ;; instruction sequence in which the LRA points, there is a header - ;; word with immediate data indicating the offset back to the - ;; beginning of the component. The calling convention says to - ;; return one word past the return point when the returner knows - ;; it has only one value, so we skip that word here and the header - ;; for the LRA. - (inst cal lip return-pc (- (* 2 word-bytes) other-pointer-type)) - (inst bx lip) - (move code-tn return-pc)) - (t - (inst li nargs (fixnum nvals)) - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst cal nsp-tn cur-nfp - (component-non-descriptor-stack-usage)))) - (move val-ptr cfp-tn) - ;; Reset the frame pointer. - (move cfp-tn old-fp) - - (let ((immediate (* nvals word-bytes))) - (assert (typep immediate '(signed-byte 16))) - (inst cal csp-tn val-ptr immediate)) - - (when (< nvals 1) (move a0 null-tn)) - (when (< nvals 2) (move a1 null-tn)) - (when (< nvals 3) (move a2 null-tn)) - - (lisp-return return-pc lip))))) - -;;; RETURN-MULTIPLE -- VOP. -;;; -;;; Do unknown-values return of an arbitrary number of values (passed on the -;;; stack.) We check for the common case of a single return value, and do that -;;; inline using the normal single value return convention. Otherwise, we -;;; branch off to an assembler routine. -;;; -;;; The Return-Multiple miscop uses a non-standard calling convention. For one -;;; thing, it doesn't return. We only use BALA because there isn't a BA -;;; instruction. Also, we don't use A0..A2 for argument passing, since the -;;; miscop will want to load these with values off of the stack. Instead, we -;;; pass Old-Fp, Start and Count in the normal locations for these values. -;;; Return-PC is passed in A3 since PC is trashed by the BALA. -;;; -(define-vop (return-multiple) - (:args - (ocfp-arg :scs (word-pointer-reg) :target ocfp) - (lra-arg :scs (descriptor-reg) :target lra) - (vals-arg :scs (word-pointer-reg) :target vals) - (nvals-arg :scs (any-reg) :target nvals)) - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) ocfp) - (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) - (:temporary (:sc any-reg :offset cname-offset :from (:argument 2)) vals) - (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) - (:temporary (:sc descriptor-reg :offset a0-offset) a0) - (:temporary (:scs (interior-reg) :type interior) lip) - (:vop-var vop) - (:generator 13 - (let ((not-single (gen-label))) - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst cal nsp-tn cur-nfp - (component-non-descriptor-stack-usage)))) - - ;; Single case? - (inst c nvals-arg (fixnum 1)) - (inst bnc :eq not-single) - - ;; Return with one value. - (loadw a0 vals-arg) - (move csp-tn cfp-tn) - (move cfp-tn ocfp-arg) - (lisp-return lra-arg lip :offset 1) - - ;; Nope, not the single case. - (emit-label not-single) - - ;; Load the register args, bailing out when we are done. - (move ocfp ocfp-arg) - (move lra lra-arg) - (move vals vals-arg) - (move nvals nvals-arg) - (inst bala (make-fixup 'really-return-multiple :assembly-routine))))) - -;;; COMPONENT-NON-DESCRIPTOR-STACK-USAGE -- Internal. -;;; -;;; This returns the non-descriptor stack usage in bytes for the component on -;;; which the compiler is currently working. -;;; -;;; On the MIPS, the stack must be dual-word aligned since it is also the C -;;; call stack. -;;; -;;; We're going to make the same assumption on the RT, but we don't even know -;;; why this is true on the MIPS. -;;; -(defun component-non-descriptor-stack-usage () - (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1) - vm:word-bytes)) - - - -;;;; XEP hackery: - - -;;; We don't need to do any special setup for regular functions. -;;; -(define-vop (setup-environment) - (:info label) - (:generator 5)) - -;;; Extract the closure from the passing location (LEXENV). -;;; -(define-vop (setup-closure-environment) - (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure - :to (:result 0)) - lexenv) - (:results (closure :scs (descriptor-reg))) - (:info label) - (:generator 6 - ;; Get result. - (move closure lexenv))) - -;;; Copy a more arg from the argument area to the end of the current frame. -;;; Fixed is the number of non-more arguments. -;;; -;;; We wire the temporaries to make sure they do not interfere with any of -;;; special registers used during full-call, because we do not have acurate -;;; lifetime info about them at the time this vop is used. -;;; -(define-vop (copy-more-arg) - (:temporary (:sc descriptor-reg :offset cname-offset) temp) - (:info fixed) - (:generator 20 - (let ((do-more-args (gen-label)) - (done-more-args (gen-label))) - (inst c nargs-tn (fixnum fixed)) - (inst bc :gt do-more-args) - (assemble (*elsewhere*) - (emit-label do-more-args) - ;; Jump to assembler routine passing fixed at cname-offset. - (inst li temp (fixnum fixed)) - (inst bala (make-fixup 'really-copy-more-args :assembly-routine)) - (inst b done-more-args)) - (emit-label done-more-args)))) - - -;;; More args are stored consequtively on the stack, starting immediately at -;;; the context pointer. The context pointer is not typed, so the lowtag is 0. -;;; -(define-vop (more-arg word-index-ref) - (:variant 0 0) - (:translate %more-arg)) - - -;;; Turn more arg (context, count) into a list. -;;; -(define-vop (listify-rest-args) - (:args (context-arg :target context :scs (descriptor-reg)) - (count-arg :target count :scs (any-reg))) - (:arg-types * tagged-num) - (:temporary (:scs (word-pointer-reg) :from (:argument 0)) context) - (:temporary (:scs (non-descriptor-reg) :from :eval) ndescr dst) - (:temporary (:scs (any-reg) :from (:argument 1)) count) - (:temporary (:scs (word-pointer-reg) :from :eval) alloc) - (:temporary (:scs (descriptor-reg) :from :eval) temp) - (:results (result :scs (descriptor-reg))) - (:translate %listify-rest-args) - (:policy :safe) - (:generator 20 - (let ((enter (gen-label)) - (loop (gen-label)) - (done (gen-label))) - (move context context-arg) - (move count count-arg) - ;; Check to see if there are any arguments. - (inst c count 0) - (inst bcx :eq done) - (move result null-tn) - - ;; We need to do this atomically. - (pseudo-atomic (ndescr) - (load-symbol-value alloc *allocation-pointer*) - ;; Allocate a cons (2 words) for each item. - (inst cal result alloc vm:list-pointer-type) - (move dst result) - (inst cas alloc count alloc) - (inst cas alloc count alloc) - (inst bx enter) - (store-symbol-value alloc *allocation-pointer*) - - ;; Store the current cons in the cdr of the previous cons. - (emit-label loop) - (storew dst dst -1 vm:list-pointer-type) - - ;; Grab one value and stash it in the car of this cons. - (emit-label enter) - (loadw temp context) - (inst inc context vm:word-bytes) - (storew temp dst 0 vm:list-pointer-type) - - ;; Dec count, and if != zero, go back for more. - (inst s count (fixnum 1)) - (inst bncx :eq loop) - (inst inc dst (* 2 vm:word-bytes)) - - ;; NIL out the last cons. - (storew null-tn dst -1 vm:list-pointer-type)) - (load-symbol-value ndescr *internal-gc-trigger*) - (inst tlt ndescr alloc) - (emit-label done)))) - - - -;;; Return the location and size of the more arg glob created by Copy-More-Arg. -;;; Supplied is the total number of arguments supplied (originally passed in -;;; NARGS.) Fixed is the number of non-rest arguments. -;;; -;;; We must duplicate some of the work done by Copy-More-Arg, since at that -;;; time the environment is in a pretty brain-damaged state, preventing this -;;; info from being returned as values. What we do is compute -;;; supplied - fixed, and return a pointer that many words below the current -;;; stack top. -;;; -(define-vop (more-arg-context) - (:args (supplied :scs (any-reg))) - (:arg-types positive-fixnum) - (:info fixed) - (:results - (context :scs (descriptor-reg)) - (count :scs (any-reg))) - (:generator 5 - (inst s count supplied (fixnum fixed)) - (move context csp-tn) - (inst s context count))) - - -;;; Signal wrong argument count error if Nargs isn't = to Count. -;;; -(define-vop (verify-argument-count) - (:args (nargs :scs (any-reg))) - (:arg-types positive-fixnum) - (:info count) - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (let ((err-lab - (generate-error-code vop invalid-argument-count-error nargs))) - (inst c nargs (fixnum count)) - (inst bnc :eq err-lab)))) - -;;; Signal an argument count error. -;;; -(macrolet ((frob (name error &rest args) - `(define-vop (,name) - (:args ,@(mapcar #'(lambda (arg) - `(,arg :scs (any-reg descriptor-reg))) - args)) - (:vop-var vop) - (:save-p :compute-only) - (:generator 1000 - (error-call vop ,error ,@args))))) - (frob argument-count-error invalid-argument-count-error nargs) - (frob type-check-error object-not-type-error object type) - (frob odd-keyword-arguments-error odd-keyword-arguments-error) - (frob unknown-keyword-argument-error unknown-keyword-argument-error key) - (frob nil-function-returned-error nil-function-returned-error fun)) diff --git a/compiler/rt/cell.lisp b/compiler/rt/cell.lisp deleted file mode 100644 index c085c4a8bdf1e63325e9135cb8588cda6236bc70..0000000000000000000000000000000000000000 --- a/compiler/rt/cell.lisp +++ /dev/null @@ -1,348 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/cell.lisp,v 1.7 1992/03/10 10:00:02 wlott Exp $ -;;; -;;; This file contains the VM definition of various primitive memory access -;;; VOPs for the IBM RT. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by Bill Chiles. -;;; - -(in-package "RT") - - - -;;;; Data object definition macros. - -(vm:define-for-each-primitive-object (obj) - (collect ((forms)) - (let ((lowtag (vm:primitive-object-lowtag obj))) - (dolist (slot (vm:primitive-object-slots obj)) - (let* ((name (vm:slot-name slot)) - (offset (vm:slot-offset slot)) - (rest-p (vm:slot-rest-p slot)) - (slot-opts (vm:slot-options slot)) - (ref-trans (getf slot-opts :ref-trans)) - (ref-vop (getf slot-opts :ref-vop ref-trans)) - (set-trans (getf slot-opts :set-trans)) - (setf-function-p (and (listp set-trans) - (= (length set-trans) 2) - (eq (car set-trans) 'setf))) - (setf-vop (getf slot-opts :setf-vop - (when setf-function-p - (intern (concatenate - 'simple-string - "SET-" - (string (cadr set-trans))))))) - (set-vop (getf slot-opts :set-vop - (if setf-vop nil set-trans)))) - (when ref-vop - (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref)) - (:variant ,offset ,lowtag) - ,@(when ref-trans - `((:translate ,ref-trans)))))) - (when (or set-vop setf-vop) - (forms `(define-vop ,(cond ((and rest-p setf-vop) - (error "Can't automatically generate ~ - a setf VOP for :rest-p ~ - slots: ~S in ~S" - name - (vm:primitive-object-name obj))) - (rest-p `(,set-vop slot-set)) - ((and set-vop setf-function-p) - (error "Setf functions (list ~S) must ~ - use :setf-vops." - set-trans)) - (set-vop `(,set-vop cell-set)) - (setf-function-p - `(,setf-vop cell-setf-function)) - (t - `(,setf-vop cell-setf))) - (:variant ,offset ,lowtag) - ,@(when set-trans - `((:translate ,set-trans))))))))) - (when (forms) - `(progn - ,@(forms))))) - - - -;;;; Symbol hacking VOPs: - -;;; CHECKED-CELL-REF -- VOP. -;;; -;;; Do a cell ref with an error check for being unbound. -;;; -(define-vop (checked-cell-ref) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (word-pointer-reg descriptor-reg any-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) - -;;; SYMBOL-VALUE -- VOP. -;;; -;;; Check that the value isn't the trap object. -;;; -(define-vop (symbol-value checked-cell-ref) - (:translate symbol-value) - (:generator 9 - (move obj-temp object) - (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type) - (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) - (inst c value vm:unbound-marker-type) - (inst bc :eq err-lab)))) - -;;; SYMBOL-FUNCTION -- VOP. -;;; -;;; Check that the result is a function, so NIL is always un-fbound. -;;; -(define-vop (symbol-function checked-cell-ref) - (:translate symbol-function) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:generator 10 - (move obj-temp object) - (loadw value obj-temp vm:symbol-function-slot vm:other-pointer-type) - (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) - (test-type value temp err-lab t vm:function-pointer-type)))) - - -;;; BOUNDP-FROB -- VOP. -;;; -;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. -;;; -(define-vop (boundp-frob) - (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value) - (:temporary (:type random :scs (non-descriptor-reg)) temp)) - -(define-vop (boundp boundp-frob) - (:translate boundp) - (:generator 9 - (loadw value object vm:symbol-value-slot vm:other-pointer-type) - (inst c value vm:unbound-marker-type) - (if not-p - ;; If they're the same, symbol is unbound, so if not-p (the symbol is - ;; bound), then go to target. - (inst bc :eq target) - (inst bnc :eq target)))) - - -;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction -;;; on the symbol case of fboundp. Instead, we transform to a funny function. - -(defknown fboundp/symbol (t) boolean (flushable)) -;;; -(deftransform fboundp ((x) (symbol)) - '(fboundp/symbol x)) -;;; -(define-vop (fboundp/symbol boundp-frob) - (:translate fboundp/symbol) - (:generator 10 - (loadw value object vm:symbol-function-slot vm:other-pointer-type) - (test-type value temp target not-p vm:function-pointer-type))) - -(define-vop (fast-symbol-value cell-ref) - (:variant vm:symbol-value-slot vm:other-pointer-type) - (:policy :fast) - (:translate symbol-value)) - -(define-vop (fast-symbol-function cell-ref) - (:variant vm:symbol-function-slot vm:other-pointer-type) - (:policy :fast) - (:translate symbol-function)) - -(define-vop (set-symbol-function) - (:translate %set-symbol-function) - (:policy :fast-safe) - (:args (symbol :scs (descriptor-reg)) - (function :scs (descriptor-reg) :target result)) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) type) - (:temporary (:scs (any-reg)) temp) - (:save-p :compute-only) - (:vop-var vop) - (:generator 30 - (let ((closure (gen-label)) - (normal-fn (gen-label))) - (load-type type function vm:function-pointer-type) - (inst c type vm:closure-header-type) - (inst bc :eq closure) - (inst c type funcallable-instance-header-type) - (inst bc :eq closure) - (inst c type vm:function-header-type) - (inst bcx :eq normal-fn) - (inst a temp function - (- (ash vm:function-header-code-offset vm:word-shift) - vm:function-pointer-type)) - (error-call vop kernel:object-not-function-error function) - (emit-label closure) - (inst cai temp (make-fixup "closure_tramp" :foreign)) - (emit-label normal-fn) - (storew function symbol vm:symbol-function-slot vm:other-pointer-type) - (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type) - (move result function)))) - - -(defknown fmakunbound/symbol (symbol) symbol (unsafe)) -;;; -(deftransform fmakunbound ((symbol) (symbol)) - '(when symbol - (fmakunbound/symbol symbol))) -;;; -(define-vop (fmakunbound/symbol) - (:translate fmakunbound/symbol) - (:policy :fast-safe) - (:args (symbol :scs (descriptor-reg) :target result)) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (sap-reg)) temp) - (:generator 5 - (inst li temp vm:unbound-marker-type) - (storew temp symbol vm:symbol-function-slot vm:other-pointer-type) - (inst cai temp (make-fixup "undefined_tramp" :foreign)) - (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type) - (move result symbol))) - - -;;; Binding and Unbinding. - -;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and -;;; the symbol on the binding stack and stuff the new value into the -;;; symbol. - -(define-vop (bind) - (:args (val :scs (any-reg descriptor-reg)) - (symbol :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (word-pointer-reg)) bsp) - (:generator 7 - (loadw temp symbol vm:symbol-value-slot vm:other-pointer-type) - (load-symbol-value bsp *binding-stack-pointer*) - (inst inc bsp (* vm:binding-size vm:word-bytes)) - (store-symbol-value bsp *binding-stack-pointer*) - (storew temp bsp (- vm:binding-value-slot vm:binding-size)) - (storew symbol bsp (- vm:binding-symbol-slot vm:binding-size)) - (storew val symbol vm:symbol-value-slot vm:other-pointer-type))) - -(define-vop (unbind) - (:temporary (:scs (descriptor-reg)) symbol value) - (:temporary (:scs (word-pointer-reg)) bsp) - (:generator 7 - (load-symbol-value bsp *binding-stack-pointer*) - (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size)) - (loadw value bsp (- vm:binding-value-slot vm:binding-size)) - (storew value symbol vm:symbol-value-slot vm:other-pointer-type) - (inst li value 0) - (storew value bsp (- vm:binding-symbol-slot vm:binding-size)) - (inst dec bsp (* vm:binding-size vm:word-bytes)) - (store-symbol-value bsp *binding-stack-pointer*))) - -(define-vop (unbind-to-here) - (:args (arg :scs (descriptor-reg any-reg) :target where)) - (:temporary (:scs (any-reg) :from (:argument 0)) where) - (:temporary (:scs (descriptor-reg)) symbol value) - (:temporary (:scs (word-pointer-reg)) bsp) - (:generator 0 - (let ((loop (gen-label)) - (skip (gen-label)) - (done (gen-label))) - (move where arg) - (load-symbol-value bsp *binding-stack-pointer*) - (inst c where bsp) - (inst bc :eq done) - - (emit-label loop) - (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size)) - (inst c symbol 0) - (inst bc :eq skip) - (loadw value bsp (- vm:binding-value-slot vm:binding-size)) - (storew value symbol vm:symbol-value-slot vm:other-pointer-type) - (inst li value 0) - (storew value bsp (- vm:binding-symbol-slot vm:binding-size)) - - (emit-label skip) - (inst dec bsp (* vm:binding-size vm:word-bytes)) - (store-symbol-value bsp *binding-stack-pointer*) - (inst c where bsp) - (inst bnc :eq loop) - - (emit-label done)))) - - - -;;;; Closure indexing. - -(define-vop (closure-index-ref word-index-ref) - (:variant vm:closure-info-offset vm:function-pointer-type) - (:translate %closure-index-ref)) - -(define-vop (set-funcallable-instance-info word-index-set) - (:variant funcallable-instance-info-offset function-pointer-type) - (:translate %set-funcallable-instance-info)) - - -;;;; Structure hackery: - -(define-vop (structure-length) - (:policy :fast-safe) - (:translate structure-length) - (:args (struct :scs (descriptor-reg))) - ;;(:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 4 - (loadw res struct 0 structure-pointer-type) - (inst sr res vm:type-bits))) - -(define-vop (structure-ref slot-ref) - (:variant structure-slots-offset structure-pointer-type) - (:policy :fast-safe) - (:translate structure-ref) - (:arg-types structure (:constant index))) - -(define-vop (structure-set slot-set) - (:policy :fast-safe) - (:translate structure-set) - (:variant structure-slots-offset structure-pointer-type) - (:arg-types structure (:constant index) *)) - -(define-vop (structure-index-ref word-index-ref) - (:policy :fast-safe) - (:translate structure-ref) - (:variant structure-slots-offset structure-pointer-type) - (:arg-types structure positive-fixnum)) - -(define-vop (structure-index-set word-index-set) - (:policy :fast-safe) - (:translate structure-set) - (:variant structure-slots-offset structure-pointer-type) - (:arg-types structure positive-fixnum *)) - - - -;;;; Extra random indexers. - -(define-vop (code-header-ref word-index-ref) - (:translate code-header-ref) - (:policy :fast-safe) - (:variant 0 other-pointer-type)) - -(define-vop (code-header-set word-index-set) - (:translate code-header-set) - (:policy :fast-safe) - (:variant 0 other-pointer-type)) - - diff --git a/compiler/rt/char.lisp b/compiler/rt/char.lisp deleted file mode 100644 index 62837a0db0e9d06b125a916b2ccb0c731cbdbebf..0000000000000000000000000000000000000000 --- a/compiler/rt/char.lisp +++ /dev/null @@ -1,167 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/char.lisp,v 1.3 1992/03/10 10:00:34 wlott Exp $ -;;; -;;; This file contains the RT VM definition of character operations. -;;; -;;; Written by Rob MacLachlan and Bill Chiles. -;;; - -(in-package "RT") - - - -;;;; Moves and coercions: - -;;; MOVE-TO-BASE-CHAR -- VOP. -;;; -;;; Move a tagged char to an untagged representation. -;;; -(define-vop (move-to-base-char) - (:args (x :scs (any-reg descriptor-reg) :target y)) - (:arg-types base-char) - (:results (y :scs (base-char-reg))) - (:generator 1 - (move y x) - (inst sr y vm:type-bits))) -;;; -(define-move-vop move-to-base-char :move - (any-reg descriptor-reg) (base-char-reg)) - - -;;; MOVE-FROM-BASE-CHAR -- VOP. -;;; -;;; Move an untagged char to a tagged representation. -;;; -(define-vop (move-from-base-char) - (:args (x :scs (base-char-reg) :target temp)) - (:temporary (:scs (base-char-reg) :from (:argument 0)) temp) - (:results (y :scs (any-reg descriptor-reg))) - (:result-types base-char) - (:generator 1 - (move temp x) - (inst sl temp vm:type-bits) - (inst oil y temp vm:base-char-type))) -;;; -(define-move-vop move-from-base-char :move - (base-char-reg) (any-reg descriptor-reg)) - -;;; BASE-CHAR-MOVE -- VOP. -;;; -;;; Move untagged base-char values. -;;; -(define-vop (base-char-move) - (:args (x :target y - :scs (base-char-reg) - :load-if (not (location= x y)))) - (:results (y :scs (base-char-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move y x))) -;;; -(define-move-vop base-char-move :move - (base-char-reg) (base-char-reg)) - - -;;; MOVE-BASE-CHAR-ARGUMENT -- VOP. -;;; -;;; Move untagged base-char arguments/return-values. -;;; -(define-vop (move-base-char-argument) - (:args (x :target y - :scs (base-char-reg)) - (fp :scs (word-pointer-reg) - :load-if (not (sc-is y base-char-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (base-char-reg - (move y x)) - (base-char-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-base-char-argument :move-argument - (any-reg base-char-reg) (base-char-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char -;;; to a descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (base-char-reg) (any-reg descriptor-reg)) - - - -;;;; Other operations: - -;;; CHAR-CODE -- VOP. -;;; -;;; This assumes it is best to keep characters in their raw representation. -;;; -(define-vop (char-code) - (:translate char-code) - (:policy :fast-safe) - (:args (ch :scs (base-char-reg) :target temp)) - (:arg-types base-char) - (:temporary (:scs (base-char-reg) - :from (:argument 0) :to (:result 0) - :target res) temp) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:generator 1 - (move temp ch) - (inst sl temp 2) - (move res temp))) - -;;; CODE-CHAR -- VOP. -;;; -(define-vop (code-char) - (:translate code-char) - (:policy :fast-safe) - (:args (code :scs (any-reg) :target res)) - (:arg-types positive-fixnum) - (:results (res :scs (base-char-reg))) - (:result-types base-char) - (:generator 1 - (move res code) - (inst sr res 2))) - - - -;;; Comparison of base-chars. -;;; -(define-vop (base-char-compare) - (:args (x :scs (base-char-reg)) - (y :scs (base-char-reg))) - (:arg-types base-char base-char) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:note "inline comparison") - (:variant-vars condition) - (:generator 6 - (inst cl x y) - (if not-p - (inst bnc condition target) - (inst bc condition target)))) - -(define-vop (fast-char=/base-char base-char-compare) - (:translate char=) - (:variant :eq)) - -(define-vop (fast-char</base-char base-char-compare) - (:translate char<) - (:variant :lt)) - -(define-vop (fast-char>/base-char base-char-compare) - (:translate char>) - (:variant :gt)) diff --git a/compiler/rt/debug.lisp b/compiler/rt/debug.lisp deleted file mode 100644 index 631db922b402816f347a36ad7e943a8782529717..0000000000000000000000000000000000000000 --- a/compiler/rt/debug.lisp +++ /dev/null @@ -1,149 +0,0 @@ -;;; -*- Package: RT; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/debug.lisp,v 1.4 1992/03/10 09:20:19 wlott Exp $ -;;; -;;; Compiler support for the new whizzy debugger. -;;; -;;; Written by William Lott. -;;; Converted to RT by Bill Chiles. -;;; - -(in-package "RT") - - -(defknown di::current-sp () system-area-pointer (movable flushable)) -(defknown di::current-fp () system-area-pointer (movable flushable)) -(defknown di::stack-ref (system-area-pointer index) t (flushable)) -(defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe)) -(defknown di::lra-code-header (t) t (movable flushable)) -(defknown di::function-code-header (t) t (movable flushable)) -(defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable)) -(defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable)) - -(define-vop (debug-cur-sp) - (:translate di::current-sp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move res csp-tn))) - -(define-vop (debug-cur-fp) - (:translate di::current-fp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move res cfp-tn))) - - -(define-vop (read-control-stack-c) - (:policy :fast-safe) - (:translate di::stack-ref) - (:args (base :scs (sap-reg))) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:arg-types system-area-pointer (:constant (unsigned-byte 13))) - (:info offset) - (:generator 5 - (inst l result base (* offset word-bytes)))) - -(define-vop (read-control-stack) - (:policy :fast-safe) - (:translate di::stack-ref) - (:args (object :scs (sap-reg) :target base) - (offset :scs (any-reg))) - (:results (result :scs (descriptor-reg))) - (:arg-types system-area-pointer positive-fixnum) - (:result-types *) - (:temporary (:scs (sap-reg) :from (:argument 0) :to :eval) base) - (:generator 7 - (move base object) - (inst a base offset) - (inst l result base 0))) - -(define-vop (write-control-stack-c) - (:policy :fast-safe) - (:translate di::%set-stack-ref) - (:args (base :scs (sap-reg)) - (data :scs (descriptor-reg) :target result :to (:result 0))) - (:arg-types system-area-pointer (:constant (unsigned-byte 13)) *) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:info offset) - (:generator 5 - (inst st data base (* offset word-bytes)) - (move result data))) - -(define-vop (write-control-stack) - (:policy :fast-safe) - (:translate di::%set-stack-ref) - (:args (object :scs (sap-reg) :target base) - (offset :scs (any-reg)) - (data :scs (descriptor-reg) :target result)) - (:arg-types system-area-pointer positive-fixnum *) - (:temporary (:scs (sap-reg) :from (:argument 0) :to :eval) base) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 7 - (move base object) - (inst cas base base offset) - (inst st data base 0) - (move result data))) - - -(define-vop (code-from-mumble) - (:policy :fast-safe) - (:args (thing :scs (descriptor-reg) :target code)) - (:results (code :scs (descriptor-reg))) - (:temporary (:scs (sap-reg)) temp) - (:variant-vars lowtag) - (:generator 5 - (let ((bogus (gen-label)) - (done (gen-label))) - (loadw temp thing 0 lowtag) - (inst sr temp vm:type-bits) - (inst bc :eq bogus) - (inst sl temp (1- (integer-length vm:word-bytes))) - (unless (= lowtag vm:other-pointer-type) - (inst cal temp temp (- lowtag vm:other-pointer-type))) - (move code thing) - (inst s code temp) - (emit-label done) - (assemble (*elsewhere*) - (emit-label bogus) - (inst bx done) - (move code null-tn))))) - -(define-vop (code-from-lra code-from-mumble) - (:translate di::lra-code-header) - (:variant vm:other-pointer-type)) - -(define-vop (code-from-function code-from-mumble) - (:translate di::function-code-header) - (:variant vm:function-pointer-type)) - -(define-vop (di::make-lisp-obj) - (:policy :fast-safe) - (:translate di::make-lisp-obj) - (:args (value :scs (unsigned-reg) :target result)) - (:arg-types unsigned-num) - (:results (result :scs (descriptor-reg))) - (:generator 1 - (move result value))) - -(define-vop (di::get-lisp-obj-address) - (:policy :fast-safe) - (:translate di::get-lisp-obj-address) - (:args (thing :scs (descriptor-reg) :target result)) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (move result thing))) diff --git a/compiler/rt/insts.lisp b/compiler/rt/insts.lisp deleted file mode 100644 index 43525248430c563763a43d848d2bbc43bbd2ee7b..0000000000000000000000000000000000000000 --- a/compiler/rt/insts.lisp +++ /dev/null @@ -1,1437 +0,0 @@ -;;; -*- 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/insts.lisp,v 1.13 1992/01/22 18:09:31 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Description of the IBM RT instruction set. -;;; -;;; Written by William Lott and Bill Chiles. -;;; - -(in-package "RT") - -(use-package "ASSEM") -(use-package "EXT") - - -;;;; Resources: - -(disassem:set-disassem-params :instruction-alignment 16) -(define-resources memory float-status mq cc) - - -;;;; Formats. - -(define-format (j1 16 :use (cc)) - (op (byte 4 12)) - (sub-op (byte 1 11)) - (n (byte 3 8)) - (j1 (byte 8 0))) - -(define-format (x 16 :clobber (cc)) - (op (byte 4 12)) - (r1 (byte 4 8) :write t) - (r2 (byte 4 4) :read t) - (r3 (byte 4 0) :read t)) - - -(define-format (r 16 :clobber (cc)) - (op (byte 8 8)) - (r2 (byte 4 4) :read t :write t) - (r3 (byte 4 0) :read t)) - -(define-format (r-immed 16 :clobber (cc)) - (op (byte 8 8)) - (r2 (byte 4 4) :read t :write t) - (r3 (byte 4 0))) - - -(define-format (bi 32 :use (cc)) - (op (byte 8 24)) - (r2 (byte 4 20)) - (bi (byte 20 0))) - -(define-format (ba 32 :attributes (assembly-call)) - (op (byte 8 24)) - (ba (byte 24 0))) - -(define-format (d 32 :clobber (cc)) - (op (byte 8 24)) - (r2 (byte 4 20) :write t) - (r3 (byte 4 16) :read t) - (i (byte 16 0))) - -(define-format (d-short 16 :clobber (cc)) - (op (byte 4 12)) - (i (byte 4 8)) - (r2 (byte 4 4) :write t) - (r3 (byte 4 0) :read t)) - - -;;;; Special argument types and fixups. - -(define-argument-type register - :type '(satisfies (lambda (object) - (and (tn-p object) - (or (eq (sc-name (tn-sc object)) 'null) - (eq (sb-name (sc-sb (tn-sc object))) - 'registers))))) - :function (lambda (tn) - (case (sc-name (tn-sc tn)) - (null null-offset) - (t (tn-offset tn))))) - -(defun address-register-p (object) - (and (tn-p object) - (not (zerop (tn-offset object))) - (eq (sb-name (sc-sb (tn-sc object))) 'registers))) - -(define-argument-type address-register - :type '(satisfies address-register-p) - :function tn-offset) - - -;;; LABEL-OFFSET -- Internal. -;;; -;;; This uses assem:*current-position* and the label's position to compute -;;; the bits that an instructions immediate field wants. -;;; -(defun label-offset (label) - (ash (- (label-position label) *current-position*) -1)) - -(define-argument-type relative-label - :type 'label - :function label-offset) - - -(defun jump-condition-value (cond) - (ecase cond - (:pz #b000) - (:lt #b001) - (:eq #b010) - (:gt #b011) - (:c0 #b100) - (:ov #b110) - (:tb #b111))) - -(define-argument-type jump-condition - :type '(member :pz :lt :eq :gt :c0 :ov :tb) - :function jump-condition-value) - -(defun branch-condition-value (cond) - (ecase cond - (:pz #b1000) - (:lt #b1001) - (:eq #b1010) - (:gt #b1011) - (:c0 #b1100) - (:ov #b1110) - (:tb #b1111))) - -(define-argument-type branch-condition - :type '(member :pz :lt :eq :gt :c0 :ov :tb) - :function branch-condition-value) - - -(define-fixup-type :ba) ;branch-absolute. -(define-fixup-type :cau) -(define-fixup-type :cal) - - - -;;;; Loading and storing. - -;;; load-character. -;;; -(define-instruction (lc) - (d-short (op :constant 4) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 4))) - (d-short (op :constant 4) - (r2 :argument register) - (r3 :argument address-register) - (i :constant 0)) - (d (op :constant #xCE) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (signed-byte 16)))) - -;;; store-character. -;;; -(define-instruction (stc) - (d-short (op :constant 1) - (r2 :argument register :read t :write nil) - (r3 :argument address-register) - (i :argument (unsigned-byte 4))) - (d-short (op :constant 1) - (r2 :argument register :read t :write nil) - (r3 :argument address-register) - (i :constant 0)) - (d (op :constant #xDE) - (r2 :argument register :read t :write nil) - (r3 :argument address-register) - (i :argument (signed-byte 16)))) - -;;; load-half. -;;; -(define-instruction (lh) - (d (op :constant #xDA) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (signed-byte 16))) - (r (op :constant #xEB) - (r2 :argument register :read nil) - (r3 :argument register))) - -;;; load-half-algebraic. -;;; -(define-instruction (lha) - (d (op :constant #xCA) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (signed-byte 16))) - (d-short (op :constant 5) - (r2 :argument register) - (r3 :argument address-register) - ;; We want the instruction to take byte indexes, but we plug the - ;; index into the instruction as a half-word index. - (i :argument (member 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) - :function (lambda (x) (ash x -1))))) - -;;; store-half. -;;; -(define-instruction (sth) - (d-short (op :constant 2) - (r2 :argument register :read t :write nil) - (r3 :argument address-register) - ;; We want the instruction to take byte indexes, but we plug the - ;; index into the instruction as a half-word index. - (i :argument (member 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) - :function (lambda (x) (ash x -1)))) - (d (op :constant #xDC) - (r2 :argument register :read t :write nil) - (r3 :argument address-register) - (i :argument (signed-byte 16)))) - -;;; load-word. -;;; -(define-instruction (l) - (d-short (op :constant 7) - (r2 :argument register) - (r3 :argument address-register) - ;; We want the instruction to take byte indexes, but we plug the - ;; index into the instruction as a word index. - (i :argument (member 0 4 8 12 16 20 24 28 32 36 40 44 48 52 56 60) - :function (lambda (x) (ash x -2)))) - (d-short (op :constant 7) - (r2 :argument register) - (r3 :argument address-register) - (i :constant 0)) - (d (op :constant #xCD) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (signed-byte 16)))) - -;;; store-word. -;;; -(define-instruction (st) - (d-short (op :constant 3) - (r2 :argument register :read t :write nil) - (r3 :argument address-register) - ;; We want the instruction to take byte indexes, but we plug the - ;; index into the instruction as a word index. - (i :argument (member 0 4 8 12 16 20 24 28 32 36 40 44 48 52 56 60) - :function (lambda (x) (ash x -2)))) - (d-short (op :constant 3) - (r2 :argument register :read t :write nil) - (r3 :argument address-register) - (i :constant 0)) - (d (op :constant #xDD) - (r2 :argument register :read t :write nil) - (r3 :argument address-register) - (i :argument (signed-byte 16)))) - - -;;;; Address computation. - -;;; compute-address-lower-half. -;;; -;;; The second format can be used for load-immediate (signed-byte 16). -;;; -(define-instruction (cal) - (d (op :constant #xC8) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (signed-byte 16))) - (d (op :constant #xC8) - (r2 :argument register) - (r3 :same-as r2) - (i :argument (signed-byte 16))) - (d (op :constant #xC8) - (r2 :argument register) - (r3 :argument (integer 0 0) :read nil) - (i :argument (signed-byte 16))) - (d (op :constant #xC8) - (r2 :argument register) - (r3 :argument address-register) - (i :argument cal-fixup))) - -;;; compute-address-lower-half-16bit. -;;; -;;; The second format can be used for load-immediate (unsigned-byte 16). -;;; -(define-instruction (cal16) - (d (op :constant #xC2) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16))) - (d (op :constant #xC2) - (r2 :argument register) - (r3 :constant 0) - (i :argument (unsigned-byte 16)))) - -;;; compute-address-upper-half. -;;; -(define-instruction (cau) - (d (op :constant #xD8) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16))) - (d (op :constant #xD8) - (r2 :argument register) - (r3 :argument (integer 0 0) :read nil) - (i :argument (unsigned-byte 16))) - (d (op :constant #xD8) - (r2 :argument register) - (r3 :constant 0) - (i :argument (unsigned-byte 16))) - (d (op :constant #xD8) - (r2 :argument register) - (r3 :constant 0) - (i :argument cau-fixup))) - -;;; compute-address-short. -;;; -;;; Use the second flavor to copy registers. -;;; -(define-instruction (cas) - (x (op :constant 6) - (r1 :argument register) - (r2 :argument register) - (r3 :argument address-register)) - (x (op :constant 6) - (r1 :argument register) - (r2 :argument register) - (r3 :constant 0))) - -;;; increment. -;;; -(define-instruction (inc) - (r-immed - (op :constant #x91) - (r2 :argument register) - (r3 :argument (unsigned-byte 4)))) - -;;; decrement -;;; -(define-instruction (dec) - (r-immed - (op :constant #x93) - (r2 :argument register) - (r3 :argument (unsigned-byte 4)))) - - -;;; load-immediate-short. -;;; -(define-instruction (lis) - (r-immed - (op :constant #xA4) - (r2 :argument register :read nil) - (r3 :argument (unsigned-byte 4)))) - - - -;;;; Arithmetics. - -(macrolet ((define-math-inst (name &key two-regs unary short-immediate - immediate function (signed t) - (use nil use-p) - (clobber nil clobber-p)) - `(define-instruction (,name - ,@(when use-p `(:use ,use)) - ,@(when clobber-p `(:clobber ,clobber))) - ,@(when two-regs - `((r (op :constant ,two-regs) - (r2 :argument register) - (r3 :argument register)) - (r (op :constant ,two-regs) - (r2 :argument register) - (r3 :same-as r2)))) - ,@(when unary - `((r (op :constant ,unary) - (r2 :argument register :read nil) - (r3 :argument register)) - (r (op :constant ,unary) - (r2 :argument register :read nil) - (r3 :same-as r2)))) - ,@(when short-immediate - `((r-immed - (op :constant ,short-immediate) - (r2 :argument register) - (r3 :argument (unsigned-byte 4))))) - ,@(when immediate - `((d (op :constant ,immediate) - (r2 :argument register) - (r3 :argument register) - (i :argument - (,(if signed 'signed-byte 'unsigned-byte) 16) - ,@(if function `(:function ,function)))) - (d (op :constant ,immediate) - (r2 :argument register) - (r3 :same-as r2) - (i :argument - (,(if signed 'signed-byte 'unsigned-byte) 16) - ,@(if function `(:function ,function))))))))) - - (define-math-inst a :two-regs #xE1 :short-immediate #x90 :immediate #xC1) - (define-math-inst ae :two-regs #xF1 :immediate #xD1 :use (cc)) - (define-math-inst abs :unary #xE0) - (define-math-inst neg :unary #xE4) ;Arithmetic negation (two's complement). - (define-math-inst s :two-regs #xE2 :short-immediate #x92 - :immediate #xC1 :function -) - (define-math-inst sf :two-regs #xB2 :immediate #xD2) - (define-math-inst se :two-regs #xF2 :use (cc)) - (define-math-inst d :two-regs #xB6 :use (cc mq) :clobber (cc mq)) - (define-math-inst m :two-regs #xE6 :use (cc mq) :clobber (cc mq)) - - (define-math-inst exts :unary #xB1) - - (define-math-inst clrbl :short-immediate #x99) - (define-math-inst clrbu :short-immediate #x98) - (define-math-inst setbl :short-immediate #x9B) - (define-math-inst setbu :short-immediate #x9A) - - (define-math-inst not :unary #xF4) ;Logical not. - (define-math-inst n :two-regs #xE5) - (define-math-inst nilz :immediate #xC5 :signed nil) - (define-math-inst nilo :immediate #xC6 :signed nil) - (define-math-inst niuz :immediate #xD5 :signed nil) - (define-math-inst niuo :immediate #xD6 :signed nil) - (define-math-inst o :two-regs #xE3) - (define-math-inst oil :immediate #xC4 :signed nil) - (define-math-inst oiu :immediate #xC3 :signed nil) - (define-math-inst x :two-regs #xE7) - (define-math-inst xil :immediate #xC7 :signed nil) - (define-math-inst xiu :immediate #xD7 :signed nil) - - (define-math-inst clz :two-regs #xF5) - -) ;macrolet - - -;;; compare. -;;; compare-immediate-short. -;;; compare-immediate. -;;; -(define-instruction (c) - (r (op :constant #xB4) - (r2 :argument register :write nil) - (r3 :argument register)) - (r-immed - (op :constant #x94) - (r2 :argument register :write nil) - (r3 :argument (unsigned-byte 4))) - (d (op :constant #xD4) - (r2 :constant 0) - (r3 :argument register) - (i :argument (signed-byte 16)))) - - -;;; compare-logical. -;;; compare-logical-immediate. -;;; -(define-instruction (cl) - (r (op :constant #xB3) - (r2 :argument register :write nil) - (r3 :argument register)) - (d (op :constant #xD3) - (r2 :constant 0) - (r3 :argument register) - (i :argument (signed-byte 16)))) - - - -;;;; Shifting. - -(define-instruction (sr) - (r (op :constant #xB8) - (r2 :argument register) - (r3 :argument register)) - (r-immed - (op :constant #xA8) - (r2 :argument register :write nil) - (r3 :argument (unsigned-byte 4))) - (r-immed - (op :constant #xA9) - (r2 :argument register :write nil) - (r3 :argument (integer 16 31) - :function (lambda (x) (- x 16))))) - -(define-instruction (sl) - (r (op :constant #xBA) - (r2 :argument register) - (r3 :argument register)) - (r-immed - (op :constant #xAA) - (r2 :argument register) - (r3 :argument (unsigned-byte 4))) - (r-immed - (op :constant #xAB) - (r2 :argument register) - (r3 :argument (integer 16 31) - :function (lambda (x) (- x 16))))) - -(define-instruction (sar) - (r (op :constant #xB0) - (r2 :argument register) - (r3 :argument register)) - (r-immed - (op :constant #xA0) - (r2 :argument register) - (r3 :argument (unsigned-byte 4))) - (r-immed - (op :constant #xA1) - (r2 :argument register) - (r3 :argument (integer 16 31) - :function (lambda (x) (- x 16))))) - - -;;;; Branch instructions. - -;;; There are some pseudo-instructions defined after this page that use these -;;; definitions. -;;; - -(define-instruction (jb) - (j1 (op :constant 0) - (sub-op :constant 1) - (n :argument jump-condition) - (j1 :argument relative-label))) - -(define-instruction (jnb) - (j1 (op :constant 0) - (sub-op :constant 0) - (n :argument jump-condition) - (j1 :argument relative-label))) - -(macrolet ((define-branch-inst (name immediate-op register-op) - `(define-instruction (,name) - (bi (op :constant ,immediate-op) - (r2 :argument branch-condition) - (bi :argument relative-label)) - (r (op :constant ,register-op) - (r2 :argument branch-condition :read nil :write nil) - (r3 :argument register))))) - - ;; branch-on-condition-bit-immediate. - ;; branch-on-condition-bit-register. - ;; - (define-branch-inst bb #x8E #xEE) - - ;; branch-on-condition-bit-immediate-with-execute. - ;; branch-on-condition-bit-register-with-execute. - ;; - (define-branch-inst bbx #x8F #xEF) - - ;; branch-on-not-condition-bit-immediate. - ;; branch-on-not-condition-bit-register. - ;; - (define-branch-inst bnb #x88 #xE8) - - ;; branch-on-not-condition-bit-immediate-with-execute. - ;; branch-on-not-condition-bit-register-with-execute. - ;; - (define-branch-inst bnbx #x89 #xE9) - -) ;MACROLET - -(define-instruction (bala) - (ba (op :constant #x8A) - (ba :argument ba-fixup))) - -(define-instruction (balax) - (ba (op :constant #x8B) - (ba :argument ba-fixup))) - - - -;;;; Pseudo-instructions - -;;; move. -;;; -;;; This body is the second format of compute-address-short. -;;; -(define-instruction (move) - (x (op :constant 6) - (r1 :argument register) - (r2 :argument register) - (r3 :constant 0))) - -;;; -;;; A couple load-immediate pseudo-instructions. -;;; - -;;; load-immediate. -;;; -;;; This might affect the condition codes, but it allows for loading 32-bit -;;; quantities into R0. -;;; -(define-pseudo-instruction li 64 (reg value) - (etypecase value - ((unsigned-byte 4) - (inst lis reg value)) - ((signed-byte 16) - (inst cal reg 0 value)) - ((unsigned-byte 16) - (inst cal16 reg value)) - ((or (signed-byte 32) (unsigned-byte 32)) - (inst cau reg (ldb (byte 16 16) value)) - (let ((low (ldb (byte 16 0) value))) - (unless (zerop low) - (inst oil reg low)))))) - -;;; compute-address-immediate. -;;; -;;; This basically exists to load 32-bit constants into address-registers, and -;;; it does not affect condition codes. Since fixups are always addresses, we -;;; have the fixup branch here instead of in load-immediate. We may use the -;;; other branches since it already exists. -;;; -(define-pseudo-instruction cai 64 (reg value) - (etypecase value - ((unsigned-byte 4) - (inst lis reg value)) - ((signed-byte 16) - (inst cal reg 0 value)) - ((unsigned-byte 16) - (inst cal16 reg value)) - ((or (signed-byte 32) (unsigned-byte 32)) - (inst cau reg (ldb (byte 16 16) value)) - (let ((low (ldb (byte 16 0) value))) - (unless (zerop low) - (inst cal16 reg reg low)))) - (fixup - (inst cau reg value) - (inst cal reg reg value)))) - - -;;; branch-unconditional. -;;; -(define-pseudo-instruction b 32 (target) - (if (and (assem::label-p target) - (<= -128 (label-offset target) 127)) - (inst jnb :pz target) - (inst bnb :pz target))) - -;;; branch-unconditional-with-execute. -;;; -(define-pseudo-instruction bx 32 (target) - (inst bnbx :pz target)) - -;;; branch-condition. -;;; -(define-pseudo-instruction bc 32 (condition target) - (if (and (assem::label-p target) - (<= -128 (label-offset target) 127)) - (inst jb condition target) - (inst bb condition target))) - -;;; branch-not-condition. -;;; -(define-pseudo-instruction bnc 32 (condition target) - (if (and (assem::label-p target) - (<= -128 (label-offset target) 127)) - (inst jnb condition target) - (inst bnb condition target))) - -;;; branch-condition-with-execute. -;;; branch-not-condition-with-execute. -;;; -;;; We define these, so VOP readers see a consistent naming scheme in branch -;;; instructions. -;;; -(define-pseudo-instruction bcx 32 (condition target) - (inst bbx condition target)) -;;; -(define-pseudo-instruction bncx 32 (condition target) - (inst bnbx condition target)) - -;;; no-op. -;;; -;;; This is compute-address-short, adding zero to R0 putting the result in R0. -;;; -(define-instruction (no-op) - (x (op :constant 6) - (r1 :constant 0) - (r2 :constant 0) - (r3 :constant 0))) - -(define-format (word-format 32) - (data (byte 32 0))) -(define-instruction (word) - (word-format (data :argument (or (unsigned-byte 32) (signed-byte 32))))) - -(define-format (short-format 16) - (data (byte 16 0))) -(define-instruction (short) - (short-format (data :argument (or (unsigned-byte 16) (signed-byte 16))))) - -(define-format (byte-format 8) - (data (byte 8 0))) -(define-instruction (byte) - (byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8))))) - - - -;;;; Breaking. - -(define-instruction (tge) - (r (op :constant #xBD) - (r2 :argument register) - (r3 :argument register))) - -(define-instruction (tlt) - (r (op :constant #xBE) - (r2 :argument register) - (r3 :argument register))) - -;;; break. -;;; -;;; This is trap-on-condition-immediate. We use the immediate field to -;;; stick in a constant value indicating why we're breaking. -;;; -(define-instruction (break) - (d (op :constant #xCC) - (r2 :constant #b0111) - (r3 :constant 0) - (i :argument (signed-byte 16)))) - - - -;;;; System control. - -;;; move-to-multiplier-quotient-system-control-register -;;; -(define-instruction (mtmqscr) - (r (op :constant #xB5) - (r2 :constant 10) - (r3 :argument register))) - -;;; move-from-multiplier-quotient-system-control-register -;;; -(define-instruction (mfmqscr) - (r (op :constant #x96) - (r2 :constant 10) - (r3 :argument register :read nil :write t))) - - - -;;;; Function and LRA Headers emitters and calculation stuff. - -(defun header-data (ignore) - (declare (ignore ignore)) - (ash (+ *current-position* (component-header-length)) (- vm:word-shift))) - -(define-format (header-object 32) - (type (byte 8 0)) - (data (byte 24 8) :default 0 :function header-data)) - -(define-instruction (function-header-word) - (header-object (type :constant vm:function-header-type))) - -(define-instruction (lra-header-word) - (header-object (type :constant vm:return-pc-header-type))) - - -;;; DEFINE-COMPUTE-INSTRUCTION -- Internal. -;;; -;;; This defines a pseudo-instruction, name, which requires the other specific -;;; instructions. When the pseudo-instruction expands, it looks at the current -;;; value of the calculation to choose between two instruction sequences. -;;; Later, when the assembler emits the instructions, the :function's run to -;;; really compute the calculation's value. This is guaranteed to be lesser in -;;; magnitude than the original test in the pseudo-instruction since all these -;;; calculation are relative to the component start, so we can only remove -;;; instructions in that range, not add them. -;;; -(defmacro define-compute-instruction (name calculation) - (let ((cal (symbolicate name "-CAL")) - (cau (symbolicate name "-CAU"))) - `(progn - ;; This is a special compute-address-lower that takes a label and - ;; asserts the type of the immediate value. - (defun ,name (label) - (let* ((whole ,calculation) - (low (logand whole #xffff)) - (high (ash whole -16))) - (values (if (logbitp 15 low) - (1+ high) - high) - low))) - (define-instruction (,cal) - (d (op :constant #xC8) - (r2 :argument register) - (r3 :argument address-register) - (i :argument label - :function (lambda (label) - (multiple-value-bind (high low) (,name label) - (declare (ignore high)) - low))))) - (define-instruction (,cau) - (d (op :constant #xD8) - (r2 :argument register) - (r3 :argument address-register) - (i :argument label - :function (lambda (label) - (multiple-value-bind (high low) (,name label) - (declare (ignore low)) - high))))) - (define-pseudo-instruction ,name 64 (dst src label) - (multiple-value-bind (high low) (,name label) - (declare (ignore low)) - (cond ((zerop high) - (inst ,cal dst src label)) - (t - (inst ,cal dst src label) - (inst ,cau dst dst label)))))))) - - -;; code = fn - header - label-offset + other-pointer-tag -(define-compute-instruction compute-code-from-fn - (- vm:other-pointer-type - (label-position label) - (component-header-length))) - -;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag -(define-compute-instruction compute-code-from-lra - (- (+ (label-position label) - (component-header-length)))) - -;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag -(define-compute-instruction compute-lra-from-code - (+ (label-position label) - (component-header-length))) - -;;;; 68881 instruction set details: - -;;; The low 7 bits of the 68881 instructions. -;;; -(defconstant mc68881-opcodes - '((:move . #x00) - (:int . #x01) - (:sinh . #x02) - (:intrz . #x03) - (:sqrt . #x04) - (:lognp1 . #x06) - (:etoxm1 . #x08) - (:tanh . #x09) - (:atan . #x0A) - (:asin . #x0C) - (:atanh . #x0D) - (:sin . #x0E) - (:tan . #x0F) - (:etox . #x10) - (:twotox . #x11) - (:tentox . #x12) - (:logn . #x14) - (:log10 . #x15) - (:log2 . #x16) - (:abs . #x18) - (:cosh . #x19) - (:neg . #x1A) - (:acos . #x1C) - (:cos . #x1D) - (:getexp . #x1E) - (:getman . #x1F) - (:div . #x20) - (:mod . #x21) - (:add . #x22) - (:mul . #x23) - (:sgldiv . #x24) - (:rem . #x25) - (:scale . #x26) - (:sglmul . #x27) - (:sub . #x28) - (:sincos . #x30) - (:cmp . #x38) - (:tst . #x3A))) - - -;;; Names of interesting 68881 control registers. -;;; -(defconstant mc68881-control-regs - '((:fpsr . 2) - (:fpcr . 4) - (:fpiar . 1))) - - -;;; The encoding of operand format in memory (bits 10..12 in the 68881 -;;; instruction.) -;;; -(defconstant mc68881-operand-types - '((:integer . 0) ; 32 bit integer. - (:single . 1) ; 32 bit float. - (:double . 5))) ; 64 bit float. - - -;;; Bits 13..15 in the 68881 instruction. Controls where operands are found. -;;; -(defconstant mc68881-instruction-classes - '((:freg-to-freg . 0) - (:mem-to-freg . 2) - (:freg-to-mem . 3) - (:mem-to-scr . 4) - (:scr-to-mem . 5))) - - -;;; Length in words of memory data to transfer. This is part of the RT -;;; hardware assist protocol, and is placed in the low two bits of the address -;;; to the store instruction. -;;; -(defconstant mc68881-operand-lengths - '((nil . 0) ; No transfer... - (:integer . 1) - (:single . 1) - (:double . 2))) - -;;; RT hardware assist protocol for whether to read or write memory, here -;;; represented as a function of the mc68881 instruction class. -;;; -(defconstant mc68881-transfer-control-field-alist - '((:freg-to-freg . 0) - (:mem-to-freg . 0) - (:freg-to-mem . #x3c0000) - (:mem-to-scr . 0) - (:scr-to-mem . #x3c0000))) - - -(defun mc68881-fp-reg-p (object) - (and (tn-p object) - (eq (sb-name (sc-sb (tn-sc object))) - 'mc68881-float-registers))) - -(define-argument-type mc68881-fp-reg - :type '(satisfies mc68881-fp-reg-p) - :function tn-offset) - -;;; This is really a ST (store word) instruction, but we have magic extra -;;; arguments to represent the reading and writing of the FP registers. R3 -;;; will already have been set up with the high bits of the FP instruction by a -;;; preceding CAL. -;;; -(define-format (mc68881-inst 32) - (fpn (byte 0 0) :read t :write t) - (fpm (byte 0 0) :read t) - (op (byte 8 24) :default #xDD) - (r2 (byte 4 20) :read t) - (r3 (byte 4 16) :read t) - (i (byte 16 0))) - - -;;; DO-68881-INST -- Internal -;;; -;;; Utility used to emit a 68881 operation. We emit the CAU that sets up -;;; the high bits of the operation in Temp, and we return the low bits that -;;; should be passed as the I field of the actual FP operation instruction. -;;; -(defun do-68881-inst (op temp &key fpn fpm (class :freg-to-freg) - data optype creg) - (assert (if fpm - (and (mc68881-fp-reg-p fpm) - (not (or optype data)) - (eql class :freg-to-freg)) - (and (tn-p data) - (eq (sb-name (sc-sb (tn-sc data))) 'registers) - (or optype creg) - (not (eql class :freg-to-freg))))) - (assert (if fpn - (mc68881-fp-reg-p fpn) - (and creg (member class '(:mem-to-scr :scr-to-mem))))) - - (let* ((opcode - (logior #xFC000000 - (or (cdr (assoc class mc68881-transfer-control-field-alist)) - (error "Unknown instruction class ~S." class)) - (ash (cdr (assoc class mc68881-instruction-classes)) - 15) - (ash (ecase class - (:freg-to-freg (tn-offset fpm)) - ((:mem-to-freg :freg-to-mem) - (or (cdr (assoc optype mc68881-operand-types)) - (error "Unknown operation type ~S." optype))) - ((:mem-to-scr :scr-to-mem) - (or (cdr (assoc creg mc68881-control-regs)) - (error "Unknown control register ~S." creg)))) - 12) - (ash (if fpn - (tn-offset fpn) - 0) - 9) - (ash (or (cdr (assoc op mc68881-opcodes)) - (error "Unknown opcode ~S." op)) - 2) - (if creg - 1 - (or (cdr (assoc optype mc68881-operand-lengths)) - (error "Unknown operation type ~S." optype))))) - (low (logand opcode #xFFFF)) - (high (+ (logand (ash opcode -16) #xFFFF) - (if (eql (logand low #x8000) 0) 0 1)))) - (inst cau temp 0 high) - low)) - - -(define-instruction (mc68881-binop-inst) - (mc68881-inst - (fpn :argument mc68881-fp-reg) - (fpm :argument mc68881-fp-reg) - (r2 :constant null-offset) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -;;; This pseudo-instruction emits a floating-point binop on the 68881. FPN is -;;; the destination float register (and second arg) FPM is the source float -;;; register. Op is the 68881 opcode. Temp is a sap-reg (i.e. non-zero, -;;; non-descriptor) register that we form the FP instruction in. -;;; -(define-pseudo-instruction mc68881-binop 64 (fpn fpm op temp) - (inst mc68881-binop-inst fpn fpm temp - (do-68881-inst op temp :fpm fpm :fpn fpn))) - - -;;; Unop is like binop, but we don't read FPN before we write it. -;;; -(define-instruction (mc68881-unop-inst) - (mc68881-inst - (fpn :argument mc68881-fp-reg :read nil) - (fpm :argument mc68881-fp-reg) - (r2 :constant null-offset) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction mc68881-unop 64 (fpn fpm op temp) - (inst mc68881-unop-inst fpn fpm temp - (do-68881-inst op temp :fpm fpm :fpn fpn))) - -;;; Compare is like binop, but we don't write FPN. -;;; -(define-instruction (mc68881-compare-inst) - (mc68881-inst - (fpn :argument mc68881-fp-reg :write nil) - (fpm :argument mc68881-fp-reg) - (r2 :constant null-offset) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction mc68881-compare 64 (fpn fpm op temp) - (inst mc68881-compare-inst fpn fpm temp - (do-68881-inst op temp :fpm fpm :fpn fpn))) - -;;; Move FPM to FPN. -;;; -(define-pseudo-instruction mc68881-move 64 (fpn fpm temp) - (inst mc68881-unop fpn fpm :move temp)) - - - -(define-format (s 16) - (op (byte 12 4)) - (n (byte 4 0))) - -;;; This is a "setcb 8", which is used to wait for a result from the FPA to -;;; appear in memory (or something...) -;;; -(define-instruction (mc68881-wait) - (s - (op :constant #x97F) - (n :constant 8))) - - -(define-instruction (mc68881-load-inst :use (memory)) - (mc68881-inst - (fpn :argument mc68881-fp-reg :read nil) - (fpm :constant 0) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction mc68881-load 80 (fpn data optype temp) - (inst mc68881-load-inst fpn data temp - (do-68881-inst :move temp :fpn fpn :data data :optype optype - :class :mem-to-freg)) - (inst mc68881-wait)) - -(define-instruction (mc68881-store-inst :clobber (memory)) - (mc68881-inst - (fpn :argument mc68881-fp-reg :write nil) - (fpm :constant 0) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction mc68881-store 80 (fpn data optype temp) - (inst mc68881-store-inst fpn data temp - (do-68881-inst :move temp :fpn fpn :data data :optype optype - :class :freg-to-mem)) - (inst mc68881-wait)) - - -(define-instruction (mc68881-load-status-inst :use (memory) - :clobber (float-status)) - (mc68881-inst - (fpn :constant 0) - (fpm :constant 0) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction mc68881-load-status 80 (creg data temp) - (inst mc68881-load-status-inst data temp - (do-68881-inst :move temp :creg creg :data data - :class :mem-to-scr)) - (inst mc68881-wait)) - -(define-instruction (mc68881-store-status-inst :clobber (memory) - :use (float-status)) - (mc68881-inst - (fpn :constant 0) - (fpm :constant 0) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction mc68881-store-status 80 (creg data temp) - (inst mc68881-store-status-inst data temp - (do-68881-inst :move temp :creg creg :data data - :class :scr-to-mem)) - (inst mc68881-wait)) - - -;;; AFPA instruction set details: - -;;; Support for the AFPA on IBM RT PC (APC and EAPC models). - -(defconstant afpa-opcodes - '((:absl . #x74) - (:abss . #x75) - (:addl . #x40) - (:adds . #x41) - (:coml . #x48) - (:coms . #x49) - (:comtl . #x4A) - (:comts . #x4B) - (:csl . #x1B) - (:cls . #x16) - (:cwl . #x03) - (:cws . #x07) - (:copl . #x44) - (:cops . #x45) - (:divl . #x60) - (:divs . #x61) - (:flw . #x3B) - (:fsw . #x3F) - (:mull . #x70) - (:muls . #x71) - (:negl . #x54) - (:negs . #x55) - (:noop . #x9F) - (:rdfr . #xBC) ; type = ld - (:rlw . #x23) - (:rsw . #x27) - (:subl . #x50) - (:subs . #x51) - (:tlw . #x2B) - (:tsw . #x2F) - (:wtfr . #x94))) - -(defconstant afpa-special-opcodes - '((:wtstr . #.(ash #x10FEE 2)) ; DS = #b01, OP1, OP2 = #xE. - (:rdstr . #.(ash #x137EE 2)) ; DS = #b01, OP1, OP2 = #xE, type = ld - (:rddma . #.(ash #xF9F00 2)))) ; DS = #b11, OP2 = #x30 - -(defconstant afpa-ds-codes - '((:register . #b00) - (:fr1-immediate . #b10) - (:fr2-immediate . #b01))) - -(defconstant afpa-ts-codes - '((:pio . #b00) - (:word . #b01) - (:single . #b01) - (:double . #b10) - (:multiple . #b11))) - -#| -(defconstant afpa-atanl #x0D4) -(defconstant afpa-cosl #x0C2) -(defconstant afpa-expl #x0D8) -(defconstant afpa-log10l #x0DE) -(defconstant afpa-logl #x0DC) -(defconstant afpa-sinl #x0C0) -(defconstant afpa-sqrl #x064) -(defconstant afpa-sqrs #x065) -(defconstant afpa-tanl #x0C4) -|# - -(defun afpa-fp-reg-p (object) - (and (tn-p object) - (eq (sb-name (sc-sb (tn-sc object))) - 'afpa-float-registers))) - -(define-argument-type afpa-fp-reg - :type '(satisfies afpa-fp-reg-p) - :function tn-offset) - -;;; These are really L and ST (load and store word) instructions, but we have -;;; magic extra arguments to represent the reading and writing of the FP -;;; registers. R3 will already have been set up with the high bits of the FP -;;; instruction by a preceding CAL. -;;; -(define-format (afpa-l-inst 32) - (fr2 (byte 0 0) :default 0) - (fr1 (byte 0 0) :read t) - (op (byte 8 24) :default #xCD) - (r2 (byte 4 20) :write t) - (r3 (byte 4 16) :read t) - (i (byte 16 0))) -;;; -(define-format (afpa-st-inst 32) - (fr2 (byte 0 0) :read t :write t) - (fr1 (byte 0 0) :read t) - (op (byte 8 24) :default #xDD) - (r2 (byte 4 20) :read t) - (r3 (byte 4 16) :read t) - (i (byte 16 0))) - - -;;; DO-AFPA-INST -- Internal -;;; -;;; Utility used to emit a afpa operation. We emit the CAU that sets up -;;; the high bits of the operation in Temp, and we return the low bits that -;;; should be passed as the I field of the actual FP operation instruction. -;;; -;;; Note: FR2 is the modified register (if any), and the *first* operand to -;;; binops (I didn't make this up.) -;;; -(defun do-afpa-inst (op temp &key fr1 fr2 (ds :register) (ts :pio) - data odd) - (when fr1 - (assert (afpa-fp-reg-p fr1))) - (when fr2 - (assert (afpa-fp-reg-p fr2))) - (when data - (assert (and (tn-p data) - (eq (sb-name (sc-sb (tn-sc data))) 'registers) - (not (and fr1 fr2))))) - (when odd (assert data)) - (let* ((inc (if odd 1 0)) - (fr1-offset (if fr1 (+ (tn-offset fr1) inc) 0)) - (fr2-offset (if fr2 (+ (tn-offset fr2) inc) 0)) - (opcode - (logior (ash (if (eq ts :pio) #xFF #xFE) 24) - (ash (ldb (byte 2 4) fr1-offset) 22) - (ash (ldb (byte 2 4) fr2-offset) 20) - (ash (or (cdr (assoc ds afpa-ds-codes)) - (error "Unknown DS code: ~S." ds)) - 18) - (let ((res (cdr (assoc op afpa-opcodes)))) - (if res - (ash res 10) - (or (cdr (assoc op afpa-special-opcodes)) - (error "Unknown opcode: ~S." op)))) - (ash (ldb (byte 4 0) fr1-offset) 6) - (ash (ldb (byte 4 0) fr2-offset) 2) - (or (cdr (assoc ts afpa-ts-codes)) - (error "Unknown TS code: ~S." ts)))) - (low (logand opcode #xFFFF)) - (high (+ (logand (ash opcode -16) #xFFFF) - (if (eql (logand low #x8000) 0) 0 1)))) - (inst cau temp 0 high) - low)) - - -;;; The AFPA-BINOP pseudo-instruction emits a floating-point binop on the afpa. -;;; FR2 is the destination float register (and first arg). FR1 is the source -;;; float register. Op is the afpa opcode. Temp is a sap-reg (i.e. non-zero, -;;; non-descriptor) register that we form the FP instruction in. -;;; -(define-instruction (afpa-binop-inst) - (afpa-st-inst - (fr2 :argument afpa-fp-reg) - (fr1 :argument afpa-fp-reg) - (r2 :constant null-offset) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) -;;; -(define-pseudo-instruction afpa-binop 64 (fr2 fr1 op temp) - (inst afpa-binop-inst fr2 fr1 temp - (do-afpa-inst op temp :fr1 fr1 :fr2 fr2))) - - -;;; Unop is like binop, but we don't read FR2 before we write it. -;;; -(define-instruction (afpa-unop-inst) - (afpa-st-inst - (fr2 :argument afpa-fp-reg :read nil) - (fr1 :argument afpa-fp-reg) - (r2 :constant null-offset) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction afpa-unop 64 (fr2 fr1 op temp) - (inst afpa-unop-inst fr2 fr1 temp - (do-afpa-inst op temp :fr1 fr1 :fr2 fr2))) - -;;; Sugar up the move a bit... -(define-pseudo-instruction afpa-move 64 (fr2 fr1 format temp) - (inst afpa-unop fr2 fr1 - (ecase format - (:single :cops) - (:double :copl)) - temp)) - -;;; Compare is like binop, but we don't write FR2. -;;; -(define-instruction (afpa-compare-inst) - (afpa-st-inst - (fr2 :argument afpa-fp-reg :write nil) - (fr1 :argument afpa-fp-reg) - (r2 :constant null-offset) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction afpa-compare 64 (fr2 fr1 op temp) - (inst afpa-compare-inst fr2 fr1 temp - (do-afpa-inst op temp :fr1 fr1 :fr2 fr2))) - - -;;; Noop is used to wait for DMA operations (load and store) to complete. -;;; -(define-instruction (afpa-noop-inst :pinned t) - (afpa-st-inst - (fr1 :constant 0) - (fr2 :constant 0) - (r2 :constant null-offset) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction afpa-noop 64 (temp) - (inst afpa-noop-inst temp - (do-afpa-inst :noop temp))) - - -;;; Load = WTFR (write float reg) + DMA. -;;; -(define-instruction (afpa-load-inst :use (memory)) - (afpa-st-inst - (fr2 :argument afpa-fp-reg :read nil) - (fr1 :constant 0) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction afpa-load 64 (fr2 data ts temp) - (inst afpa-load-inst fr2 data temp - (do-afpa-inst :wtfr temp :fr2 fr2 :data data :ts ts))) - - -;;; Store = RDDMA -;;; -(define-instruction (afpa-store-inst :clobber (memory)) - (afpa-st-inst - (fr2 :constant 0) - (fr1 :argument afpa-fp-reg) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction afpa-store 64 (fr1 data ts temp) - (inst afpa-store-inst fr1 data temp - (do-afpa-inst :rddma temp :fr1 fr1 :data data :ts ts))) - - -;;; Get float = RDFR -;;; -(define-instruction (afpa-get-float-inst :clobber (float-status)) - (afpa-l-inst - (fr2 :constant 0) - (fr1 :argument afpa-fp-reg) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction afpa-get-float 64 (data fr1 temp) - (inst afpa-get-float-inst fr1 data temp - (do-afpa-inst :rdfr temp :fr1 fr1 :data data))) - -(define-pseudo-instruction afpa-get-float-odd 64 (data fr1 temp) - (inst afpa-get-float-inst fr1 data temp - (do-afpa-inst :rdfr temp :fr1 fr1 :data data :odd t))) - - -;;; Put float = WTFR -;;; -(define-instruction (afpa-put-float-inst) - (afpa-st-inst - (fr2 :argument afpa-fp-reg) - (fr1 :constant 0) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction afpa-put-float 64 (fr2 data temp) - (inst afpa-put-float-inst fr2 data temp - (do-afpa-inst :wtfr temp :fr2 fr2 :data data))) - -(define-pseudo-instruction afpa-put-float-odd 64 (fr2 data temp) - (inst afpa-put-float-inst fr2 data temp - (do-afpa-inst :wtfr temp :fr2 fr2 :data data :odd t))) - - -;;; Get status = RDSTR -;;; -(define-instruction (afpa-get-status-inst :clobber (float-status)) - (afpa-l-inst - (fr2 :constant 0) - (fr1 :constant 0) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction afpa-get-status 64 (data temp) - (inst afpa-get-status-inst data temp - (do-afpa-inst :rdstr temp :data data))) - - -;;; Put status = WTSTR -;;; -(define-instruction (afpa-put-status-inst :use (float-status)) - (afpa-st-inst - (fr2 :constant 0) - (fr1 :constant 0) - (r2 :argument register) - (r3 :argument address-register) - (i :argument (unsigned-byte 16)))) - -(define-pseudo-instruction afpa-put-status 64 (data temp) - (inst afpa-put-status-inst data temp - (do-afpa-inst :wtstr temp :data data))) diff --git a/compiler/rt/macros.lisp b/compiler/rt/macros.lisp deleted file mode 100644 index e3a0306147480170a16c6250f54332bbd272e316..0000000000000000000000000000000000000000 --- a/compiler/rt/macros.lisp +++ /dev/null @@ -1,540 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; This file contains various useful macros for generating code for the IBM -;;; RT. -;;; -;;; Written by William Lott, Christopher Hoover, and Rob Maclachlin, and Bill -;;; Chiles. -;;; - -(in-package "RT") - - - -;;; Instruction-like macros. - -;;; MOVE -- Interface. -;;; -(defmacro move (dst src) - "Move src into dst unless they are LOCATION=." - (once-only ((n-dst dst) - (n-src src)) - `(unless (location= ,n-dst ,n-src) - (inst move ,n-dst ,n-src)))) - -;;; LOADW and STOREW -- Interface. -;;; -;;; Load and store words. -;;; -(macrolet ((def-mem-op (op inst) - `(defmacro ,op (object base &optional (offset 0) (lowtag 0)) - `(inst ,',inst ,object ,base - (- (ash ,offset word-shift) ,lowtag))))) - (def-mem-op loadw l) - (def-mem-op storew st)) - -;;; LOAD-SYMBOL -- Interface. -;;; -(defmacro load-symbol (reg symbol) - "Load a pointer to the static symbol into reg." - `(inst a ,reg null-tn (static-symbol-offset ,symbol))) - -;;; LOAD-SYMBOL-FUNCTION, STORE-SYMBOL-FUNCTION, -;;; LOAD-SYMBOL-VALUE, STORE-SYMBOL-VALUE -- interface. -;;; -(macrolet - ((frob (slot) - (let ((loader (intern (concatenate 'simple-string - "LOAD-SYMBOL-" - (string slot)))) - (storer (intern (concatenate 'simple-string - "STORE-SYMBOL-" - (string slot)))) - (offset (intern (concatenate 'simple-string - "SYMBOL-" - (string slot) - "-SLOT") - (find-package "VM")))) - `(progn - (defmacro ,loader (reg symbol) - `(inst l ,reg null-tn - (+ (static-symbol-offset ',symbol) - (ash ,',offset word-shift) - (- other-pointer-type)))) - (defmacro ,storer (reg symbol) - `(inst st ,reg null-tn - (+ (static-symbol-offset ',symbol) - (ash ,',offset word-shift) - (- other-pointer-type)))))))) - (frob value) - (frob function)) - -;;; LOAD-TYPE -- Interface. -;;; -;;; Subtract the low-tag from the pointer and add one less than the address -;;; units per word to get us to the low byte since the RT is big-endian. -;;; -(defmacro load-type (target source &optional (low-tag 0)) - "Loads the type bits from the source pointer into target, where pointer has - the specified low-tag." - `(inst lc ,target ,source (- word-bytes 1 ,low-tag))) - - - -;;;; Call and Return. - -;;; Macros to handle the fact that we cannot use the machine native call and -;;; return instructions due to low-tag bits on pointers. -;;; - -;;; LISP-JUMP -- Interface. -;;; -(defmacro lisp-jump (function lip) - "Jump to the lisp function. Lip is the lisp interior pointer register - used as a temporary." - `(progn - (inst cal ,lip ,function (- (ash function-header-code-offset - word-shift) - function-pointer-type)) - (inst bx ,lip) - (move code-tn ,function))) - -;;; LISP-RETURN -- Interface. -;;; -(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) - "Return to return-pc, an LRA. Lip is the lisp interior pointer register - used as a temporary. Offset is the number of words to skip at the target, - and it has to be small enough for whatever instruction used in here." - `(progn - (inst cal ,lip ,return-pc - (- (ash (1+ ,offset) word-shift) other-pointer-type)) - ,@(if frob-code - `((inst bx ,lip) - (move code-tn ,return-pc)) - `((inst b ,lip))))) - -;;; EMIT-RETURN-PC -- Interface. -;;; -(defmacro emit-return-pc (label) - "Emit a return-pc header word, making sure it is aligned properly for our - low-tag bits since there are other-pointers referring to the LRA's. label - is the label to use for this return-pc." - `(progn - (align lowtag-bits) - (emit-label ,label) - (inst lra-header-word))) - - -;;;; Stack TN's. - -;;; LOAD-STACK-TN, STORE-STACK-TN -- Interface. -;;; -;;; Move a stack TN to a register and vice-versa. If the VOP is supplied, -;;; we can load from (or store onto) the number stack also. -;;; -(defmacro load-stack-tn (reg stack &optional vop) - (once-only ((n-reg reg) - (n-stack stack)) - `(sc-case ,n-stack - (control-stack - (loadw ,n-reg cfp-tn (tn-offset ,n-stack))) - ,@(when vop - `(((unsigned-stack signed-stack base-char-stack sap-stack) - (loadw ,n-reg (current-nfp-tn ,vop) (tn-offset ,n-stack)))))))) -;;; -(defmacro store-stack-tn (reg stack &optional vop) - (once-only ((n-reg reg) - (n-stack stack)) - `(sc-case ,n-stack - (control-stack - (storew ,n-reg cfp-tn (tn-offset ,n-stack))) - ,@(when vop - `(((unsigned-stack signed-stack base-char-stack sap-stack) - (storew ,n-reg (current-nfp-tn ,vop) (tn-offset ,n-stack)))))))) - - -;;; MAYBE-LOAD-STACK-TN -- Interface. -;;; -(defmacro maybe-load-stack-tn (reg reg-or-stack) - "Move the TN Reg-Or-Stack into Reg if it isn't already there." - (once-only ((n-reg reg) - (n-stack reg-or-stack)) - `(sc-case ,n-reg - ((any-reg descriptor-reg non-descriptor-reg word-pointer-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg non-descriptor-reg word-pointer-reg) - (move ,n-reg ,n-stack)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) - - - -;;;; Storage allocation: - -;;; WITH-FIXED-ALLOCATION -- Internal Interface. -;;; -(defmacro with-fixed-allocation ((result-tn header-tn alloc-tn type-code size) - &body body) - "Do stuff to allocate an other-pointer object of fixed Size with a single - word header having the specified Type-Code. The result is placed in - Result-TN. Header-Tn is any register temp which this uses to hold the - header of the allocated object before storing it into the header slot. - Alloc-tn is a register to hold the heap pointer, and it can be any register - since raw heap pointers look like fixnums (dual-word aligned objects). The - body is placed inside PSEUDO-ATOMIC, and presumably initializes the object." - `(progn - (pseudo-atomic (,header-tn) - (load-symbol-value ,alloc-tn *allocation-pointer*) - ;; Take free pointer and make descriptor pointer. - ;; Just add in three low-tag bits since alloc ptr is dual-word aligned. - (inst cal ,result-tn ,alloc-tn other-pointer-type) - (inst cal ,alloc-tn ,alloc-tn (pad-data-block ,size)) - (store-symbol-value ,alloc-tn *allocation-pointer*) - (inst li ,header-tn (logior (ash (1- ,size) type-bits) ,type-code)) - (storew ,header-tn ,result-tn 0 other-pointer-type) - ,@body) - (load-symbol-value ,header-tn *internal-gc-trigger*) - (inst tlt ,header-tn ,alloc-tn))) - - - -;;;; Type testing noise. - -;;; GEN-RANGE-TEST -- Internal. -;;; -;;; Generate code that branches to TARGET iff REG contains one of VALUES. If -;;; NOT-P is true, invert the test. Jumping to DROP-THROUGH is the same as -;;; falling out the bottom. -;;; -(defun gen-range-test (reg target drop-through not-p values - &optional (separation 1) (min 0)) - (let ((tests nil) - (start nil) - (end nil) - (insts nil)) - ;; Block off list of values into ranges, so we can test these as intervals - ;; instead of individually. - (flet ((emit-test () - (if (= start end) - (push start tests) - (push (cons start end) tests)))) - (dolist (value values) - (cond ((< value min) - (error "~S is less than the specified minimum of ~S" - value min)) - ((null start) - (setf start value)) - ((> value (+ end separation)) - (emit-test) - (setf start value))) - (setf end value)) - (emit-test)) - ;; Output tests, dealing with not-p. - (macrolet ((inst (name &rest args) - `(push (list 'inst ',name ,@args) insts))) - (do ((remaining (nreverse tests) (cdr remaining))) - ((null remaining)) - (let ((test (car remaining)) - (last (null (cdr remaining)))) - (cond - ((atom test) - (inst c reg test) - (if last - (if not-p - ;; We compared for the thing. If not-p, since it is the - ;; last thing to look for, and we don't want it, then goto - ;; target. - (inst bnc :eq target) - ;; If we do want the thing, and we got it, then goto - ;; target. - (inst bc :eq target)) - ;; If it is not the last thing, and it is not not-p, and we - ;; have it, then go to target. If not-p, and we have the thing - ;; we don't want, then drop through. - (inst bc :eq (if not-p drop-through target)))) - (t - (let ((start (car test)) - (end (cdr test))) - ;; We don't need this code if start is the smallest value we - ;; could possibly have. We know reg can't be less than start. - (unless (= start min) - (inst c reg start) - ;; If I want the range, and I'm less than the start, then - ;; drop through. If I don't want the range, goto target - ;; because I'm not in the range. - (inst bc :lt (if not-p target drop-through))) - ;; We know reg is greater than or equal to start, so see if it - ;; is less than or equal to end. - (inst c reg end) - (if last - (if not-p - ;; If this range is the last test, and I don't - ;; want it, and I'm not in it, then goto target. - (inst bc :gt target) - ;; If this range is the last test, and I want the - ;; range, and I'm in it, then goto target. - (inst bnc :gt target)) - (inst bnc :gt (if not-p drop-through target))))))))) - (nreverse insts))) - -(defconstant type-separation 4) -(defconstant min-type (+ other-immediate-0-type lowtag-limit)) - -;;; TEST-TYPE-AUX -- Internal. -;;; -(defun test-type-aux (reg temp target drop-through not-p lowtags immed hdrs - function-p) - (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql) - (member odd-fixnum-type lowtags :test #'eql))) - (lowtags (sort (if fixnump - (delete even-fixnum-type - (remove odd-fixnum-type lowtags - :test #'eql) - :test #'eql) - (copy-list lowtags)) - #'<)) - (lowtag (if function-p - vm:function-pointer-type - vm:other-pointer-type)) - (hdrs (sort (copy-list hdrs) #'<)) - (immed (sort (copy-list immed) #'<))) - (append - (when immed - `((inst nilz ,temp ,reg type-mask) - ,@(if (or fixnump lowtags hdrs) - ;; If we're going to output any tests below, fall through to - ;; those tests from these. - (let ((fall-through (gensym))) - `((let (,fall-through (gen-label)) - ,@(gen-range-test - temp (if not-p drop-through target) - fall-through nil immed type-separation) - (emit-label ,fall-through)))) - ;; If there are no other tests, drop through to the end of all - ;; these tests. - (gen-range-test temp target drop-through not-p - immed type-separation)))) - (when fixnump - `((inst nilz ,temp ,reg 3) - ,(if (or lowtags hdrs) - ;; If more tests follow this one, fall through to them. - `(inst bc :eq ,(if not-p drop-through target)) - ;; If no more tests follow, drop totally out of here. - `(inst ,(if not-p 'bnc 'bc) :eq ,target)))) - (when (or lowtags hdrs) - `((inst nilz ,temp ,reg lowtag-mask))) - (when lowtags - (if hdrs - ;; If we're going to output any tests below, fall through to - ;; those tests from these. - (let ((fall-through (gensym))) - `((let ((,fall-through (gen-label))) - ,@(gen-range-test temp (if not-p drop-through target) - fall-through nil lowtags) - (emit-label ,fall-through)))) - (gen-range-test temp target drop-through not-p lowtags))) - (when hdrs - `((inst c ,temp ,lowtag) - (inst bnc :eq ,(if not-p target drop-through)) - (load-type ,temp ,reg ,lowtag) - ,@(gen-range-test temp target drop-through not-p - hdrs type-separation min-type)))))) - -(defconstant immediate-types - (list base-char-type unbound-marker-type)) - -(defconstant function-subtypes - (list funcallable-instance-header-type closure-header-type - function-header-type closure-function-header-type)) - -;;; TEST-TYPE -- Interface. -;;; -;;; This is used in type-vops.lisp. -;;; -(defmacro test-type (register temp target not-p &rest type-codes) - "Register holds a descriptor object that might have one of the types in - type-codes. If it does, goto target; otherwise, fall through. If not-p is - set, goto target when register does not hold one of the types. Type-codes - must be compile-time constants that this evaluates to get numeric codes. - Temp is a non-descriptor temporary needed by the code returned by the - macro." - (let* ((type-codes (mapcar #'eval type-codes)) - (lowtags (remove lowtag-limit type-codes :test #'<)) - (extended (remove lowtag-limit type-codes :test #'>)) - (immediates (intersection extended immediate-types :test #'eql)) - (headers (set-difference extended immediate-types :test #'eql)) - (function-p nil)) - (unless type-codes - (error "Must supply at least on type for test-type.")) - (when (and headers (member other-pointer-type lowtags)) - (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers) - (setf headers nil)) - (when (and immediates - (or (member other-immediate-0-type lowtags) - (member other-immediate-1-type lowtags))) - (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates) - (setf immediates nil)) - (when (intersection headers function-subtypes) - (unless (subsetp headers function-subtypes) - (error "Can't test for mix of function subtypes and normal ~ - header types.")) - (setq function-p t)) - (let ((n-reg (gensym)) - (n-temp (gensym)) - (n-target (gensym)) - (drop-through (gensym))) - `(let ((,n-reg ,register) - (,n-temp ,temp) - (,n-target ,target) - (,drop-through (gen-label))) - (declare (ignorable ,n-temp)) - ,@(if (constantp not-p) - (test-type-aux n-reg n-temp n-target drop-through - (eval not-p) lowtags immediates headers - function-p) - `((cond (,not-p - ,@(test-type-aux n-reg n-temp n-target drop-through t - lowtags immediates headers - function-p)) - (t - ,@(test-type-aux n-reg n-temp n-target drop-through nil - lowtags immediates headers - function-p))))) - (emit-label ,drop-through))))) - - - -;;;; Error Code - -(defvar *adjustable-vectors* nil) - -(defmacro with-adjustable-vector ((var) &rest body) - `(let ((,var (or (pop *adjustable-vectors*) - (make-array 16 - :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t)))) - (setf (fill-pointer ,var) 0) - (unwind-protect - (progn - ,@body) - (push ,var *adjustable-vectors*)))) - -(eval-when (compile load eval) - (defun emit-error-break (vop kind code values) - (let ((vector (gensym))) - `((let ((vop ,vop)) - (when vop - (note-this-location vop :internal-error))) - (inst break ,kind) - (with-adjustable-vector (,vector) - (write-var-integer (error-number-or-lose ',code) ,vector) - ,@(mapcar #'(lambda (tn) - `(let ((tn ,tn)) - (write-var-integer (make-sc-offset (sc-number - (tn-sc tn)) - (tn-offset tn)) - ,vector))) - values) - (inst byte (length ,vector)) - (dotimes (i (length ,vector)) - (inst byte (aref ,vector i)))) - (align word-shift))))) - -(defmacro error-call (vop error-code &rest values) - "Cause an error. ERROR-CODE is the error to cause." - (cons 'progn - (emit-error-break vop error-trap error-code values))) - - -;;; CERROR-CALL -- Internal Interface. -;;; -;;; Output the error break stuff followed by a branch to the continuable code. -;;; The break handler can skip the error break data, setting the pc in the -;;; signal context to our following branch, and if we continue, we're setup. -;;; -(defmacro cerror-call (vop label error-code &rest values) - "Cause a continuable error. If the error is continued, execution resumes at - LABEL." - `(progn - ,@(emit-error-break vop cerror-trap error-code values) - (inst b ,label))) - -(defmacro generate-error-code (vop error-code &rest values) - "Generate-Error-Code Error-code Value* - Emit code for an error with the specified Error-Code and context Values." - `(assemble (*elsewhere*) - (let ((start-lab (gen-label))) - (emit-label start-lab) - (error-call ,vop ,error-code ,@values) - start-lab))) - -(defmacro generate-cerror-code (vop error-code &rest values) - "Generate-CError-Code Error-code Value* - Emit code for a continuable error with the specified Error-Code and - context Values. If the error is continued, execution resumes after - the GENERATE-CERROR-CODE form." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) - `(let ((,continue (gen-label))) - (emit-label ,continue) - (assemble (*elsewhere*) - (let ((,error (gen-label))) - (emit-label ,error) - (cerror-call ,vop ,continue ,error-code ,@values) - ,error))))) - - - -;;;; PSEUDO-ATOMIC. - -;;; PSEUDO-ATOMIC -- Internal Interface. -;;; -(defmacro pseudo-atomic ((ndescr-temp) &rest forms) - (let ((label (gensym "LABEL-"))) - `(let ((,label (gen-label))) - (inst li ,ndescr-temp 0) - (store-symbol-value ,ndescr-temp lisp::*pseudo-atomic-interrupted*) - ;; Note: we just use cfp as some not-zero value. - (store-symbol-value cfp-tn lisp::*pseudo-atomic-atomic*) - ,@forms - (inst li ,ndescr-temp 0) - (store-symbol-value ,ndescr-temp lisp::*pseudo-atomic-atomic*) - (load-symbol-value ,ndescr-temp lisp::*pseudo-atomic-interrupted*) - (inst c ,ndescr-temp 0) - (inst bc :eq ,label) - (inst break pending-interrupt-trap) - (emit-label ,label)))) - -;;;; Float stuff: -;;; -;;; 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. This appears rather grody, but actually the 68881 is so slow -;;; compared to the ROMP that this overhead is not very great. -;;; -;;; Note: The RT interrupt handler preserves 64 bytes beyond the current stack -;;; pointer, so we don't need to dink the stack pointer. We can just use the -;;; space beyond it. -;;; -;;; We also use LIP to form the address of the data location that we are -;;; reading or writing. - -(defvar *in-with-fp-temp* nil) - -(defmacro with-fp-temp ((var) &body body) - `(if *in-with-fp-temp* - (error "Can only have one FP temp.") - (let ((,var nl0-tn) - (*in-with-fp-temp* t)) - (storew ,var nsp-tn -1) - (multiple-value-prog1 (progn ,@body) - (loadw ,var nsp-tn -1))))) diff --git a/compiler/rt/mc68881.lisp b/compiler/rt/mc68881.lisp deleted file mode 100644 index 33a33a8fd85a42a538b2167c2a8b2ae3a55c0340..0000000000000000000000000000000000000000 --- a/compiler/rt/mc68881.lisp +++ /dev/null @@ -1,564 +0,0 @@ -;;; -*- 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/mc68881.lisp,v 1.11 1992/03/09 20:37:46 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; The following code is to support the MC68881 floating point chip on the APC -;;; card. Adapted by Rob MacLachlan from the Sparc support, written by Rob -;;; MacLachlan and William Lott, with some stuff from Dave McDonald's original -;;; RT miscops. -;;; -(in-package "RT") - -(eval-when (compile eval load) - -;;; The actual positions of the info in the mc68881 FPCR and FPSR. -;;; -(defconstant mc68881-fpcr-rounding-mode-byte (byte 2 4)) -(defconstant mc68881-fpcr-rounding-precision-byte (byte 2 6)) -(defconstant mc68881-fpcr-traps-byte (byte 8 8)) -(defconstant mc68881-fpsr-accrued-exceptions-byte (byte 5 3)) -(defconstant mc68881-fpsr-current-exceptions-byte (byte 8 8)) -(defconstant mc68881-fpsr-condition-code-byte (byte 4 24)) - -;;; Amount to shift by the get the condition code, - 16. -;;; -(defconstant mc68881-fpsr-condition-code-shift-16 8) - -;;; The condition code bits. -;;; -(defconstant mc68881-nan-condition (ash 1 0)) -(defconstant mc68881-infinity-condition (ash 1 1)) -(defconstant mc68881-zero-condition (ash 1 2)) -(defconstant mc68881-negative-condition (ash 1 3)) - -;;; Masks that map the extended set of exceptions implemented by the 68881 to -;;; the IEEE exceptions. This extended format is used for the enabled traps -;;; and the current exceptions. -;;; -(defconstant mc68881-invalid-exception (ash #b111 5)) -(defconstant mc68881-overflow-exception (ash 1 4)) -(defconstant mc68881-underflow-exception (ash 1 3)) -(defconstant mc68881-divide-zero-exception (ash 1 2)) -(defconstant mc68881-inexact-exception (ash #b11 0)) - -;;; Encoding of float exceptions in the FLOATING-POINT-MODES result. This is -;;; also the encoding used in the mc68881 accrued exceptions. -;;; -(defconstant float-inexact-trap-bit (ash 1 0)) -(defconstant float-divide-by-zero-trap-bit (ash 1 1)) -(defconstant float-underflow-trap-bit (ash 1 2)) -(defconstant float-overflow-trap-bit (ash 1 3)) -(defconstant float-invalid-trap-bit (ash 1 4)) - -(defconstant float-round-to-nearest 0) -(defconstant float-round-to-zero 1) -(defconstant float-round-to-negative 2) -(defconstant float-round-to-positive 3) - -;;; Positions of bits in the FLOATING-POINT-MODES result. -;;; -(defconstant float-rounding-mode (byte 2 0)) -(defconstant float-sticky-bits (byte 5 2)) -(defconstant float-traps-byte (byte 5 7)) -(defconstant float-exceptions-byte (byte 5 12)) -(defconstant float-fast-bit 0) - -); eval-when - -;;; When compared to the 68881 documentation, the RT only uses the low 16 bits -;;; of the instruction. Memory access is controlled in an RT specific way. -;;; See the AFPA coprocessor hardware assist operation (page B34 in volume 1.) - - -;;;; Move functions: -;;; -;;; See With-FP-Temp comment... - -(define-move-function (load-single 7) (vop x y) - ((single-stack) (mc68881-single-reg)) - (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes)) - (with-fp-temp (temp) - (inst mc68881-load y lip-tn :single temp))) - -(define-move-function (store-single 8) (vop x y) - ((mc68881-single-reg) (single-stack)) - (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)) - (with-fp-temp (temp) - (inst mc68881-store x lip-tn :single temp))) - -(define-move-function (load-double 7) (vop x y) - ((double-stack) (mc68881-double-reg)) - (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes)) - (with-fp-temp (temp) - (inst mc68881-load y lip-tn :double temp))) - -(define-move-function (store-double 8) (vop x y) - ((mc68881-double-reg) (double-stack)) - (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)) - (with-fp-temp (temp) - (inst mc68881-store x lip-tn :double temp))) - - -;;;; Move VOPs: - -(define-vop (mc68881-move) - (:args (x :scs (mc68881-single-reg mc68881-double-reg) - :target y - :load-if (not (location= x y)))) - (:results (y :scs (mc68881-single-reg mc68881-double-reg) - :load-if (not (location= x y)))) - (:temporary (:sc sap-reg) temp) - (:generator 0 - (unless (location= y x) - (inst mc68881-move y x temp)))) - -(define-move-vop mc68881-move :move - (mc68881-single-reg) (mc68881-single-reg) - (mc68881-double-reg) (mc68881-double-reg)) - - -(define-vop (move-to-mc68881) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (mc68881-single-reg mc68881-double-reg))) - (:temporary (:sc sap-reg) temp) - (:variant-vars format data) - (:generator 7 - (inst cal lip-tn x (- (* data vm:word-bytes) vm:other-pointer-type)) - (inst mc68881-load y lip-tn format temp))) - -(macrolet ((frob (name format data sc) - `(progn - (define-vop (,name move-to-mc68881) - (:variant ,format ,data)) - (define-move-vop ,name :move (descriptor-reg) (,sc))))) - (frob move-to-mc68881-single :single vm:single-float-value-slot - mc68881-single-reg) - (frob move-to-mc68881-double :double vm:double-float-value-slot - mc68881-double-reg)) - - -(define-vop (move-from-mc68881) - (:args (x :scs (mc68881-single-reg mc68881-double-reg) :to :save)) - (:results (y :scs (descriptor-reg))) - (:temporary (:scs (sap-reg)) ndescr) - (:temporary (:scs (word-pointer-reg)) alloc) - (:variant-vars format size type data) - (:generator 20 - (with-fixed-allocation (y ndescr alloc type size) - (inst cal lip-tn y (- (* data vm:word-bytes) vm:other-pointer-type)) - (inst mc68881-store x lip-tn format ndescr)))) - -(macrolet ((frob (name sc &rest args) - `(progn - (define-vop (,name move-from-mc68881) - (:variant ,@args)) - (define-move-vop ,name :move (,sc) (descriptor-reg))))) - (frob move-from-mc68881-single mc68881-single-reg - :single vm:single-float-size vm:single-float-type - vm:single-float-value-slot) - (frob move-from-mc68881-double mc68881-double-reg - :double vm:double-float-size vm:double-float-type - vm:double-float-value-slot)) - -(define-vop (move-to-mc68881-argument) - (:args (x :scs (mc68881-single-reg mc68881-double-reg) :target y) - (nfp :scs (word-pointer-reg) - :load-if (not (sc-is y mc68881-single-reg mc68881-double-reg)))) - (:results (y)) - (:temporary (:sc sap-reg) temp) - (:variant-vars format) - (:vop-var vop) - (:generator 7 - (sc-case y - ((mc68881-single-reg mc68881-double-reg) - (unless (location= y x) - (inst mc68881-move y x temp))) - ((single-stack double-stack) - (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)) - (inst mc68881-store y lip-tn format temp))))) - -(macrolet ((frob (name format sc) - `(progn - (define-vop (,name move-to-mc68881-argument) - (:variant ,format)) - (define-move-vop ,name :move-argument - (,sc descriptor-reg) (,sc))))) - (frob move-mc68881-single-float-argument :single mc68881-single-reg) - (frob move-mc68881-double-float-argument :double mc68881-double-reg)) - -(define-move-vop move-argument :move-argument - (mc68881-single-reg mc68881-double-reg) (descriptor-reg)) - - -;;;; Arithmetic VOPs: - -(define-vop (mc68881-op) - (:args (x) (y)) - (:results (r)) - (:temporary (:sc sap-reg) temp) - (:policy :fast-safe) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only)) - -(macrolet ((frob (name sc ptype) - `(define-vop (,name mc68881-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 mc68881-move r x temp)) - (note-this-location vop :internal-error) - (inst mc68881-binop r y op temp))))) - (frob mc68881-single-float-op mc68881-single-reg mc68881-single-float) - (frob mc68881-double-float-op mc68881-double-reg mc68881-double-float)) - -(macrolet ((frob (op sinst sname dinst dname) - `(progn - (define-vop (,sname mc68881-single-float-op) - (:translate ,op) - (:variant ,sinst)) - (define-vop (,dname mc68881-double-float-op) - (:translate ,op) - (:variant ,dinst))))) - (frob + :add +/single-float :add +/double-float) - (frob - :sub -/single-float :sub -/double-float) - (frob * :sglmul */single-float :mul */double-float) - (frob / :sgldiv //single-float :div //double-float)) - -(define-vop (mc68881-unop mc68881-op) - (:args (x))) - -(macrolet ((frob (name sc ptype) - `(define-vop (,name mc68881-unop) - (:args (x :scs (,sc))) - (:results (r :scs (,sc))) - (:arg-types ,ptype) - (:result-types ,ptype) - (:variant-vars op) - (:generator 20 - (inst mc68881-unop r x op temp))))) - (frob mc68881-single-float-unop mc68881-single-reg mc68881-single-float) - (frob mc68881-double-float-unop mc68881-double-reg mc68881-double-float)) - - -(macrolet ((frob (op sinst sname dinst dname) - `(progn - (define-vop (,sname mc68881-single-float-unop) - (:translate ,op) - (:variant ,sinst)) - (define-vop (,dname mc68881-double-float-unop) - (:translate ,op) - (:variant ,dinst))))) - (frob abs :abs abs/single-float :abs abs/double-float) - (frob %negate :neg %negate/single-float :neg %negate/double-float)) - - -;;;; Comparison: - -(define-vop (mc68881-compare) - (:args (x) (y)) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:sc sap-reg) temp) - (:temporary (:sc descriptor-reg) loc) - (:temporary (:sc unsigned-stack) loc-tn) - (:variant-vars condition) - (:note "inline float comparison") - (:vop-var vop) - (:save-p :compute-only) - (:generator 20 - (let ((drop-thru (gen-label))) - (note-this-location vop :internal-error) - (if (eq condition '<) - (inst mc68881-compare y x :cmp temp) - (inst mc68881-compare x y :cmp temp)) - (let ((nfp (current-nfp-tn vop))) - (inst cal loc nfp (* (tn-offset loc-tn) word-bytes))) - (inst mc68881-store-status :fpsr loc temp) - (loadw temp loc) - (ecase condition - ((< >) - (inst niuz temp temp - (ash (logior mc68881-zero-condition - mc68881-negative-condition - mc68881-nan-condition) - mc68881-fpsr-condition-code-shift-16))) - (eql - (inst niuz temp temp - (ash mc68881-zero-condition - mc68881-fpsr-condition-code-shift-16)) - (setq not-p (not not-p)))) - - (if not-p - (inst bnc :eq target) - (inst bc :eq target)) - (emit-label drop-thru)))) - -(macrolet ((frob (name sc ptype) - `(define-vop (,name mc68881-compare) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:arg-types ,ptype ,ptype)))) - (frob mc68881-single-float-compare mc68881-single-reg mc68881-single-float) - (frob mc68881-double-float-compare mc68881-double-reg mc68881-double-float)) - -(macrolet ((frob (translate sname dname) - `(progn - (define-vop (,sname mc68881-single-float-compare) - (:translate ,translate) - (:variant ',translate)) - (define-vop (,dname mc68881-double-float-compare) - (:translate ,translate) - (:variant ',translate))))) - (frob < mc68881-</single-float mc68881-</double-float) - (frob > mc68881->/single-float mc68881->/double-float) - (frob eql mc68881-eql/single-float mc68881-eql/double-float)) - - -;;;; Conversion: - -(macrolet ((frob (name translate to-sc to-type) - `(define-vop (,name) - (:args (x :scs (signed-reg) :target temp - :load-if (not (sc-is x signed-stack)))) - (:temporary (:scs (single-stack)) temp) - (:temporary (:sc word-pointer-reg) addr) - (:temporary (:sc sap-reg) scratch) - (:results (y :scs (,to-sc))) - (:arg-types signed-num) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:generator 20 - (let ((stack-tn - (sc-case x - (signed-reg - (storew x - (current-nfp-tn vop) - (* (tn-offset temp) vm:word-bytes)) - temp) - (signed-stack - x)))) - (inst cal addr (current-nfp-tn vop) - (* (tn-offset stack-tn) vm:word-bytes)) - (note-this-location vop :internal-error) - (inst mc68881-load y addr :integer scratch)))))) - (frob mc68881-%single-float/signed %single-float - mc68881-single-reg mc68881-single-float) - (frob mc68881-%double-float/signed %double-float - mc68881-double-reg mc68881-double-float)) - -;;; Everything is represented as extended precision, so these operations don't -;;; really do anything. (Or, rather, whatever semantics there is, is -;;; automatically handled by the load functions.) -;;; -(macrolet ((frob (name translate from-sc from-type to-sc to-type) - `(define-vop (,name mc68881-move) - (:args (x :scs (,from-sc) :target y)) - (:results (y :scs (,to-sc))) - (:arg-types ,from-type) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate)))) - (frob mc68881-%single-float/double-float %single-float - mc68881-double-reg mc68881-double-float - mc68881-single-reg mc68881-single-float) - (frob mc68881-%double-float/single-float %double-float - mc68881-single-reg mc68881-single-float - mc68881-double-reg mc68881-double-float)) - -(macrolet ((frob (trans from-sc from-type inst) - `(define-vop (,(symbolicate trans "/" from-type)) - (:args (x :scs (,from-sc) :target temp)) - (:temporary (:from (:argument 0) :sc mc68881-single-reg) temp) - (:temporary (:sc sap-reg) scratch) - (:temporary (:scs (signed-stack)) stack-temp) - (:temporary (:sc word-pointer-reg) addr) - (:results (y :scs (signed-reg) - :load-if (not (sc-is y signed-stack)))) - (:arg-types ,from-type) - (:result-types signed-num) - (:translate ,trans) - (:policy :fast-safe) - (:note "inline float truncate") - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (note-this-location vop :internal-error) - (inst mc68881-unop temp x ,inst scratch) - (sc-case y - (signed-stack - (inst cal addr (current-nfp-tn vop) - (* (tn-offset y) vm:word-bytes)) - (inst mc68881-store temp addr :integer scratch)) - (signed-reg - (inst cal addr (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst mc68881-store temp addr :integer scratch) - (loadw y (current-nfp-tn vop) - (tn-offset stack-temp)))))))) - (frob %unary-truncate mc68881-single-reg mc68881-single-float :intrz) - (frob %unary-truncate mc68881-double-reg mc68881-double-float :intrz) - (frob %unary-round mc68881-single-reg mc68881-single-float :int) - (frob %unary-round mc68881-double-reg mc68881-double-float :int)) - - -(define-vop (make-mc68881-single-float) - (:args (bits :scs (signed-reg) :target res - :load-if (not (sc-is bits signed-stack)))) - (:results (res :scs (mc68881-single-reg) - :load-if (not (sc-is res single-stack)))) - (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp) - (:temporary (:scs (signed-stack)) stack-temp) - (:temporary (:sc sap-reg) scratch) - (:temporary (:sc word-pointer-reg) addr) - (:arg-types signed-num) - (:result-types mc68881-single-float) - (:translate make-single-float) - (:policy :fast-safe) - (:vop-var vop) - (:generator 20 - (sc-case bits - (signed-reg - (sc-case res - (mc68881-single-reg - (storew bits (current-nfp-tn vop) (tn-offset stack-temp)) - (inst cal addr (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst mc68881-load res addr :single scratch)) - (single-stack - (storew bits (current-nfp-tn vop) (tn-offset res))))) - (signed-stack - (sc-case res - (mc68881-single-reg - (inst cal addr (current-nfp-tn vop) - (* (tn-offset bits) vm:word-bytes)) - (inst mc68881-load res addr :single scratch)) - (single-stack - (unless (location= bits res) - (loadw temp (current-nfp-tn vop) (tn-offset bits)) - (storew temp (current-nfp-tn vop) (tn-offset res))))))))) - -(define-vop (make-mc68881-double-float) - (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) - (:arg-types signed-num unsigned-num) - (:results (res :scs (mc68881-double-reg) - :load-if (not (sc-is res double-stack)))) - (:result-types mc68881-double-float) - (:temporary (:scs (double-stack)) temp) - (:temporary (:sc sap-reg :from (:eval 0)) scratch) - (:temporary (:sc word-pointer-reg :from (:eval 0)) addr) - (:translate make-double-float) - (:policy :fast-safe) - (:vop-var vop) - (:generator 25 - (let ((stack-tn (sc-case res - (double-stack res) - (mc68881-double-reg temp)))) - (storew hi-bits (current-nfp-tn vop) (tn-offset stack-tn)) - (storew lo-bits (current-nfp-tn vop) (1+ (tn-offset stack-tn)))) - (when (sc-is res mc68881-double-reg) - (inst cal addr (current-nfp-tn vop) (* (tn-offset temp) vm:word-bytes)) - (inst mc68881-load res addr :double scratch)))) - -(define-vop (mc68881-single-float-bits) - (:args (float :scs (mc68881-single-reg))) - (:results (bits :scs (signed-reg))) - (:temporary (:scs (signed-stack)) stack-temp) - (:temporary (:sc sap-reg) scratch) - (:temporary (:sc word-pointer-reg) addr) - (:arg-types mc68881-single-float) - (:result-types signed-num) - (:translate single-float-bits) - (:policy :fast-safe) - (:vop-var vop) - (:generator 20 - (inst cal addr (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst mc68881-store float addr :single scratch) - (loadw bits (current-nfp-tn vop) (tn-offset stack-temp)))) - -(define-vop (mc68881-double-float-high-bits) - (:args (float :scs (mc68881-double-reg))) - (:results (bits :scs (signed-reg))) - (:temporary (:scs (double-stack)) stack-temp) - (:temporary (:sc sap-reg) scratch) - (:temporary (:sc word-pointer-reg) addr) - (:arg-types mc68881-double-float) - (:result-types signed-num) - (:translate double-float-high-bits) - (:policy :fast-safe) - (:vop-var vop) - (:variant-vars offset) - (:variant 0) - (:generator 20 - (inst cal addr (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst mc68881-store float addr :double scratch) - (loadw bits (current-nfp-tn vop) (+ (tn-offset stack-temp) offset)))) - -(define-vop (mc68881-double-float-low-bits mc68881-double-float-high-bits) - (:results (bits :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant 1) - (:translate double-float-low-bits)) - - -;;;; 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))) diff --git a/compiler/rt/memory.lisp b/compiler/rt/memory.lisp deleted file mode 100644 index 209840624f20d73d2441661b879e41e9ad256f36..0000000000000000000000000000000000000000 --- a/compiler/rt/memory.lisp +++ /dev/null @@ -1,182 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/memory.lisp,v 1.1 1991/02/18 15:07:59 chiles Exp $ -;;; -;;; This file contains the IBM RT definitions of some general purpose memory -;;; reference VOPs inherited by basic memory reference operations. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by Bill Chiles. -;;; - -(in-package "RT") - - -;;; CELL-REF -- VOP. -;;; CELL-SET -- VOP. -;;; CELL-SETF -- VOP. -;;; CELL-SETF-FUNCTION -- VOP. -;;; -;;; CELL-REF and CELL-SET are used to define VOPs like CAR, where the offset to -;;; be read or written is a property of the VOP used. CELL-SETF is similar to -;;; CELL-SET, but delivers the new value as the result. CELL-SETF-FUNCTION -;;; takes its arguments as if it were a setf function (new value first, as -;;; apposed to a setf macro, which takes the new value last). -;;; -(define-vop (cell-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (word-pointer-reg descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (loadw value object offset lowtag))) -;;; -(define-vop (cell-set) - (:args (object :scs (descriptor-reg)) - (value :scs (word-pointer-reg descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (storew value object offset lowtag))) -;;; -(define-vop (cell-setf) - (:args (object :scs (descriptor-reg)) - (value :scs (word-pointer-reg descriptor-reg any-reg) - :target result)) - (:results (result :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (storew value object offset lowtag) - (move result value))) -;;; -(define-vop (cell-setf-function) - (:args (value :scs (word-pointer-reg descriptor-reg any-reg) - :target result) - (object :scs (descriptor-reg))) - (:results (result :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (storew value object offset lowtag) - (move result value))) - -;;; DEFINE-CELL-ACCESSORS -- Interface. -;;; -;;; Define accessor VOPs for some cells in an object. If the operation name is -;;; NIL, then that operation isn't defined. If the translate function is null, -;;; then we don't define a translation. -;;; -(defmacro define-cell-accessors (offset lowtag ref-op ref-trans set-op set-trans) - `(progn - ,@(when ref-op - `((define-vop (,ref-op cell-ref) - (:variant ,offset ,lowtag) - ,@(when ref-trans - `((:translate ,ref-trans)))))) - ,@(when set-op - `((define-vop (,set-op cell-setf) - (:variant ,offset ,lowtag) - ,@(when set-trans - `((:translate ,set-trans)))))))) - - -;;; SLOT-REF -- VOP. -;;; SLOT-SET -- VOP. -;;; -;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF, where the -;;; offset is constant at compile time, but varies for different uses. We add -;;; in the stardard g-vector overhead. -;;; -(define-vop (slot-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:variant-vars base lowtag) - (:info offset) - (:generator 4 - (loadw value object (+ base offset) lowtag))) -;;; -(define-vop (slot-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:variant-vars base lowtag) - (:info offset) - (:generator 4 - (storew value object (+ base offset) lowtag))) - - - -;;;; Indexed references: - -(eval-when (compile eval) - -;;; DEFINE-INDEXER -- Internal. -;;; -;;; Define some VOPs for indexed memory reference. Unless the index is -;;; constant, we must compute an intermediate result in a boxed temporary, -;;; since the RT doesn't have any indexed addressing modes. -;;; -(defmacro define-indexer (name write-p op shift &key gross-hack) - `(define-vop (,name) - (:args (object :scs (descriptor-reg) :to :eval) - (index :scs (any-reg immediate) - ,@(unless (zerop shift) '(:target temp))) - ,@(when write-p - '((value :scs (any-reg descriptor-reg) :target result)))) - (:arg-types * tagged-num ,@(when write-p '(*))) - (:temporary (:scs (interior-reg) :type interior) lip) - ,@(unless (zerop shift) - `((:temporary (:scs (non-descriptor-reg) - :type random :from (:argument 1)) - temp))) - (:results (,(if write-p 'result 'value) - :scs (any-reg descriptor-reg))) - (:result-types *) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 5 - (sc-case index - ((immediate) - (inst ,op value object - (- (+ (if (and (sc-is index immediate) (zerop (tn-value index))) - 0 - (ash (tn-value index) (- word-shift ,shift))) - (ash offset word-shift)) - lowtag)) - ,@(if write-p - '((move result value)))) - (t - ,@(if (zerop shift) - ;; Object must be the last arg to CAS here since it is cannot - ;; be in R0. - `((inst cas lip index object)) - `((move temp index) - (inst sr temp ,shift) - (inst cas lip temp object))) - (inst ,op value lip (- (ash offset word-shift) lowtag)) - ,@(if write-p - '((move result value))))) - ;; The RT lacks a signed-byte load instruction, so we have to sign - ;; extend this case explicitly. This is gross but obvious and easy. - ,@(when gross-hack - '((inst sl value 24) - (inst sar value 24)))))) - -) ;EVAL-WHEN - -(define-indexer word-index-ref nil l 0) -(define-indexer word-index-set t st 0) -(define-indexer halfword-index-ref nil lh 1) -(define-indexer signed-halfword-index-ref nil lha 1) -(define-indexer halfword-index-set t sth 1) -(define-indexer byte-index-ref nil lc 2) -(define-indexer signed-byte-index-ref nil lc 2 :gross-hack t) -(define-indexer byte-index-set t stc 2) diff --git a/compiler/rt/move.lisp b/compiler/rt/move.lisp deleted file mode 100644 index 64525035b8faebaa98fc824287ad96799ba85184..0000000000000000000000000000000000000000 --- a/compiler/rt/move.lisp +++ /dev/null @@ -1,356 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/move.lisp,v 1.5 1991/11/09 02:37:19 wlott Exp $ -;;; -;;; This file contains the IBM RT VM definition of operand loading/saving and the -;;; Move VOP. -;;; -;;; Written by Rob MacLachlan. -;;; MIPS conversion by William Lott. -;;; IBM RT conversion by William Lott and Bill Chiles. -;;; - -(in-package "RT") - - -(define-move-function (load-immediate 1) (vop x y) - ((null immediate) - (any-reg word-pointer-reg descriptor-reg)) - (let ((val (tn-value x))) - (etypecase val - (integer - (inst li y (fixnum val))) - (null - (move y null-tn)) - (symbol - (load-symbol y val)) - (character - (inst li y (logior (ash (char-code val) type-bits) - base-char-type)))))) - -(define-move-function (load-number 1) (vop x y) - ((immediate) - (signed-reg unsigned-reg)) - (inst li y (tn-value x))) - -(define-move-function (load-base-char 1) (vop x y) - ((immediate) (base-char-reg)) - (inst li y (char-code (tn-value x)))) - -(define-move-function (load-system-area-pointer 1) (vop x y) - ((immediate) (sap-reg)) - (inst li y (sap-int (tn-value x)))) - -(define-move-function (load-constant 5) (vop x y) - ((constant) (descriptor-reg)) - (loadw y code-tn (tn-offset x) other-pointer-type)) - -(define-move-function (load-stack 5) (vop x y) - ((control-stack) (any-reg word-pointer-reg descriptor-reg)) - (load-stack-tn y x)) - -(define-move-function (load-number-stack 5) (vop x y) - ((base-char-stack) (base-char-reg) - (sap-stack) (sap-reg) - (signed-stack) (signed-reg) - (unsigned-stack) (unsigned-reg)) - (load-stack-tn y x vop)) - -(define-move-function (store-stack 5) (vop x y) - ((any-reg word-pointer-reg descriptor-reg) (control-stack)) - (store-stack-tn x y)) - -(define-move-function (store-number-stack 5) (vop x y) - ((base-char-reg) (base-char-stack) - (sap-reg) (sap-stack) - (signed-reg) (signed-stack) - (unsigned-reg) (unsigned-stack)) - (store-stack-tn x y vop)) - -(define-move-function (word-pointer-copy 1) (vop x y) - ((word-pointer-reg) (any-reg) - (any-reg) (word-pointer-reg)) - (move y x)) - - - -;;;; The Move VOP: - -(define-vop (move) - (:args (x :target y - :scs (any-reg word-pointer-reg descriptor-reg) - :load-if (not (location= x y)))) - (:results (y :scs (any-reg word-pointer-reg descriptor-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move y x))) - -(define-move-vop move :move - (any-reg word-pointer-reg descriptor-reg) - (any-reg word-pointer-reg descriptor-reg)) - -;;; Make Move the check VOP for T so that type check generation doesn't think -;;; it is a hairy type. This also allows checking of a few of the values in a -;;; continuation to fall out. -;;; -(primitive-type-vop move (:check) t) - -;;; MOVE-ARGUMENT -- VOP. -;;; -;;; This is used for moving descriptor values into another frame for argument -;;; or known value passing. -;;; -(define-vop (move-argument) - (:args (x :target y - :scs (any-reg word-pointer-reg descriptor-reg)) - (fp :scs (word-pointer-reg) - :load-if (not (sc-is y any-reg descriptor-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - ((any-reg word-pointer-reg descriptor-reg) - (move y x)) - (control-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-argument :move-argument - (any-reg word-pointer-reg descriptor-reg) - (any-reg word-pointer-reg descriptor-reg)) - - - -;;;; ILLEGAL-MOVE - -;;; ILLEGAL-MOVE -- VOP. -;;; -;;; This VOP exists just to begin the lifetime of a TN that couldn't be written -;;; legally due to a type error. An error is signalled before this VOP is so -;;; we don't need to do anything (not that there would be anything sensible to -;;; do anyway.) -;;; -(define-vop (illegal-move) - (:args (x) (type)) - (:results (y)) - (:ignore y) - (:vop-var vop) - (:save-p :compute-only) - (:generator 666 - (error-call vop object-not-type-error x type))) - - - -;;;; Moves and coercions: - -;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word -;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer -;;; to a tagged bignum or fixnum. - -;;; MOVE-TO-WORD/FIXNUM -- VOP. -;;; -;;; Arg is a fixnum, so just put it in a non-descriptor register and shift it. -;;; -(define-vop (move-to-word/fixnum) - (:args (x :scs (any-reg descriptor-reg) :target y)) - (:results (y :scs (signed-reg unsigned-reg))) - (:arg-types tagged-num) - (:note "fixnum untagging") - (:generator 2 - (move y x) - (inst sar y 2))) -;;; -(define-move-vop move-to-word/fixnum :move - (any-reg descriptor-reg) (signed-reg unsigned-reg)) - -;;; MOVE-TO-WORD-C -- VOP. -;;; -;;; Arg is a non-immediate constant, load it. -;;; -(define-vop (move-to-word-c) - (:args (x :scs (constant))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "constant load") - (:generator 1 - (inst li y (tn-value x)))) -;;; -(define-move-vop move-to-word-c :move - (constant) (signed-reg unsigned-reg)) - -;;; MOVE-TO-WORD/INTEGER -- VOP. -;;; -;;; Arg is a fixnum or bignum, figure out which and load if necessary. -;;; -(define-vop (move-to-word/integer) - (:args (x :scs (descriptor-reg) :to :save)) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "integer to untagged word coercion") - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 8 - (let ((done (gen-label))) - (inst nilz temp x 3) - (move y x) - (inst bcx :eq done) - (inst sar y 2) - ;; If it's a bignum, throw away what we computed in y. - (loadw y x bignum-digits-offset other-pointer-type) - (emit-label done)))) -;;; -(define-move-vop move-to-word/integer :move - (descriptor-reg) (signed-reg unsigned-reg)) - - -;;; MOVE-FROM-WORD/FIXNUM -- VOP. -;;; -;;; Since the result is know to be a fixnum, we can shift in the tag bits -;;; without fear of needing a bignum. -;;; -(define-vop (move-from-word/fixnum) - (:args (x :scs (signed-reg unsigned-reg) :target temp)) - (:temporary (:scs (non-descriptor-reg) - :from (:argument 0) :to (:result 0) :target y) - temp) - (:results (y :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "fixnum tagging") - (:generator 3 - (move temp x) - (inst sl temp 2) - (move y temp))) -;;; -(define-move-vop move-from-word/fixnum :move - (signed-reg unsigned-reg) (any-reg descriptor-reg)) - -;;; MOVE-FROM-SIGNED -- VOP. -;;; -;;; Result may be a bignum, so we have to check whether shifting to make room -;;; for tag bits results in a fixnum. Use a worst-case cost to make sure -;;; people know they may be number consing. -;;; -(define-vop (move-from-signed) - (:args (arg :scs (signed-reg unsigned-reg) :target x)) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) - (:temporary (:scs (word-pointer-reg)) alloc) - (:note "signed word to integer coercion") - (:generator 25 - (move x arg) - (let ((fixnum (gen-label)) - (done (gen-label))) - (move temp x) - (inst sar temp 29) - (inst bcx :eq fixnum) - (inst not temp) - (inst bc :eq fixnum) - - (with-fixed-allocation (y temp alloc bignum-type 2) - (storew x y bignum-digits-offset other-pointer-type)) - (inst b done) - - (emit-label fixnum) - (move y x) - (inst sl y 2) - (emit-label done)))) -;;; -(define-move-vop move-from-signed :move - (signed-reg) (descriptor-reg)) - - -;;; MOVE-FROM-UNSIGNED -- VOP. -;;; -;;; Check for fixnum, and possibly allocate one or two word bignum result. Use -;;; a worst-case cost to make sure people know they may be number consing. -;;; -(define-vop (move-from-unsigned) - (:args (arg :scs (signed-reg unsigned-reg) :target x)) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) - (:temporary (:scs (word-pointer-reg)) alloc) - (:note "unsigned word to integer coercion") - (:generator 21 - (move x arg) - (let ((done (gen-label)) - (bignum (gen-label)) - (one-word (gen-label))) - (move temp x) - (inst sar temp 29) - (inst bnc :eq bignum) - (inst sl x 2) - (move y x) - (emit-label done) - - (assemble (*elsewhere*) - (emit-label bignum) - (pseudo-atomic (temp) - (load-symbol-value alloc *allocation-pointer*) - (inst cal y alloc other-pointer-type) - (inst cal alloc alloc (pad-data-block (1+ bignum-digits-offset))) - (inst c x 0) - (inst bncx :lt one-word) - (inst li temp (logior (ash 1 type-bits) bignum-type)) - (inst cal alloc alloc - (- (pad-data-block (+ 2 bignum-digits-offset)) - (pad-data-block (1+ bignum-digits-offset)))) - (inst li temp (logior (ash 2 type-bits) bignum-type)) - (emit-label one-word) - (store-symbol-value alloc *allocation-pointer*) - (storew temp y 0 other-pointer-type) - (storew x y bignum-digits-offset other-pointer-type)) - (load-symbol-value temp *internal-gc-trigger*) - (inst tlt temp alloc) - (inst b done))))) -;;; -(define-move-vop move-from-unsigned :move - (unsigned-reg) (descriptor-reg)) - - -;;; Move untagged numbers. -;;; -(define-vop (word-move) - (:args (x :target y - :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:results (y :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:note "word integer move") - (:generator 0 - (move y x))) -;;; -(define-move-vop word-move :move - (signed-reg unsigned-reg) (signed-reg unsigned-reg)) - - -;;; Move untagged number arguments/return-values. -;;; -(define-vop (move-word-argument) - (:args (x :target y - :scs (signed-reg unsigned-reg)) - (fp :scs (word-pointer-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (:note "word integer argument move") - (:generator 0 - (sc-case y - ((signed-reg unsigned-reg) - (move y x)) - ((signed-stack unsigned-stack) - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-word-argument :move-argument - (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a -;;; descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff --git a/compiler/rt/nlx.lisp b/compiler/rt/nlx.lisp deleted file mode 100644 index 713ed7fbab88ea43bd751230035f0b61dce159ad..0000000000000000000000000000000000000000 --- a/compiler/rt/nlx.lisp +++ /dev/null @@ -1,302 +0,0 @@ -;;; -*- Package: RT -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/nlx.lisp,v 1.4 1992/01/01 15:07:09 ram Exp $ -;;; -;;; This file contains the definitions of VOPs used for non-local exit (throw, -;;; lexical exit, etc.) -;;; -;;; Written by Rob MacLachlan -;;; Converted to IBM RT by William Lott and Bill Chiles. -;;; - -(in-package "RT") - - -;;; MAKE-NLX-SP-TN -- Interface. -;;; -;;; Make an environment-live stack TN for saving the SP for NLX entry. -;;; -(def-vm-support-routine make-nlx-sp-tn (env) - (environment-live-tn - (make-representation-tn *word-pointer-type* - (sc-number-or-lose 'word-pointer-reg *backend*)) - env)) - - - -;;; Save and restore dynamic environment. -;;; -;;; These VOPs are used in the reentered function to restore the appropriate -;;; dynamic environment. Currently we only save the Current-Catch and binding -;;; stack pointer. We don't need to save/restore the current unwind-protect, -;;; since unwind-protects are implicitly processed during unwinding. If there -;;; were any additional stacks, then this would be the place to restore the top -;;; pointers. - - -;;; MAKE-DYNAMIC-STATE-TNS -- Interface. -;;; -;;; Return a list of TNs that can be used to snapshot the dynamic state for use -;;; with the Save/Restore-Dynamic-Environment VOPs. -;;; -(def-vm-support-routine make-dynamic-state-tns () - (make-n-tns 4 *fixnum-primitive-type*)) - -(define-vop (save-dynamic-state) - (:results (catch :scs (any-reg)) - (nfp :scs (any-reg)) - (nsp :scs (any-reg)) - (eval :scs (any-reg))) - (:vop-var vop) - (:generator 13 - (load-symbol-value catch lisp::*current-catch-block*) - (let ((cur-nfp (current-nfp-tn vop))) - (if cur-nfp - (move nfp cur-nfp) - (inst li nfp 0))) - (move nsp nsp-tn) - (load-symbol-value eval lisp::*eval-stack-top*))) - -(define-vop (restore-dynamic-state) - (:args (catch :scs (any-reg)) - (nfp :scs (any-reg)) - (nsp :scs (any-reg)) - (eval :scs (any-reg))) - (:temporary (:scs (descriptor-reg) :from (:eval 0)) symbol value) - (:temporary (:scs (word-pointer-reg) :from (:eval 0)) bsp) - (:vop-var vop) - (:generator 10 - (store-symbol-value catch lisp::*current-catch-block*) - (store-symbol-value eval lisp::*eval-stack-top*) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move cur-nfp nfp))) - (move nsp-tn nsp))) - -(define-vop (current-stack-pointer) - (:results (res :scs (any-reg word-pointer-reg descriptor-reg))) - (:generator 1 - (move res csp-tn))) - -(define-vop (current-binding-pointer) - (:results (res :scs (any-reg word-pointer-reg descriptor-reg))) - (:generator 1 - (load-symbol-value res *binding-stack-pointer*))) - - - -;;;; Unwind block hackery: - -;;; MAKE-UNWIND-BLOCK -- VOP. -;;; -;;; Compute the address of the catch block from its TN, then store into the -;;; block the current Fp, Env, Unwind-Protect, and the entry PC. -;;; -(define-vop (make-unwind-block) - (:args (tn)) - (:info entry-label) - (:results (block :scs (word-pointer-reg))) - (:temporary (:scs (word-pointer-reg) :target block) block-ptr) - (:temporary (:scs (descriptor-reg)) temp) - (:generator 22 - (inst cal block-ptr cfp-tn (* (tn-offset tn) vm:word-bytes)) - (load-symbol-value temp lisp::*current-unwind-protect-block*) - (storew temp block-ptr vm:unwind-block-current-uwp-slot) - (storew cfp-tn block-ptr vm:unwind-block-current-cont-slot) - (storew code-tn block-ptr vm:unwind-block-current-code-slot) - (inst compute-lra-from-code temp code-tn entry-label) - (storew temp block-ptr vm:catch-block-entry-pc-slot) - (move block block-ptr))) - - -;;; MAKE-CATCH-BLOCK -- VOP. -;;; -;;; Like MAKE-UNWIND-BLOCK, except that we also store in the specified tag, and -;;; link the block into the Current-Catch list. -;;; -(define-vop (make-catch-block) - (:args (tn) - (tag :scs (descriptor-reg))) - (:info entry-label) - (:results (block :scs (word-pointer-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (word-pointer-reg) :target block :to (:result 0)) result) - (:generator 44 - (inst cal result cfp-tn (* (tn-offset tn) vm:word-bytes)) - (load-symbol-value temp lisp::*current-unwind-protect-block*) - (storew temp result vm:catch-block-current-uwp-slot) - (storew cfp-tn result vm:catch-block-current-cont-slot) - (storew code-tn result vm:catch-block-current-code-slot) - (inst compute-lra-from-code temp code-tn entry-label) - (storew temp result vm:catch-block-entry-pc-slot) - - (storew tag result vm:catch-block-tag-slot) - (load-symbol-value temp lisp::*current-catch-block*) - (storew temp result vm:catch-block-previous-catch-slot) - (store-symbol-value result lisp::*current-catch-block*) - - (move block result))) - - -;;; SET-UNWIND-PROTECT -- VOP. -;;; -;;; Just set the current unwind-protect to TN's address. This instantiates an -;;; unwind block as an unwind-protect. -;;; -(define-vop (set-unwind-protect) - (:args (tn)) - (:temporary (:scs (descriptor-reg)) new-uwp) - (:generator 7 - (inst cal new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes)) - (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) - -;;; UNLINK-CATCH-BLOCK -- VOP. -;;; -;;; Remove the catch block from the chain of catches. This happens when -;;; we drop out of a catch instead of throwing. -;;; -(define-vop (unlink-catch-block) - (:temporary (:scs (word-pointer-reg)) block) - (:policy :fast-safe) - (:translate %catch-breakup) - (:generator 17 - (load-symbol-value block lisp::*current-catch-block*) - (loadw block block vm:catch-block-previous-catch-slot) - (store-symbol-value block lisp::*current-catch-block*))) - -;;; UNLINK-UNWIND-PROTECT -- VOP. -;;; -;;; Same thing with unwind protects. -;;; -(define-vop (unlink-unwind-protect) - (:temporary (:scs (word-pointer-reg)) block) - (:policy :fast-safe) - (:translate %unwind-protect-breakup) - (:generator 17 - (load-symbol-value block lisp::*current-unwind-protect-block*) - (loadw block block vm:unwind-block-current-uwp-slot) - (store-symbol-value block lisp::*current-unwind-protect-block*))) - - -;;;; NLX entry VOPs: - - -;;; NLX-ENTRY -- VOP. -;;; -;;; We were just thrown to, so load up the results. -;;; -(define-vop (nlx-entry) - (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops - ; would be inserted before the LRA. - (start) - (count)) - (:results (values :more t)) - (:temporary (:scs (descriptor-reg)) move-temp) - (:info label nvals) - (:save-p :force-to-stack) - (:generator 30 - (emit-return-pc label) - (cond ((zerop nvals)) - ((= nvals 1) - (let ((no-values (gen-label))) - (inst c count 0) - (inst bcx :eq no-values) - (move (tn-ref-tn values) null-tn) - (loadw (tn-ref-tn values) start) - (emit-label no-values))) - (t - (collect ((defaults)) - (inst c count 0) - (do ((i 0 (1+ i)) - (tn-ref values (tn-ref-across tn-ref))) - ((null tn-ref)) - (let ((default-lab (gen-label)) - (tn (tn-ref-tn tn-ref))) - (defaults (cons default-lab tn)) - - (inst bc :eq default-lab) - (inst s count (fixnum 1)) - (sc-case tn - ((descriptor-reg any-reg) - (loadw tn start i)) - (control-stack - (loadw move-temp start i) - (store-stack-tn move-temp tn))))) - - (let ((defaulting-done (gen-label))) - (emit-label defaulting-done) - (assemble (*elsewhere*) - (dolist (def (defaults)) - (emit-label (car def)) - (let ((tn (cdr def))) - (sc-case tn - ((descriptor-reg any-reg) - (move tn null-tn)) - (control-stack - (store-stack-tn null-tn tn))))) - (inst b defaulting-done)))))) - (load-stack-tn csp-tn sp))) - - -(define-vop (nlx-entry-multiple) - ;; Again, no SC restrictions for the args, 'cause the loading would - ;; happen before the entry label. But we know that start and count will - ;; be in registers due to the way this vop is used. - (:args (top :target dst) - (start :target src) - (count :target num)) - (:info label) - (:temporary (:scs (any-reg) :from (:argument 0)) dst) - (:temporary (:scs (any-reg) :from (:argument 1)) src) - (:temporary (:scs (any-reg) :from (:argument 2)) num) - (:temporary (:scs (descriptor-reg)) temp) - (:results (new-start) (new-count)) - (:save-p :force-to-stack) - (:generator 30 - (emit-return-pc label) - (let ((loop (gen-label)) - (done (gen-label))) - - ;; Copy args. - (load-stack-tn dst top) - (move src start) - (inst a num count 0) - - ;; Establish results. - (sc-case new-start - ((any-reg word-pointer-reg) (move new-start dst)) - (control-stack (store-stack-tn dst new-start))) - (inst bcx :eq done) - (sc-case new-count - (any-reg (inst move new-count num)) - (control-stack (store-stack-tn num new-count))) - - ;; Copy stuff on stack. - (emit-label loop) - (loadw temp src) - (inst inc src vm:word-bytes) - (storew temp dst) - (inst s num num (fixnum 1)) - (inst bncx :eq loop) - (inst inc dst vm:word-bytes) - - (emit-label done) - (move csp-tn dst)))) - - -;;; This VOP is just to force the TNs used in the cleanup onto the stack. -;;; -(define-vop (uwp-entry) - (:info label) - (:save-p :force-to-stack) - (:results (block) (start) (count)) - (:ignore block start count) - (:generator 0 - (emit-return-pc label))) diff --git a/compiler/rt/params.lisp b/compiler/rt/params.lisp deleted file mode 100644 index 913461e9092d849088c1390049826f04495e20bf..0000000000000000000000000000000000000000 --- a/compiler/rt/params.lisp +++ /dev/null @@ -1,220 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/params.lisp,v 1.13 1992/06/09 23:46:32 wlott Exp $ -;;; -;;; This file contains some parameterizations of various VM attributes for the -;;; IBM RT. This file is separate from other stuff, so we can compile and -;;; load it earlier. -;;; -;;; Written by Rob MacLachlan -;;; Converted to MIPS by William Lott. -;;; Converted to IBM RT by William Lott and Bill Chiles. -;;; - -(in-package "RT") -(use-package "C") - -(export '(word-bits byte-bits word-shift word-bytes float-sign-shift - - single-float-bias single-float-exponent-byte - single-float-significand-byte single-float-normal-exponent-min - single-float-normal-exponent-max single-float-hidden-bit - single-float-trapping-nan-bit single-float-digits - - double-float-bias double-float-exponent-byte - double-float-significand-byte double-float-normal-exponent-min - double-float-normal-exponent-max double-float-hidden-bit - double-float-trapping-nan-bit double-float-digits - - float-underflow-trap-bit float-overflow-trap-bit - float-imprecise-trap-bit float-invalid-trap-bit - float-divide-by-zero-trap-bit - -)) - - - -;;;; Compiler constants. - -(eval-when (compile eval load) - -#-afpa (progn -(setf *target-float-hardware* :mc68881) -(setf (backend-name *target-backend*) "RT") -(setf (backend-version *target-backend*) "IBM RT/Mach 1.0") -(setf (backend-fasl-file-type *target-backend*) "rtf") -(setf (backend-fasl-file-implementation *target-backend*) - rt-fasl-file-implementation) -(setf *features* (delete :afpa *features*))) - -#+afpa (progn -(setf *target-float-hardware* :afpa) -(setf (backend-name *target-backend*) "RT") -(setf (backend-version *target-backend*) "IBM RT EAPC/Mach 1.0") -(setf (backend-fasl-file-type *target-backend*) "eapcf") -(setf (backend-fasl-file-implementation *target-backend*) - rt-afpa-fasl-file-implementation) -(pushnew :afpa *features*)) - -(setf (backend-fasl-file-version *target-backend*) 1) -(setf (backend-register-save-penalty *target-backend*) 3) -(setf (backend-byte-order *target-backend*) :big-endian) -(setf (backend-page-size *target-backend*) 4096) - -) ;eval-when - - - -;;;; Machine Architecture parameters: - -(eval-when (compile load eval) - -(defconstant word-bits 32 - "Number of bits per word where a word holds one lisp descriptor.") - -(defconstant byte-bits 8 - "Number of bits per byte where a byte is the smallest addressable object.") - -(defconstant word-shift (1- (integer-length (/ word-bits byte-bits))) - "Number of bits to shift between word addresses and byte addresses.") - -(defconstant word-bytes (/ word-bits byte-bits) - "Number of bytes in a word.") - -(defparameter target-most-positive-fixnum (1- (ash 1 29)) - "most-positive-fixnum in the target architecture.") - -(defparameter target-most-negative-fixnum (ash -1 29) - "most-negative-fixnum in the target architecture.") - -(defconstant float-sign-shift 31) - -;;; The exponent min/max values are wrong, I think. The denorm, infinity, etc. -;;; info must go in there somewhere. - -(defconstant single-float-bias 126) -(defconstant single-float-exponent-byte (byte 8 23)) -(defconstant single-float-significand-byte (byte 23 0)) -(defconstant single-float-normal-exponent-min 1) -(defconstant single-float-normal-exponent-max 254) -(defconstant single-float-hidden-bit (ash 1 23)) -(defconstant single-float-trapping-nan-bit (ash 1 22)) - -(defconstant double-float-bias 1022) -(defconstant double-float-exponent-byte (byte 11 20)) -(defconstant double-float-significand-byte (byte 20 0)) -(defconstant double-float-normal-exponent-min 1) -(defconstant double-float-normal-exponent-max #x7FE) -(defconstant double-float-hidden-bit (ash 1 20)) -(defconstant double-float-trapping-nan-bit (ash 1 19)) - -(defconstant single-float-digits - (+ (byte-size single-float-significand-byte) 1)) - -(defconstant double-float-digits - (+ (byte-size double-float-significand-byte) word-bits 1)) - -); eval-when - - - - -;;;; Description of the target address space. - -(export '(target-read-only-space-start - target-static-space-start - target-dynamic-space-start)) - -;;; Where to put the different spaces. -;;; -(defparameter target-read-only-space-start #x00100000) -(defparameter target-static-space-start #x05000000) -(defparameter target-dynamic-space-start #x07000000) - - - -;;;; Other non-type constants. - -(export '(halt-trap pending-interrupt-trap error-trap cerror-trap - breakpoint-trap function-end-breakpoint-trap)) - -(defenum (:suffix -trap :start 8) - halt - pending-interrupt - error - cerror - breakpoint - function-end-breakpoint) - - - -;;;; Static symbols. - -(export '(static-symbols exported-static-symbols)) - - -;;; These symbols are loaded into static space directly after NIL so -;;; that the system can compute their address by adding a constant -;;; amount to NIL. -;;; -;;; The exported static symbols are a subset of the static symbols that get -;;; exported to the C header file. NOTE: EXPORTED-STATIC-SYMBOLS IS DEFINED -;;; AS A FUNCTION OF THE ORDERING OF THIS LIST. -;;; -(defparameter static-symbols - '(t - - ;; Random stuff needed for initialization. - lisp::lisp-environment-list - lisp::lisp-command-line-list - - ;; Functions that C needs to call. - lisp::%initial-function - lisp::maybe-gc - kernel::internal-error - di::handle-breakpoint - - ;; Free Pointers and the like - lisp::*read-only-space-free-pointer* - lisp::*static-space-free-pointer* - lisp::*initial-dynamic-space-free-pointer* - *allocation-pointer* - *internal-gc-trigger* - *binding-stack-pointer* - - ;; Things needed for non-local-exit. - lisp::*current-catch-block* - lisp::*current-unwind-protect-block* - *eval-stack-top* - - ;; Interrupt Handling - lisp::*pseudo-atomic-atomic* - lisp::*pseudo-atomic-interrupted* - unix::*interrupts-enabled* - unix::*interrupt-pending* - lisp::*free-interrupt-context-index* - - ;; Static functions. - two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= - %negate two-arg-and two-arg-ior two-arg-xor - length two-arg-gcd two-arg-lcm truncate - )) - -(defparameter exported-static-symbols - (subseq static-symbols 0 (1+ (position 'lisp::*free-interrupt-context-index* - static-symbols)))) - - - -;;;; Assembler parameters: - -;;; The number of bits per element in the assemblers code vector. -;;; -(defparameter *assembly-unit-length* 8) diff --git a/compiler/rt/pred.lisp b/compiler/rt/pred.lisp deleted file mode 100644 index 9c8973595c705225f04d1c2d2b648f0c216aef1e..0000000000000000000000000000000000000000 --- a/compiler/rt/pred.lisp +++ /dev/null @@ -1,53 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/pred.lisp,v 1.1 1991/02/18 15:08:07 chiles Exp $ -;;; -;;; This file contains the VM definition of predicate VOPs for the IBM RT. -;;; -;;; Written by Rob MacLachlan -;;; Modified by William Lott and Bill Chiles for the IBM RT. -;;; - -(in-package "RT") - - - -;;;; The Branch VOP. - -;;; The unconditional branch, emitted when we can't drop through to the desired -;;; destination. Dest is the label where we want to be. -;;; -(define-vop (branch) - (:info dest) - (:generator 5 - (inst b dest))) - - - -;;;; Conditional VOPs: - -(define-vop (if-eq) - (:args (x :scs (any-reg descriptor-reg null)) - (y :scs (any-reg descriptor-reg null))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:translate eq) - (:generator 3 - (let ((x-prime (sc-case x - ((any-reg descriptor-reg) x) - (null null-tn))) - (y-prime (sc-case y - ((any-reg descriptor-reg) y) - (null null-tn)))) - (inst c x-prime y-prime) - (if not-p - (inst bnc :eq target) - (inst bc :eq target))))) diff --git a/compiler/rt/print.lisp b/compiler/rt/print.lisp deleted file mode 100644 index eb3625aee3c63c55047e52591c369558fcde5073..0000000000000000000000000000000000000000 --- a/compiler/rt/print.lisp +++ /dev/null @@ -1,47 +0,0 @@ -;;; -*- 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/print.lisp,v 1.2 1991/10/02 23:05:52 ram Exp $ -;;; -;;; This file contains temporary printing utilities and similar noise. -;;; -;;; Written by William Lott. -;;; - -(in-package "RT") - - -(define-vop (print) - (:args (object :scs (descriptor-reg))) - (:results (result :scs (descriptor-reg))) - (:save-p t) - (:temporary (:sc any-reg :offset nl0-offset) nl0) - (:temporary (:sc any-reg :offset lra-offset) lra) - (:temporary (:scs (sap-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:vop-var vop) - (:generator 0 - (let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn cur-nfp nfp-save)) - (inst cal nsp-tn nsp-tn -16) - (storew object nsp-tn) - (inst compute-lra-from-code lra code-tn lra-label) - (inst cai nl0 (make-fixup "_debug_print" :foreign)) - (inst cai temp (make-fixup "call_into_c" :foreign)) - (inst b temp) - - (align vm:lowtag-bits) - (emit-label lra-label) - (inst lra-header-word) - (inst cal nsp-tn nsp-tn 16) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - (move result nl0)))) diff --git a/compiler/rt/sap.lisp b/compiler/rt/sap.lisp deleted file mode 100644 index 787feaa426f7478e382021ca2ed2e9349020edfc..0000000000000000000000000000000000000000 --- a/compiler/rt/sap.lisp +++ /dev/null @@ -1,413 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/sap.lisp,v 1.15 1992/03/11 20:47:38 wlott Exp $ -;;; -;;; This file contains the IBM RT VM definition of SAP operations. -;;; -;;; Written by William Lott. -;;; - -(in-package "RT") - - - -;;;; Moves and coercions: - -;;; MOVE-TO-SAP -- VOP. -;;; -;;; Move a tagged SAP to an untagged representation. -;;; -(define-vop (move-to-sap) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (sap-reg))) - (:generator 1 - (loadw y x vm:sap-pointer-slot vm:other-pointer-type))) -;;; -(define-move-vop move-to-sap :move - (descriptor-reg) (sap-reg)) - - -;;; MOVE-FROM-SAP -- VOP. -;;; -;;; Move an untagged SAP to a tagged representation. -;;; -(define-vop (move-from-sap) - (:args (sap :scs (sap-reg) :to :save)) - (:temporary (:sc any-reg) header) - (:temporary (:sc word-pointer-reg) alloc) - (:results (y :scs (descriptor-reg))) - (:generator 1 - (with-fixed-allocation (y header alloc sap-type sap-size) - (storew sap y sap-pointer-slot other-pointer-type)))) -;;; -(define-move-vop move-from-sap :move - (sap-reg) (descriptor-reg)) - - -;;; SAP-MOVE -- VOP. -;;; -;;; Move untagged sap values. -;;; -(define-vop (sap-move) - (:args (x :target y - :scs (sap-reg) - :load-if (not (location= x y)))) - (:results (y :scs (sap-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move y x))) -;;; -(define-move-vop sap-move :move - (sap-reg) (sap-reg)) - - -;;; MOVE-SAP-ARGUMENT -- VOP. -;;; -;;; Move untagged sap arguments/return-values. -;;; -(define-vop (move-sap-argument) - (:args (x :target y - :scs (sap-reg)) - (fp :scs (word-pointer-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - (sap-reg - (move y x)) - (sap-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-sap-argument :move-argument - (descriptor-reg sap-reg) (sap-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a -;;; descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (sap-reg) (descriptor-reg)) - - - -;;;; SAP-INT and INT-SAP - -(define-vop (sap-int) - (:args (sap :scs (sap-reg) :target int)) - (:arg-types system-area-pointer) - (:results (int :scs (unsigned-reg))) - (:result-types unsigned-num) - (:translate sap-int) - (:policy :fast-safe) - (:generator 1 - (move int sap))) - -(define-vop (int-sap) - (:args (int :scs (unsigned-reg) :target sap)) - (:arg-types unsigned-num) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate int-sap) - (:policy :fast-safe) - (:generator 1 - (move sap int))) - - - -;;;; POINTER+ and POINTER- - -(define-vop (pointer+) - (:translate sap+) - (:args (ptr :scs (sap-reg) :target res) - (offset :scs (signed-reg) :to :save)) - (:arg-types system-area-pointer signed-num) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:policy :fast-safe) - (:generator 2 - ;; Can't use CAS since offset and ptr may be register 0, so we have to move. - (move res ptr) - (inst a res offset))) -;;; -(define-vop (pointer+-c pointer+) - (:args (ptr :scs (sap-reg))) - (:info offset) - (:arg-types system-area-pointer (:constant (signed-byte 16))) - (:generator 1 - (inst a res ptr offset))) - -(define-vop (pointer-) - (:translate sap-) - (:args (ptr1 :scs (sap-reg) :target res) - (ptr2 :scs (sap-reg) :to :save)) - (:arg-types system-area-pointer system-area-pointer) - (:policy :fast-safe) - (:results (res :scs (signed-reg))) - (:result-types signed-num) - (:generator 1 - (move res ptr1) - (inst s res ptr2))) - - - -;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET - -(eval-when (compile eval) - -;;; DEFINE-SYSTEM-REF -- Internal Interface. -;;; -;;; Name is the name of a computed system-ref offset, from which we generate a -;;; <name>-c VOP for immediate constant offsets. Shift is the multiples of two -;;; for which we must adjust the offset to make it an index in terms of bytes -;;; (the machines address units). Translate and signed-translate are the Lisp -;;; function calls for which these VOP's are in-line expansions. -;;; -(defmacro define-system-ref (name size translate result-sc result-type - &optional - signed-translate signed-result-sc - signed-result-type) - (let ((access-form - (ecase size - (:byte - '((inst lc result base offset) - (when signed - (inst sl result 24) - (inst sar result 24)))) - (:halfword - '((if signed - (inst lha result base offset) - (inst lh result base offset)))) - (:word - '(signed ; suppress silly warnings. - (inst l result base offset))))) - (name-c (symbolicate name "-C"))) - `(progn - (define-vop (,name-c) - (:policy :fast-safe) - (:translate ,translate) - (:args (base :scs (sap-reg))) - (:results (result :scs (,result-sc))) - (:result-types ,result-type) - (:arg-types system-area-pointer (:constant (unsigned-byte 15))) - (:info offset) - (:variant-vars signed) - (:variant nil) - (:generator 5 - ,@access-form)) - - (define-vop (,name) - (:policy :fast-safe) - (:translate ,translate) - (:args (object :scs (sap-reg)) - (offset :scs (unsigned-reg) :target base)) - (:results (result :scs (,result-sc))) - (:arg-types system-area-pointer positive-fixnum) - (:result-types ,result-type) - (:temporary (:scs (sap-reg) :from (:argument 1) :to :eval) base) - (:variant-vars signed) - (:variant nil) - (:generator 7 - (inst cas base offset object) - (let ((offset 0)) - ,@access-form))) - - ,@(when signed-translate - `((define-vop (,(symbolicate "SIGNED-" name-c) ,name-c) - (:translate ,signed-translate) - (:results (result :scs (,signed-result-sc))) - (:result-types ,signed-result-type) - (:variant t)) - - (define-vop (,(symbolicate "SIGNED-" name) ,name) - (:translate ,signed-translate) - (:results (result :scs (,signed-result-sc))) - (:result-types ,signed-result-type) - (:variant t))))))) - -) ;eval-when - -(define-system-ref 8bit-system-ref :byte - sap-ref-8 unsigned-reg positive-fixnum - signed-sap-ref-8 signed-reg tagged-num) - -(define-system-ref 16bit-system-ref :halfword - sap-ref-16 unsigned-reg positive-fixnum - signed-sap-ref-16 signed-reg tagged-num) - -(define-system-ref 32bit-system-ref :word - sap-ref-32 unsigned-reg unsigned-num - signed-sap-ref-32 signed-reg signed-num) - -(define-system-ref sap-system-ref :word - sap-ref-sap sap-reg system-area-pointer) - - -(eval-when (compile eval) - -;;; DEFINE-SYSTEM-SET -- Internal. -;;; -;;; Name is the name of a computed system-ref offset, from which we generate a -;;; <name>-c VOP for immediate constant offsets. Shift is the multiples of two -;;; for which we must adjust the offset to make it an index in terms of bytes -;;; (the machines address units). Translate and signed-translate are the Lisp -;;; function calls for which these VOP's are in-line expansions. -;;; -(defmacro define-system-set (name size translate data-sc data-type) - (let ((set-form - (ecase size - (:byte '(inst stc data base offset)) - (:halfword '(inst sth data base offset)) - (:word '(inst st data base offset)))) - (name-c (symbolicate name "-C"))) - `(progn - (define-vop (,name-c) - (:policy :fast-safe) - (:translate ,translate) - (:args (base :scs (sap-reg)) - (data :scs (,data-sc) :target result :to (:result 0))) - (:arg-types system-area-pointer - (:constant (unsigned-byte 15)) - ,data-type) - (:results (result :scs (,data-sc))) - (:result-types ,data-type) - (:info offset) - (:generator 5 - ,set-form - (move result data))) - - (define-vop (,name) - (:policy :fast-safe) - (:translate ,translate) - (:args (object :scs (sap-reg)) - (offset :scs (unsigned-reg)) - (data :scs (,data-sc) :target result)) - (:arg-types system-area-pointer positive-fixnum ,data-type) - (:temporary (:scs (sap-reg) :from (:argument 1)) base) - (:results (result :scs (,data-sc))) - (:result-types ,data-type) - (:generator 7 - (inst cas base offset object) - (let ((offset 0)) - ,set-form) - (move result data)))))) - -) ;EVAL-WHEN - -(define-system-set 8bit-system-set :byte %set-sap-ref-8 - unsigned-reg positive-fixnum) - -(define-system-set 16bit-system-set :halfword %set-sap-ref-16 - unsigned-reg positive-fixnum) - -(define-system-set 32bit-system-set :word %set-sap-ref-32 - unsigned-reg unsigned-num) - -(define-system-set signed-8bit-system-set :byte %set-signed-sap-ref-8 - signed-reg tagged-num) - -(define-system-set signed-16bit-system-set :halfword %set-signed-sap-ref-16 - signed-reg tagged-num) - -(define-system-set signed-32bit-system-set :word %set-signed-sap-ref-32 - signed-reg signed-num) - - -(define-system-set sap-system-set :word %set-sap-ref-sap - sap-reg system-area-pointer) - -#| - -Maybe we can get away with using define-system-set now that offsets don't -need to be shifted. - -;;; Ugly, because there are only 2 free sap-regs. We stash the data value in -;;; NARGS to free up a sap-reg for BASE. -;;; -(define-vop (sap-system-set) - (:policy :fast-safe) - (:translate %set-sap-ref-sap) - (:args (object :scs (sap-reg)) - (offset :scs (unsigned-reg) :target base) - (data :scs (sap-reg sap-stack))) - (:arg-types system-area-pointer positive-fixnum system-area-pointer) - (:temporary (:scs (sap-reg) :from (:eval 0) :to (:eval 1)) base) - (:temporary (:scs (non-descriptor-reg) :offset nargs-offset - :from (:eval 0) :to (:eval 1)) - save) - (:vop-var vop) - (:results (result :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 7 - (sc-case data - (sap-reg (move save data)) - (sap-stack - (loadw save (current-nfp-tn vop) (* (tn-offset data) vm:word-bytes)))) - - (inst cas base offset object) - (inst st save base) - (move result save))) - -(define-vop (sap-system-set-c) - (:policy :fast-safe) - (:translate %set-sap-ref-sap) - (:args (object :scs (sap-reg)) - (data :scs (sap-reg) :target result)) - (:info offset) - (:arg-types system-area-pointer - (:constant (unsigned-byte 16)) - system-area-pointer) - (:results (result :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 4 - (inst st data object offset) - (move result data))) - -|# - -;;; fake the presence of sap-ref-single and sap-ref-double. - -(def-source-transform sap-ref-single (sap offset) - `(make-single-float (signed-sap-ref-32 ,sap ,offset))) - -(def-source-transform %set-sap-ref-single (sap offset value) - (once-only ((sap sap) (offset offset) (value value)) - `(progn - (setf (signed-sap-ref-32 ,sap ,offset) - (single-float-bits ,value)) - ,value))) - -(def-source-transform sap-ref-double (sap offset) - (once-only ((sap sap) (offset offset)) - `(make-double-float (signed-sap-ref-32 ,sap ,offset) - (sap-ref-32 ,sap (+ ,offset word-bytes))))) - -(def-source-transform %set-sap-ref-double (sap offset value) - (once-only ((sap sap) (offset offset) (value value)) - `(progn - (setf (signed-sap-ref-32 ,sap ,offset) - (double-float-high-bits ,value)) - (setf (sap-ref-32 ,sap (+ ,offset word-bytes)) - (double-float-low-bits ,value)) - ,value))) - - -;;;; Noise to convert normal lisp data objects into SAPs. - -(define-vop (vector-sap) - (:translate vector-sap) - (:policy :fast-safe) - (:args (vector :scs (descriptor-reg))) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst cal sap vector - (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type)))) diff --git a/compiler/rt/static-fn.lisp b/compiler/rt/static-fn.lisp deleted file mode 100644 index 60045803a1baf0922acf226cc0df2f3ae962978b..0000000000000000000000000000000000000000 --- a/compiler/rt/static-fn.lisp +++ /dev/null @@ -1,146 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/static-fn.lisp,v 1.1 1991/02/18 15:08:13 chiles Exp $ -;;; -;;; This file contains the VOPs and macro magic necessary to call static -;;; functions. -;;; -;;; Written by William Lott. -;;; Converted by Bill Chiles. -;;; - -(in-package "RT") - - - -(define-vop (static-function-template) - (:save-p t) - (:policy :safe) - (:variant-vars symbol) - (:vop-var vop) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg)) move-temp) - (:temporary (:sc descriptor-reg :offset lra-offset) lra) - (:temporary (:sc descriptor-reg :offset cname-offset) cname) - (:temporary (:scs (interior-reg) :type interior) lip) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) old-fp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) - - -(eval-when (compile load eval) - -(defun static-function-template-name (num-args num-results) - (intern (format nil "~:@(~R-arg-~R-result-static-function~)" - num-args num-results))) - -(defun moves (dst src) - (collect ((moves)) - (do ((dst dst (cdr dst)) - (src src (cdr src))) - ((or (null dst) (null src))) - (moves `(move ,(car dst) ,(car src)))) - (moves))) - -(defun static-function-template-vop (num-args num-results) - (assert (and (<= num-args register-arg-count) - (<= num-results register-arg-count)) - (num-args num-results) - "Either too many args (~D) or too many results (~D). Max = ~D" - num-args num-results register-arg-count) - (let ((num-temps (max num-args num-results))) - (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) - (dotimes (i num-results) - (let ((result-name (intern (format nil "RESULT-~D" i)))) - (result-names result-name) - (results `(,result-name :scs (any-reg descriptor-reg))))) - (dotimes (i num-temps) - (let ((temp-name (intern (format nil "TEMP-~D" i)))) - (temp-names temp-name) - (temps `(:temporary (:sc descriptor-reg - :offset ,(nth i register-arg-offsets) - ,@(when (< i num-args) - `(:from (:argument ,i))) - ,@(when (< i num-results) - `(:to (:result ,i) - :target ,(nth i (result-names))))) - ,temp-name)))) - (dotimes (i num-args) - (let ((arg-name (intern (format nil "ARG-~D" i)))) - (arg-names arg-name) - (args `(,arg-name - :scs (any-reg descriptor-reg) - :target ,(nth i (temp-names)))))) - `(define-vop (,(static-function-template-name num-args num-results) - static-function-template) - (:args ,@(args)) - ,@(temps) - (:results ,@(results)) - (:generator ,(+ 50 num-args num-results) - (let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - ,@(moves (temp-names) (arg-names)) - (inst li nargs (fixnum ,num-args)) - (load-symbol cname symbol) - (loadw lip cname vm:symbol-raw-function-addr-slot - vm:other-pointer-type) - (when cur-nfp - (store-stack-tn cur-nfp nfp-save)) - (move old-fp cfp-tn) - (inst compute-lra-from-code lra code-tn lra-label) - (inst bx lip) - (inst move cfp-tn csp-tn) - (emit-return-pc lra-label) - (note-this-location vop :unknown-return) - ,(collect ((bindings) (links)) - (do ((temp (temp-names) (cdr temp)) - (name 'values (gensym)) - (prev nil name) - (i 0 (1+ i))) - ((= i num-results)) - (bindings `(,name - (make-tn-ref ,(car temp) nil))) - (when prev - (links `(setf (tn-ref-across ,prev) ,name)))) - `(let ,(bindings) - ,@(links) - (default-unknown-values - ,(if (zerop num-results) nil 'values) - ,num-results move-temp lra-label))) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - ,@(moves (result-names) (temp-names)))))))) - -) ;EVAL-WHEN (compile load eval) - - -(macrolet ((frob (nargs nres) - (static-function-template-vop nargs nres))) - (frob 0 1) - (frob 1 1) - (frob 2 1)) - -(defmacro define-static-function (name args &key (results '(x)) translate - policy cost arg-types result-types) - `(define-vop (,name - ,(static-function-template-name (length args) - (length results))) - (:variant ',name) - (:note ,(format nil "static-function ~@(~S~)" name)) - ,@(when translate - `((:translate ,translate))) - ,@(when policy - `((:policy ,policy))) - ,@(when cost - `((:generator-cost ,cost))) - ,@(when arg-types - `((:arg-types ,@arg-types))) - ,@(when result-types - `((:result-types ,@result-types))))) diff --git a/compiler/rt/subprim.lisp b/compiler/rt/subprim.lisp deleted file mode 100644 index 2c9eb7942bd8c0e02813747d899d33ce695775b0..0000000000000000000000000000000000000000 --- a/compiler/rt/subprim.lisp +++ /dev/null @@ -1,63 +0,0 @@ -;;; -*- Package: MIPS; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/subprim.lisp,v 1.1 1991/02/18 15:08:16 chiles Exp $ -;;; -;;; Linkage information for standard static functions, and random vops. -;;; -;;; Written by William Lott. -;;; Converted for IBM RT by Bill Chiles. -;;; - -(in-package "RT") - - - -;;;; Length - -(define-vop (length/list) - (:translate length) - (:args (object :scs (descriptor-reg) :target ptr)) - (:arg-types list) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) - (:temporary (:scs (non-descriptor-reg) :type random) temp) - (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result) - count) - (:results (result :scs (any-reg descriptor-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:generator 50 - (let ((done (gen-label)) - (loop (gen-label)) - (not-list (generate-cerror-code vop object-not-list-error object))) - (move ptr object) - (inst li count 0) - - (emit-label loop) - - (inst c ptr null-tn) - (inst bc :eq done) - - (test-type ptr temp not-list t vm:list-pointer-type) - - (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) - (inst inc count (fixnum 1)) - (test-type ptr temp loop nil vm:list-pointer-type) - - (cerror-call vop done object-not-list-error ptr) - - (emit-label done) - (move result count)))) - - -(define-static-function length (object) :translate length) - - - diff --git a/compiler/rt/system.lisp b/compiler/rt/system.lisp deleted file mode 100644 index 90f66c3a85e9607bb5e4198d90a2267348f6c747..0000000000000000000000000000000000000000 --- a/compiler/rt/system.lisp +++ /dev/null @@ -1,244 +0,0 @@ -;;; -*- Package: rt; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/system.lisp,v 1.7 1992/03/10 10:01:15 wlott Exp $ -;;; -;;; IBM RT VM definitions of various system hacking operations. -;;; -;;; Written by Rob MacLachlan -;;; -;;; IBM RT conversion by Bill Chiles. -;;; - -(in-package "RT") - - - -;;;; Type frobbing VOPs. - -(define-vop (get-lowtag) - (:translate get-lowtag) - (:policy :fast-safe) - (:args (object :scs (any-reg descriptor-reg))) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 1 - (inst nilz result object lowtag-mask))) - -(define-vop (get-type) - (:translate get-type) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (let ((other-ptr (gen-label)) - (function-ptr (gen-label)) - (lowtag-only (gen-label)) - (done (gen-label))) - (test-type object ndescr other-ptr nil other-pointer-type) - (test-type object ndescr function-ptr nil function-pointer-type) - (test-type object ndescr lowtag-only nil - even-fixnum-type odd-fixnum-type list-pointer-type - structure-pointer-type) - (inst bx done) - (inst nilz result object type-mask) - - (emit-label function-ptr) - (load-type result object function-pointer-type) - (inst b done) - - (emit-label lowtag-only) - (inst bx done) - (inst nilz result object lowtag-mask) - - (emit-label other-ptr) - (load-type result object other-pointer-type) - - (emit-label done)))) - -(define-vop (get-header-data) - (:translate get-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 7 - (loadw res x 0 other-pointer-type) - (inst sr res type-bits))) - -(define-vop (get-closure-length) - (:translate get-closure-length) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 7 - (loadw res x 0 function-pointer-type) - (inst sr res type-bits))) - -;;; SET-HEADER-DATA -- VOP. -;;; -;;; In the immediate case for data, we use the OIL instruction assuming the -;;; data fits in the number of bits determined by 16 minus type-bits. Due to -;;; known uses of this VOP, which only store single digit tags, the above -;;; assumption is reasonable, although unnecessarily slimy. -;;; -(define-vop (set-header-data) - (:translate set-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg) :target res) - (data :scs (any-reg immediate) :target t2)) - (:arg-types * positive-fixnum) - (:results (res :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :type random) t1) - (:temporary (:scs (non-descriptor-reg) :type random :from (:argument 1)) t2) - (:generator 15 - (loadw t1 x 0 other-pointer-type) - (inst nilz t1 type-mask) - (sc-case data - (any-reg - (move t2 data) - ;; Since the data is in fixnum format, it is already shifted by 2 bits. - (inst sl t2 (- type-bits 2)) - (inst o t1 t2)) - (immediate - (let ((value (tn-value data))) - (unless (zerop value) - (inst oil t1 (ash value type-bits)))))) - (storew t1 x 0 other-pointer-type) - (move res x))) - -;;; MAKE-FIXNUM -- VOP. -;;; -;;; This is just used in hashing stuff. It doesn't necessarily have to -;;; preserve all the bits in the pointer. Some code expects a positive number, -;;; so make sure the right shift is logical. -;;; -(define-vop (make-fixnum) - (:args (ptr :scs (any-reg descriptor-reg) :target temp)) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 3 - (move temp ptr) - (inst sl temp 3) - (inst sr temp 1) - (move res temp))) - -(define-vop (make-other-immediate-type) - (:args (val :scs (any-reg descriptor-reg)) - (type :scs (any-reg descriptor-reg immediate))) - (:results (res :scs (any-reg descriptor-reg) :from :load)) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:generator 2 - (move res val) - (inst sl res (- type-bits 2)) - (sc-case type - (immediate - (inst oil res (tn-value type))) - (t - ;; Type is a fixnum, so lose those lowtag bits. - (move temp type) - (inst sr temp 2) - (inst o res temp))))) - - - -;;;; Allocation - -(define-vop (dynamic-space-free-pointer) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate dynamic-space-free-pointer) - (:policy :fast-safe) - (:generator 6 - (load-symbol-value int *allocation-pointer*))) - -(define-vop (binding-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate binding-stack-pointer-sap) - (:policy :fast-safe) - (:generator 6 - (load-symbol-value int *binding-stack-pointer*))) - -(define-vop (control-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate control-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move int csp-tn))) - - - -;;;; Code object frobbing. - -(define-vop (code-instructions) - (:translate code-instructions) - (:policy :fast-safe) - (:args (code :scs (descriptor-reg) :target sap)) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 10 - (loadw ndescr code 0 other-pointer-type) - (inst sr ndescr type-bits) - (inst sl ndescr word-shift) - (inst s ndescr other-pointer-type) - (move sap code) - (inst a sap ndescr))) - -(define-vop (compute-function) - (:args (code :scs (descriptor-reg)) - (offset :scs (signed-reg unsigned-reg))) - (:arg-types * positive-fixnum) - (:results (func :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 10 - (loadw ndescr code 0 other-pointer-type) - (inst sr ndescr type-bits) - (inst sl ndescr word-shift) - (inst a ndescr offset) - (inst a ndescr (- function-pointer-type other-pointer-type)) - (inst a ndescr code) - (move func ndescr))) - - - -;;;; Other random VOPs. - - -(defknown unix::do-pending-interrupt () (values)) -(define-vop (unix::do-pending-interrupt) - (:policy :fast-safe) - (:translate unix::do-pending-interrupt) - (:generator 1 - (inst break pending-interrupt-trap))) - - -(define-vop (halt) - (:generator 1 - (inst break halt-trap))) - - - -;;;; Dynamic vop count collection support - -(define-vop (count-me) - (:args (count-vector :scs (descriptor-reg))) - (:info index) - (:temporary (:scs (non-descriptor-reg)) count) - (:generator 1 - (let ((offset - (- (* (+ index vector-data-offset) word-bytes) other-pointer-type))) - (inst l count count-vector offset) - (inst inc count 1) - (inst st count count-vector offset)))) diff --git a/compiler/rt/type-vops.lisp b/compiler/rt/type-vops.lisp deleted file mode 100644 index e6442822f4f87368a0652ef1f150d860228dacef..0000000000000000000000000000000000000000 --- a/compiler/rt/type-vops.lisp +++ /dev/null @@ -1,474 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/type-vops.lisp,v 1.5 1992/05/26 13:55:12 wlott Exp $ -;;; -;;; This file contains the VM definition of type testing and checking VOPs -;;; for the IBM RT. -;;; -;;; Written by William Lott. -;;; Converted to IBM RT by Bill Chiles. -;;; - -(in-package "RT") - - - -;;;; Simple type checking and testing. - -;;; These types are represented by a single type code and are easily open-coded -;;; as a mask and compare. -;;; - -;;; CHECK-TYPE -- VOP. -;;; -;;; Type checking VOPs include this. Instances of this either returns value -;;; in result, or they jump to error code if the type is wrong. -;;; -(define-vop (check-type) - (:args (value :target result :scs (any-reg descriptor-reg))) - (:results (result :scs (any-reg descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:save-p :compute-only)) - -;;; TYPE-PREDICATE -- VOP. -;;; -;;; Type predicate VOPs include this. They jump to target when value is of the -;;; appropriate type; otherwise, they drop through. When not-p is true, they -;;; drop through if value is of the type and jumps to target if not. -;;; -(define-vop (type-predicate) - (:args (value :scs (any-reg descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:scs (non-descriptor-reg)) temp)) - - -(eval-when (compile eval) - -(defun cost-to-test-types (type-codes) - (+ (* 2 (length type-codes)) - (if (> (apply #'max type-codes) vm:lowtag-limit) 7 2))) - -(defmacro def-type-vops (pred-name check-name ptype error-code - &rest type-codes) - (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) - `(progn - ,@(when pred-name - `((define-vop (,pred-name type-predicate) - (:translate ,pred-name) - (:generator ,cost - (test-type value temp target not-p ,@type-codes))))) - ,@(when check-name - `((define-vop (,check-name check-type) - (:generator ,cost - (let ((err-lab - (generate-error-code vop ,error-code value))) - (test-type value temp err-lab t ,@type-codes) - (move result value)))))) - ,@(when ptype - `((primitive-type-vop ,check-name (:check) ,ptype)))))) - -); eval-when (compile eval) - - -(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error - vm:even-fixnum-type vm:odd-fixnum-type) - -(def-type-vops functionp check-function function - object-not-function-error vm:function-pointer-type) - -(def-type-vops listp check-list list - object-not-list-error vm:list-pointer-type) - -(def-type-vops structurep check-structure structure - object-not-structure-error vm:structure-pointer-type) - -(def-type-vops bignump check-bigunm bignum - object-not-bignum-error vm:bignum-type) - -(def-type-vops ratiop check-ratio ratio - object-not-ratio-error vm:ratio-type) - -(def-type-vops complexp check-complex complex - object-not-complex-error vm:complex-type) - -(def-type-vops single-float-p check-single-float nil ;single-float - object-not-single-float-error vm:single-float-type) - -(def-type-vops double-float-p check-double-float nil ;double-float - object-not-double-float-error vm:double-float-type) - -(def-type-vops simple-string-p check-simple-string simple-string - object-not-simple-string-error vm:simple-string-type) - -(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector - object-not-simple-bit-vector-error vm:simple-bit-vector-type) - -(def-type-vops simple-vector-p check-simple-vector simple-vector - object-not-simple-vector-error vm:simple-vector-type) - -(def-type-vops simple-array-unsigned-byte-2-p - check-simple-array-unsigned-byte-2 - simple-array-unsigned-byte-2 - object-not-simple-array-unsigned-byte-2-error - vm:simple-array-unsigned-byte-2-type) - -(def-type-vops simple-array-unsigned-byte-4-p - check-simple-array-unsigned-byte-4 - simple-array-unsigned-byte-4 - object-not-simple-array-unsigned-byte-4-error - vm:simple-array-unsigned-byte-4-type) - -(def-type-vops simple-array-unsigned-byte-8-p - check-simple-array-unsigned-byte-8 - simple-array-unsigned-byte-8 - object-not-simple-array-unsigned-byte-8-error - vm:simple-array-unsigned-byte-8-type) - -(def-type-vops simple-array-unsigned-byte-16-p - check-simple-array-unsigned-byte-16 - simple-array-unsigned-byte-16 - object-not-simple-array-unsigned-byte-16-error - vm:simple-array-unsigned-byte-16-type) - -(def-type-vops simple-array-unsigned-byte-32-p - check-simple-array-unsigned-byte-32 - simple-array-unsigned-byte-32 - object-not-simple-array-unsigned-byte-32-error - vm:simple-array-unsigned-byte-32-type) - -(def-type-vops simple-array-single-float-p check-simple-array-single-float - simple-array-single-float object-not-simple-array-single-float-error - vm:simple-array-single-float-type) - -(def-type-vops simple-array-double-float-p check-simple-array-double-float - simple-array-double-float object-not-simple-array-double-float-error - vm:simple-array-double-float-type) - -(def-type-vops base-char-p check-base-char base-char - object-not-base-char-error vm:base-char-type) - -(def-type-vops system-area-pointer-p check-system-area-pointer - system-area-pointer object-not-sap-error vm:sap-type) - -(def-type-vops weak-pointer-p check-weak-pointer weak-pointer - object-not-weak-pointer-error vm:weak-pointer-type) - -(def-type-vops array-header-p nil nil nil - vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type - vm:complex-vector-type vm:complex-array-type) - -(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error - vm:function-pointer-type vm:symbol-header-type) - -(def-type-vops stringp check-string nil object-not-string-error - vm:simple-string-type vm:complex-string-type) - -(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error - vm:simple-bit-vector-type vm:complex-bit-vector-type) - -(def-type-vops vectorp check-vector nil object-not-vector-error - vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type - vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type - vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type - vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type - vm:simple-array-double-float-type vm:complex-string-type - vm:complex-bit-vector-type vm:complex-vector-type) - -(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error - vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type - vm:simple-vector-type vm:simple-array-unsigned-byte-2-type - vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type - vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type - vm:simple-array-single-float-type vm:simple-array-double-float-type) - -(def-type-vops arrayp check-array nil object-not-array-error - vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type - vm:simple-vector-type vm:simple-array-unsigned-byte-2-type - vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type - vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type - vm:simple-array-single-float-type vm:simple-array-double-float-type - vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type - vm:complex-array-type) - -(def-type-vops numberp check-number nil object-not-number-error - vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type - vm:single-float-type vm:double-float-type vm:complex-type) - -(def-type-vops rationalp check-rational nil object-not-rational-error - vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) - -(def-type-vops integerp check-integer nil object-not-integer-error - vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type) - -(def-type-vops floatp check-float nil object-not-float-error - vm:single-float-type vm:double-float-type) - -(def-type-vops realp check-real nil object-not-real-error - vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type - vm:single-float-type vm:double-float-type) - -(def-type-vops code-component-p nil nil nil code-header-type) -(def-type-vops lra-p nil nil nil return-pc-header-type) -(def-type-vops scavenger-hook-p nil nil nil 0) - -(def-type-vops funcallable-instance-p nil nil nil - vm:funcallable-instance-header-type) - - -;;;; Other integer ranges. - -;;; A (signed-byte 32) can be represented with either fixnum or a bignum with -;;; exactly one digit. -;;; - -(define-vop (signed-byte-32-p type-predicate) - (:translate signed-byte-32-p) - (:generator 45 - (let ((not-target (gen-label))) - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - ;; Is it a fisnum? - (inst nilz temp value #x3) - (inst bc :eq yep) - ;; If not, is it an other pointer? - (test-type value temp nope t vm:other-pointer-type) - ;; If so, get the header. - (loadw temp value 0 vm:other-pointer-type) - ;; Is it a bignum of length one? - (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type)) - (if not-p - (inst bnc :eq target) - (inst bc :eq target)) - (emit-label not-target))))) - -(define-vop (check-signed-byte-32 check-type) - (:generator 45 - (let ((nope (generate-error-code vop object-not-signed-byte-32-error value)) - (yep (gen-label))) - (inst nilz temp value #x3) - (inst bc :eq yep) - (test-type value temp nope t vm:other-pointer-type) - (loadw temp value 0 vm:other-pointer-type) - (inst c temp - ;; Header word representing a bignum of length one. - (logior (ash 1 vm:type-bits) vm:bignum-type)) - (inst bnc :eq nope) - (emit-label yep) - (move result value)))) - - -;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a -;;; bignum with exactly one positive digit, or a bignum with exactly two digits -;;; and the second digit all zeros. - -(define-vop (unsigned-byte-32-p type-predicate) - (:translate unsigned-byte-32-p) - (:generator 45 - (let ((not-target (gen-label)) - (single-word (gen-label)) - (fixnum (gen-label))) - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - ;; Is it a fixnum? - (inst nilz temp value #x3) - (inst bcx :eq fixnum) - (inst c value 0) - ;; If not, is it an other pointer? - (test-type value temp nope t vm:other-pointer-type) - ;; Get the header. - (loadw temp value 0 vm:other-pointer-type) - ;; Is it a bignum of length one? - (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type)) - (inst bcx :eq single-word) - ;; If it length is other than two, we can't be an (unsigned-byte 32). - (inst c temp (+ (ash 2 vm:type-bits) vm:bignum-type)) - (inst bncx :eq nope) - ;; Get the second digit. - (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type) - ;; All zeros, its an (unsigned-byte 32). - (inst c temp 0) - (inst bc :eq yep) - ;; Otherwise, it isn't. - (inst b nope) - - (emit-label single-word) - ;; Get the single digit. - (loadw temp value vm:bignum-digits-offset vm:other-pointer-type) - (inst c temp 0) - - ;; positive implies (unsigned-byte 32). - (emit-label fixnum) - (if not-p - (inst bc :lt target) - (inst bnc :lt target)) - - (emit-label not-target))))) - -(define-vop (check-unsigned-byte-32 check-type) - (:generator 45 - (let ((nope - (generate-error-code vop object-not-unsigned-byte-32-error value)) - (yep (gen-label)) - (fixnum (gen-label)) - (single-word (gen-label))) - ;; Is it a fixnum? - (inst nilz temp value #x3) - (inst bcx :eq fixnum) - (inst c value 0) - - ;; If not, is it an other pointer? - (test-type value temp nope t vm:other-pointer-type) - ;; Get the number of digits. - (loadw temp value 0 vm:other-pointer-type) - ;; Is it one? - (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type)) - (inst bcx :eq single-word) - ;; If it's length is other than two, we can't be an (unsigned-byte 32). - (inst c temp (+ (ash 2 vm:type-bits) vm:bignum-type)) - (inst bncx :eq nope) - ;; Get the second digit. - (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type) - ;; All zeros, its an (unsigned-byte 32). - (inst c temp 0) - (inst bc :eq yep) - ;; Otherwise, it isn't. - (inst bnc :eq nope) - - (emit-label single-word) - ;; Get the single digit. - (loadw temp value vm:bignum-digits-offset vm:other-pointer-type) - ;; positive implies (unsigned-byte 32). - (inst c temp 0) - - (emit-label fixnum) - (inst bc :lt nope) - - (emit-label yep) - (move result value)))) - - - - -;;;; List/symbol types: - -;;; SYMBOLP -- VOP. -;;; -;;; This is (or symbol (eq nil)). -;;; -(define-vop (symbolp type-predicate) - (:translate symbolp) - (:generator 12 - (let* ((drop-thru (gen-label)) - (is-symbol-label (if not-p drop-thru target))) - (inst c value null-tn) - (inst bc :eq is-symbol-label) - (test-type value temp target not-p vm:symbol-header-type) - (emit-label drop-thru)))) -;;; -(define-vop (check-symbol check-type) - (:generator 12 - (let ((drop-thru (gen-label)) - (error (generate-error-code vop object-not-symbol-error value))) - (inst c value null-tn) - (inst bc :eq drop-thru) - (test-type value temp error t vm:symbol-header-type) - (emit-label drop-thru) - (move result value)))) - -;;; CONSP -- VOP. -;;; -;;; This is (and list (not (eq nil))). -;;; -(define-vop (consp type-predicate) - (:translate consp) - (:generator 8 - (let* ((drop-thru (gen-label)) - (is-not-cons-label (if not-p target drop-thru))) - (inst c value null-tn) - (inst bc :eq is-not-cons-label) - (test-type value temp target not-p vm:list-pointer-type) - (emit-label drop-thru)))) -;;; -(define-vop (check-cons check-type) - (:generator 8 - (let ((error (generate-error-code vop object-not-cons-error value))) - (inst c value null-tn) - (inst bc :eq error) - (test-type value temp error t vm:list-pointer-type) - (move result value)))) - - - -;;;; Function Coercion - -;;; If not a function, get the symbol value and test for that being a -;;; function. Since we test for a function rather than the unbound -;;; marker, this works on NIL. -;;; -(define-vop (coerce-to-function) - (:args (object :scs (descriptor-reg) - :target result)) - (:results (result :scs (descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) nd-temp) - (:temporary (:scs (descriptor-reg)) saved-object) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (let ((not-function-label (gen-label)) - (not-coercable-label (gen-label)) - (done-label (gen-label))) - (test-type object nd-temp not-function-label t - vm:function-pointer-type) - (move result object) - (emit-label done-label) - - (assemble (*elsewhere*) - (emit-label not-function-label) - (test-type object nd-temp not-coercable-label t - vm:symbol-header-type) - (move saved-object object) - (loadw result object vm:symbol-function-slot vm:other-pointer-type) - (test-type result nd-temp done-label nil - vm:function-pointer-type) - (error-call vop undefined-symbol-error saved-object) - - (emit-label not-coercable-label) - (error-call vop object-not-coercable-to-function-error object))))) - -(define-vop (fast-safe-coerce-to-function) - (:args (object :scs (descriptor-reg) - :target result)) - (:results (result :scs (descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) nd-temp) - (:temporary (:scs (descriptor-reg)) saved-object) - (:vop-var vop) - (:save-p :compute-only) - (:generator 10 - (let ((not-function-label (gen-label)) - (done-label (gen-label))) - (test-type object nd-temp not-function-label t vm:function-pointer-type) - (move result object) - (emit-label done-label) - - (assemble (*elsewhere*) - (emit-label not-function-label) - (move saved-object object) - (loadw result object vm:symbol-function-slot vm:other-pointer-type) - (test-type result nd-temp done-label nil vm:function-pointer-type) - (error-call vop undefined-symbol-error saved-object))))) diff --git a/compiler/rt/values.lisp b/compiler/rt/values.lisp deleted file mode 100644 index e67e53cd4b61df6954bfc46a0ab1393af736690d..0000000000000000000000000000000000000000 --- a/compiler/rt/values.lisp +++ /dev/null @@ -1,102 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/values.lisp,v 1.3 1991/12/21 23:05:29 ram Exp $ -;;; -;;; This file contains the implementation of unknown-values VOPs. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted for IBM RT by Bill Chiles. -;;; - -(in-package "RT") - - - -(define-vop (reset-stack-pointer) - (:args (ptr :scs (word-pointer-reg))) - (:generator 1 - (move csp-tn ptr))) - -;;; PUSH-VALUES -- VOP. -;;; -;;; Push some values onto the stack, returning the start and number of values -;;; pushed as results. It is assumed that the Vals are wired to the standard -;;; argument locations. Nvals is the number of values to push. -;;; -;;; The generator cost is pseudo-random. We could get it right by defining a -;;; bogus SC that reflects the costs of the memory-to-memory moves for each -;;; operand, but this seems unworthwhile. -;;; -(define-vop (push-values) - (:args - (vals :more t)) - (:results - (start :scs (word-pointer-reg)) - (count :scs (any-reg))) - (:info nvals) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) - :to (:result 0) - :target start) - start-temp) - (:generator 20 - (move start-temp csp-tn) - (inst cal csp-tn csp-tn (* nvals word-bytes)) - (do ((val vals (tn-ref-across val)) - (i 0 (1+ i))) - ((null val)) - (let ((tn (tn-ref-tn val))) - (sc-case tn - (descriptor-reg - (storew tn start-temp i)) - (control-stack - (load-stack-tn temp tn) - (storew temp start-temp i))))) - (move start start-temp) - (inst li count (fixnum nvals)))) - - -;;; VALUES-LIST -- VOP. -;;; -;;; Push a list of values on the stack, returning Start and Count as used in -;;; unknown values continuations. -;;; -(define-vop (values-list) - (:args (arg :scs (descriptor-reg) :target list)) - (:arg-types list) - (:policy :fast-safe) - (:results (start :scs (word-pointer-reg)) - (count :scs (any-reg))) - (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg) :type random) ndescr) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (let ((loop (gen-label)) - (done (gen-label))) - - (move list arg) - (move start csp-tn) - - (emit-label loop) - (inst c list null-tn) - (inst bcx :eq done) - (loadw temp list cons-car-slot list-pointer-type) - (loadw list list cons-cdr-slot list-pointer-type) - (inst cal csp-tn csp-tn word-bytes) - (storew temp csp-tn -1) - (test-type list ndescr loop nil list-pointer-type) - (error-call vop bogus-argument-to-values-list-error list) - - (emit-label done) - (move count csp-tn) - (inst s count start)))) diff --git a/compiler/rt/vm.lisp b/compiler/rt/vm.lisp deleted file mode 100644 index b168d0ee8de67d5b6f374485e44fcebd5703b88f..0000000000000000000000000000000000000000 --- a/compiler/rt/vm.lisp +++ /dev/null @@ -1,684 +0,0 @@ -;;; -*- Package: RT; Log: c.log -*- -;;; -;;; ********************************************************************** -;;; 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; This file contains the VM definition for the IBM RT. -;;; -;;; Written by William Lott, Rob Maclachlan, and Bill Chiles. -;;; - -(in-package "RT") - - - -;;;; SB and SC definition: - -(define-storage-base registers :finite :size 16) -(define-storage-base mc68881-float-registers :finite :size 8) -(define-storage-base AFPA-float-registers :finite :size 64) -(define-storage-base FPA-float-registers :finite :size 16) -(define-storage-base control-stack :unbounded :size 8) -(define-storage-base non-descriptor-stack :unbounded :size 0) -;; These are constants in components. -(define-storage-base constant :non-packed) -;; Anything I can cookup out of nowhere and store somewhere. -(define-storage-base immediate-constant :non-packed) - -;;; -;;; Handy macro so we don't have to keep changing all the numbers whenever -;;; we insert a new storage class. -;;; -(defmacro define-storage-classes (&rest classes) - (do ((forms (list 'progn) - (let* ((class (car classes)) - (sc-name (car class)) - (constant-name (intern (concatenate 'simple-string - (string sc-name) - "-SC-NUMBER")))) - (list* `(define-storage-class ,sc-name ,index - ,@(cdr class)) - `(eval-when (compile load eval) - (defconstant ,constant-name ,index)) - `(export ',constant-name) - forms))) - (index 0 (1+ index)) - (classes classes (cdr classes))) - ((null classes) - (nreverse forms)))) - -(define-storage-classes - - ;; Non-immediate contstants in the constant pool - (constant constant) - - - (immediate immediate-constant) - (null immediate-constant) - - - ;; The control stack. (Scanned by GC) - (control-stack control-stack) - - ;; The non-descriptor stack SC's. - (signed-stack non-descriptor-stack) ; (signed-byte 32) - (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) - (base-char-stack non-descriptor-stack) ; non-descriptor characters. - (sap-stack non-descriptor-stack) ; System area pointers. - (single-stack non-descriptor-stack) ; single-floats - (double-stack non-descriptor-stack :element-size 2) ; double floats. - - - ;; **** Things that can go in the non-descriptor registers. - - ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing - ;; bad will happen if they are. (fixnums, characters, header values, etc). - (any-reg registers - :locations (9 10 11 12 13 14 0 2 3 4) - :constant-scs (immediate) - :reserve-locations (0 2 3 4) - :save-p t - :alternate-scs (control-stack)) - - ;; Descriptor objects. Must be seen by GC. - (descriptor-reg registers - :locations (9 10 11 12 13 14) - ;; Immediate (and constant) for moving NULL around (at least). - :constant-scs (constant immediate null) - :save-p t - :alternate-scs (control-stack)) - - ;; Non-Descriptor characters. - (base-char-reg registers - :locations (0 2 3 4) - :constant-scs (immediate) - :save-p t - :alternate-scs (base-char-stack)) - - ;; Non-Descriptor SAP's (arbitrary pointers into address space). - (sap-reg registers - ;; Exclude R0 here because the instructions we would like to use with sap - ;; TN's use R0 as the constant zero instead of using the contents of R0. - :locations (2 3 4) - :constant-scs (immediate) - :save-p t - :alternate-scs (sap-stack)) - - ;; Non-Descriptor (signed or unsigned) numbers. - (signed-reg registers - :locations (0 2 3 4) - :constant-scs (immediate) - :save-p t - :alternate-scs (signed-stack)) - (unsigned-reg registers - :locations (0 2 3 4) - :constant-scs (immediate) - :save-p t - :alternate-scs (unsigned-stack)) - - ;; Random objects that must not be seen by GC. Used only as temporaries. - (non-descriptor-reg registers - :locations (0 2 3 4)) - - ;; Word-aligned pointers that cannot be in R0. Used for temporaries and to - ;; hold stack pointers. - (word-pointer-reg registers - :locations (2 3 4 9 10 11 12 13 14) - :save-p t - :alternate-scs (control-stack)) - - ;; Pointers to the interior of objects. Used only as an temporary. - (interior-reg registers - :locations (15)) - - - ;; **** Things that can go in the floating point registers. - - ;; Non-Descriptor mc68881-single-floats. - (mc68881-single-reg mc68881-float-registers - :locations (0 1 2 3 4 5 6 7) - :constant-scs () - :save-p t - :alternate-scs (single-stack)) - ;; Non-Descriptor mc68881-double-floats. - (mc68881-double-reg mc68881-float-registers - :locations (0 1 2 3 4 5 6 7) - :constant-scs () - :save-p t - :alternate-scs (double-stack)) - - ;; Non-Descriptor FPA-single-floats. - (FPA-single-reg FPA-float-registers - ;; 14 and 15 are status and exception registers. - :locations (0 1 2 3 4 5 6 7 8 9 10 11 12 13) - :constant-scs () - :save-p t - :alternate-scs (single-stack)) - ;; Non-Descriptor FPA-double-floats. - (FPA-double-reg FPA-float-registers - :locations (0 2 4 6 8 10 12) ;14 and 15 are status and exception registers. - :element-size 2 - :constant-scs () - :save-p t - :alternate-scs (double-stack)) - - ;; Non-Descriptor AFPA-single-floats. 0,1 reserved for loading "immediate" - ;; operands. - (AFPA-single-reg AFPA-float-registers - :locations (2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 - 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 - 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63) - :constant-scs () - :save-p t - :alternate-scs (single-stack)) - ;; Non-Descriptor AFPA-double-floats. 0 reserved for loading "immediate" - ;; operands. - (AFPA-double-reg AFPA-float-registers - :locations (2 4 6 8 10 12 14 16 18 20 22 24 26 28 - 30 32 34 36 38 40 42 44 46 48 50 52 54 56 58 60 62) - :element-size 2 - :constant-scs () - :save-p t - :alternate-scs (double-stack)) - - - ;; A catch or unwind block. - (catch-block control-stack :element-size vm:catch-block-size)) - - -(export '(single-reg-sc-number double-reg-sc-number)) -(defconstant single-reg-sc-number - (list mc68881-single-reg-sc-number - FPA-single-reg-sc-number - AFPA-single-reg-sc-number)) -(defconstant double-reg-sc-number - (list mc68881-double-reg-sc-number - FPA-double-reg-sc-number - AFPA-double-reg-sc-number)) - - -;;;; Primitive Type Definitions - -;;; *any-primitive-type* -;;; -;;; Other VOP/VM definition files use this when writing interface code for the -;;; compiler. -;;; -(def-primitive-type t (descriptor-reg)) -(defvar *any-primitive-type* (primitive-type-or-lose 't)) -(setf (c:backend-any-primitive-type c:*target-backend*) - (c:primitive-type-or-lose 't)) - -;;; Primitive integer types that fit in registers. -;;; -(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg) - :type (unsigned-byte 29)) -(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg) - :type (unsigned-byte 31)) -(def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg) - :type (unsigned-byte 32)) -(def-primitive-type fixnum (any-reg signed-reg) - :type (signed-byte 30)) -(def-primitive-type signed-byte-32 (signed-reg descriptor-reg) - :type (signed-byte 32)) -(def-primitive-type word-pointer (word-pointer-reg descriptor-reg) - :type fixnum) - - -;;; *word-pointer-type* -;;; -(defvar *word-pointer-type* (primitive-type-or-lose 'word-pointer)) - - -;;; *fixnum-primitive-type* -;;; -;;; Other VOP/VM definition files use this when writing interface code for the -;;; compiler. -;;; -(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum)) - -(def-primitive-type-alias tagged-num (:or positive-fixnum fixnum)) -(def-primitive-type-alias unsigned-num (:or unsigned-byte-32 - unsigned-byte-31 - positive-fixnum)) -(def-primitive-type-alias signed-num (:or signed-byte-32 - fixnum - unsigned-byte-31 - positive-fixnum)) - -;;; Other primitive immediate types. -(def-primitive-type base-char (base-char-reg any-reg)) - -;;; Primitive pointer types. -;;; -(def-primitive-type function (descriptor-reg)) -(def-primitive-type list (descriptor-reg)) -(def-primitive-type structure (descriptor-reg)) - -;;; Primitive other-pointer number types. -;;; -(def-primitive-type bignum (descriptor-reg)) -(def-primitive-type ratio (descriptor-reg)) -(def-primitive-type complex (descriptor-reg)) -(def-primitive-type mc68881-single-float (mc68881-single-reg descriptor-reg) - :type single-float) -(def-primitive-type mc68881-double-float (mc68881-double-reg descriptor-reg) - :type double-float) -(def-primitive-type FPA-single-float (FPA-single-reg descriptor-reg) - :type single-float) -(def-primitive-type FPA-double-float (FPA-double-reg descriptor-reg) - :type double-float) -(def-primitive-type AFPA-single-float (AFPA-single-reg descriptor-reg) - :type single-float) -(def-primitive-type AFPA-double-float (AFPA-double-reg descriptor-reg) - :type double-float) -(def-primitive-type any-single-float (descriptor-reg) - :type single-float) -(def-primitive-type any-double-float (descriptor-reg) - :type double-float) - -;;; Primitive other-pointer array types. -;;; -(def-primitive-type simple-string (descriptor-reg) :type simple-base-string) -(def-primitive-type simple-bit-vector (descriptor-reg)) -(def-primitive-type simple-vector (descriptor-reg)) -(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg) - :type (simple-array (unsigned-byte 2) (*))) -(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg) - :type (simple-array (unsigned-byte 4) (*))) -(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg) - :type (simple-array (unsigned-byte 8) (*))) -(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg) - :type (simple-array (unsigned-byte 16) (*))) -(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg) - :type (simple-array (unsigned-byte 32) (*))) -(def-primitive-type simple-array-single-float (descriptor-reg) - :type (simple-array single-float (*))) -(def-primitive-type simple-array-double-float (descriptor-reg) - :type (simple-array double-float (*))) - -;;; Note: The complex array types are not included, because it is pointless to -;;; restrict VOPs to them. - -;;; Other primitive other-pointer types. -;;; -(def-primitive-type system-area-pointer (sap-reg descriptor-reg)) -(def-primitive-type weak-pointer (descriptor-reg)) - -;;; Random primitive types that don't exist at the LISP level. -;;; -(def-primitive-type random (non-descriptor-reg) :type nil) -(def-primitive-type interior (interior-reg) :type nil) -(def-primitive-type catch-block (catch-block) :type nil) - - - - -;;;; PRIMITIVE-TYPE-OF and friends. - -;;; PRIMITIVE-TYPE-OF -- Interface. -;;; -;;; Return the most restrictive primitive type that contains Object. -;;; -(def-vm-support-routine primitive-type-of (object) - (let ((type (ctype-of object))) - (cond ((not (member-type-p type)) (primitive-type type)) - ((equal (member-type-members type) '(nil)) - (primitive-type-or-lose 'list)) - (t - *any-primitive-type*)))) - -;;; -(defvar *simple-array-primitive-types* - '((base-char . simple-string) - (string-char . simple-string) - (bit . simple-bit-vector) - ((unsigned-byte 2) . simple-array-unsigned-byte-2) - ((unsigned-byte 4) . simple-array-unsigned-byte-4) - ((unsigned-byte 8) . simple-array-unsigned-byte-8) - ((unsigned-byte 16) . simple-array-unsigned-byte-16) - ((unsigned-byte 32) . simple-array-unsigned-byte-32) - (single-float . simple-array-single-float) - (double-float . simple-array-double-float) - (t . simple-vector)) - "An a-list for mapping simple array element types to their - corresponding primitive types.") - -(defvar *target-float-hardware*) - -;;; PRIMITIVE-TYPE -- Internal Interface. -;;; -;;; Return the primitive type corresponding to a type descriptor -;;; structure. The second value is true when the primitive type is -;;; exactly equivalent to the argument Lisp type. -;;; -;;; In a bootstrapping situation, we should be careful to use the -;;; correct values for the system parameters. -;;; -(def-vm-support-routine primitive-type (type) - (declare (type ctype type)) - (macrolet ((any () '(values *any-primitive-type* nil)) - (exactly (type) `(values (primitive-type-or-lose ',type) t)) - (part-of (type) `(values (primitive-type-or-lose ',type) nil))) - (etypecase type - (numeric-type - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (case (numeric-type-complexp type) - (:real - (case (numeric-type-class type) - (integer - (cond ((and hi lo) - (dolist (spec - '((positive-fixnum 0 #.(1- (ash 1 29))) - (unsigned-byte-31 0 #.(1- (ash 1 31))) - (unsigned-byte-32 0 #.(1- (ash 1 32))) - (fixnum #.(ash -1 29) #.(1- (ash 1 29))) - (signed-byte-32 #.(ash -1 31) - #.(1- (ash 1 31)))) - (if (or (< hi (ash -1 29)) - (> lo (1- (ash 1 29)))) - (part-of bignum) - (any))) - (let ((type (car spec)) - (min (cadr spec)) - (max (caddr spec))) - (when (<= min lo hi max) - (return (values (primitive-type-or-lose type) - (and (= lo min) (= hi max)))))))) - ((or (and hi (< hi most-negative-fixnum)) - (and lo (> lo most-positive-fixnum))) - (part-of bignum)) - (t - (any)))) - (float - (float-primitive-type lo hi type)) - (t - (any)))) - (:complex - (part-of complex)) - (t - (any))))) - (array-type - (if (array-type-complexp type) - (any) - (let* ((dims (array-type-dimensions type)) - (etype (array-type-specialized-element-type type)) - (type-spec (type-specifier etype)) - (ptype (cdr (assoc type-spec *simple-array-primitive-types* - :test #'equal)))) - (if (and (consp dims) (null (rest dims)) ptype) - (values (primitive-type-or-lose ptype) (eq (first dims) '*)) - (any))))) - (union-type - (if (type= type (specifier-type 'list)) - (exactly list) - (let ((types (union-type-types type))) - (multiple-value-bind (res exact) - (primitive-type (first types)) - (dolist (type (rest types) (values res exact)) - (multiple-value-bind (ptype ptype-exact) - (primitive-type type) - (unless ptype-exact (setq exact nil)) - (unless (eq ptype res) - (return (any))))))))) - (member-type - (let* ((members (member-type-members type)) - (res (primitive-type-of (first members)))) - (dolist (mem (rest members) (values res nil)) - (unless (eq (primitive-type-of mem) res) - (return (values *any-primitive-type* nil)))))) - (named-type - (case (named-type-name type) - ((t bignum ratio complex function system-area-pointer weak-pointer - structure) - (values (primitive-type-or-lose (named-type-name type)) t)) - ((character base-char string-char) - (exactly base-char)) - (standard-char - (part-of base-char)) - (cons - (part-of list)) - (t - (any)))) - (function-type - (exactly function)) - (structure-type - (part-of structure)) - (ctype - (any))))) - -;;; FLOAT-PRIMITIVE-TYPE -- Internal. -;;; -(defun float-primitive-type (lo hi type) - (let ((exact (and (null lo) (null hi)))) - (case (numeric-type-format type) - ((short-float single-float) - (ecase *target-float-hardware* - (:mc68881 - (values (primitive-type-or-lose 'mc68881-single-float) exact)) - (:fpa - (values (primitive-type-or-lose 'fpa-single-float) exact)) - (:afpa - (values (primitive-type-or-lose 'afpa-single-float) exact)) - (:any - (values (primitive-type-or-lose 'any-single-float) exact)))) - ((double-float long-float) - (ecase *target-float-hardware* - (:mc68881 - (values (primitive-type-or-lose 'mc68881-double-float) exact)) - (:fpa - (values (primitive-type-or-lose 'fpa-double-float) exact)) - (:afpa - (values (primitive-type-or-lose 'afpa-double-float) exact)) - (:any - (values (primitive-type-or-lose 'any-double-float) exact)))) - (t - (values *any-primitive-type* nil))))) - - - -;;;; Magical Registers - -;;; Other VOP/VM definition files use the definitions on this page when writing -;;; interface code for the compiler. -;;; - -(eval-when (compile eval load) - (defconstant nargs-offset 0) - (defconstant nsp-offset 1) - (defconstant nl0-offset 2) - (defconstant ocfp-offset 3) - (defconstant nfp-offset 4) - (defconstant csp-offset 5) - (defconstant cfp-offset 6) - (defconstant code-offset 7) - (defconstant null-offset 8) - (defconstant cname-offset 9) - (defconstant lexenv-offset 10) - (defconstant lra-offset 11) - (defconstant a0-offset 12) - (defconstant a1-offset 13) - (defconstant a2-offset 14) - (defconstant lip-offset 15)) - -;;; Lisp-interior-pointer register. -;;; -(defparameter lip-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset lip-offset)) - -;;; Nil. -;;; -(defparameter null-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset null-offset)) - - -;;; Frame Pointer. -;;; -(defparameter cfp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset cfp-offset)) - - -;;; Control stack pointer. -;;; -(defparameter csp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset csp-offset)) - -;;; Number stack pointer. -;;; -(defparameter nsp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset nsp-offset)) - -;;; Code Pointer. -;;; -(defparameter code-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset code-offset)) - -;;; Random non-descriptor tn -;;; -(defparameter nl0-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'non-descriptor-reg) - :offset nl0-offset)) - - - -;;;; Side-Effect Classes - -(def-boolean-attribute vop - any) - - -;;;; Constants - -;;; IMMEDIATE-CONSTANT-SC -- Interface. -;;; -;;; If value can be represented as an immediate constant, then return the -;;; appropriate SC number, otherwise return NIL. -;;; -(def-vm-support-routine immediate-constant-sc (value) - (typecase value - ((or fixnum character system-area-pointer) - (sc-number-or-lose 'immediate)) - (null - (sc-number-or-lose 'null)) - (symbol - (if (static-symbol-p value) - (sc-number-or-lose 'immediate) - nil)))) - - - -;;;; Function Call Parameters - -;;; The SC numbers for register and stack arguments/return values. -;;; -;;; Other VOP/VM definition files use this when writing interface code for the -;;; compiler. -;;; -(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) -(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) -(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) - - -(eval-when (compile load eval) - -;;; Offsets of special stack frame locations. -;;; -(defconstant ocfp-save-offset 0) -(defconstant lra-save-offset 1) -(defconstant nfp-save-offset 2) - -); Eval-When (Compile Load Eval) - - -(defparameter nargs-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'any-reg) - :offset nargs-offset)) - -(defparameter ocfp-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset ocfp-offset)) - -(defparameter lra-tn - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset lra-offset)) - - -(eval-when (compile load eval) - -;;; The number of arguments/return values passed in registers. -;;; -;;; Other VOP/VM definition files use this when writing interface code for the -;;; compiler. -;;; -(defconstant register-arg-count 3) - -;;; The offsets within the register-arg SC where we supply values, first value -;;; first. -;;; -;;; Other VOP/VM definition files use this when writing interface code for the -;;; compiler. -;;; -(defconstant register-arg-offsets '(12 13 14)) - -;;; Names to use for the argument registers. -;;; -(defconstant register-arg-names '(a0 a1 a2)) - -); Eval-When (Compile Load Eval) - - -;;; A list of TN's describing the register arguments. -;;; -(defparameter register-arg-tns - (mapcar #'(lambda (n) - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset n)) - register-arg-offsets)) - - - -;;;; LOCATION-PRINT-NAME. - -(defconstant register-names #("NARGS" "NSP" "NL0" "OCFP" "NFP" - "CSP" "CFP" "CODE" "NULL" "CNAME" "LEXENV" - "LRA" "A0" "A1" "A2" "LIP")) - -;;; LOCATION-PRINT-NAME -- Interface. -;;; -;;; This function is called by debug output routines that want a pretty name -;;; for a TN's location. It returns a thing that can be printed with PRINC. -;;; -(def-vm-support-routine location-print-name (tn) - (declare (type tn tn)) - (let ((sb (sb-name (sc-sb (tn-sc tn)))) - (offset (tn-offset tn))) - (ecase sb - (registers (svref register-names (tn-offset tn))) - ((mc68881-float-registers FPA-float-registers AFPA-float-registers) - (format nil "F~D" offset)) - (control-stack (format nil "CS~D" offset)) - (non-descriptor-stack (format nil "NS~D" offset)) - (constant (format nil "Const~D" offset)) - (immediate-constant "Immed")))) diff --git a/compiler/saptran.lisp b/compiler/saptran.lisp deleted file mode 100644 index aa4215218c71efdc535a8f219269fe81bfd7ee6f..0000000000000000000000000000000000000000 --- a/compiler/saptran.lisp +++ /dev/null @@ -1,129 +0,0 @@ -;;; -*- Log: C.Log; Package: C -*- -;;; -;;; ********************************************************************** -;;; 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/saptran.lisp,v 1.3 1992/12/18 20:40:22 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains some magic hacks for optimizing SAP operations. -;;; -;;; Written by William Lott. -;;; -(in-package "C") - - - -;;;; Defknowns - - -(defknown foreign-symbol-address (simple-string) system-area-pointer - (movable flushable)) - -(defknown (sap< sap<= sap= sap>= sap>) - (system-area-pointer system-area-pointer) boolean - (movable flushable)) - -(defknown sap+ (system-area-pointer integer) system-area-pointer - (movable flushable)) -(defknown sap- (system-area-pointer system-area-pointer) (signed-byte 32) - (movable flushable)) - -(defknown sap-int (system-area-pointer) (unsigned-byte 32) (movable flushable)) -(defknown int-sap ((unsigned-byte 32)) system-area-pointer (movable)) - - -(defknown sap-ref-8 (system-area-pointer index) (unsigned-byte 8) - (flushable)) -(defknown %set-sap-ref-8 (system-area-pointer index (unsigned-byte 8)) - (unsigned-byte 8) - ()) - -(defknown sap-ref-16 (system-area-pointer index) (unsigned-byte 16) - (flushable)) -(defknown %set-sap-ref-16 (system-area-pointer index (unsigned-byte 16)) - (unsigned-byte 16) - ()) - -(defknown sap-ref-32 (system-area-pointer index) (unsigned-byte 32) - (flushable)) -(defknown %set-sap-ref-32 (system-area-pointer index (unsigned-byte 32)) - (unsigned-byte 32) - ()) - - -(defknown signed-sap-ref-8 (system-area-pointer index) (signed-byte 8) - (flushable)) -(defknown %set-signed-sap-ref-8 (system-area-pointer index (signed-byte 8)) - (signed-byte 8) - ()) - -(defknown signed-sap-ref-16 (system-area-pointer index) (signed-byte 16) - (flushable)) -(defknown %set-signed-sap-ref-16 (system-area-pointer index (signed-byte 16)) - (signed-byte 16) - ()) - -(defknown signed-sap-ref-32 (system-area-pointer index) (signed-byte 32) - (flushable)) -(defknown %set-signed-sap-ref-32 (system-area-pointer index (signed-byte 32)) - (signed-byte 32) - ()) - - -(defknown sap-ref-sap (system-area-pointer index) system-area-pointer - (flushable)) -(defknown %set-sap-ref-sap (system-area-pointer index system-area-pointer) - system-area-pointer - ()) - -(defknown sap-ref-single (system-area-pointer index) single-float - (flushable)) -(defknown sap-ref-double (system-area-pointer index) double-float - (flushable)) - -(defknown %set-sap-ref-single - (system-area-pointer index single-float) single-float - ()) -(defknown %set-sap-ref-double - (system-area-pointer index double-float) double-float - ()) - - -;;;; Transforms for converting sap relation operators. - -(dolist (info '((sap< <) (sap<= <=) (sap= =) (sap>= >=) (sap> >))) - (destructuring-bind (sap-fun int-fun) info - (deftransform sap-fun ((x y) '* '* :eval-name t) - `(,int-fun (sap-int x) (sap-int y))))) - - -;;;; Transforms for optimizing sap+ - -(deftransform sap+ ((sap offset)) - (cond ((and (constant-continuation-p offset) - (eql (continuation-value offset) 0)) - 'sap) - (t - (extract-function-args sap 'sap+ 2) - '(lambda (sap offset1 offset2) - (sap+ sap (+ offset1 offset2)))))) - -(dolist (fun '(sap-ref-8 %set-sap-ref-8 - signed-sap-ref-8 %set-signed-sap-ref-8 - sap-ref-16 %set-sap-ref-16 - signed-sap-ref-16 %set-signed-sap-ref-16 - sap-ref-32 %set-sap-ref-32 - signed-sap-ref-32 %set-signed-sap-ref-32 - sap-ref-sap %set-sap-ref-sap - sap-ref-single %set-sap-ref-single - sap-ref-double %set-sap-ref-double)) - (deftransform fun ((sap offset) '* '* :eval-name t) - (extract-function-args sap 'sap+ 2) - `(lambda (sap offset1 offset2) - (,fun sap (+ offset1 offset2))))) diff --git a/compiler/seqtran.lisp b/compiler/seqtran.lisp deleted file mode 100644 index bd1b9f7cb4cac5560aba29dae4b0f0029c2472fa..0000000000000000000000000000000000000000 --- a/compiler/seqtran.lisp +++ /dev/null @@ -1,470 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/seqtran.lisp,v 1.16 1992/08/05 00:36:42 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains optimizers for list and sequence functions. -;;; -;;; Written by Rob MacLachlan. Some code adapted from the old seqtran file, -;;; written by Wholey and Fahlman. -;;; -(in-package 'c) - - -(defun mapper-transform (fn arglists accumulate take-car) - (collect ((do-clauses) - (args-to-fn) - (tests)) - (let ((n-first (gensym))) - (dolist (a (if accumulate - arglists - `(,n-first ,@(rest arglists)))) - (let ((v (gensym))) - (do-clauses `(,v ,a (cdr ,v))) - (tests `(endp ,v)) - (args-to-fn (if take-car `(car ,v) v)))) - - (let ((call `(funcall ,fn . ,(args-to-fn))) - (endtest `(or ,@(tests)))) - (ecase accumulate - (:nconc - (let ((temp (gensym)) - (map-result (gensym))) - `(let ((,map-result (list nil))) - (do-anonymous ((,temp ,map-result) . ,(do-clauses)) - (,endtest (cdr ,map-result)) - (setq ,temp (last (nconc ,temp ,call))))))) - (:list - (let ((temp (gensym)) - (map-result (gensym))) - `(let ((,map-result (list nil))) - (do-anonymous ((,temp ,map-result) . ,(do-clauses)) - (,endtest (cdr ,map-result)) - (rplacd ,temp (setq ,temp (list ,call))))))) - ((nil) - `(let ((,n-first ,(first arglists))) - (do-anonymous ,(do-clauses) - (,endtest ,n-first) ,call)))))))) - -(def-source-transform mapc (function list &rest more-lists) - (mapper-transform function (cons list more-lists) nil t)) - -(def-source-transform mapcar (function list &rest more-lists) - (mapper-transform function (cons list more-lists) :list t)) - -(def-source-transform mapcan (function list &rest more-lists) - (mapper-transform function (cons list more-lists) :nconc t)) - -(def-source-transform mapl (function list &rest more-lists) - (mapper-transform function (cons list more-lists) nil nil)) - -(def-source-transform maplist (function list &rest more-lists) - (mapper-transform function (cons list more-lists) :list nil)) - -(def-source-transform mapcon (function list &rest more-lists) - (mapper-transform function (cons list more-lists) :nconc nil)) - -(deftransform elt ((s i) ((simple-array * (*)) *)) - '(aref s i)) - -(deftransform elt ((s i) (list *)) - '(nth i s)) - -(deftransform %setelt ((s i v) ((simple-array * (*)) * *)) - '(%aset s i v)) - -(deftransform %setelt ((s i v) (list * *)) - '(setf (car (nthcdr i s)) v)) - - -(deftransform member ((e l &key (test #'eql)) * * :node node) - (unless (constant-continuation-p l) (give-up)) - - (let ((val (continuation-value l))) - (unless (policy node - (or (= speed 3) - (and (>= speed space) - (<= (length val) 5)))) - (give-up)) - - (labels ((frob (els) - (if els - `(if (funcall test e ',(car els)) - ',els - ,(frob (cdr els))) - 'nil))) - (frob val)))) - -;;; Names of predicates that compute the same value as CHAR= when applied to -;;; characters. -;;; -(defconstant char=-functions '(eql equal char=)) - - -(deftransform search ((string1 string2 &key (start1 0) end1 (start2 0) end2 - test) - (simple-string simple-string &rest t)) - (unless (or (not test) - (continuation-function-is test char=-functions)) - (give-up)) - '(lisp::%sp-string-search string1 start1 (or end1 (length string1)) - string2 start2 (or end2 (length string2)))) - -(deftransform position ((item sequence &key from-end test (start 0) end) - (t simple-string &rest t)) - (unless (or (not test) - (continuation-function-is test char=-functions)) - (give-up)) - `(and (typep item 'character) - (,(if (constant-value-or-lose from-end) - 'lisp::%sp-reverse-find-character - 'lisp::%sp-find-character) - sequence start (or end (length sequence)) - item))) - - -(deftransform find ((item sequence &key from-end (test #'eql) (start 0) end) - (t simple-string &rest t)) - `(if (position item sequence - ,@(when from-end `(:from-end from-end)) - :test test :start start :end end) - item - nil)) - - -;;;; Utilities: - - -;;; CONTINUATION-FUNCTION-IS -- Interface -;;; -;;; Return true if Cont's only use is a non-notinline reference to a global -;;; function with one of the specified Names. -;;; -(defun continuation-function-is (cont names) - (declare (type continuation cont) (list names)) - (let ((use (continuation-use cont))) - (and (ref-p use) - (let ((leaf (ref-leaf use))) - (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function) - (not (null (member (leaf-name leaf) names :test #'equal)))))))) - - -;;; CONSTANT-VALUE-OR-LOSE -- Interface -;;; -;;; If Cont is a constant continuation, the return the constant value. If -;;; it is null, then return default, otherwise quietly GIVE-UP. -;;; ### Probably should take an ARG and flame using the NAME. -;;; -(defun constant-value-or-lose (cont &optional default) - (declare (type (or continuation null) cont)) - (cond ((not cont) default) - ((constant-continuation-p cont) - (continuation-value cont)) - (t - (give-up)))) - -#| -;;; MAKE-ARG, ARG-CONT, ARG-NAME -- Interface -;;; -;;; This is a frob whose job it is to make it easier to pass around the -;;; arguments to IR1 transforms. It bundles together the name of the argument -;;; (which should be referenced in any expansion), and the continuation for -;;; that argument (or NIL if unsupplied.) -;;; -(defstruct (arg (:constructor %make-arg (name cont))) - (name nil :type symbol) - (cont nil :type (or continuation null))) -;;; -(defmacro make-arg (name) - `(%make-arg ',name ,name)) - -;;; DEFAULT-ARG -- Interface -;;; -;;; If Arg is null or its CONT is null, then return Default, otherwise -;;; return Arg's NAME. -;;; -(defun default-arg (arg default) - (declare (type (or arg null) arg)) - (if (and arg (arg-cont arg)) - (arg-name arg) - default)) - - -;;; ARG-CONSTANT-VALUE -- Interface -;;; -;;; If Arg is null or has no CONT, return the default. Otherwise, Arg's -;;; CONT must be a constant continuation whose value we return. If not, we -;;; give up. -;;; -(defun arg-constant-value (arg default) - (declare (type (or arg null) arg)) - (if (and arg (arg-cont arg)) - (let ((cont (arg-cont arg))) - (unless (constant-continuation-p cont) - (give-up "Argument is not constant: ~S." (arg-name arg))) - (continuation-value from-end)) - default)) - - -;;; ARG-EQL -- Internal -;;; -;;; If Arg is a constant and is EQL to X, then return T, otherwise NIL. If -;;; Arg is NIL or its CONT is NIL, then compare to the default. -;;; -(defun arg-eql (arg default x) - (declare (type (or arg null) x)) - (if (and arg (arg-cont arg)) - (let ((cont (arg-cont arg))) - (and (constant-continuation-p cont) - (eql (continuation-value cont) x))) - (eql default x))) - - -(defstruct iterator - ;; - ;; The kind of iterator. - (kind nil (member :normal :result)) - ;; - ;; A list of LET* bindings to create the initial state. - (binds nil :type list) - ;; - ;; A list of declarations for Binds. - (decls nil :type list) - ;; - ;; A form that returns the current value. This may be set with SETF to set - ;; the current value. - (current (error "Must specify CURRENT.")) - ;; - ;; In a :Normal iterator, a form that tests whether there is a current value. - (done nil) - ;; - ;; In a :Result iterator, a form that truncates the result at the current - ;; position and returns it. - (result nil) - ;; - ;; A form that returns the initial total number of values. The result is - ;; undefined after NEXT has been evaluated. - (length (error "Must specify LENGTH.")) - ;; - ;; A form that advances the state to the next value. It is an error to call - ;; this when the iterator is Done. - (next (error "Must specify NEXT."))) - - -;;; Type of an index var that can go negative (in the from-end case.) -(deftype neg-index () - `(integer -1 ,most-positive-fixnum)) - - -;;; MAKE-SEQUENCE-ITERATOR -- Interface -;;; -;;; Return an ITERATOR structure describing how to iterate over an arbitrary -;;; sequence. Sequence is a variable bound to the sequence, and Type is the -;;; type of the sequence. If true, INDEX is a variable that should be bound to -;;; the index of the current element in the sequence. -;;; -;;; If we can't tell whether the sequence is a list or a vector, or whether -;;; the iteration is forward or backward, then GIVE-UP. -;;; -(defun make-sequence-iterator (sequence type &key start end from-end index) - (declare (symbol sequence) (type ctype type) - (type (or arg null) start end from-end) - (type (or symbol null) index)) - (let ((from-end (arg-constant-value from-end nil))) - (cond ((csubtypep type (specifier-type 'vector)) - (let* ((n-stop (gensym)) - (n-idx (or index (gensym))) - (start (default-arg 0 start)) - (end (default-arg `(length ,sequence) end))) - (make-iterator - :kind :normal - :binds `((,n-idx ,(if from-end `(1- ,end) ,start)) - (,n-stop ,(if from-end `(1- ,start) ,end))) - :decls `((type neg-index ,n-idx ,n-stop)) - :current `(aref ,sequence ,n-idx) - :done `(,(if from-end '<= '>=) ,n-idx ,n-stop) - :next `(setq ,n-idx - ,(if from-end `(1- ,n-idx) `(1+ ,n-idx))) - :length (if from-end - `(- ,n-idx ,n-stop) - `(- ,n-stop ,n-idx))))) - ((csubtypep type (specifier-type 'list)) - (let* ((n-stop (if (and end (not from-end)) (gensym) nil)) - (n-current (gensym)) - (start-p (not (arg-eql start 0 0))) - (end-p (not (arg-eql end nil nil))) - (start (default-arg start 0)) - (end (default-arg end nil))) - (make-iterator - :binds `((,n-current - ,(if from-end - (if (or start-p end-p) - `(nreverse (subseq ,sequence ,start - ,@(when end `(,end)))) - `(reverse ,sequence)) - (if start-p - `(nthcdr ,start ,sequence) - sequence))) - ,@(when n-stop - `((,n-stop (nthcdr (the index - (- ,end ,start)) - ,n-current)))) - ,@(when index - `((,index ,(if from-end `(1- ,end) start))))) - :kind :normal - :decls `((list ,n-current ,n-end) - ,@(when index `((type neg-index ,index)))) - :current `(car ,n-current) - :done `(eq ,n-current ,n-stop) - :length `(- ,(or end `(length ,sequence)) ,start) - :next `(progn - (setq ,n-current (cdr ,n-current)) - ,@(when index - `((setq ,n-idx - ,(if from-end - `(1- ,index) - `(1+ ,index))))))))) - (t - (give-up "Can't tell whether sequence is a list or a vector."))))) - - -;;; MAKE-RESULT-SEQUENCE-ITERATOR -- Interface -;;; -;;; Make an iterator used for constructing result sequences. Name is a -;;; variable to be bound to the result sequence. Type is the type of result -;;; sequence to make. Length is an expression to be evaluated to get the -;;; maximum length of the result (not evaluated in list case.) -;;; -(defun make-result-sequence-iterator (name type length) - (declare (symbol name) (type ctype type)) - -;;; COERCE-FUNCTIONS -- Interface -;;; -;;; Defines each Name as a local macro that will call the value of the -;;; Fun-Arg with the given arguments. If the argument isn't known to be a -;;; function, give them an efficiency note and reference a coerced version. -;;; -(defmacro coerce-functions (specs &body body) - "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*" - (collect ((binds) - (defs)) - (dolist (spec specs) - `(let ((body (progn ,@body)) - (n-fun (arg-name ,(second spec))) - (fun-cont (arg-cont ,(second spec)))) - (cond ((not fun-cont) - `(macrolet ((,',(first spec) (&rest args) - `(,',',(third spec) ,@args))) - ,body)) - ((not (csubtypep (continuation-type fun-cont) - (specifier-type 'function))) - (when (policy *compiler-error-context* (> speed brevity)) - (compiler-note - "~S may not be a function, so must coerce at run-time." - n-fun)) - (once-only ((n-fun `(if (functionp ,n-fun) - ,n-fun - (symbol-function ,n-fun)))) - `(macrolet ((,',(first spec) (&rest args) - `(funcall ,',n-fun ,@args))) - ,body))) - (t - `(macrolet ((,',(first spec) (&rest args) - `(funcall ,',n-fun ,@args))) - ,body))))))) - - -;;; WITH-SEQUENCE-TEST -- Interface -;;; -;;; Wrap code around the result of the body to define Name as a local macro -;;; that returns true when its arguments satisfy the test according to the Args -;;; Test and Test-Not. If both Test and Test-Not are supplied, abort the -;;; transform. -;;; -(defmacro with-sequence-test ((name test test-not) &body body) - `(let ((not-p (arg-cont ,test-not))) - (when (and (arg-cont ,test) not-p) - (abort-transform "Both ~S and ~S supplied." (arg-name ,test) - (arg-name ,test-not))) - (coerce-functions ((,name (if not-p ,test-not ,test) eql)) - ,@body))) - -|# - -;;;; Hairy sequence transforms: - - - -;;;; String operations: - -;;; STRINGxxx transform -- Internal -;;; -;;; We transform the case-sensitive string predicates into a non-keyword -;;; version. This is an IR1 transform so that we don't have to worry about -;;; changing the order of evaluation. -;;; -(dolist (stuff '((string< string<*) - (string> string>*) - (string<= string<=*) - (string>= string>=*) - (string= string=*) - (string/= string/=*))) - (destructuring-bind (fun pred*) stuff - (deftransform fun ((string1 string2 &key (start1 0) end1 - (start2 0) end2) - '* '* :eval-name t) - `(,pred* string1 string2 start1 end1 start2 end2)))) - - -;;; STRING-xxx* transform -- Internal -;;; -;;; Return a form that tests the free variables STRING1 and STRING2 for the -;;; ordering relationship specified by Lessp and Equalp. The start and end are -;;; also gotten from the environment. Both strings must be simple strings. -;;; -(dolist (stuff '((string<* t nil) - (string<=* t t) - (string>* nil nil) - (string>=* nil t))) - (destructuring-bind (name lessp equalp) stuff - (deftransform name ((string1 string2 start1 end1 start2 end2) - '(simple-string simple-string t t t t) '* - :eval-name t) - `(let* ((end1 (if (not end1) (length string1) end1)) - (end2 (if (not end2) (length string2) end2)) - (index (lisp::%sp-string-compare - string1 start1 end1 string2 start2 end2))) - (if index - (cond ((= index ,(if lessp 'end1 'end2)) index) - ((= index ,(if lessp 'end2 'end1)) nil) - ((,(if lessp 'char< 'char>) - (schar string1 index) - (schar string2 - (truly-the index - (+ index - (truly-the fixnum - (- start2 start1)))))) - index) - (t nil)) - ,(if equalp 'end1 'nil)))))) - - -(dolist (stuff '((string=* not) - (string/=* identity))) - (destructuring-bind (name result-fun) stuff - (deftransform name ((string1 string2 start1 end1 start2 end2) - '(simple-string simple-string t t t t) '* - :eval-name t) - `(,result-fun - (lisp::%sp-string-compare - string1 start1 (or end1 (length string1)) - string2 start2 (or end2 (length string2))))))) diff --git a/compiler/sparc/alloc.lisp b/compiler/sparc/alloc.lisp deleted file mode 100644 index 703cc6036dc5f58b06b9379de87afe07290f6cee..0000000000000000000000000000000000000000 --- a/compiler/sparc/alloc.lisp +++ /dev/null @@ -1,192 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/alloc.lisp,v 1.9 1992/12/17 08:59:51 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Allocation VOPs for the SPARC port. -;;; -;;; Written by William Lott. -;;; - -(in-package "SPARC") - - -;;;; LIST and LIST* - -(define-vop (list-or-list*) - (:args (things :more t)) - (:temporary (:scs (descriptor-reg) :type list) ptr) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) - res) - (:info num) - (:results (result :scs (descriptor-reg))) - (:variant-vars star) - (:policy :safe) - (:generator 0 - (cond ((zerop num) - (move result null-tn)) - ((and star (= num 1)) - (move result (tn-ref-tn things))) - (t - (macrolet - ((maybe-load (tn) - (once-only ((tn tn)) - `(sc-case ,tn - ((any-reg descriptor-reg zero null) - ,tn) - (control-stack - (load-stack-tn temp ,tn) - temp))))) - (let* ((cons-cells (if star (1- num) num)) - (alloc (* (pad-data-block cons-size) cons-cells))) - (pseudo-atomic (:extra alloc) - (inst andn res alloc-tn lowtag-mask) - (inst or res list-pointer-type) - (move ptr res) - (dotimes (i (1- cons-cells)) - (storew (maybe-load (tn-ref-tn things)) ptr - cons-car-slot list-pointer-type) - (setf things (tn-ref-across things)) - (inst add ptr ptr (pad-data-block cons-size)) - (storew ptr ptr - (- cons-cdr-slot cons-size) - list-pointer-type)) - (storew (maybe-load (tn-ref-tn things)) ptr - cons-car-slot list-pointer-type) - (storew (if star - (maybe-load (tn-ref-tn (tn-ref-across things))) - null-tn) - ptr cons-cdr-slot list-pointer-type)) - (move result res))))))) - -(define-vop (list list-or-list*) - (:variant nil)) - -(define-vop (list* list-or-list*) - (:variant t)) - - -;;;; Special purpose inline allocators. - -(define-vop (allocate-code-object) - (:args (boxed-arg :scs (any-reg)) - (unboxed-arg :scs (any-reg))) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:temporary (:scs (any-reg) :from (:argument 0)) boxed) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) - (:generator 100 - (inst add boxed boxed-arg (fixnum (1+ code-trace-table-offset-slot))) - (inst and boxed (lognot lowtag-mask)) - (inst srl unboxed unboxed-arg word-shift) - (inst add unboxed lowtag-mask) - (inst and unboxed (lognot lowtag-mask)) - (pseudo-atomic () - ;; Note: we don't have to subtract off the 4 that was added by - ;; pseudo-atomic, because oring in other-pointer-type just adds - ;; it right back. - (inst or result alloc-tn other-pointer-type) - (inst add alloc-tn boxed) - (inst add alloc-tn unboxed) - (inst sll ndescr boxed (- type-bits word-shift)) - (inst or ndescr code-header-type) - (storew ndescr result 0 other-pointer-type) - (storew unboxed result code-code-size-slot other-pointer-type) - (storew null-tn result code-entry-points-slot other-pointer-type) - (storew null-tn result code-debug-info-slot other-pointer-type)))) - -(define-vop (make-fdefn) - (:args (name :scs (descriptor-reg) :to :eval)) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg) :from :argument)) - (:policy :fast-safe) - (:translate make-fdefn) - (:generator 37 - (with-fixed-allocation (result temp fdefn-type fdefn-size) - (inst li temp (make-fixup "_undefined_tramp" :foreign)) - (storew name result fdefn-name-slot other-pointer-type) - (storew null-tn result fdefn-function-slot other-pointer-type) - (storew temp result fdefn-raw-addr-slot other-pointer-type)))) - - -(define-vop (make-closure) - (:args (function :to :save :scs (descriptor-reg))) - (:info length) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:generator 10 - (let ((size (+ length closure-info-offset))) - (pseudo-atomic (:extra (pad-data-block size)) - (inst andn result alloc-tn lowtag-mask) - (inst or result function-pointer-type) - (inst li temp (logior (ash (1- size) type-bits) closure-header-type)) - (storew temp result 0 function-pointer-type))) - (storew function result closure-function-slot function-pointer-type))) - -;;; The compiler likes to be able to directly make value cells. -;;; -(define-vop (make-value-cell) - (:args (value :to :save :scs (descriptor-reg any-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:generator 10 - (with-fixed-allocation - (result temp value-cell-header-type value-cell-size)) - (storew value result value-cell-value-slot other-pointer-type))) - - - -;;;; Automatic allocators for primitive objects. - -(define-vop (make-unbound-marker) - (:args) - (:results (result :scs (any-reg))) - (:generator 1 - (inst li result unbound-marker-type))) - -(define-vop (fixed-alloc) - (:args) - (:info name words type lowtag) - (:ignore name) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 4 - (pseudo-atomic (:extra (pad-data-block words)) - (cond ((logbitp 2 lowtag) - (inst or result alloc-tn lowtag)) - (t - (inst andn result alloc-tn lowtag-mask) - (inst or result lowtag))) - (when type - (inst li temp (logior (ash (1- words) type-bits) type)) - (storew temp result 0 lowtag))))) - -(define-vop (var-alloc) - (:args (extra :scs (any-reg))) - (:arg-types positive-fixnum) - (:info name words type lowtag) - (:ignore name) - (:results (result :scs (descriptor-reg))) - (:temporary (:scs (any-reg)) bytes header) - (:generator 6 - (inst add bytes extra (* (1+ words) word-bytes)) - (inst sll header bytes (- type-bits 2)) - (inst add header header (+ (ash -2 type-bits) type)) - (inst and bytes (lognot lowtag-mask)) - (pseudo-atomic () - (cond ((logbitp 2 lowtag) - (inst or result alloc-tn lowtag)) - (t - (inst andn result alloc-tn lowtag-mask) - (inst or result lowtag))) - (storew header result 0 lowtag) - (inst add alloc-tn alloc-tn bytes)))) diff --git a/compiler/sparc/arith.lisp b/compiler/sparc/arith.lisp deleted file mode 100644 index cd525e1594a29b2d72f4a07b2096f1ce8f16d7c0..0000000000000000000000000000000000000000 --- a/compiler/sparc/arith.lisp +++ /dev/null @@ -1,774 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/arith.lisp,v 1.9 1992/08/02 20:17:04 wlott Exp $ -;;; -;;; This file contains the VM definition arithmetic VOPs for the MIPS. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by William Lott. -;;; - -(in-package "SPARC") - - - -;;;; Unary operations. - -(define-vop (fast-safe-arith-op) - (:policy :fast-safe) - (:effects) - (:affected)) - - -(define-vop (fixnum-unop fast-safe-arith-op) - (:args (x :scs (any-reg))) - (:results (res :scs (any-reg))) - (:note "inline fixnum arithmetic") - (:arg-types tagged-num) - (:result-types tagged-num)) - -(define-vop (signed-unop fast-safe-arith-op) - (:args (x :scs (signed-reg))) - (:results (res :scs (signed-reg))) - (:note "inline (signed-byte 32) arithmetic") - (:arg-types signed-num) - (:result-types signed-num)) - -(define-vop (fast-negate/fixnum fixnum-unop) - (:translate %negate) - (:generator 1 - (inst neg res x))) - -(define-vop (fast-negate/signed signed-unop) - (:translate %negate) - (:generator 2 - (inst neg res x))) - -(define-vop (fast-lognot/fixnum fixnum-unop) - (:translate lognot) - (:generator 2 - (inst xor res x (fixnum -1)))) - -(define-vop (fast-lognot/signed signed-unop) - (:translate lognot) - (:generator 1 - (inst not res x))) - - - -;;;; Binary fixnum operations. - -;;; Assume that any constant operand is the second arg... - -(define-vop (fast-fixnum-binop fast-safe-arith-op) - (:args (x :target r :scs (any-reg zero)) - (y :target r :scs (any-reg zero))) - (:arg-types tagged-num tagged-num) - (:results (r :scs (any-reg))) - (:result-types tagged-num) - (:note "inline fixnum arithmetic")) - -(define-vop (fast-unsigned-binop fast-safe-arith-op) - (:args (x :target r :scs (unsigned-reg zero)) - (y :target r :scs (unsigned-reg zero))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:note "inline (unsigned-byte 32) arithmetic")) - -(define-vop (fast-signed-binop fast-safe-arith-op) - (:args (x :target r :scs (signed-reg zero)) - (y :target r :scs (signed-reg zero))) - (:arg-types signed-num signed-num) - (:results (r :scs (signed-reg))) - (:result-types signed-num) - (:note "inline (signed-byte 32) arithmetic")) - - -(define-vop (fast-fixnum-binop-c fast-safe-arith-op) - (:args (x :target r :scs (any-reg zero))) - (:info y) - (:arg-types tagged-num - (:constant (and (signed-byte 11) (not (integer 0 0))))) - (:results (r :scs (any-reg))) - (:result-types tagged-num) - (:note "inline fixnum arithmetic")) - -(define-vop (fast-unsigned-binop-c fast-safe-arith-op) - (:args (x :target r :scs (unsigned-reg zero))) - (:info y) - (:arg-types unsigned-num - (:constant (and (signed-byte 13) (not (integer 0 0))))) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:note "inline (unsigned-byte 32) arithmetic")) - -(define-vop (fast-signed-binop-c fast-safe-arith-op) - (:args (x :target r :scs (signed-reg zero))) - (:info y) - (:arg-types signed-num - (:constant (and (signed-byte 13) (not (integer 0 0))))) - (:results (r :scs (signed-reg))) - (:result-types signed-num) - (:note "inline (signed-byte 32) arithmetic")) - - -(eval-when (compile load eval) - -(defmacro define-binop (translate untagged-penalty op) - `(progn - (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") - fast-fixnum-binop) - (:translate ,translate) - (:generator 2 - (inst ,op r x y))) - (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum) - fast-fixnum-binop-c) - (:translate ,translate) - (:generator 1 - (inst ,op r x (fixnum y)))) - (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") - fast-signed-binop) - (:translate ,translate) - (:generator ,(1+ untagged-penalty) - (inst ,op r x y))) - (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed) - fast-signed-binop-c) - (:translate ,translate) - (:generator ,untagged-penalty - (inst ,op r x y))) - (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") - fast-unsigned-binop) - (:translate ,translate) - (:generator ,(1+ untagged-penalty) - (inst ,op r x y))) - (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned) - fast-unsigned-binop-c) - (:translate ,translate) - (:generator ,untagged-penalty - (inst ,op r x y))))) - -); eval-when - -(define-binop + 4 add) -(define-binop - 4 sub) -(define-binop logand 2 and) -(define-binop logandc2 2 andn) -(define-binop logior 2 or) -(define-binop logorc2 2 orn) -(define-binop logxor 2 xor) -(define-binop logeqv 2 xnor) - -;;; Special case fixnum + and - that trap on overflow. Useful when we -;;; don't know that the output type is a fixnum. - -(define-vop (+/fixnum fast-+/fixnum=>fixnum) - (:policy :safe) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "safe inline fixnum arithmetic") - (:generator 4 - (inst taddcctv r x y))) - -(define-vop (+-c/fixnum fast-+-c/fixnum=>fixnum) - (:policy :safe) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "safe inline fixnum arithmetic") - (:generator 3 - (inst taddcctv r x (fixnum y)))) - -(define-vop (-/fixnum fast--/fixnum=>fixnum) - (:policy :safe) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "safe inline fixnum arithmetic") - (:generator 4 - (inst tsubcctv r x y))) - -(define-vop (--c/fixnum fast---c/fixnum=>fixnum) - (:policy :safe) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "safe inline fixnum arithmetic") - (:generator 3 - (inst tsubcctv r x (fixnum y)))) - -;;; Shifting - -(define-vop (fast-ash) - (:note "inline ASH") - (:args (number :scs (signed-reg unsigned-reg) :to :save) - (amount :scs (signed-reg immediate))) - (:arg-types (:or signed-num unsigned-num) signed-num) - (:results (result :scs (signed-reg unsigned-reg))) - (:result-types (:or signed-num unsigned-num)) - (:translate ash) - (:policy :fast-safe) - (:temporary (:sc non-descriptor-reg) ndesc) - (:generator 3 - (sc-case amount - (signed-reg - (let ((positive (gen-label)) - (done (gen-label))) - (inst cmp amount) - (inst b :ge positive) - (inst neg ndesc amount) - (inst cmp ndesc 31) - (inst b :le done) - (sc-case number - (signed-reg (inst sra result number ndesc)) - (unsigned-reg (inst srl result number ndesc))) - (inst b done) - (sc-case number - (signed-reg (inst sra result number 31)) - (unsigned-reg (inst srl result number 31))) - - (emit-label positive) - ;; The result-type assures us that this shift will not overflow. - (inst sll result number amount) - - (emit-label done))) - - (immediate - (let ((amount (tn-value amount))) - (if (minusp amount) - (let ((amount (min 31 (- amount)))) - (sc-case number - (unsigned-reg - (inst srl result number amount)) - (signed-reg - (inst sra result number amount)))) - (inst sll result number amount))))))) - - - -(define-vop (signed-byte-32-len) - (:translate integer-length) - (:note "inline (signed-byte 32) integer-length") - (:policy :fast-safe) - (:args (arg :scs (signed-reg) :target shift)) - (:arg-types signed-num) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) - (:generator 30 - (let ((loop (gen-label)) - (test (gen-label))) - (inst addcc shift zero-tn arg) - (inst b :ge test) - (move res zero-tn) - (inst b test) - (inst not shift) - - (emit-label loop) - (inst add res (fixnum 1)) - - (emit-label test) - (inst cmp shift) - (inst b :ne loop) - (inst srl shift 1)))) - -(define-vop (unsigned-byte-32-count) - (:translate logcount) - (:note "inline (unsigned-byte 32) logcount") - (:policy :fast-safe) - (:args (arg :scs (unsigned-reg) :target shift)) - (:arg-types unsigned-num) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp) - (:generator 30 - (let ((loop (gen-label)) - (done (gen-label))) - (inst addcc shift zero-tn arg) - (inst b :eq done) - (move res zero-tn) - - (emit-label loop) - (inst sub temp shift 1) - (inst andcc shift temp) - (inst b :ne loop) - (inst add res (fixnum 1)) - - (emit-label done)))) - - -;;;; Binary conditional VOPs: - -(define-vop (fast-conditional) - (:conditional) - (:info target not-p) - (:effects) - (:affected) - (:policy :fast-safe)) - -(deftype integer-with-a-bite-out (s bite) - (cond ((eq s '*) 'integer) - ((and (integerp s) (> s 1)) - (let ((bound (ash 1 (1- s)))) - `(integer ,(- bound) ,(- bound bite 1)))) - (t - (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) - -(define-vop (fast-conditional/fixnum fast-conditional) - (:args (x :scs (any-reg zero)) - (y :scs (any-reg zero))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison")) - -(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg zero))) - (:arg-types tagged-num (:constant (signed-byte 11))) - (:info target not-p y)) - -(define-vop (fast-conditional/signed fast-conditional) - (:args (x :scs (signed-reg zero)) - (y :scs (signed-reg zero))) - (:arg-types signed-num signed-num) - (:note "inline (signed-byte 32) comparison")) - -(define-vop (fast-conditional-c/signed fast-conditional/signed) - (:args (x :scs (signed-reg zero))) - (:arg-types signed-num (:constant (signed-byte 13))) - (:info target not-p y)) - -(define-vop (fast-conditional/unsigned fast-conditional) - (:args (x :scs (unsigned-reg zero)) - (y :scs (unsigned-reg zero))) - (:arg-types unsigned-num unsigned-num) - (:note "inline (unsigned-byte 32) comparison")) - -(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) - (:args (x :scs (unsigned-reg zero))) - (:arg-types unsigned-num (:constant (unsigned-byte 12))) - (:info target not-p y)) - - -(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned) - `(progn - ,@(mapcar #'(lambda (suffix cost signed) - (unless (and (member suffix '(/fixnum -c/fixnum)) - (eq tran 'eql)) - `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" - tran suffix)) - ,(intern - (format nil "~:@(FAST-CONDITIONAL~A~)" - suffix))) - (:translate ,tran) - (:generator ,cost - (inst cmp x - ,(if (eq suffix '-c/fixnum) '(fixnum y) 'y)) - (inst b (if not-p - ,(if signed not-cond not-unsigned) - ,(if signed cond unsigned)) - target) - (inst nop))))) - '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) - '(4 3 6 5 6 5) - '(t t t t nil nil)))) - -(define-conditional-vop < :lt :ltu :ge :geu) - -(define-conditional-vop > :gt :gtu :le :leu) - -(define-conditional-vop eql :eq :eq :ne :ne) - -;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a -;;; known fixnum. - -;;; These versions specify a fixnum restriction on their first arg. We have -;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on -;;; the first arg and a higher cost. The reason for doing this is to prevent -;;; fixnum specific operations from being used on word integers, spuriously -;;; consing the argument. -;;; - -(define-vop (fast-eql/fixnum fast-conditional) - (:args (x :scs (any-reg descriptor-reg zero)) - (y :scs (any-reg zero))) - (:arg-types tagged-num tagged-num) - (:note "inline fixnum comparison") - (:translate eql) - (:generator 4 - (inst cmp x y) - (inst b (if not-p :ne :eq) target) - (inst nop))) -;;; -(define-vop (generic-eql/fixnum fast-eql/fixnum) - (:arg-types * tagged-num) - (:variant-cost 7)) - -(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg descriptor-reg zero))) - (:arg-types tagged-num (:constant (signed-byte 11))) - (:info target not-p y) - (:translate eql) - (:generator 2 - (inst cmp x (fixnum y)) - (inst b (if not-p :ne :eq) target) - (inst nop))) -;;; -(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) - (:arg-types * (:constant (signed-byte 11))) - (:variant-cost 6)) - - -;;;; 32-bit logical operations - -(define-vop (merge-bits) - (:translate merge-bits) - (:args (shift :scs (signed-reg unsigned-reg)) - (prev :scs (unsigned-reg)) - (next :scs (unsigned-reg))) - (:arg-types tagged-num unsigned-num unsigned-num) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:policy :fast-safe) - (:generator 4 - (let ((done (gen-label))) - (inst cmp shift) - (inst b :eq done) - (inst srl res next shift) - (inst sub temp zero-tn shift) - (inst sll temp prev temp) - (inst or res temp) - (emit-label done) - (move result res)))) - - -(define-vop (32bit-logical) - (:args (x :scs (unsigned-reg zero)) - (y :scs (unsigned-reg zero))) - (:arg-types unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:policy :fast-safe)) - -(define-vop (32bit-logical-not 32bit-logical) - (:translate 32bit-logical-not) - (:args (x :scs (unsigned-reg zero))) - (:arg-types unsigned-num) - (:generator 1 - (inst not r x))) - -(define-vop (32bit-logical-and 32bit-logical) - (:translate 32bit-logical-and) - (:generator 1 - (inst and r x y))) - -(deftransform 32bit-logical-nand ((x y) (* *)) - '(32bit-logical-not (32bit-logical-and x y))) - -(define-vop (32bit-logical-or 32bit-logical) - (:translate 32bit-logical-or) - (:generator 1 - (inst or r x y))) - -(deftransform 32bit-logical-nor ((x y) (* *)) - '(32bit-logical-not (32bit-logical-or x y))) - -(define-vop (32bit-logical-xor 32bit-logical) - (:translate 32bit-logical-xor) - (:generator 1 - (inst xor r x y))) - -(define-vop (32bit-logical-eqv 32bit-logical) - (:translate 32bit-logical-eqv) - (:generator 1 - (inst xnor r x y))) - -(define-vop (32bit-logical-orc2 32bit-logical) - (:translate 32bit-logical-orc2) - (:generator 1 - (inst orn r x y))) - -(deftransform 32bit-logical-orc1 ((x y) (* *)) - '(32bit-logical-orc2 y x)) - -(define-vop (32bit-logical-andc2 32bit-logical) - (:translate 32bit-logical-andc2) - (:generator 1 - (inst andn r x y))) - -(deftransform 32bit-logical-andc1 ((x y) (* *)) - '(32bit-logical-andc2 y x)) - - -(define-vop (shift-towards-someplace) - (:policy :fast-safe) - (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) - (:arg-types unsigned-num tagged-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (shift-towards-start shift-towards-someplace) - (:translate shift-towards-start) - (:note "shift-towards-start") - (:generator 1 - (inst sll r num amount))) - -(define-vop (shift-towards-end shift-towards-someplace) - (:translate shift-towards-end) - (:note "shift-towards-end") - (:generator 1 - (inst srl r num amount))) - - - - -;;;; Bignum stuff. - -(define-vop (bignum-length get-header-data) - (:translate bignum::%bignum-length) - (:policy :fast-safe)) - -(define-vop (bignum-set-length set-header-data) - (:translate bignum::%bignum-set-length) - (:policy :fast-safe)) - -(define-vop (bignum-ref word-index-ref) - (:variant vm:bignum-digits-offset vm:other-pointer-type) - (:translate bignum::%bignum-ref) - (:results (value :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (bignum-set word-index-set) - (:variant vm:bignum-digits-offset vm:other-pointer-type) - (:translate bignum::%bignum-set) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg immediate zero)) - (value :scs (unsigned-reg))) - (:arg-types t positive-fixnum unsigned-num) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num)) - -(define-vop (digit-0-or-plus) - (:translate bignum::%digit-0-or-plusp) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (result :scs (descriptor-reg))) - (:generator 3 - (let ((done (gen-label))) - (inst cmp digit) - (inst b :lt done) - (move result null-tn) - (load-symbol result t) - (emit-label done)))) - -(define-vop (add-w/carry) - (:translate bignum::%add-with-carry) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (any-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg)) - (carry :scs (unsigned-reg))) - (:result-types unsigned-num positive-fixnum) - (:generator 3 - (inst addcc zero-tn c -1) - (inst addxcc result a b) - (inst addx carry zero-tn zero-tn))) - -(define-vop (sub-w/borrow) - (:translate bignum::%subtract-with-borrow) - (:policy :fast-safe) - (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (any-reg))) - (:arg-types unsigned-num unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg)) - (borrow :scs (unsigned-reg))) - (:result-types unsigned-num positive-fixnum) - (:generator 4 - (inst subcc zero-tn c 1) - (inst subxcc result a b) - (inst addx borrow zero-tn zero-tn) - (inst xor borrow 1))) - -;;; EMIT-MULTIPLY -- This is used both for bignum stuff and in assembly -;;; routines. -;;; -(defun emit-multiply (multiplier multiplicand result-high result-low) - "Emit code to multiply MULTIPLIER with MULTIPLICAND, putting the result - in RESULT-HIGH and RESULT-LOW. KIND is either :signed or :unsigned. - Note: the lifetimes of MULTIPLICAND and RESULT-HIGH overlap." - (declare (type tn multiplier result-high result-low) - (type (or tn (signed-byte 13)) multiplicand)) - (let ((label (gen-label))) - (inst wry multiplier) - (inst andcc result-high zero-tn) - ;; Note: we can't use the Y register until three insts after it's written. - (inst nop) - (inst nop) - (dotimes (i 32) - (inst mulscc result-high multiplicand)) - (inst mulscc result-high zero-tn) - (inst cmp multiplicand) - (inst b :ge label) - (inst nop) - (inst add result-high multiplier) - (emit-label label) - (inst rdy result-low))) - -(define-vop (bignum-mult-and-add-3-arg) - (:translate bignum::%multiply-and-add) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg) :to (:eval 1)) - (y :scs (unsigned-reg) :to (:eval 1)) - (carry-in :scs (unsigned-reg) :to (:eval 2))) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:results (hi :scs (unsigned-reg) :from (:eval 0)) - (lo :scs (unsigned-reg) :from (:eval 1))) - (:result-types unsigned-num unsigned-num) - (:generator 40 - (emit-multiply x y hi lo) - (inst addcc lo carry-in) - (inst addx hi zero-tn))) - -(define-vop (bignum-mult-and-add-4-arg) - (:translate bignum::%multiply-and-add) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg) :to (:eval 1)) - (y :scs (unsigned-reg) :to (:eval 1)) - (prev :scs (unsigned-reg) :to (:eval 2)) - (carry-in :scs (unsigned-reg) :to (:eval 2))) - (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) - (:results (hi :scs (unsigned-reg) :from (:eval 0)) - (lo :scs (unsigned-reg) :from (:eval 1))) - (:result-types unsigned-num unsigned-num) - (:generator 40 - (emit-multiply x y hi lo) - (inst addcc lo carry-in) - (inst addx hi zero-tn) - (inst addcc lo prev) - (inst addx hi zero-tn))) - -(define-vop (bignum-mult) - (:translate bignum::%multiply) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg) :to (:result 1)) - (y :scs (unsigned-reg) :to (:result 1))) - (:arg-types unsigned-num unsigned-num) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:generator 40 - (emit-multiply x y hi lo))) - -(define-vop (bignum-lognot) - (:translate bignum::%lognot) - (:policy :fast-safe) - (:args (x :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst not r x))) - -(define-vop (fixnum-to-digit) - (:translate bignum::%fixnum-to-digit) - (:policy :fast-safe) - (:args (fixnum :scs (any-reg))) - (:arg-types tagged-num) - (:results (digit :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst sra digit fixnum 2))) - -(define-vop (bignum-floor) - (:translate bignum::%floor) - (:policy :fast-safe) - (:args (div-high :scs (unsigned-reg) :target rem) - (div-low :scs (unsigned-reg) :target quo) - (divisor :scs (unsigned-reg))) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:results (quo :scs (unsigned-reg) :from (:argument 1)) - (rem :scs (unsigned-reg) :from (:argument 0))) - (:result-types unsigned-num unsigned-num) - (:generator 300 - (move rem div-high) - (move quo div-low) - (dotimes (i 33) - (let ((label (gen-label))) - (inst cmp rem divisor) - (inst b :ltu label) - (inst addxcc quo quo) - (inst sub rem divisor) - (emit-label label) - (unless (= i 32) - (inst addx rem rem)))) - (inst not quo))) - -(define-vop (signify-digit) - (:translate bignum::%fixnum-digit-with-correct-sign) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg) :target res)) - (:arg-types unsigned-num) - (:results (res :scs (any-reg signed-reg))) - (:result-types signed-num) - (:generator 1 - (sc-case res - (any-reg - (inst sll res digit 2)) - (signed-reg - (move res digit))))) - - -(define-vop (digit-ashr) - (:translate bignum::%ashr) - (:policy :fast-safe) - (:args (digit :scs (unsigned-reg)) - (count :scs (unsigned-reg))) - (:arg-types unsigned-num positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (inst sra result digit count))) - -(define-vop (digit-lshr digit-ashr) - (:translate bignum::%digit-logical-shift-right) - (:generator 1 - (inst srl result digit count))) - -(define-vop (digit-ashl digit-ashr) - (:translate bignum::%ashl) - (:generator 1 - (inst sll result digit count))) - - -;;;; Static functions. - -(define-static-function two-arg-gcd (x y) :translate gcd) -(define-static-function two-arg-lcm (x y) :translate lcm) - -(define-static-function two-arg-+ (x y) :translate +) -(define-static-function two-arg-- (x y) :translate -) -(define-static-function two-arg-* (x y) :translate *) -(define-static-function two-arg-/ (x y) :translate /) - -(define-static-function two-arg-< (x y) :translate <) -(define-static-function two-arg-<= (x y) :translate <=) -(define-static-function two-arg-> (x y) :translate >) -(define-static-function two-arg->= (x y) :translate >=) -(define-static-function two-arg-= (x y) :translate =) -(define-static-function two-arg-/= (x y) :translate /=) - -(define-static-function %negate (x) :translate %negate) - -(define-static-function two-arg-and (x y) :translate logand) -(define-static-function two-arg-ior (x y) :translate logior) -(define-static-function two-arg-xor (x y) :translate logxor) diff --git a/compiler/sparc/array.lisp b/compiler/sparc/array.lisp deleted file mode 100644 index 841f46ae93c6ea5f070b5e29284429ae2ca2965c..0000000000000000000000000000000000000000 --- a/compiler/sparc/array.lisp +++ /dev/null @@ -1,428 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/array.lisp,v 1.10 1992/10/11 10:54:20 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the SPARC definitions for array operations. -;;; -;;; Written by William Lott -;;; -(in-package "SPARC") - - -;;;; Allocator for the array header. - -(define-vop (make-array-header) - (:translate make-array-header) - (:policy :fast-safe) - (:args (type :scs (any-reg)) - (rank :scs (any-reg))) - (:arg-types tagged-num tagged-num) - (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (result :scs (descriptor-reg))) - (:generator 0 - (pseudo-atomic () - (inst or header alloc-tn other-pointer-type) - (inst add ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes)) - (inst andn ndescr 4) - (inst add alloc-tn ndescr) - (inst add ndescr rank (fixnum (1- vm:array-dimensions-offset))) - (inst sll ndescr ndescr vm:type-bits) - (inst or ndescr ndescr type) - (inst srl ndescr ndescr 2) - (storew ndescr header 0 vm:other-pointer-type)) - (move result header))) - - -;;;; Additional accessors and setters for the array header. - -(defknown lisp::%array-dimension (t fixnum) fixnum - (flushable)) -(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum - ()) - -(define-vop (%array-dimension word-index-ref) - (:translate lisp::%array-dimension) - (:policy :fast-safe) - (:variant vm:array-dimensions-offset vm:other-pointer-type)) - -(define-vop (%set-array-dimension word-index-set) - (:translate lisp::%set-array-dimension) - (:policy :fast-safe) - (:variant vm:array-dimensions-offset vm:other-pointer-type)) - - - -(defknown lisp::%array-rank (t) fixnum (flushable)) - -(define-vop (array-rank-vop) - (:translate lisp::%array-rank) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadw temp x 0 vm:other-pointer-type) - (inst sra temp vm:type-bits) - (inst sub temp (1- vm:array-dimensions-offset)) - (inst sll res temp 2))) - - - -;;;; Bounds checking routine. - - -(define-vop (check-bound) - (:translate %check-bound) - (:policy :fast-safe) - (:args (array :scs (descriptor-reg)) - (bound :scs (any-reg descriptor-reg)) - (index :scs (any-reg descriptor-reg) :target result)) - (:results (result :scs (any-reg descriptor-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (let ((error (generate-error-code vop invalid-array-index-error - array bound index))) - (inst cmp index bound) - (inst b :geu error) - (inst nop) - (move result index)))) - - - -;;;; Accessors/Setters - -;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos -;;; elements are represented in integer registers and are built out of -;;; 8, 16, or 32 bit elements. - -(defmacro def-data-vector-frobs (type variant element-type &rest scs) - `(progn - (define-vop (,(intern (concatenate 'simple-string - "DATA-VECTOR-REF/" - (string type))) - ,(intern (concatenate 'simple-string - (string variant) - "-REF"))) - (:note "inline array access") - (:variant vm:vector-data-offset vm:other-pointer-type) - (:translate data-vector-ref) - (:arg-types ,type positive-fixnum) - (:results (value :scs ,scs)) - (:result-types ,element-type)) - (define-vop (,(intern (concatenate 'simple-string - "DATA-VECTOR-SET/" - (string type))) - ,(intern (concatenate 'simple-string - (string variant) - "-SET"))) - (:note "inline array store") - (:variant vm:vector-data-offset vm:other-pointer-type) - (:translate data-vector-set) - (:arg-types ,type positive-fixnum ,element-type) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg zero immediate)) - (value :scs ,scs)) - (:results (result :scs ,scs)) - (:result-types ,element-type)))) - -(def-data-vector-frobs simple-string byte-index - base-char base-char-reg) -(def-data-vector-frobs simple-vector word-index - * descriptor-reg any-reg) - -(def-data-vector-frobs simple-array-unsigned-byte-8 byte-index - positive-fixnum unsigned-reg) -(def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index - positive-fixnum unsigned-reg) -(def-data-vector-frobs simple-array-unsigned-byte-32 word-index - unsigned-num unsigned-reg) - - -;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, -;;; and 4-bit vectors. -;;; - -(eval-when (compile eval) - -(defmacro def-small-data-vector-frobs (type bits) - (let* ((elements-per-word (floor vm:word-bits bits)) - (bit-shift (1- (integer-length elements-per-word)))) - `(progn - (define-vop (,(symbolicate 'data-vector-ref/ type)) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (value :scs (any-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) - (:generator 20 - (inst srl temp index ,bit-shift) - (inst sll temp 2) - (inst add temp (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst ld result object temp) - (inst and temp index ,(1- elements-per-word)) - (inst xor temp ,(1- elements-per-word)) - ,@(unless (= bits 1) - `((inst sll temp ,(1- (integer-length bits))))) - (inst srl result temp) - (inst and result ,(1- (ash 1 bits))) - (inst sll value result 2))) - (define-vop (,(symbolicate 'data-vector-ref-c/ type)) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:arg-types ,type (:constant index)) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 15 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (setf extra (logxor extra (1- ,elements-per-word))) - (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) - vm:other-pointer-type))) - (cond ((typep offset '(signed-byte 13)) - (inst ld result object offset)) - (t - (inst li temp offset) - (inst ld result object temp)))) - (unless (zerop extra) - (inst srl result - (logxor (* extra ,bits) ,(1- elements-per-word)))) - (unless (= extra ,(1- elements-per-word)) - (inst and result ,(1- (ash 1 bits))))))) - (define-vop (,(symbolicate 'data-vector-set/ type)) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg) :target shift) - (value :scs (unsigned-reg zero immediate) :target result)) - (:arg-types ,type positive-fixnum positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp old offset) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift) - (:generator 25 - (inst srl offset index ,bit-shift) - (inst sll offset 2) - (inst add offset (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst ld old object offset) - (inst and shift index ,(1- elements-per-word)) - (inst xor shift ,(1- elements-per-word)) - ,@(unless (= bits 1) - `((inst sll shift ,(1- (integer-length bits))))) - (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) - (inst li temp ,(1- (ash 1 bits))) - (inst sll temp shift) - (inst not temp) - (inst and old temp)) - (unless (sc-is value zero) - (sc-case value - (immediate - (inst li temp (logand (tn-value value) ,(1- (ash 1 bits))))) - (unsigned-reg - (inst and temp value ,(1- (ash 1 bits))))) - (inst sll temp shift) - (inst or old temp)) - (inst st old object offset) - (sc-case value - (immediate - (inst li result (tn-value value))) - (t - (move result value))))) - (define-vop (,(symbolicate 'data-vector-set-c/ type)) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs (unsigned-reg zero immediate) :target result)) - (:arg-types ,type - (:constant index) - positive-fixnum) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) offset-reg temp old) - (:generator 20 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) - vm:other-pointer-type))) - (cond ((typep offset '(signed-byte 13)) - (inst ld old object offset)) - (t - (inst li offset-reg offset) - (inst ld old object offset-reg))) - (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) - (cond ((zerop extra) - (inst sll old ,bits) - (inst srl old ,bits)) - (t - (inst li temp - (lognot (ash ,(1- (ash 1 bits)) - (* (logxor extra - ,(1- elements-per-word)) - ,bits)))) - (inst and old temp)))) - (sc-case value - (zero) - (immediate - (let ((value (ash (logand (tn-value value) - ,(1- (ash 1 bits))) - (* (logxor extra - ,(1- elements-per-word)) - ,bits)))) - (cond ((typep value '(signed-byte 13)) - (inst or old value)) - (t - (inst li temp value) - (inst or old temp))))) - (unsigned-reg - (inst sll temp value - (* (logxor extra ,(1- elements-per-word)) ,bits)) - (inst or old temp))) - (if (typep offset '(signed-byte 13)) - (inst st old object offset) - (inst st old object offset-reg))) - (sc-case value - (immediate - (inst li result (tn-value value))) - (t - (move result value))))))))) - -); eval-when (compile eval) - -(def-small-data-vector-frobs simple-bit-vector 1) -(def-small-data-vector-frobs simple-array-unsigned-byte-2 2) -(def-small-data-vector-frobs simple-array-unsigned-byte-4 4) - - -;;; And the float variants. -;;; - -(define-vop (data-vector-ref/simple-array-single-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-single-float positive-fixnum) - (:results (value :scs (single-reg))) - (:temporary (:scs (non-descriptor-reg)) offset) - (:result-types single-float) - (:generator 5 - (inst add offset index (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst ldf value object offset))) - - -(define-vop (data-vector-set/simple-array-single-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (single-reg) :target result)) - (:arg-types simple-array-single-float positive-fixnum single-float) - (:results (result :scs (single-reg))) - (:result-types single-float) - (:temporary (:scs (non-descriptor-reg)) offset) - (:generator 5 - (inst add offset index - (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst stf value object offset) - (unless (location= result value) - (inst fmovs result value)))) - -(define-vop (data-vector-ref/simple-array-double-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-double-float positive-fixnum) - (:results (value :scs (double-reg))) - (:result-types double-float) - (:temporary (:scs (non-descriptor-reg)) offset) - (:generator 7 - (inst sll offset index 1) - (inst add offset (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst lddf value object offset))) - -(define-vop (data-vector-set/simple-array-double-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (double-reg) :target result)) - (:arg-types simple-array-double-float positive-fixnum double-float) - (:results (result :scs (double-reg))) - (:result-types double-float) - (:temporary (:scs (non-descriptor-reg)) offset) - (:generator 20 - (inst sll offset index 1) - (inst add offset (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) - (inst stdf value object offset) - (unless (location= result value) - (inst fmovs result value) - (inst fmovs-odd result value)))) - -;;; These vops are useful for accessing the bits of a vector irrespective of -;;; what type of vector it is. -;;; - -(define-vop (raw-bits word-index-ref) - (:note "raw-bits VOP") - (:translate %raw-bits) - (:results (value :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant 0 vm:other-pointer-type)) - -(define-vop (set-raw-bits word-index-set) - (:note "setf raw-bits VOP") - (:translate %set-raw-bits) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg zero immediate)) - (value :scs (unsigned-reg))) - (:arg-types * positive-fixnum unsigned-num) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant 0 vm:other-pointer-type)) - - - -;;;; Misc. Array VOPs. - - -#+nil -(define-vop (vector-word-length) - (:args (vec :scs (descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 6 - (loadw res vec clc::g-vector-header-words) - (inst niuo res res clc::g-vector-words-mask-16))) - -(define-vop (get-vector-subtype get-header-data)) -(define-vop (set-vector-subtype set-header-data)) - diff --git a/compiler/sparc/c-call.lisp b/compiler/sparc/c-call.lisp deleted file mode 100644 index 2cbc597ed93fe9676f72d560650a827f7b14ce0c..0000000000000000000000000000000000000000 --- a/compiler/sparc/c-call.lisp +++ /dev/null @@ -1,180 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/c-call.lisp,v 1.9 1992/04/28 15:41:03 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VOPs and other necessary machine specific support -;;; routines for call-out to C. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") -(use-package "ALIEN") -(use-package "ALIEN-INTERNALS") - -(defun my-make-wired-tn (prim-type-name sc-name offset) - (make-wired-tn (primitive-type-or-lose prim-type-name *backend*) - (sc-number-or-lose sc-name *backend*) - offset)) - -(defstruct arg-state - (register-args 0) - ;; No matter what we have to allocate at least 7 stack frame slots. One - ;; because the C call convention requries it, and 6 because whoever we call - ;; is going to expect to be able to save his 6 register arguments there. - (stack-frame-size 7)) - -(defun int-arg (state prim-type reg-sc stack-sc) - (let ((reg-args (arg-state-register-args state))) - (cond ((< reg-args 6) - (setf (arg-state-register-args state) (1+ reg-args)) - (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset))) - (t - (let ((frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ frame-size)) - (my-make-wired-tn prim-type stack-sc (+ frame-size 16))))))) - -(def-alien-type-method (integer :arg-tn) (type state) - (if (alien-integer-type-signed type) - (int-arg state 'signed-byte-32 'signed-reg 'signed-stack) - (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))) - -(def-alien-type-method (system-area-pointer :arg-tn) (type state) - (declare (ignore type)) - (int-arg state 'system-area-pointer 'sap-reg 'sap-stack)) - -(def-alien-type-method (integer :result-tn) (type) - (if (alien-integer-type-signed type) - (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset) - (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset))) - -(def-alien-type-method (system-area-pointer :result-tn) (type) - (declare (ignore type)) - (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset)) - -(def-alien-type-method (double-float :result-tn) (type) - (declare (ignore type)) - (my-make-wired-tn 'double-float 'double-reg 0)) - -(def-alien-type-method (values :result-tn) (type) - (mapcar #'(lambda (type) - (invoke-alien-type-method :result-tn type)) - (alien-values-type-values type))) - - -(def-vm-support-routine make-call-out-tns (type) - (declare (type alien-function-type type)) - (let ((arg-state (make-arg-state))) - (collect ((arg-tns)) - (dolist (arg-type (alien-function-type-arg-types type)) - (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) - (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset) - (* (arg-state-stack-frame-size arg-state) word-bytes) - (arg-tns) - (invoke-alien-type-method - :result-tn - (alien-function-type-result-type type)))))) - -(deftransform %alien-funcall ((function type &rest args)) - (assert (c::constant-continuation-p type)) - (let* ((type (c::continuation-value type)) - (arg-types (alien-function-type-arg-types type)) - (result-type (alien-function-type-result-type type))) - (assert (= (length arg-types) (length args))) - (if (some #'alien-double-float-type-p arg-types) - (collect ((new-args) (lambda-vars) (new-arg-types)) - (dolist (type arg-types) - (let ((arg (gensym))) - (lambda-vars arg) - (cond ((alien-double-float-type-p type) - (new-args `(double-float-high-bits ,arg)) - (new-args `(double-float-low-bits ,arg)) - (new-arg-types (parse-alien-type '(signed 32))) - (new-arg-types (parse-alien-type '(unsigned 32)))) - (t - (new-args arg) - (new-arg-types type))))) - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (%alien-funcall function - ',(make-alien-function-type - :arg-types (new-arg-types) - :result-type result-type) - ,@(new-args)))) - (c::give-up)))) - - -(define-vop (foreign-symbol-address) - (:translate foreign-symbol-address) - (:policy :fast-safe) - (:args) - (:arg-types (:constant simple-string)) - (:info foreign-symbol) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst li res (make-fixup (concatenate 'simple-string "_" foreign-symbol) - :foreign)))) - -(define-vop (call-out) - (:args (function :scs (sap-reg) :target cfunc) - (args :more t)) - (:results (results :more t)) - (:ignore args results) - (:save-p t) - (:temporary (:sc any-reg :offset cfunc-offset - :from (:argument 0) :to (:result 0)) cfunc) - (:temporary (:sc interior-reg :offset lip-offset) lip) - (:temporary (:scs (any-reg) :to (:result 0)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:vop-var vop) - (:generator 0 - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (move cfunc function) - (inst li temp (make-fixup "_call_into_c" :foreign)) - (inst jal lip temp) - (inst nop) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) - - -(define-vop (alloc-number-stack-space) - (:info amount) - (:results (result :scs (sap-reg any-reg))) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 0 - (unless (zerop amount) - (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 12)) - (inst sub nsp-tn delta)) - (t - (inst li temp delta) - (inst sub nsp-tn temp))))) - (unless (location= result nsp-tn) - ;; They are only location= when the result tn was allocated by - ;; make-call-out-tns above, which takes the number-stack-displacement - ;; into account itself. - (inst add result nsp-tn number-stack-displacement)))) - -(define-vop (dealloc-number-stack-space) - (:info amount) - (:policy :fast-safe) - (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) - (:generator 0 - (unless (zerop amount) - (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 12)) - (inst add nsp-tn delta)) - (t - (inst li temp delta) - (inst add nsp-tn temp))))))) diff --git a/compiler/sparc/call.lisp b/compiler/sparc/call.lisp deleted file mode 100644 index 9c09b581aa1f9a694584e3527ae049d3b8148f6a..0000000000000000000000000000000000000000 --- a/compiler/sparc/call.lisp +++ /dev/null @@ -1,1239 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/call.lisp,v 1.21 1992/12/17 09:39:14 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of function call for the SPARC. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") - - -;;;; Interfaces to IR2 conversion: - -;;; Standard-Argument-Location -- Interface -;;; -;;; Return a wired TN describing the N'th full call argument passing -;;; location. -;;; -(def-vm-support-routine standard-argument-location (n) - (declare (type unsigned-byte n)) - (if (< n register-arg-count) - (make-wired-tn *any-primitive-type* register-arg-scn - (elt register-arg-offsets n)) - (make-wired-tn *any-primitive-type* control-stack-arg-scn n))) - - -;;; Make-Return-PC-Passing-Location -- Interface -;;; -;;; Make a passing location TN for a local call return PC. If standard is -;;; true, then use the standard (full call) location, otherwise use any legal -;;; location. Even in the non-standard case, this may be restricted by a -;;; desire to use a subroutine call instruction. -;;; -(def-vm-support-routine make-return-pc-passing-location (standard) - (if standard - (make-wired-tn *any-primitive-type* register-arg-scn lra-offset) - (make-restricted-tn *any-primitive-type* register-arg-scn))) - -;;; Make-Old-FP-Passing-Location -- Interface -;;; -;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass -;;; Old-FP in. This is (obviously) wired in the standard convention, but is -;;; totally unrestricted in non-standard conventions, since we can always fetch -;;; it off of the stack using the arg pointer. -;;; -(def-vm-support-routine make-old-fp-passing-location (standard) - (if standard - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset) - (make-normal-tn *fixnum-primitive-type*))) - -;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface -;;; -;;; Make the TNs used to hold Old-FP and Return-PC within the current -;;; function. We treat these specially so that the debugger can find them at a -;;; known location. -;;; -(def-vm-support-routine make-old-fp-save-location (env) - (specify-save-tn - (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) - (make-wired-tn *fixnum-primitive-type* - control-stack-arg-scn - ocfp-save-offset))) -;;; -(def-vm-support-routine make-return-pc-save-location (env) - (specify-save-tn - (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env) - (make-wired-tn *any-primitive-type* - control-stack-arg-scn - lra-save-offset))) - -;;; Make-Argument-Count-Location -- Interface -;;; -;;; Make a TN for the standard argument count passing location. We only -;;; need to make the standard location, since a count is never passed when we -;;; are using non-standard conventions. -;;; -(def-vm-support-routine make-argument-count-location () - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) - - -;;; MAKE-NFP-TN -- Interface -;;; -;;; Make a TN to hold the number-stack frame pointer. This is allocated -;;; once per component, and is component-live. -;;; -(def-vm-support-routine make-nfp-tn () - (component-live-tn - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset))) - -;;; MAKE-STACK-POINTER-TN () -;;; -(def-vm-support-routine make-stack-pointer-tn () - (make-normal-tn *fixnum-primitive-type*)) - -;;; MAKE-NUMBER-STACK-POINTER-TN () -;;; -(def-vm-support-routine make-number-stack-pointer-tn () - (make-normal-tn *fixnum-primitive-type*)) - -;;; Make-Unknown-Values-Locations -- Interface -;;; -;;; Return a list of TNs that can be used to represent an unknown-values -;;; continuation within a function. -;;; -(def-vm-support-routine make-unknown-values-locations () - (list (make-stack-pointer-tn) - (make-normal-tn *fixnum-primitive-type*))) - - -;;; Select-Component-Format -- Interface -;;; -;;; This function is called by the Entry-Analyze phase, allowing -;;; VM-dependent initialization of the IR2-Component structure. We push -;;; placeholder entries in the Constants to leave room for additional -;;; noise in the code object header. -;;; -(def-vm-support-routine select-component-format (component) - (declare (type component component)) - (dotimes (i code-constants-offset) - (vector-push-extend nil - (ir2-component-constants (component-info component)))) - (undefined-value)) - - -;;;; Frame hackery: - -;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal -;;; -;;; Return the number of bytes needed for the current non-descriptor stack -;;; frame. Non-descriptor stack frames must be multiples of 8 bytes on -;;; the PMAX. -;;; -(defun bytes-needed-for-non-descriptor-stack-frame () - (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1) - vm:word-bytes)) - - -;;; Used for setting up the Old-FP in local call. -;;; -(define-vop (current-fp) - (:results (val :scs (any-reg))) - (:generator 1 - (move val cfp-tn))) - -;;; Used for computing the caller's NFP for use in known-values return. Only -;;; works assuming there is no variable size stuff on the nstack. -;;; -(define-vop (compute-old-nfp) - (:results (val :scs (any-reg))) - (:vop-var vop) - (:generator 1 - (let ((nfp (current-nfp-tn vop))) - (when nfp - (inst add val nfp (bytes-needed-for-non-descriptor-stack-frame)))))) - - -(define-vop (xep-allocate-frame) - (:info start-lab) - (:vop-var vop) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 1 - ;; Make sure the function is aligned, and drop a label pointing to this - ;; function header. - (align vm:lowtag-bits) - (trace-table-entry trace-table-function-prologue) - (emit-label start-lab) - ;; Allocate function header. - (inst function-header-word) - (dotimes (i (1- vm:function-code-offset)) - (inst word 0)) - ;; The start of the actual code. - ;; Fix CODE, cause the function object was passed in. - (inst compute-code-from-fn code-tn code-tn start-lab temp) - ;; Build our stack frames. - (inst add csp-tn cfp-tn - (* vm:word-bytes (sb-allocated-size 'control-stack))) - (let ((nfp-tn (current-nfp-tn vop))) - (when nfp-tn - (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame)) - (inst add nfp-tn nsp-tn number-stack-displacement))) - (trace-table-entry trace-table-normal))) - -(define-vop (allocate-frame) - (:results (res :scs (any-reg)) - (nfp :scs (any-reg))) - (:info callee) - (:generator 2 - (trace-table-entry trace-table-function-prologue) - (move res csp-tn) - (inst add csp-tn csp-tn - (* vm:word-bytes (sb-allocated-size 'control-stack))) - (when (ir2-environment-number-stack-p callee) - (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame)) - (inst add nfp nsp-tn number-stack-displacement)) - (trace-table-entry trace-table-normal))) - -;;; Allocate a partial frame for passing stack arguments in a full call. Nargs -;;; is the number of arguments passed. If no stack arguments are passed, then -;;; we don't have to do anything. -;;; -(define-vop (allocate-full-call-frame) - (:info nargs) - (:results (res :scs (any-reg))) - (:generator 2 - (when (> nargs register-arg-count) - (move res csp-tn) - (inst add csp-tn csp-tn (* nargs vm:word-bytes))))) - - - - -;;; Default-Unknown-Values -- Internal -;;; -;;; Emit code needed at the return-point from an unknown-values call for a -;;; fixed number of values. Values is the head of the TN-Ref list for the -;;; locations that the values are to be received into. Nvals is the number of -;;; values that are to be received (should equal the length of Values). -;;; -;;; Move-Temp is a Descriptor-Reg TN used as a temporary. -;;; -;;; This code exploits the fact that in the unknown-values convention, a -;;; single value return returns at the return PC + 8, whereas a return of other -;;; than one value returns directly at the return PC. -;;; -;;; If 0 or 1 values are expected, then we just emit an instruction to reset -;;; the SP (which will only be executed when other than 1 value is returned.) -;;; -;;; In the general case, we have to do three things: -;;; -- Default unsupplied register values. This need only be done when a -;;; single value is returned, since register values are defaulted by the -;;; called in the non-single case. -;;; -- Default unsupplied stack values. This needs to be done whenever there -;;; are stack values. -;;; -- Reset SP. This must be done whenever other than 1 value is returned, -;;; regardless of the number of values desired. -;;; -;;; The general-case code looks like this: -#| - b regs-defaulted ; Skip if MVs - nop - - move a1 null-tn ; Default register values - ... - loadi nargs 1 ; Force defaulting of stack values - move old-fp csp ; Set up args for SP resetting - -regs-defaulted - subcc temp nargs register-arg-count - - b :lt default-value-7 ; jump to default code - loadw move-temp ocfp-tn 6 ; Move value to correct location. - subcc temp 1 - store-stack-tn val4-tn move-temp - - b :lt default-value-8 - loadw move-temp ocfp-tn 7 - subcc temp 1 - store-stack-tn val5-tn move-temp - - ... - -defaulting-done - move csp ocfp ; Reset SP. -<end of code> - -<elsewhere> -default-value-7 - store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack) - -default-value-8 - store-stack-tn val5-tn null-tn ; Nil out 8'th value. - - ... - - br defaulting-done - nop -|# -;;; -(defun default-unknown-values (vop values nvals move-temp temp lra-label) - (declare (type (or tn-ref null) values) - (type unsigned-byte nvals) (type tn move-temp temp)) - (if (<= nvals 1) - (progn - (new-assem:without-scheduling () - (note-this-location vop :single-value-return) - (move csp-tn ocfp-tn) - (inst nop)) - (inst compute-code-from-lra code-tn code-tn lra-label temp)) - (let ((regs-defaulted (gen-label)) - (defaulting-done (gen-label)) - (default-stack-vals (gen-label))) - ;; Branch off to the MV case. - (new-assem:without-scheduling () - (note-this-location vop :unknown-return) - (inst b regs-defaulted) - (if (> nvals register-arg-count) - (inst subcc temp nargs-tn (fixnum register-arg-count)) - (move csp-tn ocfp-tn))) - - ;; Do the single value calse. - (do ((i 1 (1+ i)) - (val (tn-ref-across values) (tn-ref-across val))) - ((= i (min nvals register-arg-count))) - (move (tn-ref-tn val) null-tn)) - (when (> nvals register-arg-count) - (inst b default-stack-vals) - (move ocfp-tn csp-tn)) - - (emit-label regs-defaulted) - (when (> nvals register-arg-count) - (collect ((defaults)) - (do ((i register-arg-count (1+ i)) - (val (do ((i 0 (1+ i)) - (val values (tn-ref-across val))) - ((= i register-arg-count) val)) - (tn-ref-across val))) - ((null val)) - - (let ((default-lab (gen-label)) - (tn (tn-ref-tn val))) - (defaults (cons default-lab tn)) - - (inst b :lt default-lab) - (inst ld move-temp ocfp-tn (* i vm:word-bytes)) - (inst subcc temp (fixnum 1)) - (store-stack-tn tn move-temp))) - - (emit-label defaulting-done) - (move csp-tn ocfp-tn) - - (let ((defaults (defaults))) - (when defaults - (assemble (*elsewhere*) - (emit-label default-stack-vals) - (trace-table-entry trace-table-function-prologue) - (do ((remaining defaults (cdr remaining))) - ((null remaining)) - (let ((def (car remaining))) - (emit-label (car def)) - (when (null (cdr remaining)) - (inst b defaulting-done)) - (store-stack-tn (cdr def) null-tn))) - (trace-table-entry trace-table-normal)))))) - - (inst compute-code-from-lra code-tn code-tn lra-label temp))) - (undefined-value)) - - -;;;; Unknown values receiving: - -;;; Receive-Unknown-Values -- Internal -;;; -;;; Emit code needed at the return point for an unknown-values call for an -;;; arbitrary number of values. -;;; -;;; We do the single and non-single cases with no shared code: there doesn't -;;; seem to be any potential overlap, and receiving a single value is more -;;; important efficiency-wise. -;;; -;;; When there is a single value, we just push it on the stack, returning -;;; the old SP and 1. -;;; -;;; When there is a variable number of values, we move all of the argument -;;; registers onto the stack, and return Args and Nargs. -;;; -;;; Args and Nargs are TNs wired to the named locations. We must -;;; explicitly allocate these TNs, since their lifetimes overlap with the -;;; results Start and Count (also, it's nice to be able to target them). -;;; -(defun receive-unknown-values (args nargs start count lra-label temp) - (declare (type tn args nargs start count temp)) - (let ((variable-values (gen-label)) - (done (gen-label))) - (new-assem:without-scheduling () - (inst b variable-values) - (inst nop)) - - (inst compute-code-from-lra code-tn code-tn lra-label temp) - (inst add csp-tn 4) - (storew (first register-arg-tns) csp-tn -1) - (inst sub start csp-tn 4) - (inst li count (fixnum 1)) - - (emit-label done) - - (assemble (*elsewhere*) - (trace-table-entry trace-table-function-prologue) - (emit-label variable-values) - (inst compute-code-from-lra code-tn code-tn lra-label temp) - (do ((arg register-arg-tns (rest arg)) - (i 0 (1+ i))) - ((null arg)) - (storew (first arg) args i)) - (move start args) - (move count nargs) - (inst b done) - (inst nop) - (trace-table-entry trace-table-normal))) - (undefined-value)) - - -;;; VOP that can be inherited by unknown values receivers. The main thing this -;;; handles is allocation of the result temporaries. -;;; -(define-vop (unknown-values-receiver) - (:results - (start :scs (any-reg)) - (count :scs (any-reg))) - (:temporary (:sc descriptor-reg :offset ocfp-offset - :from :eval :to (:result 0)) - values-start) - (:temporary (:sc any-reg :offset nargs-offset - :from :eval :to (:result 1)) - nvals) - (:temporary (:scs (non-descriptor-reg)) temp)) - - - -;;;; Local call with unknown values convention return: - -;;; Non-TR local call for a fixed number of values passed according to the -;;; unknown values convention. -;;; -;;; Args are the argument passing locations, which are specified only to -;;; terminate their lifetimes in the caller. -;;; -;;; Values are the return value locations (wired to the standard passing -;;; locations). -;;; -;;; Save is the save info, which we can ignore since saving has been done. -;;; Return-PC is the TN that the return PC should be passed in. -;;; Target is a continuation pointing to the start of the called function. -;;; Nvals is the number of values received. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (call-local) - (:args (fp) - (nfp) - (args :more t)) - (:results (values :more t)) - (:save-p t) - (:move-args :local-call) - (:info arg-locs callee target nvals) - (:vop-var vop) - (:temporary (:scs (descriptor-reg) :from (:eval 0)) move-temp) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:sc any-reg :offset ocfp-offset :from (:eval 0)) ocfp) - (:ignore arg-locs args ocfp) - (:generator 5 - (trace-table-entry trace-table-call-site) - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (move callee-nfp nfp))) - (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label temp) - (note-this-location vop :call-site) - (inst b target) - (inst nop) - (emit-return-pc label) - (default-unknown-values vop values nvals move-temp temp label) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) - - -;;; Non-TR local call for a variable number of return values passed according -;;; to the unknown values convention. The results are the start of the values -;;; glob and the number of values received. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (multiple-call-local unknown-values-receiver) - (:args (fp) - (nfp) - (args :more t)) - (:save-p t) - (:move-args :local-call) - (:info save callee target) - (:ignore args save) - (:vop-var vop) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:generator 20 - (trace-table-entry trace-table-call-site) - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (move callee-nfp nfp))) - (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label temp) - (note-this-location vop :call-site) - (inst b target) - (inst nop) - (emit-return-pc label) - (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count label temp) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) - - -;;;; Local call with known values return: - -;;; Non-TR local call with known return locations. Known-value return works -;;; just like argument passing in local call. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (known-call-local) - (:args (fp) - (nfp) - (args :more t)) - (:results (res :more t)) - (:move-args :local-call) - (:save-p t) - (:info save callee target) - (:ignore args res save) - (:vop-var vop) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 5 - (trace-table-entry trace-table-call-site) - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (let ((callee-nfp (callee-nfp-tn callee))) - (when callee-nfp - (move callee-nfp nfp))) - (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label temp) - (note-this-location vop :call-site) - (inst b target) - (inst nop) - (emit-return-pc label) - (note-this-location vop :known-return) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) - -;;; Return from known values call. We receive the return locations as -;;; arguments to terminate their lifetimes in the returning function. We -;;; restore FP and CSP and jump to the Return-PC. -;;; -;;; Note: we can't use normal load-tn allocation for the fixed args, since all -;;; registers may be tied up by the more operand. Instead, we use -;;; MAYBE-LOAD-STACK-TN. -;;; -(define-vop (known-return) - (:args (old-fp :target old-fp-temp) - (return-pc :target return-pc-temp) - (vals :more t)) - (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp) - (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp) - (:move-args :known-return) - (:info val-locs) - (:ignore val-locs vals) - (:vop-var vop) - (:generator 6 - (trace-table-entry trace-table-function-epilogue) - (maybe-load-stack-tn old-fp-temp old-fp) - (maybe-load-stack-tn return-pc-temp return-pc) - (move csp-tn cfp-tn) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst add nsp-tn cur-nfp - (- (bytes-needed-for-non-descriptor-stack-frame) - number-stack-displacement)))) - (inst j return-pc-temp (- vm:word-bytes vm:other-pointer-type)) - (move cfp-tn old-fp-temp) - (trace-table-entry trace-table-normal))) - - -;;;; Full call: -;;; -;;; There is something of a cross-product effect with full calls. Different -;;; versions are used depending on whether we know the number of arguments or -;;; the name of the called function, and whether we want fixed values, unknown -;;; values, or a tail call. -;;; -;;; In full call, the arguments are passed creating a partial frame on the -;;; stack top and storing stack arguments into that frame. On entry to the -;;; callee, this partial frame is pointed to by FP. If there are no stack -;;; arguments, we don't bother allocating a partial frame, and instead set FP -;;; to SP just before the call. - -;;; Define-Full-Call -- Internal -;;; -;;; This macro helps in the definition of full call VOPs by avoiding code -;;; replication in defining the cross-product VOPs. -;;; -;;; Name is the name of the VOP to define. -;;; -;;; Named is true if the first argument is a symbol whose global function -;;; definition is to be called. -;;; -;;; Return is either :Fixed, :Unknown or :Tail: -;;; -- If :Fixed, then the call is for a fixed number of values, returned in -;;; the standard passing locations (passed as result operands). -;;; -- If :Unknown, then the result values are pushed on the stack, and the -;;; result values are specified by the Start and Count as in the -;;; unknown-values continuation representation. -;;; -- If :Tail, then do a tail-recursive call. No values are returned. -;;; The Old-Fp and Return-PC are passed as the second and third arguments. -;;; -;;; In non-tail calls, the pointer to the stack arguments is passed as the last -;;; fixed argument. If Variable is false, then the passing locations are -;;; passed as a more arg. Variable is true if there are a variable number of -;;; arguments passed on the stack. Variable cannot be specified with :Tail -;;; return. TR variable argument call is implemented separately. -;;; -;;; In tail call with fixed arguments, the passing locations are passed as a -;;; more arg, but there is no new-FP, since the arguments have been set up in -;;; the current frame. -;;; -(defmacro define-full-call (name named return variable) - (assert (not (and variable (eq return :tail)))) - `(define-vop (,name - ,@(when (eq return :unknown) - '(unknown-values-receiver))) - (:args - ,@(unless (eq return :tail) - '((new-fp :scs (any-reg) :to :eval))) - - ,(if named - '(name :target name-pass) - '(arg-fun :target lexenv)) - - ,@(when (eq return :tail) - '((old-fp :target old-fp-pass) - (return-pc :target return-pc-pass))) - - ,@(unless variable '((args :more t :scs (descriptor-reg))))) - - ,@(when (eq return :fixed) - '((:results (values :more t)))) - - (:save-p ,(if (eq return :tail) :compute-only t)) - - ,@(unless (or (eq return :tail) variable) - '((:move-args :full-call))) - - (:vop-var vop) - (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(nargs)) - ,@(when (eq return :fixed) '(nvals))) - - (:ignore - ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(args))) - - (:temporary (:sc descriptor-reg - :offset ocfp-offset - :from (:argument 1) - ,@(unless (eq return :fixed) - '(:to :eval))) - old-fp-pass) - - (:temporary (:sc descriptor-reg - :offset lra-offset - :from (:argument ,(if (eq return :tail) 2 1)) - :to :eval) - return-pc-pass) - - ,(if named - `(:temporary (:sc descriptor-reg :offset cname-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - name-pass) - `(:temporary (:sc descriptor-reg :offset lexenv-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - lexenv)) - - (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) - function) - (:temporary (:sc any-reg :offset nargs-offset :to :eval) - nargs-pass) - - ,@(when variable - (mapcar #'(lambda (name offset) - `(:temporary (:sc descriptor-reg - :offset ,offset - :to :eval) - ,name)) - register-arg-names register-arg-offsets)) - ,@(when (eq return :fixed) - '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) - - ,@(unless (eq return :tail) - '((:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) - - (:generator ,(+ (if named 5 0) - (if variable 19 1) - (if (eq return :tail) 0 10) - 15 - (if (eq return :unknown) 25 0)) - (trace-table-entry trace-table-call-site) - (let* ((cur-nfp (current-nfp-tn vop)) - ,@(unless (eq return :tail) - '((lra-label (gen-label)))) - (filler - (remove nil - (list :load-nargs - ,@(if (eq return :tail) - '((unless (location= old-fp old-fp-pass) - :load-old-fp) - (unless (location= return-pc - return-pc-pass) - :load-return-pc) - (when cur-nfp - :frob-nfp)) - '(:comp-lra - (when cur-nfp - :frob-nfp) - :save-fp - :load-fp)))))) - (flet ((do-next-filler () - (let* ((next (pop filler)) - (what (if (consp next) (car next) next))) - (ecase what - (:load-nargs - ,@(if variable - `((inst sub nargs-pass csp-tn new-fp) - ,@(let ((index -1)) - (mapcar #'(lambda (name) - `(loadw ,name new-fp - ,(incf index))) - register-arg-names))) - '((inst li nargs-pass (fixnum nargs))))) - ,@(if (eq return :tail) - '((:load-old-fp - (sc-case old-fp - (any-reg - (inst move old-fp-pass old-fp)) - (control-stack - (loadw old-fp-pass cfp-tn - (tn-offset old-fp))))) - (:load-return-pc - (sc-case return-pc - (descriptor-reg - (inst move return-pc-pass return-pc)) - (control-stack - (loadw return-pc-pass cfp-tn - (tn-offset return-pc))))) - (:frob-nfp - (inst add nsp-tn cur-nfp - (- (bytes-needed-for-non-descriptor-stack-frame) - number-stack-displacement)))) - `((:comp-lra - (inst compute-lra-from-code - return-pc-pass code-tn lra-label temp)) - (:frob-nfp - (store-stack-tn nfp-save cur-nfp)) - (:save-fp - (inst move old-fp-pass cfp-tn)) - (:load-fp - ,(if variable - '(move cfp-tn new-fp) - '(if (> nargs register-arg-count) - (move cfp-tn new-fp) - (move cfp-tn csp-tn)))))) - ((nil)))))) - - ,@(if named - `((sc-case name - (descriptor-reg (move name-pass name)) - (control-stack - (loadw name-pass cfp-tn (tn-offset name)) - (do-next-filler)) - (constant - (loadw name-pass code-tn (tn-offset name) - vm:other-pointer-type) - (do-next-filler))) - (loadw function name-pass fdefn-raw-addr-slot - other-pointer-type) - (do-next-filler)) - `((sc-case arg-fun - (descriptor-reg (move lexenv arg-fun)) - (control-stack - (loadw lexenv cfp-tn (tn-offset arg-fun)) - (do-next-filler)) - (constant - (loadw lexenv code-tn (tn-offset arg-fun) - vm:other-pointer-type) - (do-next-filler))) - (loadw function lexenv vm:closure-function-slot - vm:function-pointer-type) - (do-next-filler))) - (loop - (if filler - (do-next-filler) - (return))) - - (note-this-location vop :call-site) - (inst j function - (- (ash vm:function-code-offset vm:word-shift) - vm:function-pointer-type)) - (inst move code-tn function)) - - ,@(ecase return - (:fixed - '((emit-return-pc lra-label) - (default-unknown-values vop values nvals move-temp - temp lra-label) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)))) - (:unknown - '((emit-return-pc lra-label) - (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count - lra-label temp) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)))) - (:tail))) - (trace-table-entry trace-table-normal)))) - - -(define-full-call call nil :fixed nil) -(define-full-call call-named t :fixed nil) -(define-full-call multiple-call nil :unknown nil) -(define-full-call multiple-call-named t :unknown nil) -(define-full-call tail-call nil :tail nil) -(define-full-call tail-call-named t :tail nil) - -(define-full-call call-variable nil :fixed t) -(define-full-call multiple-call-variable nil :unknown t) - - -;;; Defined separately, since needs special code that BLT's the arguments -;;; down. -;;; -(define-vop (tail-call-variable) - (:args - (args-arg :scs (any-reg) :target args) - (function-arg :scs (descriptor-reg) :target lexenv) - (old-fp-arg :scs (any-reg) :target old-fp) - (lra-arg :scs (descriptor-reg) :target lra)) - - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) - (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) - (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp) - (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) - - (:temporary (:scs (any-reg) :from :eval) temp) - - (:vop-var vop) - - (:generator 75 - - ;; Move these into the passing locations if they are not already there. - (move args args-arg) - (move lexenv function-arg) - (move old-fp old-fp-arg) - (move lra lra-arg) - - ;; Clear the number stack if anything is there. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst add nsp-tn cur-nfp - (- (bytes-needed-for-non-descriptor-stack-frame) - number-stack-displacement)))) - - ;; And jump to the assembly-routine that does the bliting. - (inst ji temp (make-fixup 'tail-call-variable :assembly-routine)) - (inst nop))) - - -;;;; Unknown values return: - - -;;; Return a single value using the unknown-values convention. -;;; -(define-vop (return-single) - (:args (old-fp :scs (any-reg)) - (return-pc :scs (descriptor-reg)) - (value)) - (:ignore value) - (:vop-var vop) - (:generator 6 - (trace-table-entry trace-table-function-epilogue) - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst add nsp-tn cur-nfp - (- (bytes-needed-for-non-descriptor-stack-frame) - number-stack-displacement)))) - ;; Clear the control stack, and restore the frame pointer. - (move csp-tn cfp-tn) - (move cfp-tn old-fp) - ;; Out of here. - (lisp-return return-pc :offset 2) - (trace-table-entry trace-table-normal))) - -;;; Do unknown-values return of a fixed number of values. The Values are -;;; required to be set up in the standard passing locations. Nvals is the -;;; number of values returned. -;;; -;;; If returning a single value, then deallocate the current frame, restore -;;; FP and jump to the single-value entry at Return-PC + 8. -;;; -;;; If returning other than one value, then load the number of values returned, -;;; NIL out unsupplied values registers, restore FP and return at Return-PC. -;;; When there are stack values, we must initialize the argument pointer to -;;; point to the beginning of the values block (which is the beginning of the -;;; current frame.) -;;; -(define-vop (return) - (:args - (old-fp :scs (any-reg)) - (return-pc :scs (descriptor-reg) :to (:eval 1)) - (values :more t)) - (:ignore values) - (:info nvals) - (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0) - (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1) - (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2) - (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3) - (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4) - (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) - (:vop-var vop) - (:generator 6 - (trace-table-entry trace-table-function-epilogue) - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst add nsp-tn cur-nfp - (- (bytes-needed-for-non-descriptor-stack-frame) - number-stack-displacement)))) - (cond ((= nvals 1) - ;; Clear the control stack, and restore the frame pointer. - (move csp-tn cfp-tn) - (move cfp-tn old-fp) - ;; Out of here. - (lisp-return return-pc :offset 2)) - (t - ;; Establish the values pointer and values count. - (move val-ptr cfp-tn) - (inst li nargs (fixnum nvals)) - ;; restore the frame pointer and clear as much of the control - ;; stack as possible. - (move cfp-tn old-fp) - (inst add csp-tn val-ptr (* nvals word-bytes)) - ;; pre-default any argument register that need it. - (when (< nvals register-arg-count) - (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) - (move reg null-tn))) - ;; And away we go. - (lisp-return return-pc))) - (trace-table-entry trace-table-normal))) - -;;; Do unknown-values return of an arbitrary number of values (passed on the -;;; stack.) We check for the common case of a single return value, and do that -;;; inline using the normal single value return convention. Otherwise, we -;;; branch off to code that calls an assembly-routine. -;;; -(define-vop (return-multiple) - (:args - (old-fp-arg :scs (any-reg) :to (:eval 1)) - (lra-arg :scs (descriptor-reg) :to (:eval 1)) - (vals-arg :scs (any-reg) :target vals) - (nvals-arg :scs (any-reg) :target nvals)) - - (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp) - (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals) - (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) - (:temporary (:sc descriptor-reg :offset a0-offset) a0) - - (:temporary (:scs (any-reg) :from (:eval 1)) temp) - - (:vop-var vop) - - (:generator 13 - (trace-table-entry trace-table-function-epilogue) - (let ((not-single (gen-label))) - ;; Clear the number stack. - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst add nsp-tn cur-nfp - (- (bytes-needed-for-non-descriptor-stack-frame) - number-stack-displacement)))) - - ;; Check for the single case. - (inst cmp nvals-arg (fixnum 1)) - (inst b :ne not-single) - (inst ld a0 vals-arg) - - ;; Return with one value. - (move csp-tn cfp-tn) - (move cfp-tn old-fp-arg) - (lisp-return lra-arg :offset 2) - - ;; Nope, not the single case. - (emit-label not-single) - (move old-fp old-fp-arg) - (move lra lra-arg) - (move vals vals-arg) - (move nvals nvals-arg) - (inst ji temp (make-fixup 'return-multiple :assembly-routine)) - (inst nop)) - (trace-table-entry trace-table-normal))) - - - -;;;; XEP hackery: - - -;;; We don't need to do anything special for regular functions. -;;; -(define-vop (setup-environment) - (:info label) - (:ignore label) - (:generator 0 - ;; Don't bother doing anything. - )) - -;;; Get the lexical environment from it's passing location. -;;; -(define-vop (setup-closure-environment) - (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure - :to (:result 0)) - lexenv) - (:results (closure :scs (descriptor-reg))) - (:info label) - (:ignore label) - (:generator 6 - ;; Get result. - (move closure lexenv))) - -;;; Copy a more arg from the argument area to the end of the current frame. -;;; Fixed is the number of non-more arguments. -;;; -(define-vop (copy-more-arg) - (:temporary (:sc any-reg :offset nl0-offset) result) - (:temporary (:sc any-reg :offset nl1-offset) count) - (:temporary (:sc any-reg :offset nl2-offset) src) - (:temporary (:sc any-reg :offset nl3-offset) dst) - (:temporary (:sc descriptor-reg :offset l0-offset) temp) - (:info fixed) - (:generator 20 - (let ((loop (gen-label)) - (do-regs (gen-label)) - (done (gen-label))) - (when (< fixed register-arg-count) - ;; Save a pointer to the results so we can fill in register args. - ;; We don't need this if there are more fixed args than reg args. - (move result csp-tn)) - ;; Allocate the space on the stack. - (cond ((zerop fixed) - (inst cmp nargs-tn) - (inst b :eq done) - (inst add csp-tn csp-tn nargs-tn)) - (t - (inst subcc count nargs-tn (fixnum fixed)) - (inst b :le done) - (inst nop) - (inst add csp-tn csp-tn count))) - (when (< fixed register-arg-count) - ;; We must stop when we run out of stack args, not when we run out of - ;; more args. - (inst subcc count nargs-tn (fixnum register-arg-count)) - ;; Everything of interest in registers. - (inst b :le do-regs)) - ;; Initialize dst to be end of stack. - (move dst csp-tn) - ;; Initialize src to be end of args. - (inst add src cfp-tn nargs-tn) - - (emit-label loop) - ;; *--dst = *--src, --count - (inst add src src (- vm:word-bytes)) - (inst subcc count count (fixnum 1)) - (loadw temp src) - (inst add dst dst (- vm:word-bytes)) - (inst b :gt loop) - (storew temp dst) - - (emit-label do-regs) - (when (< fixed register-arg-count) - ;; Now we have to deposit any more args that showed up in registers. - (inst subcc count nargs-tn (fixnum fixed)) - (do ((i fixed (1+ i))) - ((>= i register-arg-count)) - ;; Don't deposit any more than there are. - (inst b :eq done) - (inst subcc count (fixnum 1)) - ;; Store it relative to the pointer saved at the start. - (storew (nth i register-arg-tns) result (- i fixed)))) - (emit-label done)))) - - -;;; More args are stored consequtively on the stack, starting immediately at -;;; the context pointer. The context pointer is not typed, so the lowtag is 0. -;;; -(define-vop (more-arg word-index-ref) - (:variant 0 0) - (:translate %more-arg)) - - -;;; Turn more arg (context, count) into a list. -;;; -(define-vop (listify-rest-args) - (:args (context-arg :target context :scs (descriptor-reg)) - (count-arg :target count :scs (any-reg))) - (:arg-types * tagged-num) - (:temporary (:scs (any-reg) :from (:argument 0)) context) - (:temporary (:scs (any-reg) :from (:argument 1)) count) - (:temporary (:scs (descriptor-reg) :from :eval) temp) - (:temporary (:scs (non-descriptor-reg) :from :eval) dst) - (:results (result :scs (descriptor-reg))) - (:translate %listify-rest-args) - (:policy :safe) - (:generator 20 - (let ((enter (gen-label)) - (loop (gen-label)) - (done (gen-label))) - (move context context-arg) - (move count count-arg) - ;; Check to see if there are any arguments. - (inst cmp count) - (inst b :eq done) - (move result null-tn) - - ;; We need to do this atomically. - (pseudo-atomic () - ;; Allocate a cons (2 words) for each item. - (inst andn result alloc-tn lowtag-mask) - (inst or result list-pointer-type) - (move dst result) - (inst sll temp count 1) - (inst b enter) - (inst add alloc-tn temp) - - ;; Store the current cons in the cdr of the previous cons. - (emit-label loop) - (storew dst dst -1 vm:list-pointer-type) - - ;; Grab one value and stash it in the car of this cons. - (emit-label enter) - (loadw temp context) - (inst add context context vm:word-bytes) - (storew temp dst 0 vm:list-pointer-type) - - ;; Dec count, and if != zero, go back for more. - (inst subcc count (fixnum 1)) - (inst b :gt loop) - (inst add dst dst (* 2 vm:word-bytes)) - - ;; NIL out the last cons. - (storew null-tn dst -1 vm:list-pointer-type)) - (emit-label done)))) - - -;;; Return the location and size of the more arg glob created by Copy-More-Arg. -;;; Supplied is the total number of arguments supplied (originally passed in -;;; NARGS.) Fixed is the number of non-rest arguments. -;;; -;;; We must duplicate some of the work done by Copy-More-Arg, since at that -;;; time the environment is in a pretty brain-damaged state, preventing this -;;; info from being returned as values. What we do is compute -;;; supplied - fixed, and return a pointer that many words below the current -;;; stack top. -;;; -(define-vop (more-arg-context) - (:policy :fast-safe) - (:translate c::%more-arg-context) - (:args (supplied :scs (any-reg))) - (:arg-types tagged-num (:constant fixnum)) - (:info fixed) - (:results (context :scs (descriptor-reg)) - (count :scs (any-reg))) - (:result-types t tagged-num) - (:note "more-arg-context") - (:generator 5 - (inst sub count supplied (fixnum fixed)) - (inst sub context csp-tn count))) - - -;;; Signal wrong argument count error if Nargs isn't = to Count. -;;; -(define-vop (verify-argument-count) - (:args (nargs :scs (any-reg))) - (:arg-types positive-fixnum) - (:info count) - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (let ((err-lab - (generate-error-code vop invalid-argument-count-error nargs))) - (inst cmp nargs (fixnum count)) - (inst b :ne err-lab) - (inst nop)))) - -;;; Signal various errors. -;;; -(macrolet ((frob (name error &rest args) - `(define-vop (,name) - (:args ,@(mapcar #'(lambda (arg) - `(,arg :scs (any-reg descriptor-reg))) - args)) - (:vop-var vop) - (:save-p :compute-only) - (:generator 1000 - (error-call vop ,error ,@args))))) - (frob argument-count-error invalid-argument-count-error nargs) - (frob type-check-error object-not-type-error object type) - (frob odd-keyword-arguments-error odd-keyword-arguments-error) - (frob unknown-keyword-argument-error unknown-keyword-argument-error key) - (frob nil-function-returned-error nil-function-returned-error fun)) diff --git a/compiler/sparc/cell.lisp b/compiler/sparc/cell.lisp deleted file mode 100644 index b10584ea6369ecbefdcacc17ed151cffdde18040..0000000000000000000000000000000000000000 --- a/compiler/sparc/cell.lisp +++ /dev/null @@ -1,288 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/cell.lisp,v 1.14 1992/12/16 20:27:10 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of various primitive memory access -;;; VOPs for the SPARC. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by William Lott. -;;; - -(in-package "SPARC") - - -;;;; Data object ref/set stuff. - -(define-vop (slot) - (:args (object :scs (descriptor-reg))) - (:info name offset lowtag) - (:ignore name) - (:results (result :scs (descriptor-reg any-reg))) - (:generator 1 - (loadw result object offset lowtag))) - -(define-vop (set-slot) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:info name offset lowtag) - (:ignore name) - (:results) - (:generator 1 - (storew value object offset lowtag))) - - - -;;;; Symbol hacking VOPs: - -;;; The compiler likes to be able to directly SET symbols. -;;; -(define-vop (set cell-set) - (:variant symbol-value-slot other-pointer-type)) - -;;; Do a cell ref with an error check for being unbound. -;;; -(define-vop (checked-cell-ref) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) - -;;; With Symbol-Value, we check that the value isn't the trap object. So -;;; Symbol-Value of NIL is NIL. -;;; -(define-vop (symbol-value checked-cell-ref) - (:translate symbol-value) - (:generator 9 - (move obj-temp object) - (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type) - (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) - (inst cmp value vm:unbound-marker-type) - (inst b :eq err-lab) - (inst nop)))) - -;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. -(define-vop (boundp-frob) - (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value)) - -(define-vop (boundp boundp-frob) - (:translate boundp) - (:generator 9 - (loadw value object vm:symbol-value-slot vm:other-pointer-type) - (inst cmp value vm:unbound-marker-type) - (inst b (if not-p :eq :ne) target) - (inst nop))) - -(define-vop (fast-symbol-value cell-ref) - (:variant vm:symbol-value-slot vm:other-pointer-type) - (:policy :fast) - (:translate symbol-value)) - - -;;;; Fdefinition (fdefn) objects. - -(define-vop (fdefn-function cell-ref) - (:variant fdefn-function-slot other-pointer-type)) - -(define-vop (safe-fdefn-function) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp) - (:generator 10 - (move obj-temp object) - (loadw value obj-temp fdefn-function-slot other-pointer-type) - (inst cmp value null-tn) - (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) - (inst b :eq err-lab)) - (inst nop))) - -(define-vop (set-fdefn-function) - (:policy :fast-safe) - (:translate (setf fdefn-function)) - (:args (function :scs (descriptor-reg) :target result) - (fdefn :scs (descriptor-reg))) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg)) type) - (:results (result :scs (descriptor-reg))) - (:generator 38 - (let ((normal-fn (gen-label))) - (load-type type function (- function-pointer-type)) - (inst cmp type function-header-type) - (inst b :eq normal-fn) - (inst move lip function) - (inst li lip (make-fixup "_closure_tramp" :foreign)) - (emit-label normal-fn) - (storew function fdefn fdefn-function-slot other-pointer-type) - (storew lip fdefn fdefn-raw-addr-slot other-pointer-type) - (move result function)))) - -(define-vop (fdefn-makunbound) - (:policy :fast-safe) - (:translate fdefn-makunbound) - (:args (fdefn :scs (descriptor-reg) :target result)) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:generator 38 - (storew null-tn fdefn fdefn-function-slot other-pointer-type) - (inst li temp (make-fixup "_undefined_tramp" :foreign)) - (storew temp fdefn fdefn-raw-addr-slot other-pointer-type) - (move result fdefn))) - - - -;;;; Binding and Unbinding. - -;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and -;;; the symbol on the binding stack and stuff the new value into the -;;; symbol. - -(define-vop (bind) - (:args (val :scs (any-reg descriptor-reg)) - (symbol :scs (descriptor-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:generator 5 - (loadw temp symbol vm:symbol-value-slot vm:other-pointer-type) - (inst add bsp-tn bsp-tn (* 2 vm:word-bytes)) - (storew temp bsp-tn (- vm:binding-value-slot vm:binding-size)) - (storew symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) - (storew val symbol vm:symbol-value-slot vm:other-pointer-type))) - - -(define-vop (unbind) - (:temporary (:scs (descriptor-reg)) symbol value) - (:generator 0 - (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) - (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size)) - (storew value symbol vm:symbol-value-slot vm:other-pointer-type) - (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size)) - (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes)))) - - -(define-vop (unbind-to-here) - (:args (arg :scs (descriptor-reg any-reg) :target where)) - (:temporary (:scs (any-reg) :from (:argument 0)) where) - (:temporary (:scs (descriptor-reg)) symbol value) - (:generator 0 - (let ((loop (gen-label)) - (skip (gen-label)) - (done (gen-label))) - (move where arg) - (inst cmp where bsp-tn) - (inst b :eq done) - (inst nop) - - (emit-label loop) - (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) - (inst cmp symbol) - (inst b :eq skip) - (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size)) - (storew value symbol vm:symbol-value-slot vm:other-pointer-type) - (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size)) - - (emit-label skip) - (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes)) - (inst cmp where bsp-tn) - (inst b :ne loop) - (inst nop) - - (emit-label done)))) - - - -;;;; Closure indexing. - -(define-vop (closure-index-ref word-index-ref) - (:variant vm:closure-info-offset vm:function-pointer-type) - (:translate %closure-index-ref)) - -(define-vop (set-funcallable-instance-info word-index-set) - (:variant funcallable-instance-info-offset function-pointer-type) - (:translate %set-funcallable-instance-info)) - - -(define-vop (closure-ref slot-ref) - (:variant closure-info-offset function-pointer-type)) - -(define-vop (closure-init slot-set) - (:variant closure-info-offset function-pointer-type)) - - -;;;; Value Cell hackery. - -(define-vop (value-cell-ref cell-ref) - (:variant value-cell-value-slot other-pointer-type)) - -(define-vop (value-cell-set cell-set) - (:variant value-cell-value-slot other-pointer-type)) - - - -;;;; Structure hackery: - -(define-vop (structure-length) - (:policy :fast-safe) - (:translate structure-length) - (:args (struct :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 4 - (loadw temp struct 0 structure-pointer-type) - (inst srl res temp vm:type-bits))) - -(define-vop (structure-ref slot-ref) - (:variant structure-slots-offset structure-pointer-type) - (:policy :fast-safe) - (:translate structure-ref) - (:arg-types structure (:constant index))) - -(define-vop (structure-set slot-set) - (:policy :fast-safe) - (:translate structure-set) - (:variant structure-slots-offset structure-pointer-type) - (:arg-types structure (:constant index) *)) - -(define-vop (structure-index-ref word-index-ref) - (:policy :fast-safe) - (:translate structure-ref) - (:variant structure-slots-offset structure-pointer-type) - (:arg-types structure positive-fixnum)) - -(define-vop (structure-index-set word-index-set) - (:policy :fast-safe) - (:translate structure-set) - (:variant structure-slots-offset structure-pointer-type) - (:arg-types structure positive-fixnum *)) - - - -;;;; Code object frobbing. - -(define-vop (code-header-ref word-index-ref) - (:translate code-header-ref) - (:policy :fast-safe) - (:variant 0 other-pointer-type)) - -(define-vop (code-header-set word-index-set) - (:translate code-header-set) - (:policy :fast-safe) - (:variant 0 other-pointer-type)) - diff --git a/compiler/sparc/char.lisp b/compiler/sparc/char.lisp deleted file mode 100644 index 7e0a851919dd5179dfa987c4ee436fba2bb05637..0000000000000000000000000000000000000000 --- a/compiler/sparc/char.lisp +++ /dev/null @@ -1,148 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/char.lisp,v 1.6 1992/02/25 07:04:51 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the SPARC VM definition of character operations. -;;; -;;; Written by Rob MacLachlan -;;; Converted for the MIPS R2000 by Christopher Hoover. -;;; And then to the SPARC by William Lott. -;;; -(in-package "SPARC") - - - -;;;; Moves and coercions: - -;;; Move a tagged char to an untagged representation. -;;; -(define-vop (move-to-base-char) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (base-char-reg))) - (:note "character untagging") - (:generator 1 - (inst srl y x vm:type-bits))) -;;; -(define-move-vop move-to-base-char :move - (any-reg descriptor-reg) (base-char-reg)) - - -;;; Move an untagged char to a tagged representation. -;;; -(define-vop (move-from-base-char) - (:args (x :scs (base-char-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:note "character tagging") - (:generator 1 - (inst sll y x vm:type-bits) - (inst or y vm:base-char-type))) -;;; -(define-move-vop move-from-base-char :move - (base-char-reg) (any-reg descriptor-reg)) - -;;; Move untagged base-char values. -;;; -(define-vop (base-char-move) - (:args (x :target y - :scs (base-char-reg) - :load-if (not (location= x y)))) - (:results (y :scs (base-char-reg) - :load-if (not (location= x y)))) - (:note "character move") - (:effects) - (:affected) - (:generator 0 - (move y x))) -;;; -(define-move-vop base-char-move :move - (base-char-reg) (base-char-reg)) - - -;;; Move untagged base-char arguments/return-values. -;;; -(define-vop (move-base-char-argument) - (:args (x :target y - :scs (base-char-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y base-char-reg)))) - (:results (y)) - (:note "character arg move") - (:generator 0 - (sc-case y - (base-char-reg - (move y x)) - (base-char-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-base-char-argument :move-argument - (any-reg base-char-reg) (base-char-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char -;;; to a descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (base-char-reg) (any-reg descriptor-reg)) - - - -;;;; Other operations: - -(define-vop (char-code) - (:translate char-code) - (:policy :fast-safe) - (:args (ch :scs (base-char-reg) :target res)) - (:arg-types base-char) - (:results (res :scs (any-reg))) - (:result-types positive-fixnum) - (:generator 1 - (inst sll res ch 2))) - -(define-vop (code-char) - (:translate code-char) - (:policy :fast-safe) - (:args (code :scs (any-reg) :target res)) - (:arg-types positive-fixnum) - (:results (res :scs (base-char-reg))) - (:result-types base-char) - (:generator 1 - (inst srl res code 2))) - - -;;; Comparison of base-chars. -;;; -(define-vop (base-char-compare) - (:args (x :scs (base-char-reg)) - (y :scs (base-char-reg))) - (:arg-types base-char base-char) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:note "inline comparison") - (:variant-vars condition not-condition) - (:generator 3 - (inst cmp x y) - (inst b (if not-p not-condition condition) target) - (inst nop))) - -(define-vop (fast-char=/base-char base-char-compare) - (:translate char=) - (:variant :eq :ne)) - -(define-vop (fast-char</base-char base-char-compare) - (:translate char<) - (:variant :ltu :geu)) - -(define-vop (fast-char>/base-char base-char-compare) - (:translate char>) - (:variant :gtu :leu)) - diff --git a/compiler/sparc/debug.lisp b/compiler/sparc/debug.lisp deleted file mode 100644 index d2d4ab7a2398f24ed05aa347c7950289de205dcd..0000000000000000000000000000000000000000 --- a/compiler/sparc/debug.lisp +++ /dev/null @@ -1,128 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/debug.lisp,v 1.3 1992/02/25 07:06:23 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Compiler support for the new whizzy debugger. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") - -(defknown di::current-sp () system-area-pointer (movable flushable)) -(defknown di::current-fp () system-area-pointer (movable flushable)) -(defknown di::stack-ref (system-area-pointer index) t (flushable)) -(defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe)) -(defknown di::lra-code-header (t) t (movable flushable)) -(defknown di::function-code-header (t) t (movable flushable)) -(defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable)) -(defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable)) -(defknown di::function-word-offset (function) index (movable flushable)) - -(define-vop (debug-cur-sp) - (:translate di::current-sp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move res csp-tn))) - -(define-vop (debug-cur-fp) - (:translate di::current-fp) - (:policy :fast-safe) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 1 - (move res cfp-tn))) - -(define-vop (read-control-stack) - (:translate kernel:stack-ref) - (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (offset :scs (any-reg))) - (:arg-types system-area-pointer positive-fixnum) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 5 - (inst ld result sap offset))) - -(define-vop (write-control-stack) - (:translate kernel:%set-stack-ref) - (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (offset :scs (any-reg)) - (value :scs (descriptor-reg) :target result)) - (:arg-types system-area-pointer positive-fixnum *) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:generator 5 - (inst st value sap offset) - (move result value))) - -(define-vop (code-from-mumble) - (:policy :fast-safe) - (:args (thing :scs (descriptor-reg))) - (:results (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:variant-vars lowtag) - (:generator 5 - (let ((bogus (gen-label)) - (done (gen-label))) - (loadw temp thing 0 lowtag) - (inst srl temp vm:type-bits) - (inst cmp temp) - (inst b :eq bogus) - (inst sll temp (1- (integer-length vm:word-bytes))) - (unless (= lowtag vm:other-pointer-type) - (inst add temp (- lowtag vm:other-pointer-type))) - (inst sub code thing temp) - (emit-label done) - (assemble (*elsewhere*) - (emit-label bogus) - (inst b done) - (move code null-tn))))) - -(define-vop (code-from-lra code-from-mumble) - (:translate di::lra-code-header) - (:variant vm:other-pointer-type)) - -(define-vop (code-from-function code-from-mumble) - (:translate di::function-code-header) - (:variant vm:function-pointer-type)) - -(define-vop (make-lisp-obj) - (:policy :fast-safe) - (:translate di::make-lisp-obj) - (:args (value :scs (unsigned-reg) :target result)) - (:arg-types unsigned-num) - (:results (result :scs (descriptor-reg))) - (:generator 1 - (move result value))) - -(define-vop (get-lisp-obj-address) - (:policy :fast-safe) - (:translate di::get-lisp-obj-address) - (:args (thing :scs (descriptor-reg) :target result)) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 1 - (move result thing))) - - -(define-vop (function-word-offset) - (:policy :fast-safe) - (:translate di::function-word-offset) - (:args (fun :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 5 - (loadw res fun 0 function-pointer-type) - (inst srl res vm:type-bits))) diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp deleted file mode 100644 index b273ad7d5aa3d54012d0328265cb50428a30b646..0000000000000000000000000000000000000000 --- a/compiler/sparc/float.lisp +++ /dev/null @@ -1,520 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/float.lisp,v 1.10 1992/10/20 03:10:34 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains floating point support for the MIPS. -;;; -;;; Written by Rob MacLachlan -;;; Sparc conversion by William Lott. -;;; -(in-package "SPARC") - - -;;;; Move functions: - -(define-move-function (load-single 1) (vop x y) - ((single-stack) (single-reg)) - (inst ldf y (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))) - -(define-move-function (store-single 1) (vop x y) - ((single-reg) (single-stack)) - (inst stf x (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))) - - -(define-move-function (load-double 2) (vop x y) - ((double-stack) (double-reg)) - (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset x) vm:word-bytes))) - (inst lddf y nfp offset))) - -(define-move-function (store-double 2) (vop x y) - ((double-reg) (double-stack)) - (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset y) vm:word-bytes))) - (inst stdf x nfp offset))) - - - -;;;; Move VOPs: - -(macrolet ((frob (vop sc double-p) - `(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") - (:generator 0 - (unless (location= y x) - (inst fmovs y x) - ,@(when double-p - '((inst fmovs-odd y x)))))) - (define-move-vop ,vop :move (,sc) (,sc))))) - (frob single-move single-reg nil) - (frob double-move double-reg t)) - - -(define-vop (move-from-float) - (:args (x :to :save)) - (:results (y)) - (:note "float to pointer coercion") - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:variant-vars double-p size type data) - (:generator 13 - (with-fixed-allocation (y ndescr type size)) - (if double-p - (inst stdf x y (- (* data vm:word-bytes) vm:other-pointer-type)) - (inst stf x y (- (* data vm:word-bytes) vm:other-pointer-type))))) - -(macrolet ((frob (name sc &rest args) - `(progn - (define-vop (,name move-from-float) - (:args (x :scs (,sc) :to :save)) - (:results (y :scs (descriptor-reg))) - (:variant ,@args)) - (define-move-vop ,name :move (,sc) (descriptor-reg))))) - (frob move-from-single single-reg - nil vm:single-float-size vm:single-float-type vm:single-float-value-slot) - (frob move-from-double double-reg - t vm:double-float-size vm:double-float-type vm:double-float-value-slot)) - -(macrolet ((frob (name sc double-p value) - `(progn - (define-vop (,name) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (,sc))) - (:note "pointer to float coercion") - (:generator 2 - (inst ,(if double-p 'lddf 'ldf) y x - (- (* ,value vm:word-bytes) vm:other-pointer-type)))) - (define-move-vop ,name :move (descriptor-reg) (,sc))))) - (frob move-to-single single-reg nil vm:single-float-value-slot) - (frob move-to-double double-reg t vm:double-float-value-slot)) - - -(macrolet ((frob (name sc stack-sc double-p) - `(progn - (define-vop (,name) - (:args (x :scs (,sc) :target y) - (nfp :scs (any-reg) - :load-if (not (sc-is y ,sc)))) - (:results (y)) - (:note "float argument move") - (:generator ,(if double-p 2 1) - (sc-case y - (,sc - (unless (location= x y) - (inst fmovs y x) - ,@(when double-p - '((inst fmovs-odd y x))))) - (,stack-sc - (let ((offset (* (tn-offset y) vm:word-bytes))) - (inst ,(if double-p 'stdf 'stf) x nfp offset)))))) - (define-move-vop ,name :move-argument - (,sc descriptor-reg) (,sc))))) - (frob move-single-float-argument single-reg single-stack nil) - (frob move-double-float-argument double-reg double-stack t)) - - -(define-move-vop move-argument :move-argument - (single-reg double-reg) (descriptor-reg)) - - -;;;; Arithmetic VOPs: - -(define-vop (float-op) - (:args (x) (y)) - (:results (r)) - (:policy :fast-safe) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only)) - -(macrolet ((frob (name sc ptype) - `(define-vop (,name float-op) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:results (r :scs (,sc))) - (:arg-types ,ptype ,ptype) - (:result-types ,ptype)))) - (frob single-float-op single-reg single-float) - (frob double-float-op double-reg double-float)) - -(macrolet ((frob (op sinst sname scost dinst dname dcost) - `(progn - (define-vop (,sname single-float-op) - (:translate ,op) - (:generator ,scost - (inst ,sinst r x y))) - (define-vop (,dname double-float-op) - (:translate ,op) - (:generator ,dcost - (inst ,dinst r x y)))))) - (frob + fadds +/single-float 2 faddd +/double-float 2) - (frob - fsubs -/single-float 2 fsubd -/double-float 2) - (frob * fmuls */single-float 4 fmuld */double-float 5) - (frob / fdivs //single-float 12 fdivd //double-float 19)) - -(macrolet ((frob (name inst translate double-p sc type) - `(define-vop (,name) - (:args (x :scs (,sc))) - (:results (y :scs (,sc))) - (:translate ,translate) - (:policy :fast-safe) - (:arg-types ,type) - (:result-types ,type) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:generator 1 - (note-this-location vop :internal-error) - (inst ,inst y x) - ,@(when double-p - '((inst fmovs-odd y x))))))) - (frob abs/single-float fabss abs nil single-reg single-float) - (frob abs/double-float fabss abs t double-reg double-float) - (frob %negate/single-float fnegs %negate nil single-reg single-float) - (frob %negate/double-float fnegs %negate t double-reg double-float)) - - -;;;; Comparison: - -(define-vop (float-compare) - (:args (x) (y)) - (:conditional) - (:info target not-p) - (:variant-vars format yep nope) - (:policy :fast-safe) - (:note "inline float comparison") - (:vop-var vop) - (:save-p :compute-only) - (:generator 3 - (note-this-location vop :internal-error) - (ecase format - (:single (inst fcmps x y)) - (:double (inst fcmpd x y))) - (inst nop) - (inst fb (if not-p nope yep) target) - (inst nop))) - -(macrolet ((frob (name sc ptype) - `(define-vop (,name float-compare) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:arg-types ,ptype ,ptype)))) - (frob single-float-compare single-reg single-float) - (frob double-float-compare double-reg double-float)) - -(macrolet ((frob (translate yep nope sname dname) - `(progn - (define-vop (,sname single-float-compare) - (:translate ,translate) - (:variant :single ,yep ,nope)) - (define-vop (,dname double-float-compare) - (:translate ,translate) - (:variant :double ,yep ,nope))))) - (frob < :l :ge </single-float </double-float) - (frob > :g :le >/single-float >/double-float) - (frob eql :eq :ne eql/single-float eql/double-float)) - - -;;;; Conversion: - -(macrolet ((frob (name translate inst to-sc to-type) - `(define-vop (,name) - (:args (x :scs (signed-reg) :target temp - :load-if (not (sc-is x signed-stack)))) - (:temporary (:scs (single-stack)) temp) - (:results (y :scs (,to-sc))) - (:arg-types signed-num) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (let ((stack-tn - (sc-case x - (signed-reg - (inst st x - (current-nfp-tn vop) - (* (tn-offset temp) vm:word-bytes)) - temp) - (signed-stack - x)))) - (inst ldf y - (current-nfp-tn vop) - (* (tn-offset stack-tn) vm:word-bytes)) - (note-this-location vop :internal-error) - (inst ,inst y y)))))) - (frob %single-float/signed %single-float fitos single-reg single-float) - (frob %double-float/signed %double-float fitod double-reg double-float)) - -(macrolet ((frob (name translate inst from-sc from-type to-sc to-type) - `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (,to-sc))) - (:arg-types ,from-type) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:generator 2 - (note-this-location vop :internal-error) - (inst ,inst y x))))) - (frob %single-float/double-float %single-float fdtos - double-reg double-float single-reg single-float) - (frob %double-float/single-float %double-float fstod - single-reg single-float double-reg double-float)) - -(macrolet ((frob (trans from-sc from-type inst) - `(define-vop (,(symbolicate trans "/" from-type)) - (:args (x :scs (,from-sc) :target temp)) - (:temporary (:from (:argument 0) :sc single-reg) temp) - (:temporary (:scs (signed-stack)) stack-temp) - (:results (y :scs (signed-reg) - :load-if (not (sc-is y signed-stack)))) - (:arg-types ,from-type) - (:result-types signed-num) - (:translate ,trans) - (:policy :fast-safe) - (:note "inline float truncate") - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (note-this-location vop :internal-error) - (inst ,inst temp x) - (sc-case y - (signed-stack - (inst stf temp (current-nfp-tn vop) - (* (tn-offset y) vm:word-bytes))) - (signed-reg - (inst stf temp (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst ld y (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)))))))) - (frob %unary-truncate single-reg single-float fstoi) - (frob %unary-truncate double-reg double-float fdtoi) - #-sun4 - (frob %unary-round single-reg single-float fstoir) - #-sun4 - (frob %unary-round double-reg double-float fdtoir)) - -#+sun4 -(deftransform %unary-round ((x) (float) (signed-byte 32)) - '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x))) - (extra (- x trunc)) - (absx (abs extra)) - (one-half (float 1/2 x))) - (if (if (oddp trunc) - (>= absx one-half) - (> absx one-half)) - (truly-the (signed-byte 32) (%unary-truncate (+ x extra))) - trunc))) - -(define-vop (make-single-float) - (:args (bits :scs (signed-reg) :target res - :load-if (not (sc-is bits signed-stack)))) - (:results (res :scs (single-reg) - :load-if (not (sc-is res single-stack)))) - (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp) - (:temporary (:scs (signed-stack)) stack-temp) - (:arg-types signed-num) - (:result-types single-float) - (:translate make-single-float) - (:policy :fast-safe) - (:vop-var vop) - (:generator 4 - (sc-case bits - (signed-reg - (sc-case res - (single-reg - (inst st bits (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst ldf res (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes))) - (single-stack - (inst st bits (current-nfp-tn vop) - (* (tn-offset res) vm:word-bytes))))) - (signed-stack - (sc-case res - (single-reg - (inst ldf res (current-nfp-tn vop) - (* (tn-offset bits) vm:word-bytes))) - (single-stack - (unless (location= bits res) - (inst ld temp (current-nfp-tn vop) - (* (tn-offset bits) vm:word-bytes)) - (inst st temp (current-nfp-tn vop) - (* (tn-offset res) vm:word-bytes))))))))) - -(define-vop (make-double-float) - (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) - (:results (res :scs (double-reg) - :load-if (not (sc-is res double-stack)))) - (:temporary (:scs (double-stack)) temp) - (:arg-types signed-num unsigned-num) - (:result-types double-float) - (:translate make-double-float) - (:policy :fast-safe) - (:vop-var vop) - (:generator 2 - (let ((stack-tn (sc-case res - (double-stack res) - (double-reg temp)))) - (inst st hi-bits (current-nfp-tn vop) - (* (tn-offset stack-tn) vm:word-bytes)) - (inst st lo-bits (current-nfp-tn vop) - (* (1+ (tn-offset stack-tn)) vm:word-bytes))) - (when (sc-is res double-reg) - (inst lddf res (current-nfp-tn vop) - (* (tn-offset temp) vm:word-bytes))))) - -(define-vop (single-float-bits) - (:args (float :scs (single-reg descriptor-reg) - :load-if (not (sc-is float single-stack)))) - (:results (bits :scs (signed-reg) - :load-if (or (sc-is float descriptor-reg single-stack) - (not (sc-is bits signed-stack))))) - (:temporary (:scs (signed-stack)) stack-temp) - (:arg-types single-float) - (:result-types signed-num) - (:translate single-float-bits) - (:policy :fast-safe) - (:vop-var vop) - (:generator 4 - (sc-case bits - (signed-reg - (sc-case float - (single-reg - (inst stf float (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst ld bits (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes))) - (single-stack - (inst ld bits (current-nfp-tn vop) - (* (tn-offset float) vm:word-bytes))) - (descriptor-reg - (loadw bits float vm:single-float-value-slot vm:other-pointer-type)))) - (signed-stack - (sc-case float - (single-reg - (inst stf float (current-nfp-tn vop) - (* (tn-offset bits) vm:word-bytes)))))))) - -(define-vop (double-float-high-bits) - (:args (float :scs (double-reg descriptor-reg) - :load-if (not (sc-is float double-stack)))) - (:results (hi-bits :scs (signed-reg) - :load-if (or (sc-is float descriptor-reg double-stack) - (not (sc-is hi-bits signed-stack))))) - (:temporary (:scs (signed-stack)) stack-temp) - (:arg-types double-float) - (:result-types signed-num) - (:translate double-float-high-bits) - (:policy :fast-safe) - (:vop-var vop) - (:generator 5 - (sc-case hi-bits - (signed-reg - (sc-case float - (double-reg - (inst stf float (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst ld hi-bits (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes))) - (double-stack - (inst ld hi-bits (current-nfp-tn vop) - (* (tn-offset float) vm:word-bytes))) - (descriptor-reg - (loadw hi-bits float vm:double-float-value-slot - vm:other-pointer-type)))) - (signed-stack - (sc-case float - (double-reg - (inst stf float (current-nfp-tn vop) - (* (tn-offset hi-bits) vm:word-bytes)))))))) - -(define-vop (double-float-low-bits) - (:args (float :scs (double-reg descriptor-reg) - :load-if (not (sc-is float double-stack)))) - (:results (lo-bits :scs (unsigned-reg) - :load-if (or (sc-is float descriptor-reg double-stack) - (not (sc-is lo-bits unsigned-stack))))) - (:temporary (:scs (unsigned-stack)) stack-temp) - (:arg-types double-float) - (:result-types unsigned-num) - (:translate double-float-low-bits) - (:policy :fast-safe) - (:vop-var vop) - (:generator 5 - (sc-case lo-bits - (unsigned-reg - (sc-case float - (double-reg - (inst stf-odd float (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst ld lo-bits (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes))) - (double-stack - (inst ld lo-bits (current-nfp-tn vop) - (* (1+ (tn-offset float)) vm:word-bytes))) - (descriptor-reg - (loadw lo-bits float (1+ vm:double-float-value-slot) - vm:other-pointer-type)))) - (unsigned-stack - (sc-case float - (double-reg - (inst stf-odd float (current-nfp-tn vop) - (* (tn-offset lo-bits) vm:word-bytes)))))))) - - -;;;; 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) - (:vop-var vop) - (:temporary (:sc unsigned-stack) temp) - (:generator 3 - (let ((nfp (current-nfp-tn vop))) - (inst stfsr nfp (* word-bytes (tn-offset temp))) - (loadw res nfp (tn-offset temp)) - (inst nop)))) - -(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) - (:temporary (:sc unsigned-stack) temp) - (:vop-var vop) - (:generator 3 - (let ((nfp (current-nfp-tn vop))) - (storew new nfp (tn-offset temp)) - (inst ldfsr nfp (* word-bytes (tn-offset temp))) - (move res new)))) diff --git a/compiler/sparc/insts.lisp b/compiler/sparc/insts.lisp deleted file mode 100644 index 2cb290326bf713731dbcc5fcec7bc51c024e8361..0000000000000000000000000000000000000000 --- a/compiler/sparc/insts.lisp +++ /dev/null @@ -1,890 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/insts.lisp,v 1.10 1992/07/23 17:46:06 hallgren Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Description of the SPARC architecture. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") - -(use-package "NEW-ASSEM") -(use-package "EXT") -(use-package "C") - -(def-assembler-params - :scheduler-p nil) - - -;;;; Constants, types, conversion functions, some disassembler stuff. - -(defun reg-tn-encoding (tn) - (declare (type tn tn)) - (sc-case tn - (zero zero-offset) - (null null-offset) - (t - (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers) - (tn-offset tn) - (error "~S isn't a register." tn))))) - -(defun fp-reg-tn-encoding (tn &optional odd) - (declare (type tn tn)) - (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers) - (error "~S isn't a floating-point register." tn)) - (if odd - (1+ (tn-offset tn)) - (tn-offset tn))) - -(disassem:set-disassem-params :instruction-alignment 32) - -(defvar *disassem-use-lisp-reg-names* t) - -(defconstant reg-symbols - (map 'vector - #'(lambda (name) - (cond ((null name) nil) - (t (make-symbol (concatenate 'string "%" name))))) - sparc::*register-names*)) - -(disassem:define-argument-type reg - :printer #'(lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref reg-symbols value))) - (princ regname stream) - (disassem:maybe-note-associated-storage-ref - value - 'registers - regname - dstate)))) - -(defconstant float-reg-symbols - (coerce - (loop for n from 0 to 31 collect (make-symbol (format nil "%F~d" n))) - 'vector)) - -(disassem:define-argument-type fp-reg - :printer #'(lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref float-reg-symbols value))) - (princ regname stream) - (disassem:maybe-note-associated-storage-ref - value - 'float-registers - regname - dstate)))) - -(disassem:define-argument-type relative-label - :sign-extend t - :use-label #'(lambda (value dstate) - (declare (type (signed-byte 13) value) - (type disassem:disassem-state dstate)) - (+ (ash value 2) (disassem:dstate-cur-addr dstate)))) - -(defconstant branch-conditions - '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)) - -;;; Note that these aren't the standard names for branch-conditions, I think -;;; they're a bit more readable (e.g., "eq" instead of "e"). You could just -;;; put a vector of the normal ones here too. -(defconstant branch-cond-name-vec - (coerce branch-conditions 'vector)) - -(disassem:define-argument-type branch-condition - :printer branch-cond-name-vec) - -(deftype branch-condition () - `(member ,@branch-conditions)) - -(defun branch-condition (condition) - (or (position condition branch-conditions) - (error "Unknown branch condition: ~S~%Must be one of: ~S" - condition branch-conditions))) - -(defconstant branch-cond-true - #b1000) - -(defconstant branch-fp-conditions - '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o)) - -(defconstant branch-fp-cond-name-vec - (coerce branch-fp-conditions 'vector)) - -(disassem:define-argument-type branch-fp-condition - :printer branch-fp-cond-name-vec) - -(disassem:define-argument-type call-fixup :use-label t) - -(deftype fp-branch-condition () - `(member ,@branch-fp-conditions)) - -(defun fp-branch-condition (condition) - (or (position condition branch-fp-conditions) - (error "Unknown fp-branch condition: ~S~%Must be one of: ~S" - condition branch-fp-conditions))) - - -;;;; dissassem:define-instruction-formats - -(disassem:define-instruction-format - (format-1 32 :default-printer '(:name :tab disp)) - (op :field (byte 2 30) :value 1) - (disp :field (byte 30 0))) - -(disassem:define-instruction-format - (format-2-immed 32 :default-printer '(:name :tab immed ", " rd)) - (op :field (byte 2 30) :value 0) - (rd :field (byte 5 25) :type 'reg) - (op2 :field (byte 3 22)) - (immed :field (byte 22 0))) - -(defconstant branch-printer - `(:name (:unless (:constant ,branch-cond-true) cond) - (:unless (a :constant 0) "," 'A) - :tab - disp)) - -(disassem:define-instruction-format - (format-2-branch 32 :default-printer branch-printer) - (op :field (byte 2 30) :value 0) - (a :field (byte 1 29) :value 0) - (cond :field (byte 4 25) :type 'branch-condition) - (op2 :field (byte 3 22)) - (disp :field (byte 22 0) :type 'relative-label)) - -(disassem:define-instruction-format - (format-2-unimp 32 :default-printer '(:name :tab data)) - (op :field (byte 2 30) :value 0) - (ignore :field (byte 5 25) :value 0) - (op2 :field (byte 3 22) :value 0) - (data :field (byte 22 0))) - -(defconstant f3-printer - '(:name :tab - (:unless (:same-as rd) rs1 ", ") - (:choose rs2 immed) ", " - rd)) - -(disassem:define-instruction-format - (format-3-reg 32 :default-printer f3-printer) - (op :field (byte 2 30)) - (rd :field (byte 5 25) :type 'reg) - (op3 :field (byte 6 19)) - (rs1 :field (byte 5 14) :type 'reg) - (i :field (byte 1 13) :value 0) - (asi :field (byte 8 5) :value 0) - (rs2 :field (byte 5 0) :type 'reg)) - -(disassem:define-instruction-format - (format-3-immed 32 :default-printer f3-printer) - (op :field (byte 2 30)) - (rd :field (byte 5 25) :type 'reg) - (op3 :field (byte 6 19)) - (rs1 :field (byte 5 14) :type 'reg) - (i :field (byte 1 13) :value 1) - (immed :field (byte 13 0) :sign-extend t)) ; usually sign extended - -(disassem:define-instruction-format - (format-3-fpop 32 - :default-printer - '(:name :tab (:unless (:same-as rd) rs1 ", ") rs2 ", " rd)) - (op :field (byte 2 30)) - (rd :field (byte 5 25) :type 'fp-reg) - (op3 :field (byte 6 19)) - (rs1 :field (byte 5 14) :type 'fp-reg) - (opf :field (byte 9 5)) - (rs2 :field (byte 5 0) :type 'fp-reg)) - - - -;;;; Primitive emitters. - -(define-emitter emit-word 32 - (byte 32 0)) - -(define-emitter emit-short 16 - (byte 16 0)) - -(define-emitter emit-format-1 32 - (byte 2 30) (byte 30 0)) - -(define-emitter emit-format-2-immed 32 - (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0)) - -(define-emitter emit-format-2-branch 32 - (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 22 0)) - -(define-emitter emit-format-2-unimp 32 - (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0)) - -(define-emitter emit-format-3-reg 32 - (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 8 5) - (byte 5 0)) - -(define-emitter emit-format-3-immed 32 - (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 13 0)) - -(define-emitter emit-format-3-fpop 32 - (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 9 5) (byte 5 0)) - - - -;;;; Most of the format-3-instructions. - -(defun emit-format-3-inst (segment op op3 dst src1 src2 - &key load-store fixup dest-kind odd) - (unless src2 - (cond ((and (typep src1 'tn) load-store) - (setf src2 0)) - (t - (setf src2 src1) - (setf src1 dst)))) - (etypecase src2 - (tn - (emit-format-3-reg segment op - (if dest-kind - (fp-reg-tn-encoding dst odd) - (reg-tn-encoding dst)) - op3 (reg-tn-encoding src1) 0 0 (reg-tn-encoding src2))) - (integer - (emit-format-3-immed segment op - (if dest-kind - (fp-reg-tn-encoding dst odd) - (reg-tn-encoding dst)) - op3 (reg-tn-encoding src1) 1 src2)) - (fixup - (unless (or load-store fixup) - (error "Fixups aren't allowed.")) - (note-fixup segment :add src2) - (emit-format-3-immed segment op - (if dest-kind - (fp-reg-tn-encoding dst odd) - (reg-tn-encoding dst)) - op3 (reg-tn-encoding src1) 1 0)))) - -(eval-when (compile eval) - -;;; have to do this because defconstant is evalutated in the null lex env. -(defmacro with-ref-format (printer) - `(let* ((addend - '(:choose (:plus-integer immed) ("+" rs2))) - (ref-format - `("[" rs1 (:unless (:constant 0) ,addend) "]" - (:choose (:unless (:constant 0) asi) nil)))) - ,printer)) - -(defconstant load-printer - (with-ref-format `(:NAME :TAB ,ref-format ", " rd))) - -(defconstant store-printer - (with-ref-format `(:NAME :TAB rd ", " ,ref-format))) - -(defmacro define-f3-inst (name op op3 &key fixup load-store (dest-kind 'reg) - (printer :default)) - (let ((printer - (if (eq printer :default) - (case load-store - ((nil) :default) - ((:load t) 'load-printer) - (:store 'store-printer)) - printer))) - `(define-instruction ,name (segment dst src1 &optional src2) - (:declare (type tn dst) - ,(if (or fixup load-store) - '(type (or tn (signed-byte 13) null fixup) src1 src2) - '(type (or tn (signed-byte 13) null) src1 src2))) - ,@(unless (eq dest-kind 'odd-fp-reg) - `((:printer format-3-reg - ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind)) - ,printer) - (:printer format-3-immed - ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind)) - ,printer))) - (:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2 - :load-store ,load-store - :fixup ,fixup - :dest-kind (not (eq ',dest-kind 'reg)) - :odd (eq ',dest-kind 'odd-fp-reg)))))) - -) ; eval-when (compile eval) - -(define-f3-inst ldsb #b11 #b001001 :load-store :load) -(define-f3-inst ldsh #b11 #b001010 :load-store :load) -(define-f3-inst ldub #b11 #b000001 :load-store :load) -(define-f3-inst lduh #b11 #b000010 :load-store :load) -(define-f3-inst ld #b11 #b000000 :load-store :load) -(define-f3-inst ldd #b11 #b000011 :load-store :load) -(define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load) -(define-f3-inst ldf-odd #b11 #b100000 :dest-kind odd-fp-reg :load-store :load) -(define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load) -(define-f3-inst stb #b11 #b000101 :load-store :store) -(define-f3-inst sth #b11 #b000110 :load-store :store) -(define-f3-inst st #b11 #b000100 :load-store :store) -(define-f3-inst std #b11 #b000111 :load-store :store) -(define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store) -(define-f3-inst stf-odd #b11 #b100100 :dest-kind odd-fp-reg :load-store :store) -(define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store) -(define-f3-inst ldstub #b11 #b001101 :load-store t) -(define-f3-inst swap #b11 #b001111 :load-store t) -(define-f3-inst add #b10 #b000000 :fixup t) -(define-f3-inst addcc #b10 #b010000) -(define-f3-inst addx #b10 #b001000) -(define-f3-inst addxcc #b10 #b011000) -(define-f3-inst taddcc #b10 #b100000) -(define-f3-inst taddcctv #b10 #b100010) -(define-f3-inst sub #b10 #b000100) -(define-f3-inst subcc #b10 #b010100) -(define-f3-inst subx #b10 #b001100) -(define-f3-inst subxcc #b10 #b011100) -(define-f3-inst tsubcc #b10 #b100001) -(define-f3-inst tsubcctv #b10 #b100011) -(define-f3-inst mulscc #b10 #b100100) -(define-f3-inst and #b10 #b000001) -(define-f3-inst andcc #b10 #b010001) -(define-f3-inst andn #b10 #b000101) -(define-f3-inst andncc #b10 #b010101) -(define-f3-inst or #b10 #b000010) -(define-f3-inst orcc #b10 #b010010) -(define-f3-inst orn #b10 #b000110) -(define-f3-inst orncc #b10 #b010110) -(define-f3-inst xor #b10 #b000011) -(define-f3-inst xorcc #b10 #b010011) -(define-f3-inst xnor #b10 #b000111) -(define-f3-inst xnorcc #b10 #b010111) -(define-f3-inst sll #b10 #b100101) -(define-f3-inst srl #b10 #b100110) -(define-f3-inst sra #b10 #b100111) -(define-f3-inst save #b10 #b111100) -(define-f3-inst restore #b10 #b111101) - - - -;;;; Random instructions. - -(define-instruction ldfsr (segment src1 src2) - (:declare (type tn src1) (type (signed-byte 13) src2)) - (:printer format-3-immed ((op #b11) (op3 #b100001))) - (:reads (list src1 :memory)) - (:writes :float-status) - (:emitter (emit-format-3-immed segment #b11 0 #b100001 - (reg-tn-encoding src1) 1 src2))) - -(define-instruction stfsr (segment src1 src2) - (:declare (type tn src1) (type (signed-byte 13) src2)) - (:printer format-3-immed ((op #b11) (op3 #b100101))) - (:reads (list src1 :float-status)) - (:writes :memory) - (:emitter (emit-format-3-immed segment #b11 0 #b100101 - (reg-tn-encoding src1) 1 src2))) - -(eval-when (compile load eval) - (defun sethi-arg-printer (value stream dstate) - (declare (ignore dstate)) - (format stream "%hi(#x~8,'0x)" (ash value 10))) -) ; eval-when (compile load eval) - -(define-instruction sethi (segment dst src1) - (:declare (type tn dst) - (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1)) - (:printer format-2-immed - ((op2 #b100) (immed nil :printer #'sethi-arg-printer))) - (:writes dst) - (:emitter - (etypecase src1 - (integer - (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 - src1)) - (fixup - (note-fixup segment :sethi src1) - (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0))))) - -(define-instruction rdy (segment dst) - (:declare (type tn dst)) - (:printer format-3-immed ((op #b10) (op3 #b101000) (rs1 0) (immed 0)) - '('RD :tab '%Y ", " rd)) - (:reads dst) - (:emitter (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b101000 - 0 1 0))) - -(defconstant wry-printer - '('WR :tab rs1 (:unless (:constant 0) ", " (:choose immed rs2)) ", " '%Y)) - -(define-instruction wry (segment src1 &optional src2) - (:declare (type tn src1) (type (or (signed-byte 13) tn null) src2)) - (:printer format-3-reg ((op #b10) (op3 #b110000) (rd 0)) wry-printer) - (:printer format-3-immed ((op #b10) (op3 #b110000) (rd 0)) wry-printer) - (:writes (if src2 (list src1 src2) src1)) - (:delay 3) - (:emitter - (etypecase src2 - (null - (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0)) - (tn - (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 - (reg-tn-encoding src2))) - (integer - (emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1 - src2))))) - -(defun snarf-error-junk (sap offset &optional length-only) - (let* ((length (system:sap-ref-8 sap offset)) - (vector (make-array length :element-type '(unsigned-byte 8)))) - (declare (type system:system-area-pointer sap) - (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) - (cond (length-only - (values 0 (1+ length) nil nil)) - (t - (kernel:copy-from-system-area sap (* sparc:byte-bits (1+ offset)) - vector (* sparc:word-bits - sparc:vector-data-offset) - (* length sparc:byte-bits)) - (collect ((sc-offsets) - (lengths)) - (lengths 1) ; the length byte - (let* ((index 0) - (error-number (c::read-var-integer vector index))) - (lengths index) - (loop - (when (>= index length) - (return)) - (let ((old-index index)) - (sc-offsets (c::read-var-integer vector index)) - (lengths (- index old-index)))) - (values error-number - (1+ length) - (sc-offsets) - (lengths)))))))) - -(defun unimp-control (chunk inst stream dstate) - (declare (ignore inst)) - (flet ((nt (x) (if stream (disassem:note x dstate)))) - (case (format-2-unimp-data chunk dstate) - (#.vm:error-trap - (nt "Error trap") - (disassem:handle-break-args #'snarf-error-junk stream dstate)) - (#.vm:cerror-trap - (nt "Cerror trap") - (disassem:handle-break-args #'snarf-error-junk stream dstate)) - (#.vm:object-not-list-trap - (nt "Object not list trap")) - (#.vm:breakpoint-trap - (nt "Breakpoint trap")) - (#.vm:pending-interrupt-trap - (nt "Pending interrupt trap")) - (#.vm:halt-trap - (nt "Halt trap")) - (#.vm:function-end-breakpoint-trap - (nt "Function end breakpoint trap")) - (#.vm:object-not-structure-trap - (nt "Object not structure trap")) - ))) - -(define-instruction unimp (segment data) - (:declare (type (unsigned-byte 22) data)) - (:printer format-2-unimp () :default :control #'unimp-control) - (:emitter (emit-format-2-unimp segment 0 0 0 data))) - - - -;;;; Branch instructions. - -(defun emit-relative-branch (segment a op2 cond-or-target target &optional fp) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (unless target - (setf target cond-or-target) - (setf cond-or-target :t)) - (emit-format-2-branch - segment #b00 a - (if fp - (fp-branch-condition cond-or-target) - (branch-condition cond-or-target)) - op2 - (ash (- (label-position target) posn) -2))))) - -(define-instruction b (segment cond-or-target &optional target) - (:declare (type (or label branch-condition) cond-or-target) - (type (or label null) target)) - (:printer format-2-branch ((op #b00) (op2 #b010))) - (:emitter - (emit-relative-branch segment 0 #b010 cond-or-target target))) - -(define-instruction ba (segment cond-or-target &optional target) - (:declare (type (or label branch-condition) cond-or-target) - (type (or label null) target)) - (:printer format-2-branch ((op #b00) (op2 #b010) (a 1)) - nil - :print-name 'b) - (:emitter - (emit-relative-branch segment 1 #b010 cond-or-target target))) - -(define-instruction t (segment condition target) - (:declare (type branch-condition condition) - (type (or (signed-byte 13) (unsigned-byte 13)) target)) - (:printer format-3-immed ((op #b10) - (rd nil :type 'branch-condition) - (op3 #b111010) - (rs1 0)) - '(:name rd :tab immed)) - (:emitter (emit-format-3-immed segment #b10 (branch-condition condition) - #b111010 0 1 target))) - -(define-instruction fb (segment condition target) - (:declare (type fp-branch-condition condition) (type label target)) - (:printer format-2-branch ((Op #B00) - (cond nil :type 'branch-fp-condition) - (op2 #b110))) - (:emitter - (emit-relative-branch segment 0 #b110 condition target t))) - -(defconstant jal-printer - '(:name :tab - (:choose (rs1 (:unless (:constant 0) (:plus-integer immed))) - (:cond ((rs2 :constant 0) rs1) - ((rs1 :constant 0) rs2) - (t rs1 "+" rs2))) - (:unless (:constant 0) ", " rd))) - -(define-instruction jal (segment dst src1 &optional src2) - (:declare (type tn dst) - (type (or tn integer) src1) - (type (or null fixup tn (signed-byte 13)) src2)) - (:printer format-3-reg ((op #b10) (op3 #b111000)) jal-printer) - (:printer format-3-immed ((op #b10) (op3 #b111000)) jal-printer) - (:emitter - (unless src2 - (setf src2 src1) - (setf src1 0)) - (etypecase src2 - (tn - (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b111000 - (if (integerp src1) - src1 - (reg-tn-encoding src1)) - 0 0 (reg-tn-encoding src2))) - (integer - (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b111000 - (reg-tn-encoding src1) 1 src2)) - (fixup - (note-fixup segment :add src2) - (emit-format-3-immed segment #b10 (reg-tn-encoding dst) - #b111000 (reg-tn-encoding src1) 1 0))))) - -(define-instruction j (segment src1 &optional src2) - (:declare (type tn src1) (type (or tn (signed-byte 13) fixup null) src2)) - (:printer format-3-reg ((op #b10) (op3 #b111000) (rd 0)) jal-printer) - (:printer format-3-immed ((op #b10) (op3 #b111000) (rd 0)) jal-printer) - (:emitter - (etypecase src2 - (null - (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 0)) - (tn - (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 - (reg-tn-encoding src2))) - (integer - (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1 - src2)) - (fixup - (note-fixup segment :add src2) - (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1 - 0))))) - - - -;;;; Unary and binary fp insts. - -(defun emit-fp-inst (segment opf op3 dst src1 src2) - (unless src2 - (setf src2 src1) - (setf src1 dst)) - (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst) op3 - (fp-reg-tn-encoding src1) opf (fp-reg-tn-encoding src2))) - -(eval-when (compile eval) - -(defmacro define-unary-fp-inst (name opf) - `(define-instruction ,name (segment dst src1 &optional src2) - (:declare (type tn dst src1) (type (or null tn) src2)) - (:printer format-3-fpop ((op #b10) (op3 #b110100) (opf ,opf))) - (:emitter (emit-fp-inst segment ,opf #b110100 dst src1 src2)))) - -(defmacro define-binary-fp-inst (name opf &optional (op3 #b110100)) - `(define-instruction ,name (segment dst src1 &optional src2) - (:declare (type tn dst src1) (type (or null tn) src2)) - (:printer format-3-fpop ((op #b10) (op3 ,op3) (opf ,opf))) - (:emitter (emit-fp-inst segment ,opf ,op3 dst src1 src2)))) - -); eval-when (compile eval) - - -(define-unary-fp-inst fitos #b011000100) -(define-unary-fp-inst fitod #b011001000) -(define-unary-fp-inst fitox #b011001100) - -(define-unary-fp-inst fstoir #b011000001) -(define-unary-fp-inst fdtoir #b011000010) -(define-unary-fp-inst fxtoir #b011000011) - -(define-unary-fp-inst fstoi #b011010001) -(define-unary-fp-inst fdtoi #b011010010) -(define-unary-fp-inst fxtoi #b011010011) - -(define-unary-fp-inst fstod #b011001001) -(define-unary-fp-inst fstox #b011001101) -(define-unary-fp-inst fdtos #b011000110) -(define-unary-fp-inst fdtox #b011001110) -(define-unary-fp-inst fxtos #b011000111) -(define-unary-fp-inst fxtod #b011001011) - -(define-unary-fp-inst fmovs #b000000001) -(define-instruction fmovs-odd (segment dst src1 &optional src2) - (:declare (type tn dst src1) (type (or null tn) src2)) - (:emitter (emit-fp-inst segment #b000000001 #b110100 dst src1 src2))) -(define-unary-fp-inst fnegs #b000000101) -(define-unary-fp-inst fabss #b000001001) - -(define-unary-fp-inst fsqrts #b000101001) -(define-unary-fp-inst fsqrtd #b000101010) -(define-unary-fp-inst fsqrtx #b000101011) - - - -(define-binary-fp-inst fadds #b001000001) -(define-binary-fp-inst faddd #b001000010) -(define-binary-fp-inst faddx #b001000011) -(define-binary-fp-inst fsubs #b001000101) -(define-binary-fp-inst fsubd #b001000110) -(define-binary-fp-inst fsubx #b001000111) - -(define-binary-fp-inst fmuls #b001001001) -(define-binary-fp-inst fmuld #b001001010) -(define-binary-fp-inst fmulx #b001001011) -(define-binary-fp-inst fdivs #b001001101) -(define-binary-fp-inst fdivd #b001001110) -(define-binary-fp-inst fdivx #b001001111) - -(define-binary-fp-inst fcmps #b001010001 #b110101) -(define-binary-fp-inst fcmpd #b001010010 #b110101) -(define-binary-fp-inst fcmpx #b001010011 #b110101) -(define-binary-fp-inst fcmpes #b001010101 #b110101) -(define-binary-fp-inst fcmped #b001010110 #b110101) -(define-binary-fp-inst fcmpex #b001010111 #b110101) - - - -;;;; li, jali, ji, nop, cmp, not, neg, move, and more - -(define-instruction li (segment reg value) - (:declare (type tn reg) - (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32) - fixup) value)) - (:vop-var vop) - (:emitter - (assemble (segment vop) - (etypecase value - ((signed-byte 13) - (inst add reg zero-tn value)) - ((or (signed-byte 32) (unsigned-byte 32)) - (let ((hi (ldb (byte 22 10) value)) - (lo (ldb (byte 10 0) value))) - (inst sethi reg hi) - (unless (zerop lo) - (inst add reg lo)))) - (fixup - (inst sethi reg value) - (inst add reg value)))))) - -;;; Jal to a full 32-bit address. Tmpreg is trashed. -(define-instruction jali (segment link tmpreg value) - (:declare (type tn link tmpreg) - (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32) - fixup) value)) - (:vop-var vop) - (:emitter - (assemble (segment vop) - (etypecase value - ((signed-byte 13) - (inst jal link zero-tn value)) - ((or (signed-byte 32) (unsigned-byte 32)) - (let ((hi (ldb (byte 22 10) value)) - (lo (ldb (byte 10 0) value))) - (inst sethi tmpreg hi) - (inst jal link tmpreg lo))) - (fixup - (inst sethi tmpreg value) - (inst jal link tmpreg value)))))) - -;;; Jump to a full 32-bit address. Tmpreg is trashed. -(define-instruction ji (segment tmpreg value) - (:declare (type tn tmpreg) - (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32) - fixup) value)) - (:vop-var vop) - (:emitter - (assemble (segment vop) - (inst jali zero-tn tmpreg value)))) - -(define-instruction nop (segment) - (:printer format-2-immed ((rd 0) (op2 #b100) (immed 0)) '(:name)) - (:emitter (emit-format-2-immed segment 0 0 #b100 0))) - -(define-instruction cmp (segment src1 &optional src2) - (:declare (type tn src1) (type (or null tn (signed-byte 13)) src2)) - (:printer format-3-reg ((op #b10) (op3 #b010100) (rd 0)) - '(:name :tab rs1 ", " rs2)) - (:printer format-3-immed ((op #b10) (op3 #b010100) (rd 0)) - '(:name :tab rs1 ", " immed)) - (:emitter - (etypecase src2 - (null - (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 0)) - (tn - (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 - (reg-tn-encoding src2))) - (integer - (emit-format-3-immed segment #b10 0 #b010100 (reg-tn-encoding src1) 1 - src2))))) - -(define-instruction not (segment dst &optional src1) - (:declare (type tn dst) (type (or tn null) src1)) - (:printer format-3-reg ((op #b10) (op3 #b000111) (rs2 0)) - '(:name :tab (:unless (:same-as rd) rs1 ", " ) rd)) - (:emitter - (unless src1 - (setf src1 dst)) - (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000111 - (reg-tn-encoding src1) 0 0 0))) - -(define-instruction neg (segment dst &optional src1) - (:declare (type tn dst) (type (or tn null) src1)) - (:printer format-3-reg ((op #b10) (op3 #b000100) (rs1 0)) - '(:name :tab (:unless (:same-as rd) rs2 ", " ) rd)) - (:emitter - (unless src1 - (setf src1 dst)) - (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000100 - 0 0 0 (reg-tn-encoding src1)))) - -(define-instruction move (segment dst src1) - (:declare (type tn dst src1)) - (:printer format-3-reg ((op #b10) (op3 #b000010) (rs1 0)) - '(:name :tab rs2 ", " rd)) - (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000010 - 0 0 0 (reg-tn-encoding src1)))) - - - -;;;; Instructions for dumping data and header objects. - -(define-instruction word (segment word) - (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word)) - :pinned - (:emitter - (emit-word segment word))) - -(define-instruction short (segment short) - (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short)) - :pinned - (:emitter - (emit-short segment short))) - -(define-instruction byte (segment byte) - (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte)) - :pinned - (:emitter - (emit-byte segment byte))) - -(define-emitter emit-header-object 32 - (byte 24 8) (byte 8 0)) - - - -(defun emit-header-data (segment type) - (emit-back-patch - segment 4 - #'(lambda (segment posn) - (emit-word segment - (logior type - (ash (+ posn (component-header-length)) - (- type-bits word-shift))))))) - -(define-instruction function-header-word (segment) - :pinned - (:emitter - (emit-header-data segment function-header-type))) - -(define-instruction lra-header-word (segment) - :pinned - (:emitter - (emit-header-data segment return-pc-header-type))) - - -;;;; Instructions for converting between code objects, functions, and lras. - -(defun emit-compute-inst (segment vop dst src label temp calc) - (emit-chooser - ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments. - segment 12 3 - #'(lambda (segment posn delta-if-after) - (let ((delta (funcall calc label posn delta-if-after))) - (when (<= (- (ash 1 12)) delta (1- (ash 1 12))) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (assemble (segment vop) - (inst add dst src - (funcall calc label posn 0))))) - t))) - #'(lambda (segment posn) - (let ((delta (funcall calc label posn 0))) - (assemble (segment vop) - (inst sethi temp (ldb (byte 22 10) delta)) - (inst or temp (ldb (byte 10 0) delta)) - (inst add dst src temp)))))) - -;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag -(define-instruction compute-code-from-fn (segment dst src label temp) - (:declare (type tn dst src temp) (type label label)) - (:reads src) - (:writes (list dst temp)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (- other-pointer-type - function-pointer-type - (label-position label posn delta-if-after) - (component-header-length)))))) - -;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag -(define-instruction compute-code-from-lra (segment dst src label temp) - (:declare (type tn dst src temp) (type label label)) - (:reads src) - (:writes (list dst temp)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (- (+ (label-position label posn delta-if-after) - (component-header-length))))))) - -;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag -(define-instruction compute-lra-from-code (segment dst src label temp) - (:declare (type tn dst src temp) (type label label)) - (:reads src) - (:writes (list dst temp)) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (+ (label-position label posn delta-if-after) - (component-header-length)))))) diff --git a/compiler/sparc/macros.lisp b/compiler/sparc/macros.lisp deleted file mode 100644 index baa5163481e75329b86f3f42e13ba15a70f2c396..0000000000000000000000000000000000000000 --- a/compiler/sparc/macros.lisp +++ /dev/null @@ -1,438 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.9 1992/12/17 09:40:58 wlott Exp $ -;;; -;;; This file contains various useful macros for generating SPARC code. -;;; -;;; Written by William Lott. -;;; - -(in-package "SPARC") - - -;;; Instruction-like macros. - -(defmacro move (dst src) - "Move SRC into DST unless they are location=." - (once-only ((n-dst dst) - (n-src src)) - `(unless (location= ,n-dst ,n-src) - (inst move ,n-dst ,n-src)))) - -(macrolet - ((frob (op inst shift) - `(defmacro ,op (object base &optional (offset 0) (lowtag 0)) - `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))))) - (frob loadw ld word-shift) - (frob storew st word-shift)) - -(defmacro load-symbol (reg symbol) - `(inst add ,reg null-tn (static-symbol-offset ,symbol))) - -(macrolet - ((frob (slot) - (let ((loader (intern (concatenate 'simple-string - "LOAD-SYMBOL-" - (string slot)))) - (storer (intern (concatenate 'simple-string - "STORE-SYMBOL-" - (string slot)))) - (offset (intern (concatenate 'simple-string - "SYMBOL-" - (string slot) - "-SLOT") - (find-package "VM")))) - `(progn - (defmacro ,loader (reg symbol) - `(inst ld ,reg null-tn - (+ (static-symbol-offset ',symbol) - (ash ,',offset word-shift) - (- other-pointer-type)))) - (defmacro ,storer (reg symbol) - `(inst st ,reg null-tn - (+ (static-symbol-offset ',symbol) - (ash ,',offset word-shift) - (- other-pointer-type)))))))) - (frob value) - (frob function)) - -(defmacro load-type (target source &optional (offset 0)) - "Loads the type bits of a pointer into target independent of - byte-ordering issues." - (once-only ((n-target target) - (n-source source) - (n-offset offset)) - (ecase (backend-byte-order *target-backend*) - (:little-endian - `(inst ldub ,n-target ,n-source ,n-offset)) - (:big-endian - `(inst ldub ,n-target ,n-source (+ ,n-offset 3)))))) - -;;; Macros to handle the fact that we cannot use the machine native call and -;;; return instructions. - -(defmacro lisp-jump (function) - "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." - `(progn - (inst j ,function - (- (ash function-code-offset word-shift) function-pointer-type)) - (move code-tn ,function))) - -(defmacro lisp-return (return-pc &key (offset 0) (frob-code t)) - "Return to RETURN-PC." - `(progn - (inst j ,return-pc - (- (* (1+ ,offset) word-bytes) other-pointer-type)) - ,(if frob-code - `(move code-tn ,return-pc) - '(inst nop)))) - -(defmacro emit-return-pc (label) - "Emit a return-pc header word. LABEL is the label to use for this return-pc." - `(progn - (align lowtag-bits) - (emit-label ,label) - (inst lra-header-word))) - - - -;;;; Stack TN's - -;;; Load-Stack-TN, Store-Stack-TN -- Interface -;;; -;;; Move a stack TN to a register and vice-versa. -;;; -(defmacro load-stack-tn (reg stack) - `(let ((reg ,reg) - (stack ,stack)) - (let ((offset (tn-offset stack))) - (sc-case stack - ((control-stack) - (loadw reg cfp-tn offset)))))) - -(defmacro store-stack-tn (stack reg) - `(let ((stack ,stack) - (reg ,reg)) - (let ((offset (tn-offset stack))) - (sc-case stack - ((control-stack) - (storew reg cfp-tn offset)))))) - - -;;; MAYBE-LOAD-STACK-TN -- Interface -;;; -(defmacro maybe-load-stack-tn (reg reg-or-stack) - "Move the TN Reg-Or-Stack into Reg if it isn't already there." - (once-only ((n-reg reg) - (n-stack reg-or-stack)) - `(sc-case ,n-reg - ((any-reg descriptor-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg) - (move ,n-reg ,n-stack)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) - - -;;;; Storage allocation: - -(defmacro with-fixed-allocation ((result-tn temp-tn type-code size) - &body body) - "Do stuff to allocate an other-pointer object of fixed Size with a single - word header having the specified Type-Code. The result is placed in - Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used - by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably - initializes the object." - (once-only ((result-tn result-tn) (temp-tn temp-tn) - (type-code type-code) (size size)) - `(pseudo-atomic (:extra (pad-data-block ,size)) - (inst or ,result-tn alloc-tn other-pointer-type) - (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code)) - (storew ,temp-tn ,result-tn 0 other-pointer-type) - ,@body))) - - -;;;; Type testing noise. - -;;; GEN-RANGE-TEST -- internal -;;; -;;; Generate code that branches to TARGET iff REG contains one of VALUES. -;;; If NOT-P is true, invert the test. Jumping to NOT-TARGET is the same -;;; as falling out the bottom. -;;; -(defun gen-range-test (reg target not-target not-p min seperation max values) - (let ((tests nil) - (start nil) - (end nil) - (insts nil)) - (multiple-value-bind (equal less-or-equal greater-or-equal label) - (if not-p - (values :ne :gt :lt not-target) - (values :eq :le :ge target)) - (flet ((emit-test () - (if (= start end) - (push start tests) - (push (cons start end) tests)))) - (dolist (value values) - (cond ((< value min) - (error "~S is less than the specified minimum of ~S" - value min)) - ((> value max) - (error "~S is greater than the specified maximum of ~S" - value max)) - ((not (zerop (rem (- value min) seperation))) - (error "~S isn't an even multiple of ~S from ~S" - value seperation min)) - ((null start) - (setf start value)) - ((> value (+ end seperation)) - (emit-test) - (setf start value))) - (setf end value)) - (emit-test)) - (macrolet ((inst (name &rest args) - `(push (list 'inst ',name ,@args) insts))) - (do ((remaining (nreverse tests) (cdr remaining))) - ((null remaining)) - (let ((test (car remaining)) - (last (null (cdr remaining)))) - (if (atom test) - (progn - (inst cmp reg test) - (if last - (inst b equal target) - (inst b :eq label))) - (let ((start (car test)) - (end (cdr test))) - (cond ((and (= start min) (= end max)) - (warn "The values ~S cover the entire range from ~ - ~S to ~S [step ~S]." - values min max seperation) - (push `(unless ,not-p (inst b ,target)) insts)) - ((= start min) - (inst cmp reg end) - (if last - (inst b less-or-equal target) - (inst b :le label))) - ((= end max) - (inst cmp reg start) - (if last - (inst b greater-or-equal target) - (inst b :ge label))) - (t - (inst cmp reg start) - (inst b :lt (if not-p target not-target)) - (inst cmp reg end) - (if last - (inst b less-or-equal target) - (inst b :le label)))))))))) - (nreverse insts))) - -(defun gen-other-immediate-test (reg target not-target not-p values) - (gen-range-test reg target not-target not-p - (+ other-immediate-0-type lowtag-limit) - (- other-immediate-1-type other-immediate-0-type) - (ash 1 type-bits) - values)) - - -(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs - function-p) - (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql) - (member odd-fixnum-type lowtags :test #'eql))) - (lowtags (sort (if fixnump - (delete even-fixnum-type - (remove odd-fixnum-type lowtags - :test #'eql) - :test #'eql) - (copy-list lowtags)) - #'<)) - (lowtag (if function-p - vm:function-pointer-type - vm:other-pointer-type)) - (hdrs (sort (copy-list hdrs) #'<)) - (immed (sort (copy-list immed) #'<))) - (append - (when immed - `((inst and ,temp ,reg type-mask) - ,@(if (or fixnump lowtags hdrs) - (let ((fall-through (gensym))) - `((let (,fall-through (gen-label)) - ,@(gen-other-immediate-test - temp (if not-p not-target target) - fall-through nil immed) - (emit-label ,fall-through)))) - (gen-other-immediate-test temp target not-target not-p immed)))) - (when fixnump - `((inst andcc zero-tn ,reg 3) - ,(if (or lowtags hdrs) - `(inst b :eq ,(if not-p not-target target)) - `(inst b ,(if not-p :ne :eq) ,target)))) - (when (or lowtags hdrs) - `((inst and ,temp ,reg lowtag-mask))) - (when lowtags - (if hdrs - (let ((fall-through (gensym))) - `((let ((,fall-through (gen-label))) - ,@(gen-range-test temp (if not-p not-target target) - fall-through nil - 0 1 (1- lowtag-limit) lowtags) - (emit-label ,fall-through)))) - (gen-range-test temp target not-target not-p 0 1 - (1- lowtag-limit) lowtags))) - (when hdrs - `((inst cmp ,temp ,lowtag) - (inst b :ne ,(if not-p target not-target)) - (inst nop) - (load-type ,temp ,reg (- ,lowtag)) - ,@(gen-other-immediate-test temp target not-target not-p hdrs)))))) - -(defconstant immediate-types - (list base-char-type unbound-marker-type)) - -(defconstant function-subtypes - (list funcallable-instance-header-type dylan-function-header-type - function-header-type closure-function-header-type - closure-header-type)) - -(defmacro test-type (register temp target not-p &rest type-codes) - (let* ((type-codes (mapcar #'eval type-codes)) - (lowtags (remove lowtag-limit type-codes :test #'<)) - (extended (remove lowtag-limit type-codes :test #'>)) - (immediates (intersection extended immediate-types :test #'eql)) - (headers (set-difference extended immediate-types :test #'eql)) - (function-p nil)) - (unless type-codes - (error "Must supply at least on type for test-type.")) - (when (and headers (member other-pointer-type lowtags)) - (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers) - (setf headers nil)) - (when (and immediates - (or (member other-immediate-0-type lowtags) - (member other-immediate-1-type lowtags))) - (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates) - (setf immediates nil)) - (when (intersection headers function-subtypes) - (unless (subsetp headers function-subtypes) - (error "Can't test for mix of function subtypes and normal ~ - header types.")) - (setq function-p t)) - - (let ((n-reg (gensym)) - (n-temp (gensym)) - (n-target (gensym)) - (not-target (gensym))) - `(let ((,n-reg ,register) - (,n-temp ,temp) - (,n-target ,target) - (,not-target (gen-label))) - (declare (ignorable ,n-temp)) - ,@(if (constantp not-p) - (test-type-aux n-reg n-temp n-target not-target - (eval not-p) lowtags immediates headers - function-p) - `((cond (,not-p - ,@(test-type-aux n-reg n-temp n-target not-target t - lowtags immediates headers - function-p)) - (t - ,@(test-type-aux n-reg n-temp n-target not-target nil - lowtags immediates headers - function-p))))) - (inst nop) - (emit-label ,not-target))))) - - -;;;; Error Code - -(defvar *adjustable-vectors* nil) - -(defmacro with-adjustable-vector ((var) &rest body) - `(let ((,var (or (pop *adjustable-vectors*) - (make-array 16 - :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t)))) - (setf (fill-pointer ,var) 0) - (unwind-protect - (progn - ,@body) - (push ,var *adjustable-vectors*)))) - -(eval-when (compile load eval) - (defun emit-error-break (vop kind code values) - (let ((vector (gensym))) - `((let ((vop ,vop)) - (when vop - (note-this-location vop :internal-error))) - (inst unimp ,kind) - (with-adjustable-vector (,vector) - (write-var-integer (error-number-or-lose ',code) ,vector) - ,@(mapcar #'(lambda (tn) - `(let ((tn ,tn)) - (write-var-integer (make-sc-offset (sc-number - (tn-sc tn)) - (tn-offset tn)) - ,vector))) - values) - (inst byte (length ,vector)) - (dotimes (i (length ,vector)) - (inst byte (aref ,vector i)))) - (align word-shift))))) - -(defmacro error-call (vop error-code &rest values) - "Cause an error. ERROR-CODE is the error to cause." - (cons 'progn - (emit-error-break vop error-trap error-code values))) - - -(defmacro cerror-call (vop label error-code &rest values) - "Cause a continuable error. If the error is continued, execution resumes at - LABEL." - `(progn - (inst b ,label) - ,@(emit-error-break vop cerror-trap error-code values))) - -(defmacro generate-error-code (vop error-code &rest values) - "Generate-Error-Code Error-code Value* - Emit code for an error with the specified Error-Code and context Values." - `(assemble (*elsewhere*) - (let ((start-lab (gen-label))) - (emit-label start-lab) - (error-call ,vop ,error-code ,@values) - start-lab))) - -(defmacro generate-cerror-code (vop error-code &rest values) - "Generate-CError-Code Error-code Value* - Emit code for a continuable error with the specified Error-Code and - context Values. If the error is continued, execution resumes after - the GENERATE-CERROR-CODE form." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) - `(let ((,continue (gen-label))) - (emit-label ,continue) - (assemble (*elsewhere*) - (let ((,error (gen-label))) - (emit-label ,error) - (cerror-call ,vop ,continue ,error-code ,@values) - ,error))))) - - - -;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. -;;; -(defmacro pseudo-atomic ((&key (extra 0)) &rest forms) - (let ((n-extra (gensym))) - `(let ((,n-extra ,extra)) - (without-scheduling () - (inst add alloc-tn 4)) - ,@forms - (without-scheduling () - (inst taddcctv alloc-tn (- ,n-extra 4)))))) diff --git a/compiler/sparc/memory.lisp b/compiler/sparc/memory.lisp deleted file mode 100644 index 6150db0920593885ed9a9953f6268d887e3a8043..0000000000000000000000000000000000000000 --- a/compiler/sparc/memory.lisp +++ /dev/null @@ -1,116 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/memory.lisp,v 1.2 1992/12/16 20:26:30 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the SPARC definitions of some general purpose memory -;;; reference VOPs inherited by basic memory reference operations. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by William Lott. -;;; - -(in-package "SPARC") - -;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to -;;; be read or written is a property of the VOP used. -;;; -(define-vop (cell-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (loadw value object offset lowtag))) -;;; -(define-vop (cell-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 4 - (storew value object offset lowtag))) - -;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the -;;; offset is constant at compile time, but varies for different uses. We add -;;; in the stardard g-vector overhead. -;;; -(define-vop (slot-ref) - (:args (object :scs (descriptor-reg))) - (:results (value :scs (descriptor-reg any-reg))) - (:variant-vars base lowtag) - (:info offset) - (:generator 4 - (loadw value object (+ base offset) lowtag))) -;;; -(define-vop (slot-set) - (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:variant-vars base lowtag) - (:info offset) - (:generator 4 - (storew value object (+ base offset) lowtag))) - - - -;;;; Indexed references: - -;;; Define-Indexer -- Internal -;;; -;;; Define some VOPs for indexed memory reference. -;;; -(defmacro define-indexer (name write-p op shift) - `(define-vop (,name) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg zero immediate)) - ,@(when write-p - '((value :scs (any-reg descriptor-reg) :target result)))) - (:arg-types * tagged-num ,@(when write-p '(*))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:results (,(if write-p 'result 'value) - :scs (any-reg descriptor-reg))) - (:result-types *) - (:variant-vars offset lowtag) - (:policy :fast-safe) - (:generator 5 - (sc-case index - ((immediate zero) - (let ((offset (- (+ (if (sc-is index zero) - 0 - (ash (tn-value index) - (- vm:word-shift ,shift))) - (ash offset vm:word-shift)) - lowtag))) - (etypecase offset - ((signed-byte 13) - (inst ,op value object offset)) - ((or (unsigned-byte 32) (signed-byte 32)) - (inst li temp offset) - (inst ,op value object temp))))) - (t - ,@(unless (zerop shift) - `((inst srl temp index ,shift))) - (inst add temp ,(if (zerop shift) 'index 'temp) - (- (ash offset vm:word-shift) lowtag)) - (inst ,op value object temp))) - ,@(when write-p - '((move result value)))))) - -(define-indexer word-index-ref nil ld 0) -(define-indexer word-index-set t st 0) -(define-indexer halfword-index-ref nil lduh 1) -(define-indexer signed-halfword-index-ref nil ldsh 1) -(define-indexer halfword-index-set t sth 1) -(define-indexer byte-index-ref nil ldub 2) -(define-indexer signed-byte-index-ref nil ldsb 2) -(define-indexer byte-index-set t stb 2) - diff --git a/compiler/sparc/move.lisp b/compiler/sparc/move.lisp deleted file mode 100644 index 77403fd7ca4e3505200c79b3801462cddbbed96c..0000000000000000000000000000000000000000 --- a/compiler/sparc/move.lisp +++ /dev/null @@ -1,324 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/move.lisp,v 1.4 1992/03/11 21:29:13 wlott Exp $ -;;; -;;; This file contains the SPARC VM definition of operand loading/saving and -;;; the Move VOP. -;;; -;;; Written by Rob MacLachlan. -;;; SPARC conversion by William Lott. -;;; -(in-package "SPARC") - - -(define-move-function (load-immediate 1) (vop x y) - ((null immediate zero) - (any-reg descriptor-reg)) - (let ((val (tn-value x))) - (etypecase val - (integer - (inst li y (fixnum val))) - (null - (move y null-tn)) - (symbol - (load-symbol y val)) - (character - (inst li y (logior (ash (char-code val) type-bits) - base-char-type)))))) - -(define-move-function (load-number 1) (vop x y) - ((immediate zero) - (signed-reg unsigned-reg)) - (inst li y (tn-value x))) - -(define-move-function (load-base-char 1) (vop x y) - ((immediate) (base-char-reg)) - (inst li y (char-code (tn-value x)))) - -(define-move-function (load-system-area-pointer 1) (vop x y) - ((immediate) (sap-reg)) - (inst li y (sap-int (tn-value x)))) - -(define-move-function (load-constant 5) (vop x y) - ((constant) (descriptor-reg)) - (loadw y code-tn (tn-offset x) other-pointer-type)) - -(define-move-function (load-stack 5) (vop x y) - ((control-stack) (any-reg descriptor-reg)) - (load-stack-tn y x)) - -(define-move-function (load-number-stack 5) (vop x y) - ((base-char-stack) (base-char-reg) - (sap-stack) (sap-reg) - (signed-stack) (signed-reg) - (unsigned-stack) (unsigned-reg)) - (let ((nfp (current-nfp-tn vop))) - (loadw y nfp (tn-offset x)))) - -(define-move-function (store-stack 5) (vop x y) - ((any-reg descriptor-reg) (control-stack)) - (store-stack-tn y x)) - -(define-move-function (store-number-stack 5) (vop x y) - ((base-char-reg) (base-char-stack) - (sap-reg) (sap-stack) - (signed-reg) (signed-stack) - (unsigned-reg) (unsigned-stack)) - (let ((nfp (current-nfp-tn vop))) - (storew x nfp (tn-offset y)))) - - -;;;; The Move VOP: -;;; -(define-vop (move) - (:args (x :target y - :scs (any-reg descriptor-reg zero null) - :load-if (not (location= x y)))) - (:results (y :scs (any-reg descriptor-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:generator 0 - (move y x))) - -(define-move-vop move :move - (any-reg descriptor-reg) - (any-reg descriptor-reg)) - -;;; Make Move the check VOP for T so that type check generation doesn't think -;;; it is a hairy type. This also allows checking of a few of the values in a -;;; continuation to fall out. -;;; -(primitive-type-vop move (:check) t) - -;;; The Move-Argument VOP is used for moving descriptor values into another -;;; frame for argument or known value passing. -;;; -(define-vop (move-argument) - (:args (x :target y - :scs (any-reg descriptor-reg zero null)) - (fp :scs (any-reg) - :load-if (not (sc-is y any-reg descriptor-reg)))) - (:results (y)) - (:generator 0 - (sc-case y - ((any-reg descriptor-reg) - (move y x)) - (control-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-argument :move-argument - (any-reg descriptor-reg) - (any-reg descriptor-reg)) - - - -;;;; ILLEGAL-MOVE - -;;; This VOP exists just to begin the lifetime of a TN that couldn't be written -;;; legally due to a type error. An error is signalled before this VOP is -;;; so we don't need to do anything (not that there would be anything sensible -;;; to do anyway.) -;;; -(define-vop (illegal-move) - (:args (x) (type)) - (:results (y)) - (:ignore y) - (:vop-var vop) - (:save-p :compute-only) - (:generator 666 - (error-call vop object-not-type-error x type))) - - - -;;;; Moves and coercions: - -;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word -;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer -;;; to a tagged bignum or fixnum. - -;;; Arg is a fixnum, so just shift it. We need a type restriction because some -;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs. -;;; -(define-vop (move-to-word/fixnum) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:arg-types tagged-num) - (:note "fixnum untagging") - (:generator 1 - (inst sra y x 2))) -;;; -(define-move-vop move-to-word/fixnum :move - (any-reg descriptor-reg) (signed-reg unsigned-reg)) - -;;; Arg is a non-immediate constant, load it. -(define-vop (move-to-word-c) - (:args (x :scs (constant))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "constant load") - (:generator 1 - (inst li y (tn-value x)))) -;;; -(define-move-vop move-to-word-c :move - (constant) (signed-reg unsigned-reg)) - - -;;; Arg is a fixnum or bignum, figure out which and load if necessary. -(define-vop (move-to-word/integer) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (signed-reg unsigned-reg))) - (:note "integer to untagged word coercion") - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 4 - (let ((done (gen-label))) - (inst andcc temp x 3) - (inst b :eq done) - (sc-case y - (signed-reg - (inst sra y x 2)) - (unsigned-reg - (inst srl y x 2))) - - (loadw y x bignum-digits-offset other-pointer-type) - - (emit-label done)))) -;;; -(define-move-vop move-to-word/integer :move - (descriptor-reg) (signed-reg unsigned-reg)) - - - -;;; Result is a fixnum, so we can just shift. We need the result type -;;; restriction because of the control-stack ambiguity noted above. -;;; -(define-vop (move-from-word/fixnum) - (:args (x :scs (signed-reg unsigned-reg))) - (:results (y :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "fixnum tagging") - (:generator 1 - (inst sll y x 2))) -;;; -(define-move-vop move-from-word/fixnum :move - (signed-reg unsigned-reg) (any-reg descriptor-reg)) - - -;;; Result may be a bignum, so we have to check. Use a worst-case cost to make -;;; sure people know they may be number consing. -;;; -(define-vop (move-from-signed) - (:args (arg :scs (signed-reg unsigned-reg) :target x)) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) - (:note "signed word to integer coercion") - (:generator 20 - (move x arg) - (let ((fixnum (gen-label)) - (done (gen-label))) - (inst sra temp x 29) - (inst cmp temp) - (inst b :eq fixnum) - (inst orncc temp zero-tn temp) - (inst b :eq done) - (inst sll y x 2) - - (with-fixed-allocation - (y temp bignum-type (1+ bignum-digits-offset)) - (storew x y bignum-digits-offset other-pointer-type)) - (inst b done) - (inst nop) - - (emit-label fixnum) - (inst sll y x 2) - (emit-label done)))) -;;; -(define-move-vop move-from-signed :move - (signed-reg) (descriptor-reg)) - - -;;; Check for fixnum, and possibly allocate one or two word bignum result. Use -;;; a worst-case cost to make sure people know they may be number consing. -;;; -(define-vop (move-from-unsigned) - (:args (arg :scs (signed-reg unsigned-reg) :target x)) - (:results (y :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) - (:note "unsigned word to integer coercion") - (:generator 20 - (move x arg) - (let ((done (gen-label)) - (one-word (gen-label)) - (initial-alloc (pad-data-block (1+ bignum-digits-offset)))) - (inst sra temp x 29) - (inst cmp temp) - (inst b :eq done) - (inst sll y x 2) - - (pseudo-atomic (:extra initial-alloc) - (inst or y alloc-tn other-pointer-type) - (inst cmp x) - (inst b :ge one-word) - (inst li temp (logior (ash 1 type-bits) bignum-type)) - (inst add alloc-tn - (- (pad-data-block (+ bignum-digits-offset 2)) - (pad-data-block (+ bignum-digits-offset 1)))) - (inst li temp (logior (ash 2 type-bits) bignum-type)) - (emit-label one-word) - (storew temp y 0 other-pointer-type) - (storew x y bignum-digits-offset other-pointer-type)) - (emit-label done)))) -;;; -(define-move-vop move-from-unsigned :move - (unsigned-reg) (descriptor-reg)) - - -;;; Move untagged numbers. -;;; -(define-vop (word-move) - (:args (x :target y - :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:results (y :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) - (:effects) - (:affected) - (:note "word integer move") - (:generator 0 - (move y x))) -;;; -(define-move-vop word-move :move - (signed-reg unsigned-reg) (signed-reg unsigned-reg)) - - -;;; Move untagged number arguments/return-values. -;;; -(define-vop (move-word-argument) - (:args (x :target y - :scs (signed-reg unsigned-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (:note "word integer argument move") - (:generator 0 - (sc-case y - ((signed-reg unsigned-reg) - (move y x)) - ((signed-stack unsigned-stack) - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-word-argument :move-argument - (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a -;;; descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff --git a/compiler/sparc/nlx.lisp b/compiler/sparc/nlx.lisp deleted file mode 100644 index faa010a3f52e10891d4b99d46d3bf2332a1753be..0000000000000000000000000000000000000000 --- a/compiler/sparc/nlx.lisp +++ /dev/null @@ -1,279 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/nlx.lisp,v 1.5 1992/05/21 23:22:31 wlott Exp $ -;;; -;;; This file contains the definitions of VOPs used for non-local exit -;;; (throw, lexical exit, etc.) -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "SPARC") - -;;; MAKE-NLX-SP-TN -- Interface -;;; -;;; Make an environment-live stack TN for saving the SP for NLX entry. -;;; -(def-vm-support-routine make-nlx-sp-tn (env) - (environment-live-tn - (make-representation-tn *fixnum-primitive-type* immediate-arg-scn) - env)) - - - -;;; Save and restore dynamic environment. -;;; -;;; These VOPs are used in the reentered function to restore the appropriate -;;; dynamic environment. Currently we only save the Current-Catch and binding -;;; stack pointer. We don't need to save/restore the current unwind-protect, -;;; since unwind-protects are implicitly processed during unwinding. If there -;;; were any additional stacks, then this would be the place to restore the top -;;; pointers. - - -;;; Make-Dynamic-State-TNs -- Interface -;;; -;;; Return a list of TNs that can be used to snapshot the dynamic state for -;;; use with the Save/Restore-Dynamic-Environment VOPs. -;;; -(def-vm-support-routine make-dynamic-state-tns () - (make-n-tns 4 *any-primitive-type*)) - -(define-vop (save-dynamic-state) - (:results (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg)) - (eval :scs (descriptor-reg))) - (:vop-var vop) - (:generator 13 - (load-symbol-value catch lisp::*current-catch-block*) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move nfp cur-nfp))) - (move nsp nsp-tn) - (load-symbol-value eval lisp::*eval-stack-top*))) - -(define-vop (restore-dynamic-state) - (:args (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg)) - (eval :scs (descriptor-reg))) - (:vop-var vop) - (:generator 10 - (store-symbol-value catch lisp::*current-catch-block*) - (store-symbol-value eval lisp::*eval-stack-top*) - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (move cur-nfp nfp))) - (move nsp-tn nsp))) - -(define-vop (current-stack-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move res csp-tn))) - -(define-vop (current-binding-pointer) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - (move res bsp-tn))) - - - -;;;; Unwind block hackery: - -;;; Compute the address of the catch block from its TN, then store into the -;;; block the current Fp, Env, Unwind-Protect, and the entry PC. -;;; -(define-vop (make-unwind-block) - (:args (tn)) - (:info entry-label) - (:results (block :scs (any-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 22 - (inst add block cfp-tn (* (tn-offset tn) vm:word-bytes)) - (load-symbol-value temp lisp::*current-unwind-protect-block*) - (storew temp block vm:unwind-block-current-uwp-slot) - (storew cfp-tn block vm:unwind-block-current-cont-slot) - (storew code-tn block vm:unwind-block-current-code-slot) - (inst compute-lra-from-code temp code-tn entry-label ndescr) - (storew temp block vm:catch-block-entry-pc-slot))) - - -;;; Like Make-Unwind-Block, except that we also store in the specified tag, and -;;; link the block into the Current-Catch list. -;;; -(define-vop (make-catch-block) - (:args (tn) - (tag :scs (descriptor-reg))) - (:info entry-label) - (:results (block :scs (any-reg))) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 44 - (inst add result cfp-tn (* (tn-offset tn) vm:word-bytes)) - (load-symbol-value temp lisp::*current-unwind-protect-block*) - (storew temp result vm:catch-block-current-uwp-slot) - (storew cfp-tn result vm:catch-block-current-cont-slot) - (storew code-tn result vm:catch-block-current-code-slot) - (inst compute-lra-from-code temp code-tn entry-label ndescr) - (storew temp result vm:catch-block-entry-pc-slot) - - (storew tag result vm:catch-block-tag-slot) - (load-symbol-value temp lisp::*current-catch-block*) - (storew temp result vm:catch-block-previous-catch-slot) - (store-symbol-value result lisp::*current-catch-block*) - - (move block result))) - - -;;; Just set the current unwind-protect to TN's address. This instantiates an -;;; unwind block as an unwind-protect. -;;; -(define-vop (set-unwind-protect) - (:args (tn)) - (:temporary (:scs (descriptor-reg)) new-uwp) - (:generator 7 - (inst add new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes)) - (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) - - -(define-vop (unlink-catch-block) - (:temporary (:scs (any-reg)) block) - (:policy :fast-safe) - (:translate %catch-breakup) - (:generator 17 - (load-symbol-value block lisp::*current-catch-block*) - (loadw block block vm:catch-block-previous-catch-slot) - (store-symbol-value block lisp::*current-catch-block*))) - -(define-vop (unlink-unwind-protect) - (:temporary (:scs (any-reg)) block) - (:policy :fast-safe) - (:translate %unwind-protect-breakup) - (:generator 17 - (load-symbol-value block lisp::*current-unwind-protect-block*) - (loadw block block vm:unwind-block-current-uwp-slot) - (store-symbol-value block lisp::*current-unwind-protect-block*))) - - -;;;; NLX entry VOPs: - - -(define-vop (nlx-entry) - (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops - ; would be inserted before the LRA. - (start) - (count)) - (:results (values :more t)) - (:temporary (:scs (descriptor-reg)) move-temp) - (:info label nvals) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (emit-return-pc label) - (note-this-location vop :non-local-entry) - (cond ((zerop nvals)) - ((= nvals 1) - (let ((no-values (gen-label))) - (inst cmp count) - (inst b :eq no-values) - (move (tn-ref-tn values) null-tn) - (loadw (tn-ref-tn values) start) - (emit-label no-values))) - (t - (collect ((defaults)) - (inst subcc count (fixnum 1)) - (do ((i 0 (1+ i)) - (tn-ref values (tn-ref-across tn-ref))) - ((null tn-ref)) - (let ((default-lab (gen-label)) - (tn (tn-ref-tn tn-ref))) - (defaults (cons default-lab tn)) - - (inst b :lt default-lab) - (inst subcc count (fixnum 1)) - (sc-case tn - ((descriptor-reg any-reg) - (loadw tn start i)) - (control-stack - (loadw move-temp start i) - (store-stack-tn tn move-temp))))) - - (let ((defaulting-done (gen-label))) - - (emit-label defaulting-done) - - (assemble (*elsewhere*) - (dolist (def (defaults)) - (emit-label (car def)) - (let ((tn (cdr def))) - (sc-case tn - ((descriptor-reg any-reg) - (move tn null-tn)) - (control-stack - (store-stack-tn tn null-tn))))) - (inst b defaulting-done) - (inst nop)))))) - (load-stack-tn csp-tn sp))) - - -(define-vop (nlx-entry-multiple) - (:args (top :target result) (src) (count)) - ;; Again, no SC restrictions for the args, 'cause the loading would - ;; happen before the entry label. - (:info label) - (:temporary (:scs (any-reg)) dst) - (:temporary (:scs (descriptor-reg)) temp) - (:results (result :scs (any-reg) :from (:argument 0)) - (num :scs (any-reg) :from (:argument 0))) - (:save-p :force-to-stack) - (:vop-var vop) - (:generator 30 - (emit-return-pc label) - (note-this-location vop :non-local-entry) - (let ((loop (gen-label)) - (done (gen-label))) - - ;; Setup results, and test for the zero value case. - (load-stack-tn result top) - (inst cmp count) - (inst b :eq done) - (inst li num 0) - - ;; Compute dst as one slot down from result, because we inc the index - ;; before we use it. - (inst sub dst result 4) - - ;; Copy stuff down the stack. - (emit-label loop) - (inst ld temp src num) - (inst add num (fixnum 1)) - (inst cmp num count) - (inst b :ne loop) - (inst st temp dst num) - - ;; Reset the CSP. - (emit-label done) - (inst add csp-tn result num)))) - - -;;; This VOP is just to force the TNs used in the cleanup onto the stack. -;;; -(define-vop (uwp-entry) - (:info label) - (:save-p :force-to-stack) - (:results (block) (start) (count)) - (:ignore block start count) - (:vop-var vop) - (:generator 0 - (emit-return-pc label) - (note-this-location vop :non-local-entry))) - diff --git a/compiler/sparc/parms.lisp b/compiler/sparc/parms.lisp deleted file mode 100644 index 11020d01cb57399f0136210271bbcdbecbae1977..0000000000000000000000000000000000000000 --- a/compiler/sparc/parms.lisp +++ /dev/null @@ -1,238 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/parms.lisp,v 1.20 1992/12/07 22:25:04 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains some parameterizations of various VM -;;; attributes for the SPARC. This file is separate from other stuff so -;;; that it can be compiled and loaded earlier. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted to MIPS by William Lott. -;;; - -(in-package "SPARC") -(use-package "C") - - -;;;; Compiler constants. - -(eval-when (compile eval load) - -(setf (backend-name *target-backend*) "SPARC") -(setf (backend-version *target-backend*) "SPARCstation/Sun 4") -(setf (backend-fasl-file-type *target-backend*) "sparcf") -(setf (backend-fasl-file-implementation *target-backend*) - sparc-fasl-file-implementation) -(setf (backend-fasl-file-version *target-backend*) 4) -(setf (backend-register-save-penalty *target-backend*) 3) -(setf (backend-byte-order *target-backend*) :big-endian) -(setf (backend-page-size *target-backend*) - #+mach 4096 #+sunos 8192) - -); eval-when - -(pushnew :new-assembler *features*) - - -;;;; Machine Architecture parameters: - -(export '(word-bits byte-bits word-shift word-bytes float-sign-shift - - single-float-bias single-float-exponent-byte - single-float-significand-byte single-float-normal-exponent-min - single-float-normal-exponent-max single-float-hidden-bit - single-float-trapping-nan-bit single-float-digits - - double-float-bias double-float-exponent-byte - double-float-significand-byte double-float-normal-exponent-min - double-float-normal-exponent-max double-float-hidden-bit - double-float-trapping-nan-bit double-float-digits - - float-underflow-trap-bit float-overflow-trap-bit - float-imprecise-trap-bit float-invalid-trap-bit - float-divide-by-zero-trap-bit)) - - - -(eval-when (compile load eval) - -(defconstant word-bits 32 - "Number of bits per word where a word holds one lisp descriptor.") - -(defconstant byte-bits 8 - "Number of bits per byte where a byte is the smallest addressable object.") - -(defconstant word-shift (1- (integer-length (/ word-bits byte-bits))) - "Number of bits to shift between word addresses and byte addresses.") - -(defconstant word-bytes (/ word-bits byte-bits) - "Number of bytes in a word.") - - -(defconstant float-sign-shift 31) - -(defconstant single-float-bias 126) -(defconstant single-float-exponent-byte (byte 8 23)) -(defconstant single-float-significand-byte (byte 23 0)) -(defconstant single-float-normal-exponent-min 1) -(defconstant single-float-normal-exponent-max 254) -(defconstant single-float-hidden-bit (ash 1 23)) -(defconstant single-float-trapping-nan-bit (ash 1 22)) - -(defconstant double-float-bias 1022) -(defconstant double-float-exponent-byte (byte 11 20)) -(defconstant double-float-significand-byte (byte 20 0)) -(defconstant double-float-normal-exponent-min 1) -(defconstant double-float-normal-exponent-max #x7FE) -(defconstant double-float-hidden-bit (ash 1 20)) -(defconstant double-float-trapping-nan-bit (ash 1 19)) - -(defconstant single-float-digits - (+ (byte-size single-float-significand-byte) 1)) - -(defconstant double-float-digits - (+ (byte-size double-float-significand-byte) word-bits 1)) - - -(defconstant float-inexact-trap-bit (ash 1 0)) -(defconstant float-divide-by-zero-trap-bit (ash 1 1)) -(defconstant float-underflow-trap-bit (ash 1 2)) -(defconstant float-overflow-trap-bit (ash 1 3)) -(defconstant float-invalid-trap-bit (ash 1 4)) - -(defconstant float-round-to-nearest 0) -(defconstant float-round-to-zero 1) -(defconstant float-round-to-positive 2) -(defconstant float-round-to-negative 3) - -(defconstant float-rounding-mode (byte 2 30)) ; RD -(defconstant float-sticky-bits (byte 5 5)) ; aexc -(defconstant float-traps-byte (byte 5 23)) ; TEM -(defconstant float-exceptions-byte (byte 5 0)) ; cexc - -;;; According to the SPARC doc (as opposed to FPU doc), the fast mode bit (EFM) -;;; is "reserved", and should always be zero. -(defconstant float-fast-bit 0) - -); eval-when - -;;; NUMBER-STACK-DISPLACEMENT -;;; -;;; The number of bytes reserved above the number stack pointer. These -;;; slots are required by architecture for a place to spill register windows. -;;; -(defconstant number-stack-displacement - (* 16 vm:word-bytes)) - - -;;;; Description of the target address space. - -(export '(target-read-only-space-start - target-static-space-start - target-dynamic-space-start)) - -;;; Where to put the different spaces. -;;; -(defparameter target-read-only-space-start #x00200000) -(defparameter target-static-space-start #x0c000000) -(defparameter target-dynamic-space-start #x10000000) - - - -;;;; Other random constants. - -(export '(halt-trap pending-interrupt-trap error-trap cerror-trap - breakpoint-trap function-end-breakpoint-trap - after-breakpoint-trap - object-not-list-trap object-not-structure-trap - trace-table-normal trace-table-call-site - trace-table-function-prologue trace-table-function-epilogue)) - -(defenum (:suffix -trap :start 8) - halt - pending-interrupt - error - cerror - breakpoint - function-end-breakpoint - after-breakpoint) - -(defenum (:prefix object-not- :suffix -trap :start 16) - list - structure) - -(defenum (:prefix trace-table-) - normal - call-site - function-prologue - function-epilogue) - - -;;;; Static symbols. - -(export '(static-symbols static-functions)) - -;;; These symbols are loaded into static space directly after NIL so -;;; that the system can compute their address by adding a constant -;;; amount to NIL. -;;; -;;; The fdefn objects for the static functions are loaded into static -;;; space directly after the static symbols. That way, the raw-addr -;;; can be loaded directly out of them by indirecting relative to NIL. -;;; -(defparameter static-symbols - '(t - - ;; The C startup code must fill these in. - lisp::lisp-environment-list - lisp::lisp-command-line-list - lisp::*initial-fdefn-objects* - - ;; Functions that the C code needs to call - lisp::%initial-function - lisp::maybe-gc - kernel::internal-error - di::handle-breakpoint - lisp::fdefinition-object - - ;; Free Pointers. - lisp::*read-only-space-free-pointer* - lisp::*static-space-free-pointer* - lisp::*initial-dynamic-space-free-pointer* - - ;; Things needed for non-local-exit. - lisp::*current-catch-block* - lisp::*current-unwind-protect-block* - *eval-stack-top* - - ;; Interrupt Handling - lisp::*free-interrupt-context-index* - unix::*interrupts-enabled* - unix::*interrupt-pending* - )) - -(defparameter static-functions - '(length - two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= - two-arg-<= two-arg->= two-arg-/= eql %negate - two-arg-and two-arg-ior two-arg-xor - two-arg-gcd two-arg-lcm - )) - - - -;;;; Assembler parameters: - -;;; The number of bits per element in the assemblers code vector. -;;; -(defparameter *assembly-unit-length* 8) diff --git a/compiler/sparc/pred.lisp b/compiler/sparc/pred.lisp deleted file mode 100644 index 3dd37ef3f9407afcad1ad2f8c3f40d0a8dee6848..0000000000000000000000000000000000000000 --- a/compiler/sparc/pred.lisp +++ /dev/null @@ -1,46 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/pred.lisp,v 1.1 1990/11/30 17:04:59 wlott Exp $ -;;; -;;; This file contains the VM definition of predicate VOPs for the SPARC. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted by William Lott. -;;; - -(in-package "SPARC") - - -;;;; The Branch VOP. - -;;; The unconditional branch, emitted when we can't drop through to the desired -;;; destination. Dest is the continuation we transfer control to. -;;; -(define-vop (branch) - (:info dest) - (:generator 5 - (inst b dest) - (inst nop))) - - -;;;; Conditional VOPs: - -(define-vop (if-eq) - (:args (x :scs (any-reg descriptor-reg zero null)) - (y :scs (any-reg descriptor-reg zero null))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:translate eq) - (:generator 3 - (inst cmp x y) - (inst b (if not-p :ne :eq) target) - (inst nop))) diff --git a/compiler/sparc/print.lisp b/compiler/sparc/print.lisp deleted file mode 100644 index 66361f358feafc6aa67226b5a5e2fe889250ef1a..0000000000000000000000000000000000000000 --- a/compiler/sparc/print.lisp +++ /dev/null @@ -1,41 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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). -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/print.lisp,v 1.1 1990/11/30 17:05:00 wlott Exp $ -;;; -;;; This file contains VOPs for things like printing during %initial-function -;;; before the world is initialized. -;;; -;;; Written by William Lott. - -(in-package "SPARC") - - -(define-vop (print) - (:args (object :scs (descriptor-reg any-reg) :target nl0)) - (:results (result :scs (descriptor-reg))) - (:save-p t) - (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) nl0) - (:temporary (:sc any-reg :offset cfunc-offset) cfunc) - (:temporary (:sc interior-reg :offset lip-offset) lip) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:vop-var vop) - (:generator 100 - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (move nl0 object) - (inst li cfunc (make-fixup "_debug_print" :foreign)) - (inst li temp (make-fixup "_call_into_c" :foreign)) - (inst jal lip temp) - (inst nop) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - (move result nl0)))) diff --git a/compiler/sparc/sap.lisp b/compiler/sparc/sap.lisp deleted file mode 100644 index 5a92f99aa5c836a8a0fab497e9543aee8f69da21..0000000000000000000000000000000000000000 --- a/compiler/sparc/sap.lisp +++ /dev/null @@ -1,287 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/sap.lisp,v 1.5 1992/04/27 20:04:06 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the SPARC VM definition of SAP operations. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") - - -;;;; Moves and coercions: - -;;; Move a tagged SAP to an untagged representation. -;;; -(define-vop (move-to-sap) - (:args (x :scs (any-reg descriptor-reg))) - (:results (y :scs (sap-reg))) - (:note "pointer to SAP coercion") - (:generator 1 - (loadw y x sap-pointer-slot other-pointer-type))) - -;;; -(define-move-vop move-to-sap :move - (descriptor-reg) (sap-reg)) - - -;;; Move an untagged SAP to a tagged representation. -;;; -(define-vop (move-from-sap) - (:args (sap :scs (sap-reg) :to :save)) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (res :scs (descriptor-reg))) - (:note "SAP to pointer coercion") - (:generator 20 - (with-fixed-allocation (res ndescr sap-type sap-size) - (storew sap res sap-pointer-slot other-pointer-type)))) -;;; -(define-move-vop move-from-sap :move - (sap-reg) (descriptor-reg)) - - -;;; Move untagged sap values. -;;; -(define-vop (sap-move) - (:args (x :target y - :scs (sap-reg) - :load-if (not (location= x y)))) - (:results (y :scs (sap-reg) - :load-if (not (location= x y)))) - (:note "SAP move") - (:effects) - (:affected) - (:generator 0 - (move y x))) -;;; -(define-move-vop sap-move :move - (sap-reg) (sap-reg)) - - -;;; Move untagged sap arguments/return-values. -;;; -(define-vop (move-sap-argument) - (:args (x :target y - :scs (sap-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) - (:results (y)) - (:note "SAP argument move") - (:generator 0 - (sc-case y - (sap-reg - (move y x)) - (sap-stack - (storew x fp (tn-offset y)))))) -;;; -(define-move-vop move-sap-argument :move-argument - (descriptor-reg sap-reg) (sap-reg)) - - -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a -;;; descriptor passing location. -;;; -(define-move-vop move-argument :move-argument - (sap-reg) (descriptor-reg)) - - - -;;;; SAP-INT and INT-SAP - -(define-vop (sap-int) - (:args (sap :scs (sap-reg) :target int)) - (:arg-types system-area-pointer) - (:results (int :scs (unsigned-reg))) - (:result-types unsigned-num) - (:translate sap-int) - (:policy :fast-safe) - (:generator 1 - (move int sap))) - -(define-vop (int-sap) - (:args (int :scs (unsigned-reg) :target sap)) - (:arg-types unsigned-num) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate int-sap) - (:policy :fast-safe) - (:generator 1 - (move sap int))) - - - -;;;; POINTER+ and POINTER- - -(define-vop (pointer+) - (:translate sap+) - (:args (ptr :scs (sap-reg)) - (offset :scs (signed-reg))) - (:arg-types system-area-pointer signed-num) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:policy :fast-safe) - (:generator 2 - (inst add res ptr offset))) - -(define-vop (pointer+-c) - (:translate sap+) - (:args (ptr :scs (sap-reg))) - (:info offset) - (:arg-types system-area-pointer (:constant (signed-byte 13))) - (:results (res :scs (sap-reg))) - (:result-types system-area-pointer) - (:policy :fast-safe) - (:generator 1 - (inst add res ptr offset))) - -(define-vop (pointer-) - (:translate sap-) - (:args (ptr1 :scs (sap-reg)) - (ptr2 :scs (sap-reg))) - (:arg-types system-area-pointer system-area-pointer) - (:policy :fast-safe) - (:results (res :scs (signed-reg))) - (:result-types signed-num) - (:generator 1 - (inst sub res ptr1 ptr2))) - - - -;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET - -(eval-when (compile eval) - -(defmacro def-system-ref-and-set - (ref-name set-name sc type size &optional signed) - (let ((ref-name-c (symbolicate ref-name "-C")) - (set-name-c (symbolicate set-name "-C"))) - `(progn - (define-vop (,ref-name) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (offset :scs (unsigned-reg))) - (:arg-types system-area-pointer unsigned-num) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 5 - (inst ,(ecase size - (:byte (if signed 'ldsb 'ldub)) - (:short (if signed 'ldsh 'lduh)) - (:long 'ld) - (:single 'ldf) - (:double 'lddf)) - result sap offset))) - (define-vop (,ref-name-c) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (sap :scs (sap-reg))) - (:arg-types system-area-pointer (:constant (signed-byte 13))) - (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 4 - (inst ,(ecase size - (:byte (if signed 'ldsb 'ldub)) - (:short (if signed 'ldsh 'lduh)) - (:long 'ld) - (:single 'ldf) - (:double 'lddf)) - result sap offset))) - (define-vop (,set-name) - (:translate ,set-name) - (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (offset :scs (unsigned-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer unsigned-num ,type) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 5 - (inst ,(ecase size - (:byte 'stb) - (:short 'sth) - (:long 'st) - (:single 'stf) - (:double 'stdf)) - value sap offset) - (unless (location= result value) - ,@(case size - (:single - '((inst fmovs result value))) - (:double - '((inst fmovs result value) - (inst fmovs-odd result value))) - (t - '((inst move result value))))))) - (define-vop (,set-name-c) - (:translate ,set-name) - (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer (:constant (signed-byte 13)) ,type) - (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 4 - (inst ,(ecase size - (:byte 'stb) - (:short 'sth) - (:long 'st) - (:single 'stf) - (:double 'stdf)) - value sap offset) - (unless (location= result value) - ,@(case size - (:single - '((inst fmovs result value))) - (:double - '((inst fmovs result value) - (inst fmovs-odd result value))) - (t - '((inst move result value)))))))))) - -); eval-when (compile eval) - -(def-system-ref-and-set sap-ref-8 %set-sap-ref-8 - unsigned-reg positive-fixnum :byte nil) -(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 - signed-reg tagged-num :byte t) -(def-system-ref-and-set sap-ref-16 %set-sap-ref-16 - unsigned-reg positive-fixnum :short nil) -(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 - signed-reg tagged-num :short t) -(def-system-ref-and-set sap-ref-32 %set-sap-ref-32 - unsigned-reg unsigned-num :long nil) -(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 - signed-reg signed-num :long t) -(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap - sap-reg system-area-pointer :long) -(def-system-ref-and-set sap-ref-single %set-sap-ref-single - single-reg single-float :single) -(def-system-ref-and-set sap-ref-double %set-sap-ref-double - double-reg double-float :double) - - - -;;; Noise to convert normal lisp data objects into SAPs. - -(define-vop (vector-sap) - (:translate vector-sap) - (:policy :fast-safe) - (:args (vector :scs (descriptor-reg))) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 2 - (inst add sap vector - (- (* vector-data-offset word-bytes) other-pointer-type)))) - diff --git a/compiler/sparc/static-fn.lisp b/compiler/sparc/static-fn.lisp deleted file mode 100644 index 168b4e28db1c889b58d8ecfe8f31041e607417e3..0000000000000000000000000000000000000000 --- a/compiler/sparc/static-fn.lisp +++ /dev/null @@ -1,150 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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 (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/static-fn.lisp,v 1.4 1992/12/17 09:42:02 wlott Exp $ -;;; -;;; This file contains the VOPs and macro magic necessary to call static -;;; functions. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") - - - -(define-vop (static-function-template) - (:save-p t) - (:policy :safe) - (:variant-vars symbol) - (:vop-var vop) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg)) move-temp) - (:temporary (:sc descriptor-reg :offset lra-offset) lra) - (:temporary (:scs (descriptor-reg)) func) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) old-fp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) - - -(eval-when (compile load eval) - - -(defun static-function-template-name (num-args num-results) - (intern (format nil "~:@(~R-arg-~R-result-static-function~)" - num-args num-results))) - - -(defun moves (dst src) - (collect ((moves)) - (do ((dst dst (cdr dst)) - (src src (cdr src))) - ((or (null dst) (null src))) - (moves `(move ,(car dst) ,(car src)))) - (moves))) - -(defun static-function-template-vop (num-args num-results) - (assert (and (<= num-args register-arg-count) - (<= num-results register-arg-count)) - (num-args num-results) - "Either too many args (~D) or too many results (~D). Max = ~D" - num-args num-results register-arg-count) - (let ((num-temps (max num-args num-results))) - (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) - (dotimes (i num-results) - (let ((result-name (intern (format nil "RESULT-~D" i)))) - (result-names result-name) - (results `(,result-name :scs (any-reg descriptor-reg))))) - (dotimes (i num-temps) - (let ((temp-name (intern (format nil "TEMP-~D" i)))) - (temp-names temp-name) - (temps `(:temporary (:sc descriptor-reg - :offset ,(nth i register-arg-offsets) - ,@(when (< i num-args) - `(:from (:argument ,i))) - ,@(when (< i num-results) - `(:to (:result ,i) - :target ,(nth i (result-names))))) - ,temp-name)))) - (dotimes (i num-args) - (let ((arg-name (intern (format nil "ARG-~D" i)))) - (arg-names arg-name) - (args `(,arg-name - :scs (any-reg descriptor-reg) - :target ,(nth i (temp-names)))))) - `(define-vop (,(static-function-template-name num-args num-results) - static-function-template) - (:args ,@(args)) - ,@(temps) - (:results ,@(results)) - (:generator ,(+ 50 num-args num-results) - (let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - ,@(moves (temp-names) (arg-names)) - (inst ld func null-tn (static-function-offset symbol)) - (inst li nargs (fixnum ,num-args)) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (inst move old-fp cfp-tn) - (inst move cfp-tn csp-tn) - (inst compute-lra-from-code lra code-tn lra-label temp) - (note-this-location vop :call-site) - (inst j func (- (ash function-code-offset word-shift) - function-pointer-type)) - (inst move code-tn func) - (emit-return-pc lra-label) - ,(collect ((bindings) (links)) - (do ((temp (temp-names) (cdr temp)) - (name 'values (gensym)) - (prev nil name) - (i 0 (1+ i))) - ((= i num-results)) - (bindings `(,name - (make-tn-ref ,(car temp) nil))) - (when prev - (links `(setf (tn-ref-across ,prev) ,name)))) - `(let ,(bindings) - ,@(links) - (default-unknown-values vop - ,(if (zerop num-results) nil 'values) - ,num-results move-temp temp lra-label))) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)) - ,@(moves (result-names) (temp-names)))))))) - - -) ; eval-when (compile load eval) - - -(macrolet ((frob (num-args num-res) - (static-function-template-vop (eval num-args) (eval num-res)))) - (frob 0 1) - (frob 1 1) - (frob 2 1) - (frob 3 1) - (frob 4 1) - (frob 5 1)) - - -(defmacro define-static-function (name args &key (results '(x)) translate - policy cost arg-types result-types) - `(define-vop (,name - ,(static-function-template-name (length args) - (length results))) - (:variant ',name) - (:note ,(format nil "static-function ~@(~S~)" name)) - ,@(when translate - `((:translate ,translate))) - ,@(when policy - `((:policy ,policy))) - ,@(when cost - `((:generator-cost ,cost))) - ,@(when arg-types - `((:arg-types ,@arg-types))) - ,@(when result-types - `((:result-types ,@result-types))))) diff --git a/compiler/sparc/subprim.lisp b/compiler/sparc/subprim.lisp deleted file mode 100644 index 726b4ac59ac72057510436250d7a02149e37f1de..0000000000000000000000000000000000000000 --- a/compiler/sparc/subprim.lisp +++ /dev/null @@ -1,62 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/subprim.lisp,v 1.2 1992/10/11 10:54:22 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; Linkage information for standard static functions, and random vops. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") - - - -;;;; Length - -(define-vop (length/list) - (:translate length) - (:args (object :scs (descriptor-reg) :target ptr)) - (:arg-types list) - (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result) - count) - (:results (result :scs (any-reg descriptor-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:generator 50 - (let ((done (gen-label)) - (loop (gen-label)) - (not-list (generate-cerror-code vop object-not-list-error object))) - (move ptr object) - (move count zero-tn) - - (emit-label loop) - - (inst cmp ptr null-tn) - (inst b :eq done) - (inst nop) - - (test-type ptr temp not-list t vm:list-pointer-type) - - (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) - (inst add count count (fixnum 1)) - (test-type ptr temp loop nil vm:list-pointer-type) - - (cerror-call vop done object-not-list-error ptr) - - (emit-label done) - (move result count)))) - - -(define-static-function length (object) :translate length) - diff --git a/compiler/sparc/system.lisp b/compiler/sparc/system.lisp deleted file mode 100644 index 1f29d07edd9002e5ec2fe0b87b6f78a2406806e0..0000000000000000000000000000000000000000 --- a/compiler/sparc/system.lisp +++ /dev/null @@ -1,245 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/system.lisp,v 1.9 1992/10/11 10:54:24 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; MIPS VM definitions of various system hacking operations. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Mips conversion by William Lott and Christopher Hoover. -;;; -(in-package "SPARC") - - - -;;;; Type frobbing VOPs - -(define-vop (get-lowtag) - (:translate get-lowtag) - (:policy :fast-safe) - (:args (object :scs (any-reg descriptor-reg))) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 1 - (inst and result object vm:lowtag-mask))) - -(define-vop (get-type) - (:translate get-type) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (let ((other-ptr (gen-label)) - (function-ptr (gen-label)) - (done (gen-label))) - (test-type object ndescr other-ptr nil vm:other-pointer-type) - (test-type object ndescr function-ptr nil vm:function-pointer-type) - (inst andcc result object - (logand vm:other-immediate-0-type vm:other-immediate-1-type)) - (inst b :eq done) - (inst nop) - - (inst b done) - (inst and result object vm:type-mask) - - (emit-label function-ptr) - (load-type result object (- vm:function-pointer-type)) - (inst b done) - (inst nop) - - (emit-label other-ptr) - (load-type result object (- vm:other-pointer-type)) - (inst nop) - - (emit-label done)))) - -(define-vop (function-subtype) - (:translate function-subtype) - (:policy :fast-safe) - (:args (function :scs (descriptor-reg))) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (load-type result function (- vm:function-pointer-type)))) - -(define-vop (set-function-subtype) - (:translate (setf function-subtype)) - (:policy :fast-safe) - (:args (type :scs (unsigned-reg) :target result) - (function :scs (descriptor-reg))) - (:arg-types positive-fixnum *) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (inst stb type function (- 3 function-pointer-type)) - (move result type))) - -(define-vop (get-header-data) - (:translate get-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (loadw res x 0 vm:other-pointer-type) - (inst srl res res vm:type-bits))) - -(define-vop (get-closure-length) - (:translate get-closure-length) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:generator 6 - (loadw res x 0 vm:function-pointer-type) - (inst srl res res vm:type-bits))) - -(define-vop (set-header-data) - (:translate set-header-data) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg) :target res) - (data :scs (any-reg immediate zero))) - (:arg-types * positive-fixnum) - (:results (res :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) t1 t2) - (:generator 6 - (loadw t1 x 0 vm:other-pointer-type) - (inst and t1 vm:type-mask) - (sc-case data - (any-reg - (inst sll t2 data (- vm:type-bits 2)) - (inst or t1 t2)) - (immediate - (inst or t1 (ash (tn-value data) vm:type-bits))) - (zero)) - (storew t1 x 0 vm:other-pointer-type) - (move res x))) - - -(define-vop (make-fixnum) - (:args (ptr :scs (any-reg descriptor-reg))) - (:results (res :scs (any-reg descriptor-reg))) - (:generator 1 - ;; - ;; Some code (the hash table code) depends on this returning a - ;; positive number so make sure it does. - (inst sll res ptr 3) - (inst srl res res 1))) - -(define-vop (make-other-immediate-type) - (:args (val :scs (any-reg descriptor-reg)) - (type :scs (any-reg descriptor-reg immediate) - :target temp)) - (:results (res :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 2 - (sc-case type - (immediate - (inst sll temp val vm:type-bits) - (inst or res temp (tn-value type))) - (t - (inst sra temp type 2) - (inst sll res val (- vm:type-bits 2)) - (inst or res res temp))))) - - -;;;; Allocation - -(define-vop (dynamic-space-free-pointer) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate dynamic-space-free-pointer) - (:policy :fast-safe) - (:generator 1 - (move int alloc-tn))) - -(define-vop (binding-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate binding-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move int bsp-tn))) - -(define-vop (control-stack-pointer-sap) - (:results (int :scs (sap-reg))) - (:result-types system-area-pointer) - (:translate control-stack-pointer-sap) - (:policy :fast-safe) - (:generator 1 - (move int csp-tn))) - - -;;;; Code object frobbing. - -(define-vop (code-instructions) - (:translate code-instructions) - (:policy :fast-safe) - (:args (code :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:results (sap :scs (sap-reg))) - (:result-types system-area-pointer) - (:generator 10 - (loadw ndescr code 0 vm:other-pointer-type) - (inst srl ndescr vm:type-bits) - (inst sll ndescr vm:word-shift) - (inst sub ndescr vm:other-pointer-type) - (inst add sap code ndescr))) - -(define-vop (compute-function) - (:args (code :scs (descriptor-reg)) - (offset :scs (signed-reg unsigned-reg))) - (:arg-types * positive-fixnum) - (:results (func :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:generator 10 - (loadw ndescr code 0 vm:other-pointer-type) - (inst srl ndescr vm:type-bits) - (inst sll ndescr vm:word-shift) - (inst add ndescr offset) - (inst add ndescr (- vm:function-pointer-type vm:other-pointer-type)) - (inst add func code ndescr))) - - - -;;;; Other random VOPs. - - -(defknown unix::do-pending-interrupt () (values)) -(define-vop (unix::do-pending-interrupt) - (:policy :fast-safe) - (:translate unix::do-pending-interrupt) - (:generator 1 - (inst unimp pending-interrupt-trap))) - - -(define-vop (halt) - (:generator 1 - (inst unimp halt-trap))) - - - -;;;; Dynamic vop count collection support - -(define-vop (count-me) - (:args (count-vector :scs (descriptor-reg))) - (:info index) - (:temporary (:scs (non-descriptor-reg)) count) - (:generator 1 - (let ((offset - (- (* (+ index vector-data-offset) word-bytes) other-pointer-type))) - (assert (typep offset '(signed-byte 13))) - (inst ld count count-vector offset) - (inst add count 1) - (inst st count count-vector offset)))) diff --git a/compiler/sparc/type-vops.lisp b/compiler/sparc/type-vops.lisp deleted file mode 100644 index e8c3e2a887f3f452231b3264afa470d6c93dcdb3..0000000000000000000000000000000000000000 --- a/compiler/sparc/type-vops.lisp +++ /dev/null @@ -1,421 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/type-vops.lisp,v 1.12 1992/12/05 21:57:12 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition of type testing and checking VOPs -;;; for the SPARC. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") - - -;;;; Simple type checking and testing: -;;; -;;; These types are represented by a single type code, so are easily -;;; open-coded as a mask and compare. - -(define-vop (check-type) - (:args (value :target result :scs (any-reg descriptor-reg))) - (:results (result :scs (any-reg descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) - (:vop-var vop) - (:save-p :compute-only)) - -(define-vop (type-predicate) - (:args (value :scs (any-reg descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:scs (non-descriptor-reg)) temp)) - -(eval-when (compile eval) - -(defun cost-to-test-types (type-codes) - (+ (* 2 (length type-codes)) - (if (> (apply #'max type-codes) vm:lowtag-limit) 7 2))) - -(defmacro def-type-vops (pred-name check-name ptype error-code - &rest type-codes) - (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) - `(progn - ,@(when pred-name - `((define-vop (,pred-name type-predicate) - (:translate ,pred-name) - (:generator ,cost - (test-type value temp target not-p ,@type-codes))))) - ,@(when check-name - `((define-vop (,check-name check-type) - (:generator ,cost - (let ((err-lab - (generate-error-code vop ,error-code value))) - (test-type value temp err-lab t ,@type-codes) - (move result value)))))) - ,@(when ptype - `((primitive-type-vop ,check-name (:check) ,ptype)))))) - -); eval-when (compile eval) - -(def-type-vops fixnump nil nil nil vm:even-fixnum-type vm:odd-fixnum-type) -(define-vop (check-fixnum check-type) - (:ignore temp) - (:generator 1 - (inst taddcctv result value zero-tn))) -(primitive-type-vop check-fixnum (:check) fixnum) - - -(def-type-vops functionp check-function function - object-not-function-error vm:function-pointer-type) - -(def-type-vops listp nil nil nil vm:list-pointer-type) -(define-vop (check-list check-type) - (:generator 3 - (inst and temp value lowtag-mask) - (inst cmp temp list-pointer-type) - (inst t :ne (logior (ash (tn-offset value) 8) object-not-list-trap)) - (move result value))) -(primitive-type-vop check-list (:check) list) - -(def-type-vops structurep nil nil nil vm:structure-pointer-type) -(define-vop (check-structure check-type) - (:generator 3 - (inst and temp value lowtag-mask) - (inst cmp temp structure-pointer-type) - (inst t :ne (logior (ash (tn-offset value) 8) object-not-structure-trap)) - (move result value))) -(primitive-type-vop check-structure (:check) structure) - -(def-type-vops bignump check-bigunm bignum - object-not-bignum-error vm:bignum-type) - -(def-type-vops ratiop check-ratio ratio - object-not-ratio-error vm:ratio-type) - -(def-type-vops complexp check-complex complex - object-not-complex-error vm:complex-type) - -(def-type-vops single-float-p check-single-float single-float - object-not-single-float-error vm:single-float-type) - -(def-type-vops double-float-p check-double-float double-float - object-not-double-float-error vm:double-float-type) - -(def-type-vops simple-string-p check-simple-string simple-string - object-not-simple-string-error vm:simple-string-type) - -(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector - object-not-simple-bit-vector-error vm:simple-bit-vector-type) - -(def-type-vops simple-vector-p check-simple-vector simple-vector - object-not-simple-vector-error vm:simple-vector-type) - -(def-type-vops simple-array-unsigned-byte-2-p - check-simple-array-unsigned-byte-2 - simple-array-unsigned-byte-2 - object-not-simple-array-unsigned-byte-2-error - vm:simple-array-unsigned-byte-2-type) - -(def-type-vops simple-array-unsigned-byte-4-p - check-simple-array-unsigned-byte-4 - simple-array-unsigned-byte-4 - object-not-simple-array-unsigned-byte-4-error - vm:simple-array-unsigned-byte-4-type) - -(def-type-vops simple-array-unsigned-byte-8-p - check-simple-array-unsigned-byte-8 - simple-array-unsigned-byte-8 - object-not-simple-array-unsigned-byte-8-error - vm:simple-array-unsigned-byte-8-type) - -(def-type-vops simple-array-unsigned-byte-16-p - check-simple-array-unsigned-byte-16 - simple-array-unsigned-byte-16 - object-not-simple-array-unsigned-byte-16-error - vm:simple-array-unsigned-byte-16-type) - -(def-type-vops simple-array-unsigned-byte-32-p - check-simple-array-unsigned-byte-32 - simple-array-unsigned-byte-32 - object-not-simple-array-unsigned-byte-32-error - vm:simple-array-unsigned-byte-32-type) - -(def-type-vops simple-array-single-float-p check-simple-array-single-float - simple-array-single-float object-not-simple-array-single-float-error - vm:simple-array-single-float-type) - -(def-type-vops simple-array-double-float-p check-simple-array-double-float - simple-array-double-float object-not-simple-array-double-float-error - vm:simple-array-double-float-type) - -(def-type-vops base-char-p check-base-char base-char - object-not-base-char-error vm:base-char-type) - -(def-type-vops system-area-pointer-p check-system-area-pointer - system-area-pointer object-not-sap-error vm:sap-type) - -(def-type-vops weak-pointer-p check-weak-pointer weak-pointer - object-not-weak-pointer-error vm:weak-pointer-type) - -(def-type-vops scavenger-hook-p nil nil nil - 0) - -(def-type-vops code-component-p nil nil nil - vm:code-header-type) - -(def-type-vops lra-p nil nil nil - vm:return-pc-header-type) - -(def-type-vops fdefn-p nil nil nil - vm:fdefn-type) - -(def-type-vops funcallable-instance-p nil nil nil - vm:funcallable-instance-header-type) - -(def-type-vops dylan::dylan-function-p nil nil nil - dylan-function-header-type) - -(def-type-vops array-header-p nil nil nil - vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type - vm:complex-vector-type vm:complex-array-type) - -(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error - vm:function-pointer-type vm:symbol-header-type) - -(def-type-vops stringp check-string nil object-not-string-error - vm:simple-string-type vm:complex-string-type) - -(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error - vm:simple-bit-vector-type vm:complex-bit-vector-type) - -(def-type-vops vectorp check-vector nil object-not-vector-error - vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type - vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type - vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type - vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type - vm:simple-array-double-float-type vm:complex-string-type - vm:complex-bit-vector-type vm:complex-vector-type) - -(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error - vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type - vm:simple-vector-type vm:simple-array-unsigned-byte-2-type - vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type - vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type - vm:simple-array-single-float-type vm:simple-array-double-float-type) - -(def-type-vops arrayp check-array nil object-not-array-error - vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type - vm:simple-vector-type vm:simple-array-unsigned-byte-2-type - vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type - vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type - vm:simple-array-single-float-type vm:simple-array-double-float-type - vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type - vm:complex-array-type) - -(def-type-vops numberp check-number nil object-not-number-error - vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type - vm:single-float-type vm:double-float-type vm:complex-type) - -(def-type-vops rationalp check-rational nil object-not-rational-error - vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) - -(def-type-vops integerp check-integer nil object-not-integer-error - vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type) - -(def-type-vops floatp check-float nil object-not-float-error - vm:single-float-type vm:double-float-type) - -(def-type-vops realp check-real nil object-not-real-error - vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type - vm:single-float-type vm:double-float-type) - - -;;;; Other integer ranges. - -;;; A (signed-byte 32) can be represented with either fixnum or a bignum with -;;; exactly one digit. - -(define-vop (signed-byte-32-p type-predicate) - (:translate signed-byte-32-p) - (:generator 45 - (let ((not-target (gen-label))) - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - (inst andcc zero-tn value #x3) - (inst b :eq yep) - (test-type value temp nope t vm:other-pointer-type) - (loadw temp value 0 vm:other-pointer-type) - (inst cmp temp (+ (ash 1 vm:type-bits) - vm:bignum-type)) - (inst b (if not-p :ne :eq) target) - (inst nop) - (emit-label not-target))))) - -(define-vop (check-signed-byte-32 check-type) - (:generator 45 - (let ((nope (generate-error-code vop object-not-signed-byte-32-error value)) - (yep (gen-label))) - (inst andcc temp value #x3) - (inst b :eq yep) - (test-type value temp nope t vm:other-pointer-type) - (loadw temp value 0 vm:other-pointer-type) - (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type)) - (inst b :ne nope) - (inst nop) - (emit-label yep) - (move result value)))) - - -;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a -;;; bignum with exactly one positive digit, or a bignum with exactly two digits -;;; and the second digit all zeros. - -(define-vop (unsigned-byte-32-p type-predicate) - (:translate unsigned-byte-32-p) - (:generator 45 - (let ((not-target (gen-label)) - (single-word (gen-label)) - (fixnum (gen-label))) - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - ;; Is it a fixnum? - (inst andcc temp value #x3) - (inst b :eq fixnum) - (inst cmp value) - - ;; If not, is it an other pointer? - (test-type value temp nope t vm:other-pointer-type) - ;; Get the header. - (loadw temp value 0 vm:other-pointer-type) - ;; Is it one? - (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type)) - (inst b :eq single-word) - ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type)) - (inst b :ne nope) - ;; Get the second digit. - (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type) - ;; All zeros, its an (unsigned-byte 32). - (inst cmp temp) - (inst b :eq yep) - (inst nop) - ;; Otherwise, it isn't. - (inst b nope) - (inst nop) - - (emit-label single-word) - ;; Get the single digit. - (loadw temp value vm:bignum-digits-offset vm:other-pointer-type) - (inst cmp temp) - - ;; positive implies (unsigned-byte 32). - (emit-label fixnum) - (inst b (if not-p :lt :ge) target) - (inst nop) - - (emit-label not-target))))) - -(define-vop (check-unsigned-byte-32 check-type) - (:generator 45 - (let ((nope - (generate-error-code vop object-not-unsigned-byte-32-error value)) - (yep (gen-label)) - (fixnum (gen-label)) - (single-word (gen-label))) - ;; Is it a fixnum? - (inst andcc temp value #x3) - (inst b :eq fixnum) - (inst cmp value) - - ;; If not, is it an other pointer? - (test-type value temp nope t vm:other-pointer-type) - ;; Get the number of digits. - (loadw temp value 0 vm:other-pointer-type) - ;; Is it one? - (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type)) - (inst b :eq single-word) - ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type)) - (inst b :ne nope) - ;; Get the second digit. - (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type) - ;; All zeros, its an (unsigned-byte 32). - (inst cmp temp) - (inst b :eq yep) - ;; Otherwise, it isn't. - (inst b :ne nope) - (inst nop) - - (emit-label single-word) - ;; Get the single digit. - (loadw temp value vm:bignum-digits-offset vm:other-pointer-type) - ;; positive implies (unsigned-byte 32). - (inst cmp temp) - - (emit-label fixnum) - (inst b :lt nope) - (inst nop) - - (emit-label yep) - (move result value)))) - - - - -;;;; List/symbol types: -;;; -;;; symbolp (or symbol (eq nil)) -;;; consp (and list (not (eq nil))) - -(define-vop (symbolp type-predicate) - (:translate symbolp) - (:generator 12 - (let* ((drop-thru (gen-label)) - (is-symbol-label (if not-p drop-thru target))) - (inst cmp value null-tn) - (inst b :eq is-symbol-label) - (test-type value temp target not-p vm:symbol-header-type) - (emit-label drop-thru)))) - -(define-vop (check-symbol check-type) - (:generator 12 - (let ((drop-thru (gen-label)) - (error (generate-error-code vop object-not-symbol-error value))) - (inst cmp value null-tn) - (inst b :eq drop-thru) - (test-type value temp error t vm:symbol-header-type) - (emit-label drop-thru) - (move result value)))) - -(define-vop (consp type-predicate) - (:translate consp) - (:generator 8 - (let* ((drop-thru (gen-label)) - (is-not-cons-label (if not-p target drop-thru))) - (inst cmp value null-tn) - (inst b :eq is-not-cons-label) - (test-type value temp target not-p vm:list-pointer-type) - (emit-label drop-thru)))) - -(define-vop (check-cons check-type) - (:generator 8 - (let ((error (generate-error-code vop object-not-cons-error value))) - (inst cmp value null-tn) - (inst b :eq error) - (test-type value temp error t vm:list-pointer-type) - (move result value)))) - diff --git a/compiler/sparc/values.lisp b/compiler/sparc/values.lisp deleted file mode 100644 index db76810548e57394b6860bde1cb0d70565b89c10..0000000000000000000000000000000000000000 --- a/compiler/sparc/values.lisp +++ /dev/null @@ -1,91 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/values.lisp,v 1.2 1992/10/11 10:54:28 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the implementation of unknown-values VOPs. -;;; -;;; Written by Rob MacLachlan -;;; -;;; Converted for SPARC by William Lott. -;;; - -(in-package "SPARC") - -(define-vop (reset-stack-pointer) - (:args (ptr :scs (any-reg))) - (:generator 1 - (move csp-tn ptr))) - - -;;; Push some values onto the stack, returning the start and number of values -;;; pushed as results. It is assumed that the Vals are wired to the standard -;;; argument locations. Nvals is the number of values to push. -;;; -;;; The generator cost is pseudo-random. We could get it right by defining a -;;; bogus SC that reflects the costs of the memory-to-memory moves for each -;;; operand, but this seems unworthwhile. -;;; -(define-vop (push-values) - (:args (vals :more t)) - (:results (start :scs (any-reg) :from :load) - (count :scs (any-reg))) - (:info nvals) - (:temporary (:scs (descriptor-reg)) temp) - (:generator 20 - (inst move start csp-tn) - (inst add csp-tn csp-tn (* nvals vm:word-bytes)) - (do ((val vals (tn-ref-across val)) - (i 0 (1+ i))) - ((null val)) - (let ((tn (tn-ref-tn val))) - (sc-case tn - (descriptor-reg - (storew tn start i)) - (control-stack - (load-stack-tn temp tn) - (storew temp start i))))) - (inst li count (fixnum nvals)))) - -;;; Push a list of values on the stack, returning Start and Count as used in -;;; unknown values continuations. -;;; -(define-vop (values-list) - (:args (arg :scs (descriptor-reg) :target list)) - (:arg-types list) - (:policy :fast-safe) - (:results (start :scs (any-reg)) - (count :scs (any-reg))) - (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) - (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (non-descriptor-reg)) ndescr) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (let ((loop (gen-label)) - (done (gen-label))) - - (move list arg) - (move start csp-tn) - - (emit-label loop) - (inst cmp list null-tn) - (inst b :eq done) - (loadw temp list vm:cons-car-slot vm:list-pointer-type) - (loadw list list vm:cons-cdr-slot vm:list-pointer-type) - (inst add csp-tn csp-tn vm:word-bytes) - (storew temp csp-tn -1) - (test-type list ndescr loop nil vm:list-pointer-type) - (error-call vop bogus-argument-to-values-list-error list) - - (emit-label done) - (inst sub count csp-tn start)))) - diff --git a/compiler/sparc/vm.lisp b/compiler/sparc/vm.lisp deleted file mode 100644 index 773b833b03d90a1777e3cde78d8fb30a4c49eb06..0000000000000000000000000000000000000000 --- a/compiler/sparc/vm.lisp +++ /dev/null @@ -1,340 +0,0 @@ -;;; -*- Package: SPARC -*- -;;; -;;; ********************************************************************** -;;; 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/sparc/vm.lisp,v 1.6 1992/05/21 02:21:35 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains the VM definition for the SPARC. -;;; -;;; Written by William Lott. -;;; -(in-package "SPARC") - - -;;;; Define the registers - -(eval-when (compile eval) - -(defmacro defreg (name offset) - (let ((offset-sym (symbolicate name "-OFFSET"))) - `(eval-when (compile eval load) - (defconstant ,offset-sym ,offset) - (setf (svref *register-names* ,offset-sym) ,(symbol-name name))))) - -(defmacro defregset (name &rest regs) - `(eval-when (compile eval load) - (defconstant ,name - (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))) - -); eval-when (compile eval) - - -(eval-when (compile load eval) - -(defvar *register-names* (make-array 32 :initial-element nil)) - -); eval-when (compile load eval) - - -;; Globals. These are difficult to extract from a sigcontext. -(defreg zero 0) -(defreg alloc 1) -(defreg null 2) -(defreg csp 3) -(defreg cfp 4) -(defreg bsp 5) -(defreg nfp 6) -(defreg cfunc 7) - -;; Outs. These get clobbered when we call into C. -(defreg nl0 8) -(defreg nl1 9) -(defreg nl2 10) -(defreg nl3 11) -(defreg nl4 12) -(defreg nl5 13) -(defreg nsp 14) -(defreg nargs 15) - -;; Locals. These are preserved when we call into C. -(defreg a0 16) -(defreg a1 17) -(defreg a2 18) -(defreg a3 19) -(defreg a4 20) -(defreg a5 21) -(defreg ocfp 22) -(defreg lra 23) - -;; Ins. These are preserved just like locals. -(defreg cname 24) -(defreg lexenv 25) -(defreg l0 26) -(defreg l1 27) -(defreg l2 28) -(defreg code 29) -;; we can't touch reg 30 if we ever want to return -(defreg lip 31) - -(defregset non-descriptor-regs - nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp) - -(defregset descriptor-regs - a0 a1 a2 a3 a4 a5 ocfp lra cname lexenv l0 l1 l2) - -(defregset register-arg-offsets - a0 a1 a2 a3 a4 a5) - - - -;;;; SB and SC definition: - -(define-storage-base registers :finite :size 32) -(define-storage-base float-registers :finite :size 32) -(define-storage-base control-stack :unbounded :size 8) -(define-storage-base non-descriptor-stack :unbounded :size 0) -(define-storage-base constant :non-packed) -(define-storage-base immediate-constant :non-packed) - -;;; -;;; Handy macro so we don't have to keep changing all the numbers whenever -;;; we insert a new storage class. -;;; -(defmacro define-storage-classes (&rest classes) - (do ((forms (list 'progn) - (let* ((class (car classes)) - (sc-name (car class)) - (constant-name (intern (concatenate 'simple-string - (string sc-name) - "-SC-NUMBER")))) - (list* `(define-storage-class ,sc-name ,index - ,@(cdr class)) - `(defconstant ,constant-name ,index) - `(export ',constant-name) - forms))) - (index 0 (1+ index)) - (classes classes (cdr classes))) - ((null classes) - (nreverse forms)))) - -(define-storage-classes - - ;; Non-immediate contstants in the constant pool - (constant constant) - - ;; ZERO and NULL are in registers. - (zero immediate-constant) - (null immediate-constant) - - ;; Anything else that can be an immediate. - (immediate immediate-constant) - - - ;; **** The stacks. - - ;; The control stack. (Scanned by GC) - (control-stack control-stack) - - ;; The non-descriptor stacks. - (signed-stack non-descriptor-stack) ; (signed-byte 32) - (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) - (base-char-stack non-descriptor-stack) ; non-descriptor characters. - (sap-stack non-descriptor-stack) ; System area pointers. - (single-stack non-descriptor-stack) ; single-floats - (double-stack non-descriptor-stack - :element-size 2 :alignment 2) ; double floats. - - - ;; **** Things that can go in the integer registers. - - ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing - ;; bad will happen if they are. (fixnums, characters, header values, etc). - (any-reg - registers - :locations #.(append non-descriptor-regs descriptor-regs) - :constant-scs (zero immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; Pointer descriptor objects. Must be seen by GC. - (descriptor-reg registers - :locations #.descriptor-regs - :constant-scs (constant null immediate) - :save-p t - :alternate-scs (control-stack)) - - ;; Non-Descriptor characters - (base-char-reg registers - :locations #.non-descriptor-regs - :constant-scs (immediate) - :save-p t - :alternate-scs (base-char-stack)) - - ;; Non-Descriptor SAP's (arbitrary pointers into address space) - (sap-reg registers - :locations #.non-descriptor-regs - :constant-scs (immediate) - :save-p t - :alternate-scs (sap-stack)) - - ;; Non-Descriptor (signed or unsigned) numbers. - (signed-reg registers - :locations #.non-descriptor-regs - :constant-scs (zero immediate) - :save-p t - :alternate-scs (signed-stack)) - (unsigned-reg registers - :locations #.non-descriptor-regs - :constant-scs (zero immediate) - :save-p t - :alternate-scs (unsigned-stack)) - - ;; Random objects that must not be seen by GC. Used only as temporaries. - (non-descriptor-reg registers - :locations #.non-descriptor-regs) - - ;; Pointers to the interior of objects. Used only as an temporary. - (interior-reg registers - :locations (#.lip-offset)) - - - ;; **** Things that can go in the floating point registers. - - ;; Non-Descriptor single-floats. - (single-reg float-registers - :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) - ;; ### Note: We really should have every location listed, but then we - ;; would have to make load-tns work with element-sizes other than 1. - :constant-scs () - :save-p t - :alternate-scs (single-stack)) - - ;; Non-Descriptor double-floats. - (double-reg float-registers - :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) - ;; ### Note: load-tns don't work with an element-size other than 1. - ;; :element-size 2 :alignment 2 - :constant-scs () - :save-p t - :alternate-scs (double-stack)) - - - ;; A catch or unwind block. - (catch-block control-stack :element-size vm:catch-block-size)) - - - -;;;; Make some random tns for important registers. - -(eval-when (compile eval) - -(defmacro defregtn (name sc) - (let ((offset-sym (symbolicate name "-OFFSET")) - (tn-sym (symbolicate name "-TN"))) - `(defparameter ,tn-sym - (make-random-tn :kind :normal - :sc (sc-or-lose ',sc) - :offset ,offset-sym)))) - -); eval-when (compile eval) - -(defregtn zero any-reg) -(defregtn null descriptor-reg) -(defregtn code descriptor-reg) -(defregtn alloc any-reg) - -(defregtn nargs any-reg) -(defregtn bsp any-reg) -(defregtn csp any-reg) -(defregtn cfp any-reg) -(defregtn ocfp any-reg) -(defregtn nsp any-reg) - - - -;;; Immediate-Constant-SC -- Interface -;;; -;;; If value can be represented as an immediate constant, then return the -;;; appropriate SC number, otherwise return NIL. -;;; -(def-vm-support-routine immediate-constant-sc (value) - (typecase value - ((integer 0 0) - (sc-number-or-lose 'zero *backend*)) - (null - (sc-number-or-lose 'null *backend*)) - ((or fixnum system-area-pointer character) - (sc-number-or-lose 'immediate *backend*)) - (symbol - (if (static-symbol-p value) - (sc-number-or-lose 'immediate *backend*) - nil)))) - - -;;;; Function Call Parameters - -;;; The SC numbers for register and stack arguments/return values. -;;; -(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) -(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) -(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) - -(eval-when (compile load eval) - -;;; Offsets of special stack frame locations -(defconstant ocfp-save-offset 0) -(defconstant lra-save-offset 1) -(defconstant nfp-save-offset 2) - -;;; The number of arguments/return values passed in registers. -;;; -(defconstant register-arg-count 6) - -;;; Names to use for the argument registers. -;;; -(defconstant register-arg-names '(a0 a1 a2 a3 a4 a5)) - -); Eval-When (Compile Load Eval) - - -;;; A list of TN's describing the register arguments. -;;; -(defparameter register-arg-tns - (mapcar #'(lambda (n) - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset n)) - register-arg-offsets)) - -;;; SINGLE-VALUE-RETURN-BYTE-OFFSET -;;; -;;; This is used by the debugger. -;;; -(export 'single-value-return-byte-offset) -(defconstant single-value-return-byte-offset 8) - - -;;; LOCATION-PRINT-NAME -- Interface -;;; -;;; This function is called by debug output routines that want a pretty name -;;; for a TN's location. It returns a thing that can be printed with PRINC. -;;; -(def-vm-support-routine location-print-name (tn) - (declare (type tn tn)) - (let ((sb (sb-name (sc-sb (tn-sc tn)))) - (offset (tn-offset tn))) - (ecase sb - (registers (or (svref *register-names* offset) - (format nil "R~D" offset))) - (float-registers (format nil "F~D" offset)) - (control-stack (format nil "CS~D" offset)) - (non-descriptor-stack (format nil "NS~D" offset)) - (constant (format nil "Const~D" offset)) - (immediate-constant "Immed")))) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp deleted file mode 100644 index a85ab957f0ff49f486fdc211220b3736878443fd..0000000000000000000000000000000000000000 --- a/compiler/srctran.lisp +++ /dev/null @@ -1,1587 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/srctran.lisp,v 1.39 1992/12/13 15:18:54 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains macro-like source transformations which convert -;;; uses of certain functions into the canonical form desired within the -;;; compiler. ### and other IR1 transforms and stuff. Some code adapted from -;;; CLC, written by Wholey and Fahlman. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package "C") - -;;; Source transform for Not, Null -- Internal -;;; -;;; Convert into an IF so that IF optimizations will eliminate redundant -;;; negations. -;;; -(def-source-transform not (x) `(if ,x nil t)) -(def-source-transform null (x) `(if ,x nil t)) - -;;; Source transform for Endp -- Internal -;;; -;;; Endp is just NULL with a List assertion. -;;; -(def-source-transform endp (x) `(null (the list ,x))) - -;;; We turn Identity into Prog1 so that it is obvious that it just returns the -;;; first value of its argument. Ditto for Values with one arg. -(def-source-transform identity (x) `(prog1 ,x)) -(def-source-transform values (x) `(prog1 ,x)) - -;;; CONSTANTLY source transform -- Internal -;;; -;;; Bind the values and make a closure that returns them. -;;; -(def-source-transform constantly (value &rest values) - (let ((temps (loop repeat (1+ (length values)) - collect (gensym))) - (dum (gensym))) - `(let ,(loop for temp in temps and - value in (list* value values) - collect `(,temp ,value)) - #'(lambda (&rest ,dum) - (declare (ignore ,dum)) - (values ,@temps))))) - - -;;; COMPLEMENT IR1 transform -- Internal -;;; -;;; If the function has a known number of arguments, then return a lambda -;;; with the appropriate fixed number of args. If the destination is a -;;; FUNCALL, then do the &REST APPLY thing, and let MV optimization figure -;;; things out. -;;; -(deftransform complement ((fun) * * :node node) - "open code" - (multiple-value-bind (min max) - (function-type-nargs (continuation-type fun)) - (cond - ((and min (eql min max)) - (let ((dums (loop repeat min collect (gensym)))) - `#'(lambda ,dums (not (funcall fun ,@dums))))) - ((let* ((cont (node-cont node)) - (dest (continuation-dest cont))) - (and (combination-p dest) - (eq (combination-fun dest) cont))) - '#'(lambda (&rest args) - (not (apply fun args)))) - (t - (give-up "Function doesn't have fixed argument count."))))) - - -;;;; List hackery: - -;;; -;;; Translate CxxR into car/cdr combos. -(def-source-transform caar (x) `(car (car ,x))) -(def-source-transform cadr (x) `(car (cdr ,x))) -(def-source-transform cdar (x) `(cdr (car ,x))) -(def-source-transform cddr (x) `(cdr (cdr ,x))) -(def-source-transform caaar (x) `(car (car (car ,x)))) -(def-source-transform caadr (x) `(car (car (cdr ,x)))) -(def-source-transform cadar (x) `(car (cdr (car ,x)))) -(def-source-transform caddr (x) `(car (cdr (cdr ,x)))) -(def-source-transform cdaar (x) `(cdr (car (car ,x)))) -(def-source-transform cdadr (x) `(cdr (car (cdr ,x)))) -(def-source-transform cddar (x) `(cdr (cdr (car ,x)))) -(def-source-transform cdddr (x) `(cdr (cdr (cdr ,x)))) -(def-source-transform caaaar (x) `(car (car (car (car ,x))))) -(def-source-transform caaadr (x) `(car (car (car (cdr ,x))))) -(def-source-transform caadar (x) `(car (car (cdr (car ,x))))) -(def-source-transform caaddr (x) `(car (car (cdr (cdr ,x))))) -(def-source-transform cadaar (x) `(car (cdr (car (car ,x))))) -(def-source-transform cadadr (x) `(car (cdr (car (cdr ,x))))) -(def-source-transform caddar (x) `(car (cdr (cdr (car ,x))))) -(def-source-transform cadddr (x) `(car (cdr (cdr (cdr ,x))))) -(def-source-transform cdaaar (x) `(cdr (car (car (car ,x))))) -(def-source-transform cdaadr (x) `(cdr (car (car (cdr ,x))))) -(def-source-transform cdadar (x) `(cdr (car (cdr (car ,x))))) -(def-source-transform cdaddr (x) `(cdr (car (cdr (cdr ,x))))) -(def-source-transform cddaar (x) `(cdr (cdr (car (car ,x))))) -(def-source-transform cddadr (x) `(cdr (cdr (car (cdr ,x))))) -(def-source-transform cdddar (x) `(cdr (cdr (cdr (car ,x))))) -(def-source-transform cddddr (x) `(cdr (cdr (cdr (cdr ,x))))) - -;;; -;;; Turn First..Fourth and Rest into the obvious synonym, assuming whatever is -;;; right for them is right for us. Fifth..Tenth turn into Nth, which can be -;;; expanded into a car/cdr later on if policy favors it. -(def-source-transform first (x) `(car ,x)) -(def-source-transform rest (x) `(cdr ,x)) -(def-source-transform second (x) `(cadr ,x)) -(def-source-transform third (x) `(caddr ,x)) -(def-source-transform fourth (x) `(cadddr ,x)) -(def-source-transform fifth (x) `(nth 4 ,x)) -(def-source-transform sixth (x) `(nth 5 ,x)) -(def-source-transform seventh (x) `(nth 6 ,x)) -(def-source-transform eighth (x) `(nth 7 ,x)) -(def-source-transform ninth (x) `(nth 8 ,x)) -(def-source-transform tenth (x) `(nth 9 ,x)) - - -;;; -;;; Translate RPLACx to LET and SETF. -(def-source-transform rplaca (x y) - (once-only ((n-x x)) - `(progn - (setf (car ,n-x) ,y) - ,n-x))) -;;; -(def-source-transform rplacd (x y) - (once-only ((n-x x)) - `(progn - (setf (cdr ,n-x) ,y) - ,n-x))) - - -(def-source-transform nth (n l) `(car (nthcdr ,n ,l))) - -(defvar *default-nthcdr-open-code-limit* 6) -(defvar *extreme-nthcdr-open-code-limit* 20) - -(deftransform nthcdr ((n l) (unsigned-byte t) * :node node) - "convert NTHCDR to CAxxR" - (unless (constant-continuation-p n) (give-up)) - (let ((n (continuation-value n))) - (when (> n - (if (policy node (= speed 3) (= space 0)) - *extreme-nthcdr-open-code-limit* - *default-nthcdr-open-code-limit*)) - (give-up)) - - (labels ((frob (n) - (if (zerop n) - 'l - `(cdr ,(frob (1- n)))))) - (frob n)))) - - -;;;; ARITHMETIC and NUMEROLOGY. - -(def-source-transform plusp (x) `(> ,x 0)) -(def-source-transform minusp (x) `(< ,x 0)) -(def-source-transform zerop (x) `(= ,x 0)) - -(def-source-transform 1+ (x) `(+ ,x 1)) -(def-source-transform 1- (x) `(- ,x 1)) - -(def-source-transform oddp (x) `(not (zerop (logand ,x 1)))) -(def-source-transform evenp (x) `(zerop (logand ,x 1))) - -;;; Note that all the integer division functions are available for inline -;;; expansion. - -(macrolet ((frob (fun) - `(def-source-transform ,fun (x &optional (y nil y-p)) - (declare (ignore y)) - (if y-p - (values nil t) - `(,',fun ,x 1))))) - (frob truncate) - (frob round)) - -(def-source-transform lognand (x y) `(lognot (logand ,x ,y))) -(def-source-transform lognor (x y) `(lognot (logior ,x ,y))) -(def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y)) -(def-source-transform logandc2 (x y) `(logand ,x (lognot ,y))) -(def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y)) -(def-source-transform logorc2 (x y) `(logior ,x (lognot ,y))) -(def-source-transform logtest (x y) `(not (zerop (logand ,x ,y)))) -(def-source-transform logbitp (index integer) - `(not (zerop (logand (ash 1 ,index) ,integer)))) -(def-source-transform byte (size position) `(cons ,size ,position)) -(def-source-transform byte-size (spec) `(car ,spec)) -(def-source-transform byte-position (spec) `(cdr ,spec)) -(def-source-transform ldb-test (bytespec integer) - `(not (zerop (mask-field ,bytespec ,integer)))) - - -;;; With the ratio and complex accessors, we pick off the "identity" case, and -;;; use a primitive to handle the cell access case. -;;; -(def-source-transform numerator (num) - (once-only ((n-num `(the rational ,num))) - `(if (ratiop ,n-num) - (%numerator ,n-num) - ,n-num))) -;;; -(def-source-transform denominator (num) - (once-only ((n-num `(the rational ,num))) - `(if (ratiop ,n-num) - (%denominator ,n-num) - 1))) -;;; -(def-source-transform realpart (num) - (once-only ((n-num num)) - `(if (complexp ,n-num) - (%realpart ,n-num) - ,n-num))) -;;; -(def-source-transform imagpart (num) - (once-only ((n-num num)) - `(cond ((complexp ,n-num) - (%imagpart ,n-num)) - ((floatp ,n-num) - (float 0 ,n-num)) - (t - 0)))) - - -;;;; Numeric Derive-Type methods: - -;;; Derive-Integer-Type -- Internal -;;; -;;; Utility for defining derive-type methods of integer operations. If the -;;; types of both X and Y are integer types, then we compute a new integer type -;;; with bounds determined Fun when applied to X and Y. Otherwise, we use -;;; Numeric-Contagion. -;;; -(defun derive-integer-type (x y fun) - (declare (type continuation x y) (type function fun)) - (let ((x (continuation-type x)) - (y (continuation-type y))) - (if (and (numeric-type-p x) (numeric-type-p y) - (eq (numeric-type-class x) 'integer) - (eq (numeric-type-class y) 'integer) - (eq (numeric-type-complexp x) :real) - (eq (numeric-type-complexp y) :real)) - (multiple-value-bind (low high) - (funcall fun x y) - (make-numeric-type :class 'integer :complexp :real - :low low :high high)) - (numeric-contagion x y)))) - - -(defoptimizer (+ derive-type) ((x y)) - (derive-integer-type - x y - #'(lambda (x y) - (flet ((frob (x y) - (if (and x y) - (+ x y) - nil))) - (values (frob (numeric-type-low x) (numeric-type-low y)) - (frob (numeric-type-high x) (numeric-type-high y))))))) - -(defoptimizer (- derive-type) ((x y)) - (derive-integer-type - x y - #'(lambda (x y) - (flet ((frob (x y) - (if (and x y) - (- x y) - nil))) - (values (frob (numeric-type-low x) (numeric-type-high y)) - (frob (numeric-type-high x) (numeric-type-low y))))))) - -(defoptimizer (* derive-type) ((x y)) - (derive-integer-type - x y - #'(lambda (x y) - (let ((x-low (numeric-type-low x)) - (x-high (numeric-type-high x)) - (y-low (numeric-type-low y)) - (y-high (numeric-type-high y))) - (cond ((not (and x-low y-low)) - (values nil nil)) - ((or (minusp x-low) (minusp y-low)) - (if (and x-high y-high) - (let ((max (* (max (abs x-low) (abs x-high)) - (max (abs y-low) (abs y-high))))) - (values (- max) max)) - (values nil nil))) - (t - (values (* x-low y-low) - (if (and x-high y-high) - (* x-high y-high) - nil)))))))) - -(defoptimizer (/ derive-type) ((x y)) - (numeric-contagion (continuation-type x) (continuation-type y))) - - -(defoptimizer (ash derive-type) ((n shift)) - (or (let ((n-type (continuation-type n))) - (when (numeric-type-p n-type) - (let ((n-low (numeric-type-low n-type)) - (n-high (numeric-type-high n-type))) - (if (constant-continuation-p shift) - (let ((shift (continuation-value shift))) - (make-numeric-type :class 'integer :complexp :real - :low (when n-low - #+new-compiler - (ash n-low shift) - ;; ### fuckin' bignum bug. - #-new-compiler - (* n-low (ash 1 shift))) - :high (when n-high (ash n-high shift)))) - (let ((s-type (continuation-type shift))) - (when (numeric-type-p s-type) - (let ((s-low (numeric-type-low s-type)) - (s-high (numeric-type-high s-type))) - (if (and s-low s-high (<= s-low 32) (<= s-high 32)) - (make-numeric-type :class 'integer :complexp :real - :low (when n-low - (min (ash n-low s-high) - (ash n-low s-low))) - :high (when n-high - (max (ash n-high s-high) - (ash n-high s-low)))) - (make-numeric-type :class 'integer - :complexp :real))))))))) - *universal-type*)) - - -(macrolet ((frob (fun) - `#'(lambda (type type2) - (declare (ignore type2)) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (values (if hi (,fun hi) nil) (if lo (,fun lo) nil)))))) - - (defoptimizer (%negate derive-type) ((num)) - (derive-integer-type num num (frob -))) - - (defoptimizer (lognot derive-type) ((int)) - (derive-integer-type int int (frob lognot)))) - - -(defoptimizer (abs derive-type) ((num)) - (let ((type (continuation-type num))) - (if (and (numeric-type-p type) - (eq (numeric-type-class type) 'integer) - (eq (numeric-type-complexp type) :real)) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (make-numeric-type :class 'integer :complexp :real - :low (cond ((and hi (minusp hi)) - (abs hi)) - (lo - (max 0 lo)) - (t - 0)) - :high (if (and hi lo) - (max (abs hi) (abs lo)) - nil))) - (numeric-contagion type type)))) - - -(defoptimizer (truncate derive-type) ((number divisor)) - (let ((number-type (continuation-type number)) - (divisor-type (continuation-type divisor)) - (integer-type (specifier-type 'integer))) - (if (and (numeric-type-p number-type) - (csubtypep number-type integer-type) - (numeric-type-p divisor-type) - (csubtypep divisor-type integer-type)) - (let ((number-low (numeric-type-low number-type)) - (number-high (numeric-type-high number-type)) - (divisor-low (numeric-type-low divisor-type)) - (divisor-high (numeric-type-high divisor-type))) - (values-specifier-type - `(values ,(integer-truncate-derive-type number-low number-high - divisor-low divisor-high) - ,(integer-rem-derive-type number-low number-high - divisor-low divisor-high)))) - *universal-type*))) - -;;; NUMERIC-RANGE-INFO -- internal. -;;; -;;; Derive useful information about the range. Returns three values: -;;; - '+ if its positive, '- negative, or nil if it overlaps 0. -;;; - The abs of the minimal value (i.e. closest to 0) in the range. -;;; - The abs of the maximal value if there is one, or nil if it is unbounded. -;;; -(defun numeric-range-info (low high) - (cond ((and low (not (minusp low))) - (values '+ low high)) - ((and high (not (plusp high))) - (values '- (- high) (if low (- low) nil))) - (t - (values nil 0 (and low high (max (- low) high)))))) - -;;; INTEGER-TRUNCATE-DERIVE-TYPE -- internal -;;; -(defun integer-truncate-derive-type - (number-low number-high divisor-low divisor-high) - ;; The result cannot be larger in magnitude than the number, but the sign - ;; might change. If we can determine the sign of either the number or - ;; the divisor, we can eliminate some of the cases. - (multiple-value-bind - (number-sign number-min number-max) - (numeric-range-info number-low number-high) - (multiple-value-bind - (divisor-sign divisor-min divisor-max) - (numeric-range-info divisor-low divisor-high) - (when (and divisor-max (zerop divisor-max)) - ;; We've got a problem: guarenteed division by zero. - (return-from integer-truncate-derive-type t)) - (when (zerop divisor-min) - ;; We'll assume that they arn't going to divide by zero. - (incf divisor-min)) - (cond ((and number-sign divisor-sign) - ;; We know the sign of both. - (if (eq number-sign divisor-sign) - ;; Same sign, so the result will be positive. - `(integer ,(if divisor-max - (truncate number-min divisor-max) - 0) - ,(if number-max - (truncate number-max divisor-min) - '*)) - ;; Different signs, the result will be negative. - `(integer ,(if number-max - (- (truncate number-max divisor-min)) - '*) - ,(if divisor-max - (- (truncate number-min divisor-max)) - 0)))) - ((eq divisor-sign '+) - ;; The divisor is positive. Therefore, the number will just - ;; become closer to zero. - `(integer ,(if number-low - (truncate number-low divisor-min) - '*) - ,(if number-high - (truncate number-high divisor-min) - '*))) - ((eq divisor-sign '-) - ;; The divisor is negative. Therefore, the absolute value of - ;; the number will become closer to zero, but the sign will also - ;; change. - `(integer ,(if number-high - (- (truncate number-high divisor-min)) - '*) - ,(if number-low - (- (truncate number-low divisor-min)) - '*))) - ;; The divisor could be either positive or negative. - (number-max - ;; The number we are dividing has a bound. Divide that by the - ;; smallest posible divisor. - (let ((bound (truncate number-max divisor-min))) - `(integer ,(- bound) ,bound))) - (t - ;; The number we are dividing is unbounded, so we can't tell - ;; anything about the result. - 'integer))))) - -(defun integer-rem-derive-type - (number-low number-high divisor-low divisor-high) - (if (and divisor-low divisor-high) - ;; We know the range of the divisor, and the remainder must be smaller - ;; than the divisor. We can tell the sign of the remainer if we know - ;; the sign of the number. - (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high))))) - `(integer ,(if (or (null number-low) - (minusp number-low)) - (- divisor-max) - 0) - ,(if (or (null number-high) - (plusp number-high)) - divisor-max - 0))) - ;; The divisor is potentially either very positive or very negative. - ;; Therefore, the remainer is unbounded, but we might be able to tell - ;; something about the sign from the number. - `(integer ,(if (and number-low (not (minusp number-low))) - ;; The number we are dividing is positive. Therefore, - ;; the remainder must be positive. - 0 - '*) - ,(if (and number-high (not (plusp number-high))) - ;; The number we are dividing is negative. Therefore, - ;; the remainder must be negative. - 0 - '*)))) - -(defoptimizer (random derive-type) ((bound &optional state)) - (let ((type (continuation-type bound))) - (when (numeric-type-p type) - (let ((class (numeric-type-class type)) - (high (numeric-type-high type)) - (format (numeric-type-format type))) - (make-numeric-type - :class class - :format format - :low (coerce 0 (or format class 'real)) - :high (cond ((not high) nil) - ((eq class 'integer) (max (1- high) 0)) - ((or (consp high) (zerop high)) high) - (t `(,high)))))))) - - -;;;; Logical derive-type methods: - - -;;; Integer-Type-Length -- Internal -;;; -;;; Return the maximum number of bits an integer of the supplied type can take -;;; up, or NIL if it is unbounded. The second (third) value is T if the -;;; integer can be positive (negative) and NIL if not. Zero counts as -;;; positive. -;;; -(defun integer-type-length (type) - (if (numeric-type-p type) - (let ((min (numeric-type-low type)) - (max (numeric-type-high type))) - (values (and min max (max (integer-length min) (integer-length max))) - (or (null max) (not (minusp max))) - (or (null min) (minusp min)))) - (values nil t t))) - -(defoptimizer (logand derive-type) ((x y)) - (multiple-value-bind - (x-len x-pos x-neg) - (integer-type-length (continuation-type x)) - (declare (ignore x-pos)) - (multiple-value-bind - (y-len y-pos y-neg) - (integer-type-length (continuation-type y)) - (declare (ignore y-pos)) - (if (not x-neg) - ;; X must be positive. - (if (not y-neg) - ;; The must both be positive. - (cond ((or (null x-len) (null y-len)) - (specifier-type 'unsigned-byte)) - ((or (zerop x-len) (zerop y-len)) - (specifier-type '(integer 0 0))) - (t - (specifier-type `(unsigned-byte ,(min x-len y-len))))) - ;; X is positive, but Y might be negative. - (cond ((null x-len) - (specifier-type 'unsigned-byte)) - ((zerop x-len) - (specifier-type '(integer 0 0))) - (t - (specifier-type `(unsigned-byte ,x-len))))) - ;; X might be negative. - (if (not y-neg) - ;; Y must be positive. - (cond ((null y-len) - (specifier-type 'unsigned-byte)) - ((zerop y-len) - (specifier-type '(integer 0 0))) - (t - (specifier-type - `(unsigned-byte ,y-len)))) - ;; Either might be negative. - (if (and x-len y-len) - ;; The result is bounded. - (specifier-type `(signed-byte ,(1+ (max x-len y-len)))) - ;; We can't tell squat about the result. - (specifier-type 'integer))))))) - -(defoptimizer (logior derive-type) ((x y)) - (multiple-value-bind - (x-len x-pos x-neg) - (integer-type-length (continuation-type x)) - (multiple-value-bind - (y-len y-pos y-neg) - (integer-type-length (continuation-type y)) - (cond - ((and (not x-neg) (not y-neg)) - ;; Both are positive. - (specifier-type `(unsigned-byte ,(if (and x-len y-len) - (max x-len y-len) - '*)))) - ((not x-pos) - ;; X must be negative. - (if (not y-pos) - ;; Both are negative. The result is going to be negative and be - ;; the same length or shorter than the smaller. - (if (and x-len y-len) - ;; It's bounded. - (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1)) - ;; It's unbounded. - (specifier-type '(integer * -1))) - ;; X is negative, but we don't know about Y. The result will be - ;; negative, but no more negative than X. - (specifier-type - `(integer ,(or (numeric-type-low (continuation-type x)) '*) - -1)))) - (t - ;; X might be either positive or negative. - (if (not y-pos) - ;; But Y is negative. The result will be negative. - (specifier-type - `(integer ,(or (numeric-type-low (continuation-type y)) '*) - -1)) - ;; We don't know squat about either. It won't get any bigger. - (if (and x-len y-len) - ;; Bounded. - (specifier-type `(signed-byte ,(1+ (max x-len y-len)))) - ;; Unbounded. - (specifier-type 'integer)))))))) - -(defoptimizer (logxor derive-type) ((x y)) - (multiple-value-bind - (x-len x-pos x-neg) - (integer-type-length (continuation-type x)) - (multiple-value-bind - (y-len y-pos y-neg) - (integer-type-length (continuation-type y)) - (cond - ((or (and (not x-neg) (not y-neg)) - (and (not x-pos) (not y-pos))) - ;; Either both are negative or both are positive. The result will be - ;; positive, and as long as the longer. - (specifier-type `(unsigned-byte ,(if (and x-len y-len) - (max x-len y-len) - '*)))) - ((or (and (not x-pos) (not y-neg)) - (and (not y-neg) (not y-pos))) - ;; Either X is negative and Y is positive of vice-verca. The result - ;; will be negative. - (specifier-type `(integer ,(if (and x-len y-len) - (ash -1 (max x-len y-len)) - '*) - -1))) - ;; We can't tell what the sign of the result is going to be. All we - ;; know is that we don't create new bits. - ((and x-len y-len) - (specifier-type `(signed-byte ,(1+ (max x-len y-len))))) - (t - (specifier-type 'integer)))))) - - - -;;;; Miscellaneous derive-type methods: - - -(defoptimizer (code-char derive-type) ((code)) - (specifier-type 'base-char)) - - -(defoptimizer (values derive-type) ((&rest values)) - (values-specifier-type - `(values ,@(mapcar #'(lambda (x) - (type-specifier (continuation-type x))) - values)))) - - - -;;;; Byte operations: -;;; -;;; We try to turn byte operations into simple logical operations. First, -;;; we convert byte specifiers into separate size and position arguments passed -;;; to internal %FOO functions. We then attempt to transform the %FOO -;;; functions into boolean operations when the size and position are constant -;;; and the operands are fixnums. - - -;;; With-Byte-Specifier -- Internal -;;; -;;; Evaluate body with Size-Var and Pos-Var bound to expressions that -;;; evaluate to the Size and Position of the byte-specifier form Spec. We may -;;; wrap a let around the result of the body to bind some variables. -;;; -;;; If the spec is a Byte form, then bind the vars to the subforms. -;;; otherwise, evaluate Spec and use the Byte-Size and Byte-Position. The goal -;;; of this transformation is to avoid consing up byte specifiers and then -;;; immediately throwing them away. -;;; -(defmacro with-byte-specifier ((size-var pos-var spec) &body body) - (once-only ((spec `(macroexpand ,spec)) - (temp '(gensym))) - `(if (and (consp ,spec) - (eq (car ,spec) 'byte) - (= (length ,spec) 3)) - (let ((,size-var (second ,spec)) - (,pos-var (third ,spec))) - ,@body) - (let ((,size-var `(byte-size ,,temp)) - (,pos-var `(byte-position ,,temp))) - `(let ((,,temp ,,spec)) - ,,@body))))) - -(def-source-transform ldb (spec int) - (with-byte-specifier (size pos spec) - `(%ldb ,size ,pos ,int))) - -(def-source-transform dpb (newbyte spec int) - (with-byte-specifier (size pos spec) - `(%dpb ,newbyte ,size ,pos ,int))) - -(def-source-transform mask-field (spec int) - (with-byte-specifier (size pos spec) - `(%mask-field ,size ,pos ,int))) - -(def-source-transform deposit-field (newbyte spec int) - (with-byte-specifier (size pos spec) - `(%deposit-field ,newbyte ,size ,pos ,int))) - - -(defoptimizer (%ldb derive-type) ((size posn num)) - (let ((size (continuation-type size))) - (if (and (numeric-type-p size) - (csubtypep size (specifier-type 'integer))) - (let ((size-high (numeric-type-high size))) - (if (and size-high (<= size-high vm:word-bits)) - (specifier-type `(unsigned-byte ,size-high)) - (specifier-type 'unsigned-byte))) - *universal-type*))) - -(defoptimizer (%mask-field derive-type) ((size posn num)) - (let ((size (continuation-type size)) - (posn (continuation-type posn))) - (if (and (numeric-type-p size) - (csubtypep size (specifier-type 'integer)) - (numeric-type-p posn) - (csubtypep posn (specifier-type 'integer))) - (let ((size-high (numeric-type-high size)) - (posn-high (numeric-type-high posn))) - (if (and size-high posn-high - (<= (+ size-high posn-high) vm:word-bits)) - (specifier-type `(unsigned-byte ,(+ size-high posn-high))) - (specifier-type 'unsigned-byte))) - *universal-type*))) - -(defoptimizer (%dpb derive-type) ((newbyte size posn int)) - (let ((size (continuation-type size)) - (posn (continuation-type posn)) - (int (continuation-type int))) - (if (and (numeric-type-p size) - (csubtypep size (specifier-type 'integer)) - (numeric-type-p posn) - (csubtypep posn (specifier-type 'integer)) - (numeric-type-p int) - (csubtypep int (specifier-type 'integer))) - (let ((size-high (numeric-type-high size)) - (posn-high (numeric-type-high posn)) - (high (numeric-type-high int)) - (low (numeric-type-low int))) - (if (and size-high posn-high high low - (<= (+ size-high posn-high) vm:word-bits)) - (specifier-type - (list (if (minusp low) 'signed-byte 'unsigned-byte) - (max (integer-length high) - (integer-length low) - (+ size-high posn-high)))) - *universal-type*)) - *universal-type*))) - -(defoptimizer (%deposit-field derive-type) ((newbyte size posn int)) - (let ((size (continuation-type size)) - (posn (continuation-type posn)) - (int (continuation-type int))) - (if (and (numeric-type-p size) - (csubtypep size (specifier-type 'integer)) - (numeric-type-p posn) - (csubtypep posn (specifier-type 'integer)) - (numeric-type-p int) - (csubtypep int (specifier-type 'integer))) - (let ((size-high (numeric-type-high size)) - (posn-high (numeric-type-high posn)) - (high (numeric-type-high int)) - (low (numeric-type-low int))) - (if (and size-high posn-high high low - (<= (+ size-high posn-high) vm:word-bits)) - (specifier-type - (list (if (minusp low) 'signed-byte 'unsigned-byte) - (max (integer-length high) - (integer-length low) - (+ size-high posn-high)))) - *universal-type*)) - *universal-type*))) - - - -(deftransform %ldb ((size posn int) - (fixnum fixnum integer) - (unsigned-byte #.vm:word-bits)) - "convert to inline logical ops" - `(logand (ash int (- posn)) - (ash ,(1- (ash 1 vm:word-bits)) - (- size ,vm:word-bits)))) - -(deftransform %mask-field ((size posn int) - (fixnum fixnum integer) - (unsigned-byte #.vm:word-bits)) - "convert to inline logical ops" - `(logand int - (ash (ash ,(1- (ash 1 vm:word-bits)) - (- size ,vm:word-bits)) - posn))) - -;;; Note: for %dpb and %deposit-field, we can't use (or (signed-byte n) -;;; (unsigned-byte n)) as the result type, as that would allow result types -;;; that cover the range -2^(n-1) .. 1-2^n, instead of allowing result types -;;; of (unsigned-byte n) and result types of (signed-byte n). - -(deftransform %dpb ((new size posn int) - * - (unsigned-byte #.vm:word-bits)) - "convert to inline logical ops" - `(let ((mask (ldb (byte size 0) -1))) - (logior (ash (logand new mask) posn) - (logand int (lognot (ash mask posn)))))) - -(deftransform %dpb ((new size posn int) - * - (signed-byte #.vm:word-bits)) - "convert to inline logical ops" - `(let ((mask (ldb (byte size 0) -1))) - (logior (ash (logand new mask) posn) - (logand int (lognot (ash mask posn)))))) - -(deftransform %deposit-field ((new size posn int) - * - (unsigned-byte #.vm:word-bits)) - "convert to inline logical ops" - `(let ((mask (ash (ldb (byte size 0) -1) posn))) - (logior (logand new mask) - (logand int (lognot mask))))) - -(deftransform %deposit-field ((new size posn int) - * - (signed-byte #.vm:word-bits)) - "convert to inline logical ops" - `(let ((mask (ash (ldb (byte size 0) -1) posn))) - (logior (logand new mask) - (logand int (lognot mask))))) - - -;;; Miscellanous numeric transforms: - - -;;; COMMUTATIVE-ARG-SWAP -- Internal -;;; -;;; If a constant appears as the first arg, swap the args. -;;; -(deftransform commutative-arg-swap ((x y) * * :defun-only t :node node) - (if (and (constant-continuation-p x) - (not (constant-continuation-p y))) - `(,(continuation-function-name (basic-combination-fun node)) - y - ,(continuation-value x)) - (give-up))) - -(dolist (x '(= char= + * logior logand logxor)) - (%deftransform x '(function * *) #'commutative-arg-swap - "place constant arg last.")) - -;;; Handle the case of a constant boole-code. -;;; -(deftransform boole ((op x y)) - "convert to inline logical ops" - (unless (constant-continuation-p op) - (give-up "BOOLE code is not a constant.")) - (let ((control (continuation-value op))) - (case control - (#.boole-clr 0) - (#.boole-set -1) - (#.boole-1 'x) - (#.boole-2 'y) - (#.boole-c1 '(lognot x)) - (#.boole-c2 '(lognot y)) - (#.boole-and '(logand x y)) - (#.boole-ior '(logior x y)) - (#.boole-xor '(logxor x y)) - (#.boole-eqv '(logeqv x y)) - (#.boole-nand '(lognand x y)) - (#.boole-nor '(lognor x y)) - (#.boole-andc1 '(logandc1 x y)) - (#.boole-andc2 '(logandc2 x y)) - (#.boole-orc1 '(logorc1 x y)) - (#.boole-orc2 '(logorc2 x y)) - (t - (abort-transform "~S illegal control arg to BOOLE." control))))) - - -;;;; Convert multiply/divide to shifts. - -;;; If arg is a constant power of two, turn * into a shift. -;;; -(deftransform * ((x y) (integer integer)) - "convert x*2^k to shift" - (unless (constant-continuation-p y) (give-up)) - (let* ((y (continuation-value y)) - (y-abs (abs y)) - (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) (give-up)) - (if (minusp y) - `(- (ash x ,len)) - `(ash x ,len)))) - -;;; If both arguments and the result are (unsigned-byte 32), try to come up -;;; with a ``better'' multiplication using multiplier recoding. There are two -;;; different ways the multiplier can be recoded. The more obvious is to shift -;;; X by the correct amount for each bit set in Y and to sum the results. But -;;; if there is a string of bits that are all set, you can add X shifted by -;;; one more then the bit position of the first set bit and subtract X shifted -;;; by the bit position of the last set bit. We can't use this second method -;;; when the high order bit is bit 31 because shifting by 32 doesn't work -;;; too well. -;;; -(deftransform * ((x y) - ((unsigned-byte 32) (unsigned-byte 32)) - (unsigned-byte 32)) - "recode as shift and add" - (unless (constant-continuation-p y) - (give-up)) - (let ((y (continuation-value y)) - (result nil) - (first-one nil)) - (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x)) - (add (next-factor) - (setf result - (tub32 - (if result - `(+ ,result ,(tub32 next-factor)) - next-factor))))) - (declare (inline add)) - (dotimes (bitpos 32) - (if first-one - (when (not (logbitp bitpos y)) - (add (if (= (1+ first-one) bitpos) - ;; There is only a single bit in the string. - `(ash x ,first-one) - ;; There are at least two. - `(- ,(tub32 `(ash x ,bitpos)) - ,(tub32 `(ash x ,first-one))))) - (setf first-one nil)) - (when (logbitp bitpos y) - (setf first-one bitpos)))) - (when first-one - (cond ((= first-one 31)) - ((= first-one 30) - (add '(ash x 30))) - (t - (add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one)))))) - (add '(ash x 31)))) - (or result 0))) - -;;; If arg is a constant power of two, turn floor into a shift and mask. -;;; If ceiling, add in (1- (abs y)) and then do floor. -;;; -(flet ((frob (y ceil-p) - (unless (constant-continuation-p y) (give-up)) - (let* ((y (continuation-value y)) - (y-abs (abs y)) - (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) (give-up)) - (let ((shift (- len)) - (mask (1- y-abs))) - `(let ,(when ceil-p `((x (+ x ,(1- y-abs))))) - ,(if (minusp y) - `(values (ash (- x) ,shift) - (- (logand (- x) ,mask))) - `(values (ash x ,shift) - (logand x ,mask)))))))) - (deftransform floor ((x y) (integer integer)) - "convert division by 2^k to shift" - (frob y nil)) - (deftransform ceiling ((x y) (integer integer)) - "convert division by 2^k to shift" - (frob y t))) - - -;;; Do the same for mod. -;;; -(deftransform mod ((x y) (integer integer)) - "convert remainder mod 2^k to LOGAND" - (unless (constant-continuation-p y) (give-up)) - (let* ((y (continuation-value y)) - (y-abs (abs y)) - (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) (give-up)) - (let ((mask (1- y-abs))) - (if (minusp y) - `(- (logand (- x) ,mask)) - `(logand x ,mask))))) - - -;;; If arg is a constant power of two, turn truncate into a shift and mask. -;;; -(deftransform truncate ((x y) (integer integer)) - "convert division by 2^k to shift" - (unless (constant-continuation-p y) (give-up)) - (let* ((y (continuation-value y)) - (y-abs (abs y)) - (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) (give-up)) - (let* ((shift (- len)) - (mask (1- y-abs))) - `(if (minusp x) - (values ,(if (minusp y) - `(ash (- x) ,shift) - `(- (ash (- x) ,shift))) - (- (logand (- x) ,mask))) - (values ,(if (minusp y) - `(- (ash (- x) ,shift)) - `(ash x ,shift)) - (logand x ,mask)))))) - -;;; And the same for rem. -;;; -(deftransform rem ((x y) (integer integer)) - "convert remainder mod 2^k to LOGAND" - (unless (constant-continuation-p y) (give-up)) - (let* ((y (continuation-value y)) - (y-abs (abs y)) - (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) (give-up)) - (let ((mask (1- y-abs))) - `(if (minusp x) - (- (logand (- x) ,mask)) - (logand x ,mask))))) - - -;;;; Arithmetic and logical identity operation elimination: -;;; -;;; Flush calls to random arith functions that convert to the identity -;;; function or a constant. - - -(dolist (stuff '((ash 0 x) - (logand -1 x) - (logand 0 0) - (logior 0 x) - (logior -1 -1) - (logxor -1 (lognot x)) - (logxor 0 x))) - (destructuring-bind (name identity result) stuff - (deftransform name ((x y) `(* (constant-argument (member ,identity))) '* - :eval-name t) - "fold identity operations" - result))) - - -;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and -;;; (* 0 -4.0) is -0.0. -;;; -(deftransform - ((x y) ((constant-argument (member 0)) rational)) - "convert (- 0 x) to negate" - '(%negate y)) -;;; -(deftransform * ((x y) (rational (constant-argument (member 0)))) - "convert (* x 0) to 0." - 0) - - -;;; NOT-MORE-CONTAGIOUS -- Interface -;;; -;;; Return T if in an arithmetic op including continuations X and Y, the -;;; result type is not affected by the type of X. That is, Y is at least as -;;; contagious as X. -;;; -(defun not-more-contagious (x y) - (declare (type continuation x y)) - (let ((x (continuation-type x)) - (y (continuation-type y))) - (values (type= (numeric-contagion x y) - (numeric-contagion y y))))) - - -;;; Fold (OP x 0). -;;; -;;; If y is not constant, not zerop, or is contagious, then give up. -;;; -(dolist (stuff '((+ x) - (- x) - (expt 1))) - (destructuring-bind (name result) stuff - (deftransform name ((x y) '(t (constant-argument t)) '* :eval-name t) - "fold zero arg" - (let ((val (continuation-value y))) - (unless (and (zerop val) - (not (and (floatp val) (minusp (float-sign val)))) - (not-more-contagious y x)) - (give-up))) - result))) - -;;; Fold (OP x +/-1) -;;; -(dolist (stuff '((* x (%negate x)) - (/ x (%negate x)) - (expt x (/ 1 x)))) - (destructuring-bind (name result minus-result) stuff - (deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t) - "fold identity operations" - (let ((val (continuation-value y))) - (unless (and (= (abs val) 1) - (not-more-contagious y x)) - (give-up)) - (if (minusp val) minus-result result))))) - - -;;;; Character operations: - -(deftransform char-equal ((a b) (base-char base-char)) - "open code" - '(let* ((ac (char-code a)) - (bc (char-code b)) - (sum (logxor ac bc))) - (or (zerop sum) - (when (eql sum #x20) - (let ((sum (+ ac bc))) - (and (> sum 161) (< sum 213))))))) - -(deftransform char-upcase ((x) (base-char)) - "open code" - '(let ((n-code (char-code x))) - (if (and (> n-code #o140) ; Octal 141 is #\a. - (< n-code #o173)) ; Octal 172 is #\z. - (code-char (logxor #x20 n-code)) - x))) - -(deftransform char-downcase ((x) (base-char)) - "open code" - '(let ((n-code (char-code x))) - (if (and (> n-code 64) ; 65 is #\A. - (< n-code 91)) ; 90 is #\Z. - (code-char (logxor #x20 n-code)) - x))) - - -;;;; Equality predicate transforms: - - -;;; SAME-LEAF-REF-P -- Internal -;;; -;;; Return true if X and Y are continuations whose only use is a reference -;;; to the same leaf, and the value of the leaf cannot change. -;;; -(defun same-leaf-ref-p (x y) - (declare (type continuation x y)) - (let ((x-use (continuation-use x)) - (y-use (continuation-use y))) - (and (ref-p x-use) - (ref-p y-use) - (eq (ref-leaf x-use) (ref-leaf y-use)) - (constant-reference-p x-use)))) - - -;;; SIMPLE-EQUALITY-TRANSFORM -- Internal -;;; -;;; If X and Y are the same leaf, then the result is true. Otherwise, if -;;; there is no intersection between the types of the arguments, then the -;;; result is definitely false. -;;; -(deftransform simple-equality-transform ((x y) * * :defun-only t) - (cond ((same-leaf-ref-p x y) - 't) - ((not (types-intersect (continuation-type x) (continuation-type y))) - 'nil) - (t - (give-up)))) - -(dolist (x '(eq char= equal)) - (%deftransform x '(function * *) #'simple-equality-transform)) - - -;;; EQL IR1 Transform -- Internal -;;; -;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to convert -;;; to a type-specific predicate or EQ: -;;; -- If both args are characters, convert to CHAR=. This is better than just -;;; converting to EQ, since CHAR= may have special compilation strategies -;;; for non-standard representations, etc. -;;; -- If either arg is definitely not a number, then we can compare with EQ. -;;; -- Otherwise, we try to put the arg we know more about second. If X is -;;; constant then we put it second. If X is a subtype of Y, we put it -;;; second. These rules make it easier for the back end to match these -;;; interesting cases. -;;; -- If Y is a fixnum, then we quietly pass because the back end can handle -;;; that case, otherwise give an efficency note. -;;; -(deftransform eql ((x y)) - "convert to simpler equality predicate" - (let ((x-type (continuation-type x)) - (y-type (continuation-type y)) - (char-type (specifier-type 'character)) - (number-type (specifier-type 'number))) - (cond ((same-leaf-ref-p x y) - 't) - ((not (types-intersect x-type y-type)) - 'nil) - ((and (csubtypep x-type char-type) - (csubtypep y-type char-type)) - '(char= x y)) - ((or (not (types-intersect x-type number-type)) - (not (types-intersect y-type number-type))) - '(eq x y)) - ((and (not (constant-continuation-p y)) - (or (constant-continuation-p x) - (and (csubtypep x-type y-type) - (not (csubtypep y-type x-type))))) - '(eql y x)) - (t - (give-up))))) - - -;;; = IR1 Transform -- Internal -;;; -;;; Convert to EQL if both args are the "same" numeric type. This allows -;;; all of EQL's type-specific expertise to come into play. "Same" means -;;; either both rational or both floats of the same format. Complexp must also -;;; be specified and identical. -;;; -(deftransform = ((x y)) - "open code" - (let ((x-type (continuation-type x)) - (y-type (continuation-type y))) - (if (and (numeric-type-p x-type) (numeric-type-p y-type) - (let ((x-class (numeric-type-class x-type)) - (y-class (numeric-type-class y-type)) - (x-format (numeric-type-format x-type))) - (or (and (eq x-class 'float) (eq y-class 'float) - x-format - (eq x-format (numeric-type-format y-type))) - (and (member x-class '(rational integer)) - (member y-class '(rational integer))))) - (let ((x-complexp (numeric-type-complexp x-type))) - (and x-complexp - (eq x-complexp (numeric-type-complexp y-type))))) - '(eql x y) - (give-up "Operands might not be the same type.")))) - - -;;; Numeric-Type-Or-Lose -- Interface -;;; -;;; If Cont's type is a numeric type, then return the type, otherwise -;;; GIVE-UP. -;;; -(defun numeric-type-or-lose (cont) - (declare (type continuation cont)) - (let ((res (continuation-type cont))) - (unless (numeric-type-p res) (give-up)) - res)) - - -;;; IR1-TRANSFORM-< -- Internal -;;; -;;; See if we can statically determine (< X Y) using type information. If -;;; X's high bound is < Y's low, then X < Y. Similarly, if X's low is >= to -;;; Y's high, the X >= Y (so return NIL). If not, at least make sure any -;;; constant arg is second. -;;; -(defun ir1-transform-< (x y first second inverse) - (if (same-leaf-ref-p x y) - 'nil - (let* ((x-type (numeric-type-or-lose x)) - (x-lo (numeric-type-low x-type)) - (x-hi (numeric-type-high x-type)) - (y-type (numeric-type-or-lose y)) - (y-lo (numeric-type-low y-type)) - (y-hi (numeric-type-high y-type))) - (cond ((and x-hi y-lo (< x-hi y-lo)) - 't) - ((and y-hi x-lo (>= x-lo y-hi)) - 'nil) - ((and (constant-continuation-p first) - (not (constant-continuation-p second))) - `(,inverse y x)) - (t - (give-up)))))) - - -(deftransform < ((x y) (integer integer)) - (ir1-transform-< x y x y '>)) - -(deftransform > ((x y) (integer integer)) - (ir1-transform-< y x x y '<)) - - -;;;; Converting N-arg comparisons: -;;; -;;; We convert calls to N-arg comparison functions such as < into two-arg -;;; calls. This transformation is enabled for all such comparisons in this -;;; file. If any of these predicates are not open-coded, then the -;;; transformation should be removed at some point to avoid pessimization. - -;;; Multi-Compare -- Internal -;;; -;;; This function is used for source transformation of N-arg comparison -;;; functions other than inequality. We deal both with converting to two-arg -;;; calls and inverting the sense of the test, if necessary. If the call has -;;; two args, then we pass or return a negated test as appropriate. If it is a -;;; degenerate one-arg call, then we transform to code that returns true. -;;; Otherwise, we bind all the arguments and expand into a bunch of IFs. -;;; -(proclaim '(function multi-compare (symbol list boolean))) -(defun multi-compare (predicate args not-p) - (let ((nargs (length args))) - (cond ((< nargs 1) (values nil t)) - ((= nargs 1) `(progn ,@args t)) - ((= nargs 2) - (if not-p - `(if (,predicate ,(first args) ,(second args)) nil t) - (values nil t))) - (t - (do* ((i (1- nargs) (1- i)) - (last nil current) - (current (gensym) (gensym)) - (vars (list current) (cons current vars)) - (result 't (if not-p - `(if (,predicate ,current ,last) - nil ,result) - `(if (,predicate ,current ,last) - ,result nil)))) - ((zerop i) - `((lambda ,vars ,result) . ,args))))))) - - -(def-source-transform = (&rest args) (multi-compare '= args nil)) -(def-source-transform < (&rest args) (multi-compare '< args nil)) -(def-source-transform > (&rest args) (multi-compare '> args nil)) -(def-source-transform <= (&rest args) (multi-compare '> args t)) -(def-source-transform >= (&rest args) (multi-compare '< args t)) - -(def-source-transform char= (&rest args) (multi-compare 'char= args nil)) -(def-source-transform char< (&rest args) (multi-compare 'char< args nil)) -(def-source-transform char> (&rest args) (multi-compare 'char> args nil)) -(def-source-transform char<= (&rest args) (multi-compare 'char> args t)) -(def-source-transform char>= (&rest args) (multi-compare 'char< args t)) - -(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil)) -(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil)) -(def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil)) -(def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t)) -(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t)) - - -;;; Multi-Not-Equal -- Internal -;;; -;;; This function does source transformation of N-arg inequality functions -;;; such as /=. This is similar to Multi-Compare in the <3 arg cases. If -;;; there are more than two args, then we expand into the appropriate n^2 -;;; comparisons only when speed is important. -;;; -(proclaim '(function multi-not-equal (symbol list))) -(defun multi-not-equal (predicate args) - (let ((nargs (length args))) - (cond ((< nargs 1) (values nil t)) - ((= nargs 1) `(progn ,@args t)) - ((= nargs 2) - `(if (,predicate ,(first args) ,(second args)) nil t)) - ((not (policy nil (>= speed space) (>= speed cspeed))) - (values nil t)) - (t - (collect ((vars)) - (dotimes (i nargs) (vars (gensym))) - (do ((var (vars) next) - (next (cdr (vars)) (cdr next)) - (result 't)) - ((null next) - `((lambda ,(vars) ,result) . ,args)) - (let ((v1 (first var))) - (dolist (v2 next) - (setq result `(if (,predicate ,v1 ,v2) nil ,result)))))))))) - -(def-source-transform /= (&rest args) (multi-not-equal '= args)) -(def-source-transform char/= (&rest args) (multi-not-equal 'char= args)) -(def-source-transform char-not-equal (&rest args) (multi-not-equal 'char-equal args)) - - -;;; Expand Max and Min into the obvious comparisons. -(def-source-transform max (arg &rest more-args) - (if (null more-args) - `(values ,arg) - (once-only ((arg1 arg) - (arg2 `(max ,@more-args))) - `(if (> ,arg1 ,arg2) - ,arg1 ,arg2)))) -;;; -(def-source-transform min (arg &rest more-args) - (if (null more-args) - `(values ,arg) - (once-only ((arg1 arg) - (arg2 `(min ,@more-args))) - `(if (< ,arg1 ,arg2) - ,arg1 ,arg2)))) - - -;;;; Converting N-arg arithmetic functions: -;;; -;;; N-arg arithmetic and logic functions are associated into two-arg -;;; versions, and degenerate cases are flushed. - -;;; Associate-Arguments -- Internal -;;; -;;; Left-associate First-Arg and More-Args using Function. -;;; -(proclaim '(function associate-arguments (symbol t list) list)) -(defun associate-arguments (function first-arg more-args) - (let ((next (rest more-args)) - (arg (first more-args))) - (if (null next) - `(,function ,first-arg ,arg) - (associate-arguments function `(,function ,first-arg ,arg) next)))) - -;;; Source-Transform-Transitive -- Internal -;;; -;;; Do source transformations for transitive functions such as +. One-arg -;;; cases are replaced with the arg and zero arg cases with the identity. If -;;; Leaf-Fun is true, then replace two-arg calls with a call to that function. -;;; -(defun source-transform-transitive (fun args identity &optional leaf-fun) - (declare (symbol fun leaf-fun) (list args)) - (case (length args) - (0 identity) - (1 `(values ,(first args))) - (2 (if leaf-fun - `(,leaf-fun ,(first args) ,(second args)) - (values nil t))) - (t - (associate-arguments fun (first args) (rest args))))) - -(def-source-transform + (&rest args) (source-transform-transitive '+ args 0)) -(def-source-transform * (&rest args) (source-transform-transitive '* args 1)) -(def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0)) -(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0)) -(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1)) - -(def-source-transform logeqv (&rest args) - (if (evenp (length args)) - `(lognot (logxor ,@args)) - `(logxor ,@args))) - -;;; Note: we can't use source-transform-transitive for GCD and LCM because when -;;; they are given one argument, they return it's absolute value. - -(def-source-transform gcd (&rest args) - (case (length args) - (0 0) - (1 `(abs (the integer ,(first args)))) - (2 (values nil t)) - (t (associate-arguments 'gcd (first args) (rest args))))) - -(def-source-transform lcm (&rest args) - (case (length args) - (0 1) - (1 `(abs (the integer ,(first args)))) - (2 (values nil t)) - (t (associate-arguments 'lcm (first args) (rest args))))) - - -;;; Source-Transform-Intransitive -- Internal -;;; -;;; Do source transformations for intransitive n-arg functions such as /. -;;; With one arg, we form the inverse. With two args we pass. Otherwise we -;;; associate into two-arg calls. -;;; -(proclaim '(function source-transform-intransitive (symbol list t) list)) -(defun source-transform-intransitive (function args inverse) - (case (length args) - ((0 2) (values nil t)) - (1 `(,@inverse ,(first args))) - (t - (associate-arguments function (first args) (rest args))))) - -(def-source-transform - (&rest args) - (source-transform-intransitive '- args '(%negate))) -(def-source-transform / (&rest args) - (source-transform-intransitive '/ args '(/ 1))) - - -;;;; Apply: -;;; -;;; We convert Apply into Multiple-Value-Call so that the compiler only -;;; needs to understand one kind of variable-argument call. It is more -;;; efficient to convert Apply to MV-Call than MV-Call to Apply. - -(def-source-transform apply (fun arg &rest more-args) - (let ((args (cons arg more-args))) - `(multiple-value-call ,fun - ,@(mapcar #'(lambda (x) - `(values ,x)) - (butlast args)) - (values-list ,(car (last args)))))) - - -;;;; FORMAT transform: - -;;; A transform for FORMAT, based on the original (courtesy of Skef.) -;;; -(deftransform format ((stream control &rest args) - ((or (member t) stream) simple-string &rest t)) - "convert to output primitives" - (unless (constant-continuation-p control) - (give-up "Control string is not a constant.")) - (let* ((control (continuation-value control)) - (end (length control)) - (penultimus (1- end)) - (stream-form (if (csubtypep (continuation-type stream) - (specifier-type 'stream)) - `(stream) - ())) - (arg-vars (mapcar #'(lambda (x) - (declare (ignore x)) - (gensym)) - args)) - (args arg-vars) - (index 0)) - (declare (simple-string control)) - (collect ((forms)) - (loop - (let ((command-index (position #\~ control :start index))) - (unless command-index - ;; Write out the final part of the string. - (forms `(write-string ,(subseq control index end) - ,@stream-form)) - (when args - (compiler-warning "~R extra format argument~:P. Ignoring..." - (length args)) - (forms `(progn ,@args))) - - (return `(lambda (stream control ,@arg-vars) - (declare (ignorable stream control)) - ,@(forms) - nil))) - - (when (= command-index penultimus) - (abort-transform "FORMAT control string ends in a ~~: ~S" - control)) - - ;; Non-command stuff gets write-string'ed out. - (when (/= index command-index) - (forms `(write-string - ,(subseq control index command-index) - ,@stream-form))) - - ;; Get the format directive. - (flet ((next-arg () - (unless args - (abort-transform "Missing FORMAT argument.")) - (pop args))) - (forms - (case (schar control (1+ command-index)) - ((#\b #\B) `(let ((*print-base* 2)) - (princ ,(next-arg) ,@stream-form))) - ((#\o #\O) `(let ((*print-base* 8)) - (princ ,(next-arg) ,@stream-form))) - ((#\d #\D) `(let ((*print-base* 10)) - (princ ,(next-arg) ,@stream-form))) - ((#\x #\X) `(let ((*print-base* 16)) - (princ ,(next-arg) ,@stream-form))) - ((#\a #\A) `(princ ,(next-arg) ,@stream-form)) - ((#\s #\S) `(prin1 ,(next-arg) ,@stream-form)) - (#\% `(terpri ,@stream-form)) - (#\& `(fresh-line ,@stream-form)) - (#\| `(write-char #\form ,@stream-form)) - (#\~ `(write-char #\~ ,@stream-form)) - (#\newline - (let ((new-pos (position-if-not - #'lisp::whitespace-char-p - control - :start (+ command-index 2)))) - (if new-pos - (setq command-index (- new-pos 2))))) - (t - (give-up))))) - - (setq index (+ command-index 2))))))) diff --git a/compiler/sset.lisp b/compiler/sset.lisp deleted file mode 100644 index fb9bc00d2c2fbf5b09c61b08d4a07ec3b0358ca3..0000000000000000000000000000000000000000 --- a/compiler/sset.lisp +++ /dev/null @@ -1,300 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/sset.lisp,v 1.4 1991/02/20 14:59:48 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; A sparse set abstraction, implemented as a sorted linked list. We don't -;;; use bit-vectors to represent sets in flow analysis, since the universe may -;;; be quite large but the average number of elements is small. We keep the -;;; list sorted so that we can do union and intersection in linear time. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -;;; -;;; Each structure that may be placed in a SSet must include the SSet-Element -;;; structure. We allow an initial value of NIL to mean that no ordering has -;;; been assigned yet (although an ordering must be assigned before doing set -;;; operations.) -;;; -(defstruct sset-element - (number nil :type (or index null))) - - -(defstruct (sset (:constructor make-sset ()) - (:copier nil) - (:print-function %print-sset)) - (elements (list nil) :type list)) - - -(defprinter sset - (elements :prin1 (cdr elements))) - - -;;; Do-Elements -- Interface -;;; -;;; Iterate over the elements in Set, binding Var to each element in turn. -;;; -(defmacro do-elements ((var set &optional result) &body body) - `(dolist (,var (cdr (sset-elements ,set)) ,result) ,@body)) - - -;;; SSet-Adjoin -- Interface -;;; -;;; Destructively add Element to Set. If Element was not in the set, then -;;; we return true, otherwise we return false. -;;; -(proclaim '(function sset-adjoin (sset-element sset) boolean)) -(defun sset-adjoin (element set) - (let ((number (sset-element-number element)) - (elements (sset-elements set))) - (do ((prev elements current) - (current (cdr elements) (cdr current))) - ((null current) - (setf (cdr prev) (list element)) - t) - (let ((el (car current))) - (when (>= (sset-element-number el) number) - (when (eq el element) - (return nil)) - (setf (cdr prev) (cons element current)) - (return t)))))) - - -;;; SSet-Delete -- Interface -;;; -;;; Destructively remove Element from Set. If element was in the set, -;;; then return true, otherwise return false. -;;; -(proclaim '(function sset-delete (sset-element sset) boolean)) -(defun sset-delete (element set) - (let ((elements (sset-elements set))) - (do ((prev elements current) - (current (cdr elements) (cdr current))) - ((null current) nil) - (when (eq (car current) element) - (setf (cdr prev) (cdr current)) - (return t))))) - - -;;; SSet-Member -- Interface -;;; -;;; Return true if Element is in Set, false otherwise. -;;; -(proclaim '(function sset-member (sset-element sset) boolean)) -(defun sset-member (element set) - (declare (inline member)) - (not (null (member element (cdr (sset-elements set)) :test #'eq)))) - - -;;; SSet-Empty -- Interface -;;; -;;; Return true if Set contains no elements, false otherwise. -;;; -(proclaim '(function sset-empty (sset) boolean)) -(defun sset-empty (set) - (null (cdr (sset-elements set)))) - - -;;; SSet-Singleton -- Interface -;;; -;;; If Set contains exactly one element, then return it, otherwise return -;;; NIL. -;;; -(proclaim '(function sset-singleton (sset) (or sset-element null))) -(defun sset-singleton (set) - (let ((elements (cdr (sset-elements set)))) - (if (and elements (not (cdr elements))) - (car elements) - nil))) - - -;;; SSet-Subsetp -- Interface -;;; -;;; If Set1 is a (not necessarily proper) subset of Set2, then return true, -;;; otherwise return false. -;;; -(proclaim '(function sset-subsetp (sset sset) boolean)) -(defun sset-subsetp (set1 set2) - (let ((el2 (cdr (sset-elements set2)))) - (do ((el1 (cdr (sset-elements set1)) (cdr el1))) - ((null el1) t) - (let ((num1 (sset-element-number (car el1)))) - (loop - (when (null el2) (return-from sset-subsetp nil)) - (let ((num2 (sset-element-number (pop el2)))) - (when (>= num2 num1) - (when (> num2 num1) (return-from sset-subsetp nil)) - (return)))))))) - - -;;; SSet-Equal -- Interface -;;; -;;; Return true if Set1 and Set2 contain the same elements, false otherwise. -;;; -(proclaim '(function sset-equal (sset sset) boolean)) -(defun sset-equal (set1 set2) - (do ((el1 (cdr (sset-elements set1)) (cdr el1)) - (el2 (cdr (sset-elements set2)) (cdr el2))) - (()) - (when (null el1) (return (null el2))) - (when (null el2) (return nil)) - (unless (eq (car el1) (car el2)) (return nil)))) - - -;;; Copy-SSet -- Interface -;;; -;;; Return a new copy of Set. -;;; -(proclaim '(function copy-sset (sset) sset)) -(defun copy-sset (set) - (let ((res (make-sset))) - (setf (sset-elements res) (copy-list (sset-elements set))) - res)) - - -;;; SSet-Union, SSet-Intersection, SSet-Difference -- Interface -;;; -;;; Perform the appropriate set operation on Set1 and Set2 by destructively -;;; modifying Set1. We return true if Set1 was modified, false otherwise. -;;; -(proclaim '(ftype (function (sset sset) boolean) sset-union sset-intersection - sset-difference)) -(defun sset-union (set1 set2) - (let* ((prev-el1 (sset-elements set1)) - (el1 (cdr prev-el1)) - (changed nil)) - (do ((el2 (cdr (sset-elements set2)) (cdr el2))) - ((null el2) changed) - (let* ((e (car el2)) - (num2 (sset-element-number e))) - (loop - (when (null el1) - (setf (cdr prev-el1) (copy-list el2)) - (return-from sset-union t)) - (let ((num1 (sset-element-number (car el1)))) - (when (>= num1 num2) - (if (> num1 num2) - (let ((new (cons e el1))) - (setf (cdr prev-el1) new) - (setq prev-el1 new changed t)) - (shiftf prev-el1 el1 (cdr el1))) - (return)) - (shiftf prev-el1 el1 (cdr el1)))))))) -;;; -(defun sset-intersection (set1 set2) - (let* ((prev-el1 (sset-elements set1)) - (el1 (cdr prev-el1)) - (changed nil)) - (do ((el2 (cdr (sset-elements set2)) (cdr el2))) - ((null el2) - (cond (el1 - (setf (cdr prev-el1) nil) - t) - (t changed))) - (let ((num2 (sset-element-number (car el2)))) - (loop - (when (null el1) - (return-from sset-intersection changed)) - (let ((num1 (sset-element-number (car el1)))) - (when (>= num1 num2) - (when (= num1 num2) - (shiftf prev-el1 el1 (cdr el1))) - (return)) - (pop el1) - (setf (cdr prev-el1) el1) - (setq changed t))))))) -;;; -(defun sset-difference (set1 set2) - (let* ((prev-el1 (sset-elements set1)) - (el1 (cdr prev-el1)) - (changed nil)) - (do ((el2 (cdr (sset-elements set2)) (cdr el2))) - ((null el2) changed) - (let ((num2 (sset-element-number (car el2)))) - (loop - (when (null el1) - (return-from sset-difference changed)) - (let ((num1 (sset-element-number (car el1)))) - (when (>= num1 num2) - (when (= num1 num2) - (pop el1) - (setf (cdr prev-el1) el1) - (setq changed t)) - (return)) - (shiftf prev-el1 el1 (cdr el1)))))))) - - -;;; SSet-Union-Of-Difference -- Interface -;;; -;;; Destructively modify Set1 to include its union with the difference of -;;; Set2 and Set3. We return true if Set1 was modified, false otherwise. -;;; -(proclaim '(function sset-union-of-difference (sset sset sset) boolean)) -(defun sset-union-of-difference (set1 set2 set3) - (let* ((prev-el1 (sset-elements set1)) - (el1 (cdr prev-el1)) - (el3 (cdr (sset-elements set3))) - (changed nil)) - (do ((el2 (cdr (sset-elements set2)) (cdr el2))) - ((null el2) changed) - (let* ((e (car el2)) - (num2 (sset-element-number e))) - (loop - (when (null el3) - (loop - (when (null el1) - (setf (cdr prev-el1) (copy-list el2)) - (return-from sset-union-of-difference t)) - (let ((num1 (sset-element-number (car el1)))) - (when (>= num1 num2) - (if (> num1 num2) - (let ((new (cons e el1))) - (setf (cdr prev-el1) new) - (setq prev-el1 new changed t)) - (shiftf prev-el1 el1 (cdr el1))) - (return)) - (shiftf prev-el1 el1 (cdr el1)))) - (return)) - (let ((num3 (sset-element-number (car el3)))) - (when (<= num2 num3) - (unless (= num2 num3) - (loop - (when (null el1) - (do ((el2 el2 (cdr el2))) - ((null el2) - (return-from sset-union-of-difference changed)) - (let* ((e (car el2)) - (num2 (sset-element-number e))) - (loop - (when (null el3) - (setf (cdr prev-el1) (copy-list el2)) - (return-from sset-union-of-difference t)) - (setq num3 (sset-element-number (car el3))) - (when (<= num2 num3) - (unless (= num2 num3) - (let ((new (cons e el1))) - (setf (cdr prev-el1) new) - (setq prev-el1 new changed t))) - (return)) - (pop el3))))) - (let ((num1 (sset-element-number (car el1)))) - (when (>= num1 num2) - (if (> num1 num2) - (let ((new (cons e el1))) - (setf (cdr prev-el1) new) - (setq prev-el1 new changed t)) - (shiftf prev-el1 el1 (cdr el1))) - (return)) - (shiftf prev-el1 el1 (cdr el1))))) - (return))) - (pop el3)))))) diff --git a/compiler/stack.lisp b/compiler/stack.lisp deleted file mode 100644 index b3a0b52d32ae97d740b7402d6d6244e4fef3e827..0000000000000000000000000000000000000000 --- a/compiler/stack.lisp +++ /dev/null @@ -1,259 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/stack.lisp,v 1.5 1991/05/08 01:15:34 ram Exp $") -;;; -;;; ********************************************************************** -;;; -;;; The stack analysis phase in the compiler. We do a graph walk to -;;; determine which unknown-values continuations are on the stack at each point -;;; in the program, and then we insert cleanup code to pop off unused values. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - - -;;; Find-Pushed-Continuations -- Internal -;;; -;;; Scan through Block looking for uses of :Unknown continuations that have -;;; their Dest outside of the block. We do some checking to verify the -;;; invariant that all pushes come after the last pop. -;;; -(defun find-pushed-continuations (block) - (let* ((2block (block-info block)) - (popped (ir2-block-popped 2block)) - (last-pop (if popped - (continuation-dest (car (last popped))) - nil))) - (collect ((pushed)) - (let ((saw-last nil)) - (do-nodes (node cont block) - (when (eq node last-pop) - (setq saw-last t)) - - (let ((dest (continuation-dest cont)) - (2cont (continuation-info cont))) - (when (and dest - (not (eq (node-block dest) block)) - 2cont - (eq (ir2-continuation-kind 2cont) :unknown)) - (assert (or saw-last (not last-pop))) - (pushed cont))))) - - (setf (ir2-block-pushed 2block) (pushed)))) - (undefined-value)) - - -;;;; Annotation graph walk: - -;;; Stack-Simulation-Walk -- Internal -;;; -;;; Do a backward walk in the flow graph simulating the run-time stack of -;;; unknown-values continuations and annotating the blocks with the result. -;;; -;;; Block is the block that is currently being walked and Stack is the stack -;;; of unknown-values continuations in effect immediately after block. We -;;; simulate the stack by popping off the unknown-values generated by this -;;; block (if any) and pushing the continuations for values received by this -;;; block. (The role of push and pop are interchanged because we are doing a -;;; backward walk.) -;;; -;;; If we run into a values generator whose continuation isn't on stack top, -;;; then the receiver hasn't yet been reached on any walk to this use. In this -;;; case, we ignore the push for now, counting on Annotate-Dead-Values to clean -;;; it up if we discover that it isn't reachable at all. -;;; -;;; If our final stack isn't empty, then we walk all the predecessor blocks -;;; that don't have all the continuations that we have on our Start-Stack on -;;; their End-Stack. This is our termination condition for the graph walk. We -;;; put the test around the recursive call so that the initial call to this -;;; function will do something even though there isn't initially anything on -;;; the stack. -;;; -;;; We can use the tailp test, since the only time we want to bottom out -;;; with a non-empty stack is when we intersect with another path from the same -;;; top-level call to this function that has more values receivers on that -;;; path. When we bottom out in this way, we are counting on -;;; DISCARD-UNUSED-VALUES doing its thing. -;;; -;;; When we do recurse, we check that predecessor's END-STACK is a -;;; subsequence of our START-STACK. There may be extra stuff on the top -;;; of our stack because the last path to the predecessor may have discarded -;;; some values that we use. There may be extra stuff on the bottom of our -;;; stack because this walk may be from a values receiver whose lifetime -;;; encloses that of the previous walk. -;;; -;;; If a predecessor block is the component head, then it must be the case -;;; that this is a NLX entry stub. If so, we just stop our walk, since the -;;; stack at the exit point doesn't have anything to do with our stack. -;;; -(defun stack-simulation-walk (block stack) - (declare (type cblock block) (list stack)) - (let ((2block (block-info block))) - (setf (ir2-block-end-stack 2block) stack) - (let ((new-stack stack)) - (dolist (push (reverse (ir2-block-pushed 2block))) - (if (eq (car new-stack) push) - (pop new-stack) - (assert (not (member push new-stack))))) - - (dolist (pop (reverse (ir2-block-popped 2block))) - (push pop new-stack)) - - (setf (ir2-block-start-stack 2block) new-stack) - - (when new-stack - (dolist (pred (block-pred block)) - (if (eq pred (component-head (block-component block))) - (assert (find block - (environment-nlx-info (block-environment block)) - :key #'nlx-info-target)) - (let ((pred-stack (ir2-block-end-stack (block-info pred)))) - (unless (tailp new-stack pred-stack) - (assert (search pred-stack new-stack)) - (stack-simulation-walk pred new-stack)))))))) - - (undefined-value)) - - -;;; Annotate-Dead-Values -- Internal -;;; -;;; Do stack annotation for any values generators in Block that were -;;; unreached by all walks (i.e. the continuation isn't live at the point that -;;; it is generated.) This will only happen when the values receiver cannot be -;;; reached from this particular generator (due to an unconditional control -;;; transfer.) -;;; -;;; What we do is push on the End-Stack all continuations in Pushed that -;;; aren't already present in the End-Stack. When we find any pushed -;;; continuation that isn't live, it must be the case that all continuations -;;; pushed after (on top of) it aren't live. -;;; -;;; If we see a pushed continuation that is the CONT of a tail call, then we -;;; ignore it, since the tail call didn't actually push anything. The tail -;;; call must always the last in the block. -;;; -(defun annotate-dead-values (block) - (declare (type cblock block)) - (let* ((2block (block-info block)) - (stack (ir2-block-end-stack 2block)) - (last (block-last block)) - (tailp-cont (if (node-tail-p last) (node-cont last)))) - (do ((pushes (ir2-block-pushed 2block) (rest pushes)) - (popping nil)) - ((null pushes)) - (let ((push (first pushes))) - (cond ((member push stack) - (assert (not popping))) - ((eq push tailp-cont) - (assert (null (rest pushes)))) - (t - (push push (ir2-block-end-stack 2block)) - (setq popping t)))))) - - (undefined-value)) - - -;;; Discard-Unused-Values -- Internal -;;; -;;; Called when we discover that the stack-top unknown-values continuation -;;; at the end of Block1 is different from that at the start of Block2 (its -;;; successor.) -;;; -;;; We insert a call to a funny function in a new cleanup block introduced -;;; between Block1 and Block2. Since control analysis and LTN have already -;;; run, we must do make an IR2 block, then do ADD-TO-EMIT-ORDER and -;;; LTN-ANALYZE-BLOCK on the new block. The new block is inserted after Block1 -;;; in the emit order. -;;; -;;; If the control transfer between Block1 and Block2 represents a -;;; tail-recursive return (:Deleted IR2-continuation) or a non-local exit, then -;;; the cleanup code will never actually be executed. It doesn't seem to be -;;; worth the risk of trying to optimize this, since this rarely happens and -;;; wastes only space. -;;; -(defun discard-unused-values (block1 block2) - (declare (type cblock block1 block2)) - (let* ((block1-stack (ir2-block-end-stack (block-info block1))) - (block2-stack (ir2-block-start-stack (block-info block2))) - (last-popped (elt block1-stack - (- (length block1-stack) - (length block2-stack) - 1)))) - (assert (tailp block2-stack block1-stack)) - - (let* ((block (insert-cleanup-code block1 block2 - (continuation-next (block-start block2)) - `(%pop-values ',last-popped))) - (2block (make-ir2-block block))) - (setf (block-info block) 2block) - (add-to-emit-order 2block (block-info block1)) - (ltn-analyze-block block))) - - (undefined-value)) - - -;;;; Stack analyze: - - -;;; FIND-VALUES-GENERATORS -- Internal -;;; -;;; Return a list of all the blocks containing genuine uses of one of the -;;; Receivers. Exits are excluded, since they don't drop through to the -;;; receiver. -;;; -(defun find-values-generators (receivers) - (declare (list receivers)) - (collect ((res nil adjoin)) - (dolist (rec receivers) - (dolist (pop (ir2-block-popped (block-info rec))) - (do-uses (use pop) - (unless (exit-p use) - (res (node-block use)))))) - (res))) - - -;;; Stack-Analyze -- Interface -;;; -;;; Analyze the use of unknown-values continuations in Component, inserting -;;; cleanup code to discard values that are generated but never received. This -;;; phase doesn't need to be run when Values-Receivers is null, i.e. there are -;;; no unknown-values continuations used across block boundaries. -;;; -;;; Do the backward graph walk, starting at each values receiver. We ignore -;;; receivers that already have a non-null Start-Stack. These are nested -;;; values receivers that have already been reached on another walk. We don't -;;; want to clobber that result with our null initial stack. -;;; -(defun stack-analyze (component) - (declare (type component component)) - (let* ((2comp (component-info component)) - (receivers (ir2-component-values-receivers 2comp)) - (generators (find-values-generators receivers))) - - (dolist (block generators) - (find-pushed-continuations block)) - - (dolist (block receivers) - (unless (ir2-block-start-stack (block-info block)) - (stack-simulation-walk block ()))) - - (dolist (block generators) - (annotate-dead-values block)) - - (do-blocks (block component) - (let ((top (car (ir2-block-end-stack (block-info block))))) - (dolist (succ (block-succ block)) - (when (and (block-start succ) - (not (eq (car (ir2-block-start-stack (block-info succ))) - top))) - (discard-unused-values block succ)))))) - - (undefined-value)) diff --git a/compiler/statcount.lisp b/compiler/statcount.lisp deleted file mode 100644 index 0fa9f3597b0a8581d5af99641332bab0a0d81dab..0000000000000000000000000000000000000000 --- a/compiler/statcount.lisp +++ /dev/null @@ -1,166 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/statcount.lisp,v 1.5 1992/08/04 08:22:44 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/statcount.lisp,v 1.5 1992/08/04 08:22:44 wlott Exp $ -;;; -;;; Functions and utilities for collecting statistics on static vop usages. -;;; -;;; Written by William Lott -;;; -(in-package "C") - -(export '(*count-vop-usages*)) - - - -;;;; Vop counting utilities - -;;; T if we should count the number of times we use each vop and the number -;;; of instructions that come from each. -;;; -(defvar *count-vop-usages* nil) - -;;; Hash table containing all the current counts. The key is the name of the -;;; vop, and the value is a 3 element simple-vector. The elements are: -;;; 0 - the name of the vop. -;;; 1 - the number of times this vop was emitted. -;;; 2 - the number of normal instructions emitted due to this vop. -;;; 3 - the number of elsewhere instructions emitted due to this vop. -;;; -(defvar *vop-counts* (make-hash-table :test #'eq)) - -;;; COUNT-VOPS -- internal interface. -;;; -;;; COUNT-VOPS is called by COMPILE-COMPONENT to count the vop usages in -;;; component. -;;; -(defun count-vops (component) - (declare (ignore component)) - (error "Vop counting not implemented for the new assembler.") - #+nil - (flet ((vop-entry (vop) - (let* ((name (vop-info-name (vop-info vop))) - (entry (gethash name *vop-counts*))) - (the (simple-vector 4) - (or entry - (let ((new (make-array 4 :initial-element 0))) - (setf (svref new 0) name) - (setf (gethash name *vop-counts*) new) - new)))))) - (do-ir2-blocks (block component) - (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop)) - (incf (svref (vop-entry vop) 1)))) - (assem:count-instructions - #'(lambda (vop count elsewherep) - (incf (svref (vop-entry vop) - (if elsewherep 3 2)) - count)) - *code-segment* - *elsewhere* - :size)) - (undefined-value)) - - -;;;; Stuff for using the statistics. - -;;; Clear-Vop-Counts -- interface -;;; -(defun clear-vop-counts () - (clrhash *vop-counts*) - nil) - -;;; Report-Vop-Counts -- interface -;;; -(defun report-vop-counts (&key (cut-off 15) (sort-by :size)) - (declare (type (or null unsigned-byte) cut-off) - (type (member :size :count :name) sort-by)) - (let ((results nil) - (total-count 0) - (total-size 0) - (w/o-elsewhere-size 0)) - (maphash #'(lambda (key value) - (declare (ignore key)) - (push value results) - (incf total-count (svref value 1)) - (incf total-size (+ (svref value 2) (svref value 3))) - (incf w/o-elsewhere-size (svref value 2))) - *vop-counts*) - (format t "~18<Vop ~> ~17:@<Count~> ~17:@<Bytes~> ~ - ~17:@<W/o elsewhere~> Ave Sz~%") - (let ((total-count (coerce total-count 'double-float)) - (total-size (coerce total-size 'double-float)) - (w/o-elsewhere-size (coerce w/o-elsewhere-size 'double-float))) - (dolist (info (sort results - (ecase sort-by - (:name #'(lambda (name-1 name-2) - (string< (symbol-name name-1) - (symbol-name name-2)))) - ((:count :size) #'>)) - :key (ecase sort-by - (:name #'(lambda (x) (svref x 0))) - (:count #'(lambda (x) (svref x 1))) - (:size #'(lambda (x) - (+ (svref x 2) - (svref x 3))))))) - (when cut-off - (if (zerop cut-off) - (return) - (decf cut-off))) - (let* ((name (symbol-name (svref info 0))) - (name-len (length name)) - (count (svref info 1)) - (count-len (truncate (truncate (rational (log count 10))) 3/4)) - (w/o-elsewhere (svref info 2)) - (size (+ w/o-elsewhere (svref info 3)))) - (if (> (+ name-len count-len) 24) - (format t "~A:~%~18T~9:D" name count) - (format t "~VT~A:~VT~:D" - (max (- 18 name-len) 0) - name - (- 26 count-len) - count)) - (format t " (~4,1,2F%) ~9:D (~4,1,2F%) ~9:D (~4,1,2F%) ~3D ~3D~%" - (/ (coerce count 'double-float) total-count) - size - (/ (coerce size 'double-float) total-size) - w/o-elsewhere - (/ (coerce w/o-elsewhere 'double-float) w/o-elsewhere-size) - (round size count) - (round w/o-elsewhere count)))))) - (values)) - -(defun save-vop-counts (filename) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (maphash #'(lambda (key value) - (declare (ignore key)) - (prin1 value stream) - (terpri stream)) - *vop-counts*))) - -(defun augment-vop-counts (filename) - (with-open-file (stream filename) - (loop - (let ((stuff (read stream nil :eof))) - (when (eq stuff :eof) - (return)) - (multiple-value-bind - (entry found) - (gethash (svref stuff 0) *vop-counts*) - (cond (found - (incf (svref entry 1) (svref stuff 1)) - (incf (svref entry 2) (svref stuff 3)) - (incf (svref entry 3) (svref stuff 2))) - (t - (setf (gethash (svref stuff 0) *vop-counts*) stuff)))))))) - diff --git a/compiler/tn.lisp b/compiler/tn.lisp deleted file mode 100644 index cc5718c20095f437d401c0c38ce9654d74752ae6..0000000000000000000000000000000000000000 --- a/compiler/tn.lisp +++ /dev/null @@ -1,572 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/tn.lisp,v 1.16 1992/06/27 21:51:42 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains utilities used for creating and manipulating TNs, and -;;; some other more assorted IR2 utilities. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package 'c) - -(export '(make-normal-tn make-representation-tn make-wired-tn - make-restricted-tn environment-live-tn - environment-debug-live-tn component-live-tn specify-save-tn - make-constant-tn make-alias-tn make-load-time-constant-tn - make-n-tns location= tn-value force-tn-to-stack)) - -;;; The component that is currently being compiled. TNs are allocated in this -;;; component. -;;; -(defvar *compile-component*) - - -;;; Do-Packed-TNs -- Interface -;;; -(defmacro do-packed-tns ((tn component &optional result) &body body) - "Do-Packed-TNs (TN-Var Component [Result]) Declaration* Form* - Iterate over all packed TNs allocated in Component." - (let ((n-component (gensym))) - `(let ((,n-component (component-info ,component))) - (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn))) - ((null ,tn)) - ,@body) - (do ((,tn (ir2-component-restricted-tns ,n-component) (tn-next ,tn))) - ((null ,tn)) - ,@body) - (do ((,tn (ir2-component-wired-tns ,n-component) (tn-next ,tn))) - ((null ,tn) - ,result) - ,@body)))) - - -;;; Delete-Unreferenced-TNs -- Interface -;;; -;;; Remove all TNs with no references from the lists of unpacked TNs. We -;;; null out the Offset so that nobody will mistake deleted wired TNs for -;;; properly packed TNs. We mark non-deleted alias TNs so that aliased TNs -;;; aren't considered to be unreferenced. -;;; -(defun delete-unreferenced-tns (component) - (let* ((2comp (component-info component)) - (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp)) - :element-type 'bit :initial-element 0))) - (labels ((delete-some (getter setter) - (let ((prev nil)) - (do ((tn (funcall getter 2comp) (tn-next tn))) - ((null tn)) - (cond - ((or (used-p tn) - (and (eq (tn-kind tn) :specified-save) - (used-p (tn-save-tn tn)))) - (setq prev tn)) - (t - (delete-1 tn prev setter)))))) - (used-p (tn) - (or (tn-reads tn) (tn-writes tn) - (member (tn-kind tn) '(:component :environment)) - (not (zerop (sbit aliases (tn-number tn)))))) - (delete-1 (tn prev setter) - (if prev - (setf (tn-next prev) (tn-next tn)) - (funcall setter (tn-next tn) 2comp)) - (setf (tn-offset tn) nil) - (case (tn-kind tn) - (:environment - (clear-live tn #'ir2-environment-live-tns - #'(setf ir2-environment-live-tns))) - (:debug-environment - (clear-live tn #'ir2-environment-debug-live-tns - #'(setf ir2-environment-debug-live-tns))))) - (clear-live (tn getter setter) - (let ((env (environment-info (tn-environment tn)))) - (funcall setter (delete tn (funcall getter env)) env)))) - (declare (inline used-p delete-some delete-1 clear-live)) - (delete-some #'ir2-component-alias-tns - #'(setf ir2-component-alias-tns)) - (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn))) - ((null tn)) - (setf (sbit aliases (tn-number (tn-save-tn tn))) 1)) - (delete-some #'ir2-component-normal-tns - #'(setf ir2-component-normal-tns)) - (delete-some #'ir2-component-restricted-tns - #'(setf ir2-component-restricted-tns)) - (delete-some #'ir2-component-wired-tns - #'(setf ir2-component-wired-tns)))) - (undefined-value)) - - -;;;; TN Creation: - -;;; Make-Normal-TN -- Interface -;;; -;;; Create a packed TN of the specified primitive-type in the -;;; *Compile-Component*. We use the SCs from the primitive type to determine -;;; which SCs it can be packed in. -;;; -(defun make-normal-tn (type) - (declare (type primitive-type type)) - (let* ((component (component-info *compile-component*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal type nil))) - (push-in tn-next res (ir2-component-normal-tns component)) - res)) - - -;;; MAKE-REPRESENTATION-TN -- Interface -;;; -;;; Create a normal packed TN with representation indicated by SCN. -;;; -(defun make-representation-tn (ptype scn) - (declare (type primitive-type ptype) (type sc-number scn)) - (let* ((component (component-info *compile-component*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal ptype - (svref (backend-sc-numbers *backend*) scn)))) - (push-in tn-next res (ir2-component-normal-tns component)) - res)) - - -;;; Make-Wired-TN -- Interface -;;; -;;; Create a TN wired to a particular location in an SC. We set the Offset -;;; and FSC to record where it goes, and then put it on the current component's -;;; Wired-TNs list. Ptype is the TN's primitive-type, which may be NIL in VOP -;;; temporaries. -;;; -(defun make-wired-tn (ptype scn offset) - (declare (type (or primitive-type null) ptype) - (type sc-number scn) (type unsigned-byte offset)) - (let* ((component (component-info *compile-component*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal ptype - (svref (backend-sc-numbers *backend*) scn)))) - (setf (tn-offset res) offset) - (push-in tn-next res (ir2-component-wired-tns component)) - res)) - - -;;; Make-Restricted-TN -- Interface -;;; -;;; Create a packed TN restricted to the SC with number SCN. Ptype is as -;;; for MAKE-WIRED-TN. -;;; -(defun make-restricted-tn (ptype scn) - (declare (type (or primitive-type null) ptype) (type sc-number scn)) - (let* ((component (component-info *compile-component*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal ptype - (svref (backend-sc-numbers *backend*) scn)))) - (push-in tn-next res (ir2-component-restricted-tns component)) - res)) - - -;;; ENVIRONMENT-LIVE-TN, ENVIRONMENT-DEBUG-LIVE-TN -- Interface -;;; -;;; Make TN be live throughout environment. Return TN. In the DEBUG case, -;;; the TN is treated normally in blocks in the environment which reference the -;;; TN, allowing targeting to/from the TN. This results in move efficient -;;; code, but may result in the TN sometimes not being live when you want it. -;;; -(defun environment-live-tn (tn env) - (declare (type tn tn) (type environment env)) - (assert (eq (tn-kind tn) :normal)) - (setf (tn-kind tn) :environment) - (setf (tn-environment tn) env) - (push tn (ir2-environment-live-tns (environment-info env))) - tn) -;;; -(defun environment-debug-live-tn (tn env) - (declare (type tn tn) (type environment env)) - (assert (eq (tn-kind tn) :normal)) - (setf (tn-kind tn) :debug-environment) - (setf (tn-environment tn) env) - (push tn (ir2-environment-debug-live-tns (environment-info env))) - tn) - - -;;; Component-Live-TN -- Interface -;;; -;;; Make TN be live throughout the current component. Return TN. -;;; -(defun component-live-tn (tn) - (declare (type tn tn)) - (assert (eq (tn-kind tn) :normal)) - (setf (tn-kind tn) :component) - (push tn (ir2-component-component-tns (component-info *compile-component*))) - tn) - - -;;; SPECIFY-SAVE-TN -- Interface -;;; -;;; Specify that Save be used as the save location for TN. TN is returned. -;;; -(defun specify-save-tn (tn save) - (declare (type tn tn save)) - (assert (eq (tn-kind save) :normal)) - (assert (and (not (tn-save-tn tn)) (not (tn-save-tn save)))) - (setf (tn-kind save) :specified-save) - (setf (tn-save-tn tn) save) - (setf (tn-save-tn save) tn) - (push save - (ir2-component-specified-save-tns - (component-info *compile-component*))) - tn) - - -;;; Make-Constant-TN -- Interface -;;; -;;; Create a constant TN. The implementation dependent -;;; Immediate-Constant-SC function is used to determine whether the constant -;;; has an immediate representation. -;;; -(defun make-constant-tn (constant) - (declare (type constant constant)) - (let* ((component (component-info *compile-component*)) - (immed (immediate-constant-sc (constant-value constant))) - (sc (svref (backend-sc-numbers *backend*) - (or immed (sc-number-or-lose 'constant *backend*)))) - (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc))) - (unless immed - (let ((constants (ir2-component-constants component))) - (setf (tn-offset res) (fill-pointer constants)) - (vector-push-extend constant constants))) - (push-in tn-next res (ir2-component-constant-tns component)) - (setf (tn-leaf res) constant) - res)) - - -;;; MAKE-LOAD-TIME-VALUE-TN -- interface. -;;; -(defun make-load-time-value-tn (handle type) - (let* ((component (component-info *compile-component*)) - (sc (svref (backend-sc-numbers *backend*) - (sc-number-or-lose 'constant *backend*))) - (res (make-tn 0 :constant (primitive-type type) sc)) - (constants (ir2-component-constants component))) - (setf (tn-offset res) (fill-pointer constants)) - (vector-push-extend (cons :load-time-value handle) constants) - (push-in tn-next res (ir2-component-constant-tns component)) - res)) - -;;; MAKE-ALIAS-TN -- Interface -;;; -;;; Make a TN that aliases TN for use in local call argument passing. -;;; -(defun make-alias-tn (tn) - (declare (type tn tn)) - (let* ((component (component-info *compile-component*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :alias (tn-primitive-type tn) nil))) - (setf (tn-save-tn res) tn) - (push-in tn-next res - (ir2-component-alias-tns component)) - res)) - - -;;; Make-Load-Time-Constant-TN -- Internal -;;; -;;; Return a load-time constant TN with the specified Kind and Info. If the -;;; desired Constants entry already exists, then reuse it, otherwise allocate a -;;; new load-time constant slot. -;;; -(defun make-load-time-constant-tn (kind info) - (declare (type keyword kind)) - (let* ((component (component-info *compile-component*)) - (res (make-tn 0 :constant (backend-any-primitive-type *backend*) - (svref (backend-sc-numbers *backend*) - (sc-number-or-lose 'constant *backend*)))) - (constants (ir2-component-constants component))) - - (do ((i 0 (1+ i))) - ((= i (length constants)) - (setf (tn-offset res) i) - (vector-push-extend (cons kind info) constants)) - (let ((entry (aref constants i))) - (when (and (consp entry) - (eq (car entry) kind) - (eq (cdr entry) info)) - (setf (tn-offset res) i) - (return)))) - - (push-in tn-next res (ir2-component-constant-tns component)) - res)) - - -;;;; TN referencing: - -;;; Reference-TN -- Interface -;;; -;;; Make a TN-Ref that references TN and return it. Write-P should be true -;;; if this is a write reference, otherwise false. All we do other than -;;; calling the constructor is add the reference to the TN's references. -;;; -(defun reference-tn (tn write-p) - (declare (type tn tn) (type boolean write-p)) - (let ((res (make-tn-ref tn write-p))) - (if write-p - (push-in tn-ref-next res (tn-writes tn)) - (push-in tn-ref-next res (tn-reads tn))) - res)) - - -;;; Reference-TN-List -- Interface -;;; -;;; Make TN-Refs to reference each TN in TNs, linked together by -;;; TN-Ref-Across. Write-P is the Write-P value for the refs. More is -;;; stuck in the TN-Ref-Across of the ref for the last TN, or returned as the -;;; result if there are no TNs. -;;; -(defun reference-tn-list (tns write-p &optional more) - (declare (list tns) (type boolean write-p) (type (or tn-ref null) more)) - (if tns - (let* ((first (reference-tn (first tns) write-p)) - (prev first)) - (dolist (tn (rest tns)) - (let ((res (reference-tn tn write-p))) - (setf (tn-ref-across prev) res) - (setq prev res))) - (setf (tn-ref-across prev) more) - first) - more)) - - -;;; Delete-TN-Ref -- Interface -;;; -;;; Remove Ref from the references for its associated TN. -;;; -(defun delete-tn-ref (ref) - (declare (type tn-ref ref)) - (if (tn-ref-write-p ref) - (deletef-in tn-ref-next (tn-writes (tn-ref-tn ref)) ref) - (deletef-in tn-ref-next (tn-reads (tn-ref-tn ref)) ref)) - (undefined-value)) - - -;;; Change-TN-Ref-TN -- Interface -;;; -;;; Do stuff to change the TN referenced by Ref. We remove Ref from it's -;;; old TN's refs, add ref to TN's refs, and set the TN-Ref-TN. -;;; -(defun change-tn-ref-tn (ref tn) - (declare (type tn-ref ref) (type tn tn)) - (delete-tn-ref ref) - (setf (tn-ref-tn ref) tn) - (if (tn-ref-write-p ref) - (push-in tn-ref-next ref (tn-writes tn)) - (push-in tn-ref-next ref (tn-reads tn))) - (undefined-value)) - - -;;;; Random utilities: - - -;;; Emit-Move-Template -- Internal -;;; -;;; Emit a move-like template determined at run-time, with X as the argument -;;; and Y as the result. Useful for move, coerce and type-check templates. If -;;; supplied, then insert before VOP, otherwise insert at then end of the -;;; block. Returns the last VOP inserted. -;;; -(defun emit-move-template (node block template x y &optional before) - (declare (type node node) (type ir2-block block) - (type template template) (type tn x y)) - (let ((arg (reference-tn x nil)) - (result (reference-tn y t))) - (multiple-value-bind - (first last) - (funcall (template-emit-function template) node block template arg - result) - (insert-vop-sequence first last block before) - last))) - - -;;; EMIT-LOAD-TEMPLATE -- Internal -;;; -;;; Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too. -;;; -(defun emit-load-template (node block template x y info &optional before) - (declare (type node node) (type ir2-block block) - (type template template) (type tn x y)) - (let ((arg (reference-tn x nil)) - (result (reference-tn y t))) - (multiple-value-bind - (first last) - (funcall (template-emit-function template) node block template arg - result info) - (insert-vop-sequence first last block before) - last))) - - -;;; EMIT-MOVE-ARG-TEMPLATE -- Internal -;;; -;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args. -;;; -(defun emit-move-arg-template (node block template x f y &optional before) - (declare (type node node) (type ir2-block block) - (type template template) (type tn x f y)) - (let ((x-ref (reference-tn x nil)) - (f-ref (reference-tn f nil)) - (y-ref (reference-tn y t))) - (setf (tn-ref-across x-ref) f-ref) - (multiple-value-bind - (first last) - (funcall (template-emit-function template) node block template x-ref - y-ref) - (insert-vop-sequence first last block before) - last))) - - -;;; EMIT-CONTEXT-TEMPLATE -- Internal -;;; -;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args. -;;; -(defun emit-context-template (node block template y &optional before) - (declare (type node node) (type ir2-block block) - (type template template) (type tn y)) - (let ((y-ref (reference-tn y t))) - (multiple-value-bind - (first last) - (funcall (template-emit-function template) node block template nil - y-ref) - (insert-vop-sequence first last block before) - last))) - - -;;; Block-Label -- Interface -;;; -;;; Return the label marking the start of Block, assigning one if necessary. -;;; -(defun block-label (block) - (declare (type cblock block)) - (let ((2block (block-info block))) - (or (ir2-block-%label 2block) - (setf (ir2-block-%label 2block) (gen-label))))) - - -;;; Drop-Thru-P -- Interface -;;; -;;; Return true if Block is emitted immediately after the block ended by -;;; Node. -;;; -(defun drop-thru-p (node block) - (declare (type node node) (type cblock block)) - (let ((next-block (ir2-block-next (block-info (node-block node))))) - (assert (eq node (block-last (node-block node)))) - (eq next-block (block-info block)))) - - -;;; Insert-VOP-Sequence -- Interface -;;; -;;; Link a list of VOPs from First to Last into Block, Before the specified -;;; VOP. If Before is NIL, insert at the end. -;;; -(defun insert-vop-sequence (first last block before) - (declare (type vop first last) (type ir2-block block) - (type (or vop null) before)) - (if before - (let ((prev (vop-prev before))) - (setf (vop-prev first) prev) - (if prev - (setf (vop-next prev) first) - (setf (ir2-block-start-vop block) first)) - (setf (vop-next last) before) - (setf (vop-prev before) last)) - (let ((current (ir2-block-last-vop block))) - (setf (vop-prev first) current) - (setf (ir2-block-last-vop block) last) - (if current - (setf (vop-next current) first) - (setf (ir2-block-start-vop block) first)))) - (undefined-value)) - - -;;; DELETE-VOP -- Interface -;;; -;;; Delete all of the TN-Refs associated with VOP and remove VOP from the -;;; IR2. -;;; -(defun delete-vop (vop) - (declare (type vop vop)) - (do ((ref (vop-refs vop) (tn-ref-next-ref ref))) - ((null ref)) - (delete-tn-ref ref)) - - (let ((prev (vop-prev vop)) - (next (vop-next vop)) - (block (vop-block vop))) - (if prev - (setf (vop-next prev) next) - (setf (ir2-block-start-vop block) next)) - (if next - (setf (vop-prev next) prev) - (setf (ir2-block-last-vop block) prev))) - - (undefined-value)) - - -;;; Make-N-TNs -- Interface -;;; -;;; Return a list of N normal TNs of the specified primitive type. -;;; -(defun make-n-tns (n ptype) - (declare (type unsigned-byte n) (type primitive-type ptype)) - (collect ((res)) - (dotimes (i n) - (res (make-normal-tn ptype))) - (res))) - - -;;; Location= -- Interface -;;; -;;; Return true if X and Y are packed in the same location, false otherwise. -;;; This is false if either operand is constant. -;;; -(defun location= (x y) - (declare (type tn x y)) - (and (eq (sc-sb (tn-sc x)) (sc-sb (tn-sc y))) - (eql (tn-offset x) (tn-offset y)) - (not (or (eq (tn-kind x) :constant) - (eq (tn-kind y) :constant))))) - - -;;; TN-Value -- Interface -;;; -;;; Return the value of an immediate constant TN. -;;; -(defun tn-value (tn) - (declare (type tn tn)) - (assert (member (tn-kind tn) '(:constant :cached-constant))) - (constant-value (tn-leaf tn))) - - -;;; Force-TN-To-Stack -- Interface -;;; -;;; Force TN to be allocated in a SC that doesn't need to be saved: an -;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN, -;;; but since we change the SC to an unbounded one, we should always succeed in -;;; packing it in that SC. -;;; -(defun force-tn-to-stack (tn) - (declare (type tn tn)) - (let ((sc (tn-sc tn))) - (unless (and (not (sc-save-p sc)) - (eq (sb-kind (sc-sb sc)) :unbounded)) - (dolist (alt (sc-alternate-scs sc) - (error "SC ~S has no :unbounded :save-p NIL alternate SC." - (sc-name sc))) - (when (and (not (sc-save-p alt)) - (eq (sb-kind (sc-sb alt)) :unbounded)) - (setf (tn-sc tn) alt) - (return))))) - (undefined-value)) - diff --git a/compiler/vmdef.lisp b/compiler/vmdef.lisp deleted file mode 100644 index 700049403e81957cb70ef20d89fb72d195bfcb8d..0000000000000000000000000000000000000000 --- a/compiler/vmdef.lisp +++ /dev/null @@ -1,281 +0,0 @@ -;;; -*- Package: C; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; 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/vmdef.lisp,v 1.46 1992/08/25 17:44:03 wlott Exp $") -;;; -;;; ********************************************************************** -;;; -;;; This file contains implementation-independent facilities used for -;;; defining the compiler's interface to the VM in a given implementation. -;;; -;;; Written by Rob MacLachlan -;;; -(in-package :c) - -(export '(template-or-lose sc-or-lose sb-or-lose sc-number-or-lose - primitive-type-or-lose note-this-location note-next-instruction)) - -;;; Template-Or-Lose -- Internal -;;; -;;; Return the template having the specified name, or die trying. -;;; -(defun template-or-lose (x &optional (backend *target-backend*)) - (the template - (or (gethash x (backend-template-names backend)) - (error "~S is not a defined template." x)))) - - -;;; SC-Or-Lose, SB-Or-Lose, SC-Number-Or-Lose -- Internal -;;; -;;; Return the SC structure, SB structure or SC number corresponding to a -;;; name, or die trying. -;;; -(defun sc-or-lose (x &optional (backend *target-backend*)) - (the sc - (or (gethash x (backend-sc-names backend)) - (error "~S is not a defined storage class." x)))) -;;; -(defun sb-or-lose (x &optional (backend *target-backend*)) - (the sb - (or (gethash x (backend-sb-names backend)) - (error "~S is not a defined storage base." x)))) -;;; -(defun sc-number-or-lose (x &optional (backend *target-backend*)) - (the sc-number (sc-number (sc-or-lose x backend)))) - - - -;;;; Side-Effect Classes - -(def-boolean-attribute vop - any) - - - -;;;; Move/coerce definition: - -;;; COMPUTE-MOVE-COSTS -- Internal -;;; -;;; Compute at compiler load time the costs for moving between all SCs that -;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost. -;;; -(defun compute-move-costs (from-sc to-sc cost) - (declare (type sc from-sc to-sc) (type index cost)) - (let ((to-scn (sc-number to-sc)) - (from-costs (sc-load-costs from-sc))) - (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc))) - (let ((vec (sc-move-costs dest-sc)) - (dest-costs (sc-load-costs dest-sc))) - (setf (svref vec (sc-number from-sc)) cost) - (dolist (sc (append (sc-alternate-scs from-sc) - (sc-constant-scs from-sc))) - (let* ((scn (sc-number sc)) - (total (+ (svref from-costs scn) - (svref dest-costs to-scn) - cost)) - (old (svref vec scn))) - (unless (and old (< old total)) - (setf (svref vec scn) total)))))))) - - -;;;; Primitive type definition: - -;;; PRIMITIVE-TYPE-OR-LOSE -- Interface -;;; -;;; Return the primitive type corresponding to the specified name, or die -;;; trying. -;;; -(defun primitive-type-or-lose (name &optional (backend *target-backend*)) - (the primitive-type - (or (gethash name (backend-primitive-type-names backend)) - (error "~S is not a defined primitive type." name)))) - - -;;; SC-ALLOWED-BY-PRIMITIVE-TYPE -- Interface -;;; -;;; Return true if SC is either one of Ptype's SC's, or one of those SC's -;;; alternate or constant SCs. -;;; -(defun sc-allowed-by-primitive-type (sc ptype) - (declare (type sc sc) (type primitive-type ptype)) - (let ((scn (sc-number sc))) - (dolist (allowed (primitive-type-scs ptype) nil) - (when (eql allowed scn) - (return t)) - (let ((allowed-sc (svref (backend-sc-numbers *backend*) allowed))) - (when (or (member sc (sc-alternate-scs allowed-sc)) - (member sc (sc-constant-scs allowed-sc))) - (return t)))))) - - -;;;; Emit function generation: - -(defconstant max-vop-tn-refs 256) - -(defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil)) -(defvar *using-vop-tn-refs* nil) - -(defun flush-vop-tn-refs () - (unless *using-vop-tn-refs* - (fill *vop-tn-refs* nil))) - -(pushnew 'flush-vop-tn-refs *before-gc-hooks*) - -(defconstant sc-bits (integer-length (1- sc-number-limit))) - -(defun emit-generic-vop (node block template args results &optional info) - (%emit-generic-vop node block template args results info)) - -(defun %emit-generic-vop (node block template args results info) - (let* ((vop (make-vop block node template args results)) - (num-args (vop-info-num-args template)) - (last-arg (1- num-args)) - (num-results (vop-info-num-results template)) - (num-operands (+ num-args num-results)) - (last-result (1- num-operands)) - (ref-ordering (vop-info-ref-ordering template))) - (declare (type vop vop) - (type (integer 0 #.max-vop-tn-refs) - num-args num-results num-operands) - (type (integer -1 #.(1- max-vop-tn-refs)) last-arg last-result) - (type (simple-array (mod #.max-vop-tn-refs) (*)) ref-ordering)) - (setf (vop-codegen-info vop) info) - (let ((refs *vop-tn-refs*) - (*using-vop-tn-refs* t)) - (declare (type (simple-vector #.max-vop-tn-refs) refs)) - (do ((index 0 (1+ index)) - (ref args (and ref (tn-ref-across ref)))) - ((= index num-args)) - (setf (svref refs index) ref)) - (do ((index num-args (1+ index)) - (ref results (and ref (tn-ref-across ref)))) - ((= index num-operands)) - (setf (svref refs index) ref)) - (let ((temps (vop-info-temps template))) - (when temps - (let ((index num-operands) - (prev nil)) - (dotimes (i (length temps)) - (let* ((temp (aref temps i)) - (tn (if (logbitp 0 temp) - (make-wired-tn nil - (ldb (byte sc-bits 1) temp) - (ash temp (- (1+ sc-bits)))) - (make-restricted-tn nil (ash temp -1)))) - (write-ref (reference-tn tn t))) - (setf (aref refs index) (reference-tn tn nil)) - (setf (aref refs (1+ index)) write-ref) - (if prev - (setf (tn-ref-across prev) write-ref) - (setf (vop-temps vop) write-ref)) - (setf prev write-ref) - (incf index 2)))))) - (let ((prev nil)) - (flet ((add-ref (ref) - (setf (tn-ref-vop ref) vop) - (setf (tn-ref-next-ref ref) prev) - (setf prev ref))) - (declare (inline add-ref)) - (dotimes (i (length ref-ordering)) - (let* ((index (aref ref-ordering i)) - (ref (aref refs index))) - (if (or (= index last-arg) (= index last-result)) - (do ((ref ref (tn-ref-across ref))) - ((null ref)) - (add-ref ref)) - (add-ref ref))))) - (setf (vop-refs vop) prev)) - (let ((targets (vop-info-targets template))) - (when targets - (dotimes (i (length targets)) - (let ((target (aref targets i))) - (target-if-desirable (aref refs (ldb (byte 8 8) target)) - (aref refs (ldb (byte 8 0) target)))))))) - (values vop vop))) - - -;;;; Function translation stuff: - -;;; Adjoin-Template -- Internal -;;; -;;; Add Template into List, removing any old template with the same name. -;;; We also maintain the increasing cost ordering. -;;; -(defun adjoin-template (template list) - (declare (type template template) (list list)) - (sort (cons template - (remove (template-name template) list - :key #'template-name)) - #'<= - :key #'template-cost)) - - - -;;; Template-Type-Specifier -- Internal -;;; -;;; Return a function type specifier describing Template's type computed -;;; from the operand type restrictions. -;;; -(defun template-type-specifier (template) - (declare (type template template)) - (flet ((convert (types more-types) - (flet ((frob (x) - (if (eq x '*) - 't - (ecase (first x) - (:or `(or ,@(mapcar #'(lambda (type) - (type-specifier - (primitive-type-type - type))) - (rest x)))) - (:constant `(constant-argument ,(third x))))))) - `(,@(mapcar #'frob types) - ,@(when more-types - `(&rest ,(frob more-types))))))) - (let* ((args (convert (template-arg-types template) - (template-more-args-type template))) - (result-restr (template-result-types template)) - (results (if (eq result-restr :conditional) - '(boolean) - (convert result-restr - (cond ((template-more-results-type template)) - ((/= (length result-restr) 1) '*) - (t nil)))))) - `(function ,args - ,(if (= (length results) 1) - (first results) - `(values ,@results)))))) - - -;;;; Random utilities. - -;;; NOTE-THIS-LOCATION -- Interface -;;; -(defun note-this-location (vop kind) - "NOTE-THIS-LOCATION VOP Kind - Note that the current code location is an interesting (to the debugger) - location of the specified Kind. VOP is the VOP responsible for this code. - This VOP must specify some non-null :SAVE-P value (perhaps :COMPUTE-ONLY) so - that the live set is computed." - (let ((lab (gen-label))) - (emit-label lab) - (note-debug-location vop lab kind))) - -;;; NOTE-NEXT-INSTRUCTION -- interface. -;;; -(defun note-next-instruction (vop kind) - "NOTE-NEXT-INSTRUCTION VOP Kind - Similar to NOTE-THIS-LOCATION, except the use the location of the next - instruction for the code location, wherever the scheduler decided to put - it." - (let ((loc (note-debug-location vop nil kind))) - (new-assem:emit-postit #'(lambda (segment posn) - (declare (ignore segment)) - (setf (location-info-label loc) posn)))) - (undefined-value)) diff --git a/contrib/CATALOG.TXT b/contrib/CATALOG.TXT deleted file mode 100644 index 99796fae142834636fd18b2701fdbca03039f6cb..0000000000000000000000000000000000000000 --- a/contrib/CATALOG.TXT +++ /dev/null @@ -1,291 +0,0 @@ -Package Name: - DEMOS - -Description: - Graphics demonstration programs for CMU Common Lisp using version 11 of the -X Window System. - -Author: - CMU Common Lisp Group. - -Maintainer: - CMU Common Lisp Group. - -Address: - Carnegie-Mellon University - Computer Science Department - Pittsburgh, PA 15213 - -Net Address: - slisp-group@b - -Copyright Status: - Public Domain. - -Files: - demos.lisp, demos.fasl, demos.catalog. - -How to Get: - The following unix command will copy the pertinent files into directory -<spec>: - cp /afs/cs.cmu.edu/project/slisp/library/demos/* <spec> - -Portability: - Should run in any Common Lisp supporting CLX V11R3. - -Instructions: - The function DEMOS:DO-ALL-DEMOS will run through each of the demos once, and -the function DEMOS:DEMO will present a menu of all the demos. - - -Name: - Follow Mouse. - -Package Name: - HEMLOCK - -Description: - This Hemlock customization causes Hemlock's current window to be set to -whatever Hemlock window the mouse enters, except the echo area. - -Author: - Todd Kaufmann, modified by Dave Touretzky. - -Maintainer: - Todd Kaufmann. - -Address: - Carnegie-Mellon University - Computer Science Department - Pittsburgh, PA 15213 - -Net Address: - Todd.Kaufmann@CS.CMU.EDU - -Copyright Status: - Public Domain. - -Files: - follow-mouse.lisp, follow-mouse.fasl, follow-mouse.catalog. - -How to Get: - The following unix command will copy the pertinent files into directory -<spec>: - cp /afs/cs.cmu.edu/project/slisp/library/follow-mouse/* <spec> - -Portability: - This should work in any Common Lisp supporting Hemlock and CLX V11R3. - -Instructions: - Load the fasl file into your editor Lisp. A value of T for the hemlock -variable "Follow Mouse To Read-Only Buffers", which is the default, means -follow mouse is on. Anything else means hemlock will behave normally. - -Bugs: - A few more PROMPT-FOR-... functions need to be modified. They are mentioned -in the source code. - - -Package Name: - HIST - -Description: - Simple histogram facility using Format strings for output. - -Author: - Scott E. Fahlman - -Address: - Carnegie-Mellon University - Computer Science Department - Pittsburgh, PA 15213 - -Net Address: - Scott.Fahlman@CS.CMU.EDU - -Copyright Status: - Public Domain. - -Files: - hist.lisp, hist.fasl, hist.catalog - -How to Get: - The following unix command will copy the pertinent files into directory -<spec>. - cp /afs/cs.cmu.edu/project/slisp/library/hist/* <spec> - -Portability: - Should run in any legal Common Lisp. - -Instructions: - Hist is a macro of form (HIST (min max [bucket-size]) . body) - -Creates a histogram with buckets of the specified size (defaults to 1), -spanning the range from Low (inclusive) to High (exclusive), with two -additional buckets to catch values below and above this range. The body is -executed as a progn, and every call to Hist-Record within the body provides a -value for the histogram to count. When Body exits, the histogram is printed -out and Hist returns Nil. - -A simple example: - (hist (0 10) (dotimes (i 1000) (random 10))) -This example may make the RANDOM distribution look more normal: - (hist (0 10 2) (dotimes (i 1000) (random 10))) -This example will show you overflow buckets: - (hist (2 12) (dotimes (i 1000) (random 15))) - -Wish List: - Some sort of automatic scaling for the number and size of buckets would be -nice, if the user chooses not to supply these. This would probably require -running the body twice, once to determine the spread of values, and again to -actually produce the histogram. - - -Name: - OPS - -Package Name: - OPS - -Description: - Interpreter for Ops5, a programming language for production systems. - -Author: - Charles L. Forgy. Ported to Common lisp by George Wood and Jim Kowalski. -CMU Common Lisp mods by Dario Guise, Skef Wholey, and Dan Kuokka. - -Maintainer: - CMU Common Lisp Group. - -Net Address: - slisp-group@b - -Copyright Status: - Public domain. - -Files: - ops.lisp, ops-backup.lisp, ops-compile.lisp, ops-io.lisp, ops-main.lisp, -ops-match.lisp, ops-rhs.lisp, ops-util.lisp, ops.catalog, ops-demo-mab.lisp, -ops-demo-ttt.lisp, and binaries. - -How to Get: - The following unix command will copy the pertinent files into directory -<spec>. - cp /afs/cs.cmu.edu/project/slisp/library/ops/* <spec> - -Portability: - Should run in any legal Common Lisp implementation. - -Instructions: - From Lisp, load "ops" and then go into the OPS package with (in-package -'ops). Now you can load your OPS5 code or start typing in productions. - -There are two demos -- interactive tic-tac-toe and the monkey and banana -problem. To run the former just load it and call RUN. For the latter, first -enter "(make start 1)" and then call RUN. - -See the OPS5 User's Manual, July 1981, by Forgy, CMU CSD. - -Bugs: - This has been put in its own package, but only a few interfaces have been -exported. You must run in the ops package. - - -Package Name: - PROFILE - -Description: - Provides macros to do simple code profiling things. - -Author: - Skef Wholey - Rob MacLachlan - -Address: - Carnegie-Mellon University - Computer Science Department - Pittsburgh, PA 15213 - -Net Address: - ram@cs.cmu.edu - -Copyright Status: - Public Domain - -Files: - profile.lisp, profile.fasl, profile.doc, profile.catalog - -How to Get: - The following unix command will copy the pertinent files into directory -<spec>: - cp /afs/cs.cmu.edu/project/slisp/library/profile/* <spec> - -Portability: - Should run in any Common Lisp. Someone porting this may want to change a -few things mentioned in profile.lisp to tune it to another implementation. - -Instructions: - See the file profile.doc for details. - - -Name: - PSgrapher - -Description: - The PSgrapher is a set of Lisp routines that can be called to produce -Postscript commands that display a directed acyclic graph. - -Author: - Joseph Bates. Skef put the whole thing in the PSGRPAPH package and added -functionality which allows the user to specify EQ, EQUAL, or EQUALP as the -node equivalence function. Bill made all exported symbols have stars on them. - -Address: - Carnegie-Mellon University - Computer Science Department - Pittsburgh, PA 15213 - -Net Address: - Joseph.Bates@CS.CMU.EDU - -Copyright Status: - Public Domain. - -Files: - psgraph.lisp, psgraph.fasl, psgraph.doc, psgraph.log, psgraph.catalog - -How to Get: - The following unix command will copy the pertinent files into directory -<spec>. - cp /afs/cs.cmu.edu/project/clisp/library/psgraph/* <spec> - -Portability: - Should run in any legal Common Lisp. Requires Postscript for printing. - -Instructions: - See psgraph.doc. - -Bugs: - This code blindly outputs what the user gives it as node labels. It should -run through the output escaping any PS control characters. For example, if -node labels contain parentheses, your output PS file will not print. - -Examples: - Skef Wholey submitted this as a reasonable example: - -;;; I use this in my compiler so I can look at code trees without -;;; crawling around them in the inspector. The postsript previewer -;;; groks the generated ps file, which is bitchin' marvy. - - (defun code-graph-to-file (s file &optional shrink insert) - (let ((psgraph:*fontname* "Times-Roman") - (psgraph:*fontsize* 8) - (psgraph:*second-fontname* "Times-BoldItalic") - (psgraph:*second-fontsize* 6) - (psgraph:*boxgray* "0") - (psgraph:*edgegray* "0") - (psgraph:*extra-x-spacing* 30)) - (with-open-file (*standard-output* file - :direction :output - :if-exists :supersede) - (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq)))) diff --git a/contrib/READ-ME.TXT b/contrib/READ-ME.TXT deleted file mode 100644 index 7e9800b6a4fbd091f4be8251362436f415fc927a..0000000000000000000000000000000000000000 --- a/contrib/READ-ME.TXT +++ /dev/null @@ -1,132 +0,0 @@ -DESCRIPTION OF THE CMU COMMON LISP LIBRARY AND CATALOG ENTRY FORMAT. - -The CMU Common Lisp library contains a variety of useful or interesting -software packages written by users of CMU Common Lisp. Each entry is contained -in its own subdirectory. The CATALOG.TXT describes every entry in the library. -Two subdirectories are for library maintainers, library-broken and -library-maintenance. - -To submit a program for inclusion in the library, send mail to Gripe -pointing to the relevant files and providing the information for the -catalog entry in the format described below. The library maintainers will -verify that the program runs as documented in the current Lisp, has no -crippling bugs, and that the functionality is not duplicated in some other -program; then we will add the program to the library. Programs that are -made obsolete by later submissions may be dropped from the library, after -due notice is given to the user community. Some programs may be deemed so -useful that they will be included in the standard CMU Common Lisp system. - -All source files must be included for each software package in the library. -Whenever possible, a program should be submitted as a single large file -rather than as a collection of smaller files; this will help to minimize -version-control problems. - -Note: We plan to distribute this software freely over the Arpanet and we -may set up some mechanism to provide non-arpanet users with tapes. We can -in general accept only public-domain code (anything with no copyright -notice in the source will be assumed to be in the public domain) and code -for which Carnegie-Mellon University holds the copyright. If you have any -code of commercial value, the copyright system provides little real -protection in any case. - -Bugs in library programs not listed in the "bugs" section of the program's -description should be reported to the maintainer listed below (or to the -author if there is no maintainer), with CC to Gripe. - -Send any questions or comments to Gripe. - - -CATALOG ENTRY FORMAT FOR CATALOG.TXT. - -Each entry is on a separate page, separated by the page mark Control-L. - -Each entry consists of fields. Each new field begins on a fresh line with a -field name terminated by a colon. Then on a new line, indented at least one -space, is an arbitrary amount of text. This somewhat rigid format is designed -to make it easy to build various sorts of software to automatically manipulate -catalogs, but the indentation is simply a convenience for paragraph -manipulation and filling commands in the editor. The field names are sensitive -to spelling, but insensitive to case and extra whitespace. - -The following is a specification of the possible fields in the catalog format: - -Name: or -Module Name: - This specifies the name of the program or set of programs. If the supplier -of the entry does not specify a Package Name, then this is the package in which -the code lives. - -Package Name: - If the programs are loaded into a package of their own, this is the name of -that package. If the supplier of the entry does not specify a Name or Module -Name, the package name will be used as the name for everything. - -Description: - This is a brief description of what the program does. - -Author: - This is the name of the author, or "anonymous". - -Maintainer: - This is the name of the current maintainer, if different from the author. -If a program is not being maintained by anyone, the Maintainer is "none". - -Address: or -Address of Author: or -Address of Maintainer: - This is the physical mailing address of the author or maintainer. If the -field is just "address", it is assumed to be the maintainer if one is -specified, and the author otherwise. - -Net Address: or -Net Address of Author: or -Net Address of Maintainer: - This is a network address that can be reached from the arpanet. - -Copyright Status: - This is "Public domain.", or some sort of copyright notice. - -Files: - This is a list of the files that constitute this facility. For example, a -system named "Foo" may be distributed as files "foo.lisp", "foo.fasl", and -(optionally) "foo.doc" or "foo.PS" for documentation. In order to minimize -maintenance headaches and encourage people to build on the work of others, we -want all programs in the library to include complete sources. - -How to Get: - This can either be a shell command using such programs as lcp or cp, or -there may be a .cmd file that will copy all the sources, binaries, catalog, and -log files to the user's current directory. This .cmd file will try to preserve -write date (such as using -p with cp). - -Portability: - If the program will run in any legal Common Lisp, say so. If there are -known dependencies on CMU Common Lisp specific or Mach/RT specific features, -describe them here. Programs relying on CLX, CLOS, etc. should be considered -to have a high expectation of portability. - -Dependencies: - If the program requires other library packages not built into the standard -CMU Common Lisp core image, list those other packages here. - -Instructions: - Place here any instructions for use that are too lengthy to be mere -documentation strings, but that are not lengthy enough to deserve a separate -document. - -Recent Changes: - What is different between this version and the one that preceded it, if any. -(May go back several versions at the author's discretion.) - -Bugs: - Describe here any known bugs or treacherous features. - -Future Plans: - Describe here any improvements planned by the author. - -Wish List: - Describe here any desirable features that the author does not plan to work -on in the near future. - -Notes: - This is anything else that users or potential users ought to know about. diff --git a/contrib/defsystem/defsystem.lisp b/contrib/defsystem/defsystem.lisp deleted file mode 100644 index 33c2541f89dfeee4b06fde241dd9424d4a54137b..0000000000000000000000000000000000000000 --- a/contrib/defsystem/defsystem.lisp +++ /dev/null @@ -1,1217 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-Lisp -*- - -;;; ******************************************************************** -;;; Portable Mini-DefSystem ******************************************** -;;; ******************************************************************** -;;; Fri Feb 2 10:24:17 1990 by Mark Kantrowitz <mkant@GS8.SP.CS.CMU.EDU> - -;;; This is a portable system definition facility for Common Lisp. -;;; Though home-grown, the syntax was inspired by fond memories of the -;;; defsystem facility on Symbolics 3600's. The exhaustive lists of -;;; filename extensions for various lisps and the idea to have one -;;; "operate-on-system" function instead of separate "compile-system" -;;; and "load-system" functions were taken from Xerox Corp.'s PCL -;;; system. - -;;; This system improves on both PCL and Symbolics defsystem utilities -;;; by performing a topological sort of the graph of file-dependency -;;; constraints. Thus, the components of the system need not be listed -;;; in any special order, because the defsystem command reorganizes them -;;; based on their constraints. It includes all the standard bells and -;;; whistles, such as not recompiling a binary file that is up to date -;;; (unless the user specifies that all files should be recompiled). - -;;; Written by Mark Kantrowitz, School of Computer Science, -;;; Carnegie Mellon University, October 1989. - -;;; Copyright (c) 1989 by Mark Kantrowitz. All rights reserved. - -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted, so long as the following -;;; conditions are met: -;;; o no fees or compensation are charged for use, copies, or -;;; access to this software -;;; o this copyright notice is included intact. -;;; This software is made available AS IS, and no warranty is made about -;;; the software or its performance. - -;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu. - - -;;; ******************************************************************** -;;; How to Use this System ********************************************* -;;; ******************************************************************** - -;;; To use this system, -;;; 1. If you want to have a central registry of system definitions, -;;; modify the value of the variable *central-registry* below. -;;; 2. Load this file (defsystem.lisp) in either source or compiled form, -;;; 3. Load the file containing the "defsystem" definition of your system, -;;; 4. Use the function "operate-on-system" to do things to your system. - -;;; For more information, see the documentation and examples in defsystem.text. - -;;; **************************************************************** -;;; Lisp Code ****************************************************** -;;; **************************************************************** - -;;; ******************************** -;;; Set up Package ***************** -;;; ******************************** - -(in-package "DEFSYSTEM" - :nicknames '("DEFSYS" "MAKE") - :use '("USER" - "LISP") - ) - -(provide 'defsystem) - -(defvar *exports* - '(defsystem operate-on-system oos afs-binary-directory files-in-system)) - -(defvar *other-exports* - '(*central-registry* *bin-subdir* - machine-type-translation software-type-translation - ;require - allegro-make-system-fasl files-which-need-compilation - )) - -(export (append *exports* *other-exports*)) -#| -;(import *exports* "LISP") -;(import *exports* "USER") -|# - -#-(OR CMU :CCL) -(import *exports* "USER") -#+(OR CMU :CCL) -(progn - (import (cdr *exports*) "USER") - (shadowing-import (car *exports*) "USER")) - -#-PCL(when (find-package "PCL") (push :pcl *modules*)(push :pcl *features*)) - - - -;;; ******************************** -;;; Customizable System Parameters * -;;; ******************************** - -;;; Change this variable to set up the location of a central -;;; repository for system definitions if you want one. -(defvar *central-registry* "/afs/cs.cmu.edu/project/oz/oz2/system/Registry/" - "Central directory of system definitions" ) - -(defvar *bin-subdir* ".bin/" - "The subdirectory of an AFS directory where the binaries are really kept.") - -;;; These variables set up defaults for operate-on-system, and are used -;;; for communication in lieu of parameter passing. Yes, this is bad, -;;; but it keeps the interface small. Also, in the case of the -if-no-binary -;;; variables, parameter passing would require multiple value returns -;;; from some functions. Why make life complicated? -(defvar *tell-user-when-done* nil - "If T, system will print ...DONE at the end of an operation") -(defvar *oos-verbose* nil - "Operate on System Verbose Mode") -(defvar *oos-test* nil - "Operate on System Test Mode") -(defvar *load-source-if-no-binary* nil - "If T, system will try loading the source if the binary is missing") -(defvar *bother-user-if-no-binary* t - "If T, the system will ask the user whether to load the source if the binary is missing") -(defvar *load-source-instead-of-binary* nil - "If T, the system will load the source file instead of the binary.") - -;;; Particular to CMULisp -(defvar *compile-error-file-type* "err" - "File type of compilation error file in cmulisp") -(defvar *cmu-errors-to-terminal* t - "Argument to :errors-to-terminal in compile-file in cmulisp") -(defvar *cmu-errors-to-file* t - "If T, cmulisp will write an error file during compilation") - -;;; ******************************** -;;; Global Variables *************** -;;; ******************************** - -;;; Massage people's *features* into better shape. -(eval-when (compile load eval) - (dolist (feature *features*) - (when (and (symbolp feature) ; 3600 - (equal (symbol-name feature) "CMU")) - (pushnew :CMU *features*))) - - #+Lucid - (when (search "IBM RT PC" (machine-type)) - (pushnew :ibm-rt-pc *features*)) - ) - -;;; *filename-extensions* is a cons of the source and binary extensions. -(defvar *filename-extensions* - (car '(#+(and Symbolics Lispm) ("lisp" . "bin") - #+(and dec common vax (not ultrix)) ("LSP" . "FAS") - #+(and dec common vax ultrix) ("lsp" . "fas") - #+KCL ("lsp" . "o") - #+IBCL ("lsp" . "o") - #+Xerox ("lisp" . "dfasl") - #+(and Lucid MC68000) ("lisp" . "lbin") - #+(and Lucid Vax) ("lisp" . "vbin") - #+(and Lucid Prime) ("lisp" . "pbin") - #+(and Lucid SUNRise) ("lisp" . "sbin") - #+(and Lucid SPARC) ("lisp" . "sbin") - #+(and Lucid :IBM-RT-PC) ("lisp" . "bbin") - #+excl ("cl" . "fasl") - #+:CMU ("lisp" . "fasl") - #+PRIME ("lisp" . "pbin") - #+HP ("l" . "b") - #+TI ("lisp" . #.(string (si::local-binary-file-type))) - #+:gclisp ("LSP" . "F2S") - #+pyramid ("clisp" . "o") - #+:coral ("lisp" . "fasl") - - ;; Otherwise, - ("lisp" . "lbin"))) - "Filename extensions for Common Lisp. A cons of the form - (Source-Extension . Binary-Extension). If the system is - unknown (as in *features* not known), defaults to lisp and lbin.") - -;;; There is no real support for this variable being nil, so don't change it. -;;; Note that in any event, the toplevel system (defined with defsystem) -;;; will have its dependencies delayed. Not having dependencies delayed -;;; might be useful if we define several systems within one defsystem. -(defvar *system-dependencies-delayed* t - "If T, system dependencies are expanded at run time") - -(defun non-empty-listp (list) - (and list (listp list))) - -;;; ******************************** -;;; Alist Manipulation ************* -;;; ******************************** -(defun alist-lookup (name alist &key test test-not key) - (cdr (assoc name alist :test test :test-not test-not :key key))) - -(defmacro set-alist-lookup ((name alist &key test test-not key) value) - (let ((pair (gensym))) - `(let ((,pair (assoc ,name ,alist :test ,test :test-not ,test-not :key ,key))) - (if ,pair - (rplacd ,pair ,value) - (push (cons ,name ,value) ,alist))))) - -(defvar *component-operations* nil - "Alist of (operation-name function) pairs" ) -(defun component-operation (name &optional operation) - (if operation - (set-alist-lookup (name *component-operations*) operation) - (alist-lookup name *component-operations*))) - -;;; ******************************** -;;; AFS @sys immitator ************* -;;; ******************************** -(defun afs-binary-directory (root-directory) - ;; Function for obtaining the directory AFS's @sys feature would have - ;; chosen when we're not in AFS. This function is useful as the argument - ;; to :binary-pathname in defsystem. - (let ((machine (machine-type-translation (machine-type))) - (software (software-type-translation (software-type)))) - ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach - (format nil "~A~@[~A~]~@[~A/~]" - (namestring root-directory) - *bin-subdir* - (afs-component machine software) - ))) - -(defun afs-component (machine software) - (format nil "~@[~A~]~@[_~A~]" - machine - (or software "mach"))) - -(defvar *machine-type-alist* nil - "Alist for retrieving the machine-type") -(defun machine-type-translation (name &optional operation) - (if operation - (set-alist-lookup (name *machine-type-alist* :test #'string-equal) operation) - (alist-lookup name *machine-type-alist* :test #'string-equal))) - -(machine-type-translation "IBM RT PC" "rt") -(machine-type-translation "DEC 3100" "pmax") -(machine-type-translation "DEC VAX-11" "vax") -(machine-type-translation "Sun3" "sun3") - -(defvar *software-type-alist* nil - "Alist for retrieving the software-type") -(defun software-type-translation (name &optional operation) - (if operation - (set-alist-lookup (name *software-type-alist* :test #'string-equal) operation) - (alist-lookup name *software-type-alist* :test #'string-equal))) - -(software-type-translation "BSD UNIX" "mach") ; "unix" -(software-type-translation "Ultrix" "mach") ; "ultrix" -(software-type-translation "SunOS" "SunOS") -(software-type-translation "MACH/4.3BSD" "mach") - -;;; ******************************** -;;; System Names ******************* -;;; ******************************** -(defun canonicalize-system-name (name) - ;; Names of modules or files may be symbols or strings, but - ;; names of systems must be symbols for accessing the system. - (if (symbolp name) - name - (intern (string-upcase (string name))))) - -(defun get-system (name) - ;; The system definition is stored under the - ;; 'system property of the system name. - (get (canonicalize-system-name name) 'system)) - -(defsetf get-system (name) (value) - `(setf (get (canonicalize-system-name ,name) 'system) ,value)) - -;;; ******************************** -;;; Directory Pathname Hacking ***** -;;; ******************************** - -;;; There is no CL primitive for tacking a subdirectory onto a directory. -;;; Such a primitive is needed since we use both absolute and relative -;;; directories. The merge-directories function was a try that failed -;;; (we're keeping it around to prevent future mistakes of that sort), -;;; while the append-directories function seems to work right most -;;; of the time (i.e., it gets the pathname delimiters right). - -;;; Unix example: An absolute directory starts with / while a -;;; relative directory doesn't. A directory ends with /, while -;;; a file's pathname doesn't. This is important 'cause -;;; (pathname-directory "foo/bar") will return "foo" and not "foo/". - -(defun append-directories (absolute-directory relative-directory) - ;; Assumptions: Absolute-directory is a directory, with no - ;; filename stuck on the end. Relative-directory, however, may - ;; have a filename stuck on the end. - (when (or absolute-directory relative-directory) - #+ExCL(when (and (stringp absolute-directory) - (null-string absolute-directory)) - (setq absolute-directory nil)) - #+CMU(when (pathnamep absolute-directory) - (setq absolute-directory (namestring absolute-directory))) - #+CMU(when (pathnamep relative-directory) - (setq relative-directory (namestring relative-directory))) - (namestring (make-pathname :directory absolute-directory - :name relative-directory)))) - -(defun null-string (s) - (string-equal s "")) - -#| -<cl> (defun d (d n) (namestring (make-pathname :directory d :name n))) - -D -<cl> (d "/foo/bar/" "baz/barf.lisp") - -"/foo/bar/baz/barf.lisp" -<cl> (d "foo/bar/" "baz/barf.lisp") - -"foo/bar/baz/barf.lisp" -<cl> (d "foo/bar" "baz/barf.lisp") - -"foo/bar/baz/barf.lisp" -<cl> (d "foo/bar" "/baz/barf.lisp") - -"foo/bar//baz/barf.lisp" -<cl> (d "foo/bar" nil) - -"foo/bar/" -<cl> (d nil "baz/barf.lisp") - -"baz/barf.lisp" -<cl> (d nil nil) - -"" - -|# - -#| -(defun merge-directories (absolute-directory relative-directory) - ;; replace concatenate with something more intelligent - ;; i.e., concatenation won't work with some directories. - ;; it should also behave well if the parent directory - ;; has a filename at the end, or if the relative-directory ain't relative - (when absolute-directory - (setq absolute-directory (pathname-directory absolute-directory))) - (concatenate 'string - (or absolute-directory "") - (or relative-directory ""))) -|# - -(defun namestring-or-nil (pathname) - (when pathname - (namestring pathname))) - -(defun new-file-type (pathname type) - (make-pathname - :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (pathname-directory pathname) - :name (pathname-name pathname) - :type type - :version (pathname-version pathname))) - -;;; ******************************** -;;; Component Defstruct ************ -;;; ******************************** -(defstruct (topological-sort-node (:conc-name topsort-)) - color - time) - -(defstruct (component (:include topological-sort-node) - (:print-function print-component)) - type ; :system, :module, or :file, or :private-file - name ; a symbol or string - indent ; number of characters of indent in verbose output to the user. - host ; the pathname host (i.e., "/../a") - device ; the pathname device - source-root-dir - source-pathname ; relative or absolute (starts with "/"), directory or file (ends with "/") - source-extension ; a string, e.g., "lisp". If nil, uses default for machine-type - binary-pathname - binary-root-dir - binary-extension ; a string, e.g., "fasl". If nil, uses default for machine-type - package ; package for use-package - components ; a list of components comprising this component's definition - depends-on ; a list of the components this one depends on. may refer only - ; to the components at the same level as this one. - initially-do ; form to evaluate before the operation - finally-do ; form to evaluate after the operation - compile-form ; for foreign libraries - load-form ; for foreign libraries -) - -(defun print-component (component stream depth) - (declare (ignore depth)) - (format stream "#<~:(~A~) ~A>" - (component-type component) - (component-name component))) - -(defun canonicalize-component-name (component) - ;; Within the component, the name is a string. - (if (typep (component-name component) 'string) - ;; Unnecessary to change it, so just return it, same case - (component-name component) - ;; Otherwise, make it a downcase string - (setf (component-name component) - (string-downcase (string (component-name component)))))) - -(defun component-pathname (component type) - (when component - (case type - (:source (component-source-pathname component)) - (:binary (component-binary-pathname component)) - (:error (component-error-pathname component))))) -(defun component-error-pathname (component) - (let ((binary (component-pathname component :binary))) - (new-file-type binary *compile-error-file-type*))) -(defsetf component-pathname (component type) (value) - `(when ,component - (case ,type - (:source (setf (component-source-pathname ,component) ,value)) - (:binary (setf (component-binary-pathname ,component) ,value))))) - -(defun component-root-dir (component type) - (when component - (case type - (:source (component-source-root-dir component)) - ((:binary :error) (component-binary-root-dir component)) - ))) -(defsetf component-root-dir (component type) (value) - `(when ,component - (case ,type - (:source (setf (component-source-root-dir ,component) ,value)) - (:binary (setf (component-binary-root-dir ,component) ,value))))) - -(defvar *version-dir* nil - "The version subdir. bound in oos.") -(defvar *version-replace* nil - "The version replace. bound in oos.") -(defvar *version* nil - "Default version") -(defun component-full-pathname (component type &optional (version *version*) - &aux version-dir replace) - (when component - ;; If the pathname-type is :binary and the root pathname is null, - ;; distribute the binaries among the sources (= use :source pathname). - ;; This assumes that the component's :source pathname has been set - ;; before the :binary one. - (if version - (multiple-value-setq (version-dir replace) (translate-version version)) - (setq version-dir *version-dir* replace *version-replace*)) - (let ((pathname - (append-directories - (if replace - version-dir - (append-directories (component-root-dir component type) - version-dir)) - (component-pathname component type)))) - (make-pathname :name (pathname-name pathname) - :type (component-extension component type) - :host (pathname-host (component-host component)) - :device #+CMU :absolute - #-CMU (pathname-device (component-device component)) - ;; :version :newest - ;; Use :directory instead of :defaults - :directory (pathname-directory pathname))))) - -(defun translate-version (version) - ;; Value returns the version directory and whether it replaces - ;; the entire root (t) or is a subdirectory. - ;; Version may be nil to signify no subdirectory, - ;; a symbol, such as alpha, beta, omega, :alpha, mark, which - ;; specifies a subdirectory of the root, or - ;; a string, which replaces the root. - (cond ((null version) - (values "" nil)) - ((symbolp version) - (values (string-downcase (string version)) nil)) - ((stringp version) - (values version t)) - (t (error "~&; Illegal version ~S" version)))) - -(defun component-extension (component type) - (case type - (:source (component-source-extension component)) - (:binary (component-binary-extension component)) - (:error *compile-error-file-type*))) -(defsetf component-extension (component type) (value) - `(case ,type - (:source (setf (component-source-extension ,component) ,value)) - (:binary (setf (component-binary-extension ,component) ,value)) - (:error (setf *compile-error-file-type* ,value)))) - -;;; ******************************** -;;; System Definition ************** -;;; ******************************** -(defmacro defsystem (name &rest definition-body) - `(create-component :system ',name ',definition-body nil 0)) - -(defun create-component (type name definition-body &optional parent (indent 0)) - (let ((component (apply #'make-component :type type :name name :indent indent definition-body))) - ;; Initializations/after makes - (canonicalize-component-name component) - - ;; Type specific setup: - (when (eq type :system) - (setf (get-system name) component)) - - ;; Set up the component's pathname - (create-component-pathnames component parent) - - ;; If there are any components of the component, expand them too. - (expand-component-components component (+ indent 2)) - - ;; Make depends-on refer to structs instead of names. - (link-component-depends-on (component-components component)) - - ;; Design Decision: Topologically sort the dependency graph at - ;; time of definition instead of at time of use. Probably saves a - ;; little bit of time for the user. - - ;; Topological Sort the components at this level. - (setf (component-components component) - (topological-sort (component-components component))) - - ;; Return the component. - component)) - -(defun create-component-pathnames (component parent) - ;; Evaluate the root dir arg - (setf (component-root-dir component :source) - (eval (component-root-dir component :source))) - (setf (component-root-dir component :binary) - (eval (component-root-dir component :binary))) - ;; Evaluate the pathname arg - (setf (component-pathname component :source) - (eval (component-pathname component :source))) - (setf (component-pathname component :binary) - (eval (component-pathname component :binary))) - ;; Pass along the host and devices - (setf (component-host component) - (or (component-host component) - (when parent (component-host parent)))) - (setf (component-device component) - (or (component-device component) - (when parent (component-device parent)))) - ;; Set up extension defaults - (setf (component-extension component :source) - (or (component-extension component :source) ; for local defaulting - (when parent ; parent's default - (component-extension parent :source)) - (car *filename-extensions*))) ; system default - (setf (component-extension component :binary) - (or (component-extension component :binary) ; for local defaulting - (when parent ; parent's default - (component-extension parent :binary)) - (cdr *filename-extensions*))) ; system default - ;; Set up pathname defaults -- expand with parent - ;; We must set up the source pathname before the binary pathname - ;; to allow distribution of binaries among the sources to work. - (generate-component-pathname component parent :source) - (generate-component-pathname component parent :binary)) - -;; maybe file's inheriting of pathnames should be moved elsewhere? -(defun generate-component-pathname (component parent pathname-type) - ;; Pieces together a pathname for the component based on its component-type. - ;; Assumes source defined first. - ;; Null binary pathnames inherit from source instead of the component's - ;; name. This allows binaries to be distributed among the source if - ;; binary pathnames are not specified. Or if the root directory is - ;; specified for binaries, but no module directories, it inherits - ;; parallel directory structure. - (case (component-type component) - (:system ; Absolute Pathname - ;; Set the root-dir to be the absolute pathname - (setf (component-root-dir component pathname-type) - (or (component-pathname component pathname-type) - (when (eq pathname-type :binary) - ;; When the binary root is nil, use source. - (component-root-dir component :source))) ) - ;; Set the relative pathname to be nil - (setf (component-pathname component pathname-type) - nil));; should this be "" instead? - ;; If the name of the component-pathname is nil, it - ;; defaults to the name of the component. Use "" to - ;; avoid this defaulting. - (:private-file ; Absolute Pathname - ;; Root-dir is the directory part of the pathname - (setf (component-root-dir component pathname-type) - "" - #+ignore(or (when (component-pathname component pathname-type) - (pathname-directory - (component-pathname component pathname-type))) - (when (eq pathname-type :binary) - ;; When the binary root is nil, use source. - (component-root-dir component :source))) - ) - ;; The relative pathname is the name part - (setf (component-pathname component pathname-type) - (or (when (and (eq pathname-type :binary) - (null (component-pathname component :binary))) - ;; When the binary-pathname is nil use source. - (component-pathname component :source)) - (or (when (component-pathname component pathname-type) -; (pathname-name ) - (component-pathname component pathname-type)) - (component-name component))))) - (:module ; Pathname relative to parent. - ;; Inherit root-dir from parent - (setf (component-root-dir component pathname-type) - (component-root-dir parent pathname-type)) - ;; Tack the relative-dir onto the pathname - (setf (component-pathname component pathname-type) - (or (when (and (eq pathname-type :binary) - (null (component-pathname component :binary))) - ;; When the binary-pathname is nil use source. - (component-pathname component :source)) - (append-directories - (component-pathname parent pathname-type) - (or (component-pathname component pathname-type) - (component-name component)))))) - (:file ; Pathname relative to parent. - ;; Inherit root-dir from parent - (setf (component-root-dir component pathname-type) - (component-root-dir parent pathname-type)) - ;; Tack the relative-dir onto the pathname - (setf (component-pathname component pathname-type) - (or (append-directories - (component-pathname parent pathname-type) - (or (component-pathname component pathname-type) - (component-name component) - (when (eq pathname-type :binary) - ;; When the binary-pathname is nil use source. - (component-pathname component :source))))))) - )) - -(defun expand-component-components (component &optional (indent 0)) - (setf (component-components component) - (mapcar #'(lambda (definition) - (expand-component-definition definition component indent)) - (component-components component)))) - -(defun expand-component-definition (definition parent &optional (indent 0)) - ;; Should do some checking for malformed definitions here. - (cond ((null definition) nil) - ((stringp definition) - ;; Strings are assumed to be of type :file - (create-component :file definition nil parent indent)) - ((and (listp definition) - (not (member (car definition) - '(:system :module :file :private-file)))) - ;; Lists whose first element is not a component type - ;; are assumed to be of type :file - (create-component :file (car definition) (cdr definition) parent indent)) - ((listp definition) - ;; Otherwise, it is (we hope) a normal form definition - (create-component (car definition) ; type - (cadr definition) ; name - (cddr definition) ; definition body - parent ; parent - indent) ; indent - ))) - -(defun link-component-depends-on (components) - (dolist (component components) - (unless (and *system-dependencies-delayed* - (eq (component-type component) :system)) - (setf (component-depends-on component) - (mapcar #'(lambda (dependency) - (find (string dependency) components :key #'component-name - :test #'string-equal)) - (component-depends-on component)))))) - -;;; ******************************** -;;; Topological Sort the Graph ***** -;;; ******************************** -(defun topological-sort (list &aux (time 0)) - ;; The algorithm works by calling depth-first-search to compute the - ;; blackening times for each vertex, and then sorts the vertices into - ;; reverse order by blackening time. - (labels ((dfs-visit (node) - (setf (topsort-color node) 'gray) - (unless (and *system-dependencies-delayed* - (eq (component-type node) :system)) - (dolist (child (component-depends-on node)) - (cond ((eq (topsort-color child) 'white) - (dfs-visit child)) - ((eq (topsort-color child) 'gray) - (format t "~&Detected cycle containing ~A" child))))) - (setf (topsort-color node) 'black) - (setf (topsort-time node) time) - (incf time))) - (dolist (node list) - (setf (topsort-color node) 'white)) - (dolist (node list) - (when (eq (topsort-color node) 'white) - (dfs-visit node))) - (sort list #'< :key #'topsort-time))) - -;;; ******************************** -;;; Output to User ***************** -;;; ******************************** -;;; All output to the user is via the tell-user functions. - -(defun split-string (string &key (item #\space) (test #'char=)) - ;; Splits the string into substrings at spaces. - (let ((len (length string)) - (index 0) result) - (dotimes (i len - (progn (unless (= index len) - (push (subseq string index) result)) - (reverse result))) - (when (funcall test (char string i) item) - (unless (= index i);; two spaces in a row - (push (subseq string index i) result)) - (setf index (1+ i)))))) - -(defun prompt-string (component) - (format nil "; ~:[~;TEST:~]~V,@T " - *oos-test* - (component-indent component))) - -(defun format-justified-string (prompt contents) - (format t (concatenate 'string "~%" prompt "-~{~<~%" prompt " ~1,80:; ~A~>~^~}") - (split-string contents)) - (finish-output *standard-output*)) - -(defun tell-user (what component &optional type no-dots force) - (when (or *oos-verbose* force) - (format-justified-string (prompt-string component) - (format nil "~A ~(~A~) ~@[\"~A\"~] ~:[~;...~]" - (case what - ((compile :compile) "Compiling") - ((load :load) "Loading") - (otherwise what)) - (component-type component) - (or (when type - (namestring-or-nil (component-full-pathname - component type))) - (component-name component)) - (and *tell-user-when-done* - (not no-dots)))))) - -(defun tell-user-done (component &optional force no-dots) - ;; test is no longer really used, but we're leaving it in. - (when (and *tell-user-when-done* - (or *oos-verbose* force)) - (format t "~&~A~:[~;...~] Done." - (prompt-string component) (not no-dots)) - (finish-output *standard-output*))) - -(defmacro with-tell-user ((what component &optional type no-dots force) &body body) - `(progn - (tell-user ,what ,component ,type ,no-dots ,force) - ,@body - (tell-user-done ,component ,force ,no-dots))) - -(defun tell-user-no-files (component &optional force) - (when (or *oos-verbose* force) - (format-justified-string (prompt-string component) - (format nil "Binary file ~A ~ - ~:[and source file ~A do~;does~] not exist, not loading." - (namestring (component-full-pathname component :binary)) - (or *load-source-if-no-binary* *load-source-instead-of-binary*) - (namestring (component-full-pathname component :source)))))) - -(defun tell-user-require-system (name parent) - (when *oos-verbose* - (format t "~&; ~:[~;TEST:~] - System ~A requires ~S" - *oos-test* (component-name parent) name) - (finish-output *standard-output*))) - -(defun tell-user-generic (string) - (when *oos-verbose* - (format t "~&; ~:[~;TEST:~] - ~A" - *oos-test* string) - (finish-output *standard-output*))) - -;;; ******************************** -;;; Y-OR-N-P-WAIT ****************** -;;; ******************************** -;;; y-or-n-p-wait is like y-or-n-p, but will timeout -;;; after a specified number of seconds -(defun internal-real-time-in-seconds () - (float (/ (get-internal-real-time) - internal-time-units-per-second))) - -(defun read-char-wait (&optional (timeout 20) input-stream &aux char) - (do ((start (internal-real-time-in-seconds))) - ((or (setq char (read-char-no-hang input-stream)) ;(listen *query-io*) - (< (+ start timeout) (internal-real-time-in-seconds))) - char))) - -(defun y-or-n-p-wait (&optional (default #\y) (timeout 20) - format-string &rest args) - (clear-input *query-io*) - (format *query-io* "~&~?" (or format-string "") args) - (finish-output *query-io*);; needed for CMU and other places - (let* ((read-char (read-char-wait timeout *query-io*)) - (char (or read-char default))) - (clear-input *query-io*) - (when (null read-char) (format *query-io* "~@[~A~]" default)) - (cond ((null char) t) - ((find char '(#\y #\Y #\space) :test #'char=) t) - ((find char '(#\n #\N) :test #'char=) nil) - (t (y-or-n-p-wait default timeout - "Type \"y\" for yes or \"n\" for no. "))))) - -(defvar *use-timeouts* t) - -(defun y-or-n-p-wait-optional (&optional (default #\y) (timeout 20) - format-string &rest args) - (cond ((and default - *use-timeouts*) - (apply 'y-or-n-p-wait default timeout format-string args)) - (t (apply 'y-or-n-p format-string args)))) - -#| -(y-or-n-p-wait #\y 20 "What? ") -(progn (format t "~&hi") - (y-or-n-p-wait #\y 10 "1? ") - (y-or-n-p-wait #\n 10 "2? ")) -|# -;;; ******************************** -;;; Operate on System ************** -;;; ******************************** -;;; Operate-on-system -;; Operation is :compile, 'compile, :load or 'load -;; Force is :all or :new-source or :new-source-and-dependents or a list of -;; specific modules. -;; :all (or T) forces a recompilation of every file in the system -;; :new-source-and-dependents compiles only those files whose -;; sources have changed or who depend on recompiled files. -;; :new-source compiles only those files whose sources have changed -;; A list of modules means that only those modules and their dependents are recompiled. -;; Test is T to print out what it would do without actually doing it. -;; Note: it automatically sets verbose to T if test is T. -;; Verbose is T to print out what it is doing (compiling, loading of -;; modules and files) as it does it. -;; Dribble should be the pathname of the dribble file if you want to -;; dribble the compilation. -;; Load-source-instead-of-binary is T to load .lisp instead of binary files. -;; Version may be nil to signify no subdirectory, -;; a symbol, such as alpha, beta, omega, :alpha, mark, which -;; specifies a subdirectory of the root, or -;; a string, which replaces the root. -(defun operate-on-system (name operation &key force - (version *version*) - (test *oos-test*) (verbose *oos-verbose*) - (load-source-instead-of-binary *load-source-instead-of-binary*) - (load-source-if-no-binary *load-source-if-no-binary*) - (bother-user-if-no-binary *bother-user-if-no-binary*) - dribble) - (when dribble (dribble dribble)) - (when test (setq verbose t)) - (when (null force);; defaults - (case operation - ((load :load) (setq force :all)) - ((compile :compile) (setq force :new-source-and-dependents)))) - ;; Some CL implementations have a variable called *compile-verbose* - (multiple-value-bind (*version-dir* *version-replace*) - (translate-version version) - (let ((*load-verbose* nil);; CL implementations may uniformly default this to nil - (*version* version) - (*oos-verbose* verbose) - (*oos-test* test) - (*load-source-if-no-binary* load-source-if-no-binary) - (*bother-user-if-no-binary* bother-user-if-no-binary) - (*load-source-instead-of-binary* load-source-instead-of-binary) - (system (get-system name))) - (unless system (error "Can't find system named ~A." name)) - (unless (component-operation operation) (error "Operation ~A undefined." operation)) - (operate-on-component system operation force))) - (when dribble (dribble))) - -(defun operate-on-component (component operation force &aux changed) - ;; Returns T if something changed and had to be compiled. - (let ((type (component-type component)) - ;; Use the correct package. - #+ignore(*package* - (or (when (component-package component) - (tell-user-generic (format nil "Using package ~A" - (component-package component))) - (cond (*oos-test* *package*) - (t (find-package (component-package component))))) - *package*)) -) - (when (component-package component) - (tell-user-generic (format nil "Using package ~A" - (component-package component))) - (cond (*oos-test* *package*) - (t (unless (find-package (component-package component)) - (require (component-package component))) - (use-package (component-package component))))) - - ;; Load any required systems - (when (eq type :system) - (operate-on-system-dependencies component)) - - ;; Do any initial actions - (when (component-initially-do component) - (tell-user-generic (format nil "Doing initializations for ~A" - (component-name component))) - (or *oos-test* - (eval (component-initially-do component)))) - - ;; Do operation and set changed flag if necessary. - (setq changed - (case type - ((:file :private-file) - (funcall (component-operation operation) component force)) - ((:module :system) - (operate-on-components component operation force changed)))) - - ;; Do any final actions - (when (component-finally-do component) - (tell-user-generic (format nil "Doing finalizations for ~A" - (component-name component))) - (or *oos-test* - (eval (component-finally-do component)))) - - ;; Provide the loaded system - (when (eq type :system) - (tell-user-generic (format nil "Providing system ~A" - (component-name component))) - (or *oos-test* - (provide (canonicalize-system-name (component-name component)))))) - - ;; Return t if something changed in this component and hence had to be recompiled. - changed) - -(defun operate-on-system-dependencies (component) - (when *system-dependencies-delayed* - (dolist (system (component-depends-on component)) - ;; For each system that this system depends on, - ;; runs require (my version) on that system to load it. - ;; Explores the system tree in a DFS manner. - (cond ((listp system) - (tell-user-require-system - (cond ((and (null (car system)) (null (cadr system))) - (caddr system)) - (t system)) - component) - (or *oos-test* (require (car system) nil - (eval (cadr system)) - (caddr system) - (or (car (cdddr system)) - *version*)))) - (t - (tell-user-require-system system component) - (or *oos-test* (require system)))) - ))) - -(defun operate-on-components (component operation force changed) - (with-tell-user (operation component) - (if (component-components component) - (dolist (module (component-components component)) - (when (operate-on-component module operation - (cond ((and (some #'(lambda (dependent) - (member dependent changed)) - (component-depends-on module)) - (or (non-empty-listp force) - (eq force :new-source-and-dependents))) - ;; The component depends on a changed file - ;; and force agrees. - (if (eq force :new-source-and-dependents) - :new-source-all - :all)) - ((and (non-empty-listp force) - (member (component-name module) force - :test #'string-equal :key #'string)) - ;; Force is a list of modules - ;; and the component is one of them. - :all) - (t force))) - (push module changed))) - (case operation - ((compile :compile) - (eval (component-compile-form component))) - ((load :load) - (eval (component-load-form component)))))) - changed) - -;;; ******************************** -;;; Component Operations *********** -;;; ******************************** -;;; Define :compile/compile and :load/load operations -(component-operation :compile 'compile-and-load-operation) -(component-operation 'compile 'compile-and-load-operation) -(component-operation :load 'load-file-operation) -(component-operation 'load 'load-file-operation) - -(defun compile-and-load-operation (component force) - (let ((changed (compile-file-operation component force))) - (load-file-operation component changed) - changed)) - -(defun compile-file-operation (component force) - ;; Returns T if the file had to be compiled. - (let ((must-compile - (or (find force '(:all :new-source-all t) :test #'eq) - (and (find force '(:new-source :new-source-and-dependents) - :test #'eq) - (needs-compilation component))))) - - (cond ((and must-compile - (probe-file (component-full-pathname component :source))) - (with-tell-user ("Compiling source" component :source) - (or *oos-test* - (compile-file (component-full-pathname component :source) - :output-file (component-full-pathname component :binary) - #+CMU :error-file #+CMU (and *cmu-errors-to-file* - (component-full-pathname component :error)) - #+CMU :errors-to-terminal #+CMU *cmu-errors-to-terminal* - ))) - must-compile) - (must-compile - (tell-user "Source file not found. Not compiling" - component :source :no-dots :force) - nil) - (t nil)))) - -(defun needs-compilation (component) - ;; If there is no binary, or it is older than the source - ;; file, then the component needs to be compiled. - ;; Otherwise we only need to recompile if it depends on a file that changed. - (or - ;; no binary - (null (probe-file (component-full-pathname component :binary))) - ;; old binary - (< (file-write-date (component-full-pathname component :binary)) - (file-write-date (component-full-pathname component :source))))) - -(defun load-file-operation (component force) - ;; Returns T if the file had to be loaded - (let ((load-source - (or *load-source-instead-of-binary* - (and (find force '(:new-source :new-source-and-dependents - :new-source-all) - :test #'eq) - (needs-compilation component)))) - (load-binary - (or (find force '(:all :new-source-all t) :test #'eq) ; Force load. - ;; :new-source* and binary up to date - (find force '(:new-source :new-source-and-dependents) - :test #'eq)))) - - (cond ((and load-source - (probe-file (component-full-pathname component :source))) - (with-tell-user ("Loading source" component :source) - (or *oos-test* - (load (component-full-pathname component :source)))) - T) - ((and load-binary - (probe-file (component-full-pathname component :binary))) - (with-tell-user ("Loading binary" component :binary) - (or *oos-test* - (load (component-full-pathname component :binary)))) - T) - ((and load-binary - (probe-file (component-full-pathname component :source)) - (load-source-if-no-binary component)) - (with-tell-user ("Loading source" component :source) - (or *oos-test* - (load (component-full-pathname component :source)))) - T) - ((or load-source load-binary) - (tell-user-no-files component :force) - nil) - (t nil)))) - - -;; when the operation = :compile, we can assume the binary exists in test mode. -;; ((and *oos-test* -;; (eq operation :compile) -;; (probe-file (component-full-pathname component :source))) -;; (with-tell-user ("Loading binary" component :binary))) - -(defun load-source-if-no-binary (component) - (and (not *load-source-instead-of-binary*) - (or *load-source-if-no-binary* - (when *bother-user-if-no-binary* - (let* ((prompt (prompt-string component)) - (load-source - (y-or-n-p-wait-optional - #\y 30 - "~A- Binary file ~A does not exist. ~ - ~&~A Load source file ~A instead? " - prompt - (namestring (component-full-pathname component :binary)) - prompt - (namestring (component-full-pathname component :source))))) - (setq *bother-user-if-no-binary* - (y-or-n-p-wait-optional - #\n 30 - "~A- Should I bother you if this happens again? " - prompt )) - (unless *bother-user-if-no-binary* - (setq *load-source-if-no-binary* load-source)) - load-source))))) - -;;; ******************************** -;;; New Require ******************** -;;; ******************************** -(defun compute-system-path (module-name definition-pname) - (let* ((filename (format nil "~A.system" - (if (symbolp module-name) - (string-downcase (string module-name)) - module-name)))) - (or (when definition-pname ; given pathname for system def - (probe-file definition-pname)) - (probe-file filename) ; try current dir - (probe-file (append-directories *central-registry* filename))) ; central registry - )) - -(unless (fboundp 'old-require) - (setf (symbol-function 'old-require) (symbol-function 'lisp:require)) - - (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil)) - (defun lisp:require (module-name &optional pathname definition-pname - default-action (version *version*) - &aux system-path) - ;; If the pathname is present, this behaves like the old require. - (unless (and module-name - (find #-CMU (string module-name) - #+CMU (string-downcase (string module-name)) - *modules* :test #'string=)) - (cond (pathname - (funcall 'old-require module-name pathname)) - ;; If the system is defined, load it. - ((or (get-system module-name) - (and (setq system-path - (compute-system-path module-name definition-pname)) - (load system-path) - (get-system module-name))) - (operate-on-system module-name :load - :version version - :test *oos-test* - :verbose *oos-verbose* - :load-source-if-no-binary *load-source-if-no-binary* - :bother-user-if-no-binary *bother-user-if-no-binary* - :load-source-instead-of-binary *load-source-instead-of-binary*)) - ;; If there's a default action, do it. This could be a progn which - ;; loads a file that does everything. - ((and default-action - (eval default-action))) - ;; If no system definition file, try regular require. - ((funcall 'old-require module-name pathname)) - ;; If no default action, print a warning or error message. - (t - (format t "~&Warning: System ~A doesn't seem to be defined..." module-name)) - ))))) - -;;; ******************************** -;;; Allegro Make System Fasl ******* -;;; ******************************** -#+:excl -(defun allegro-make-system-fasl (system destination) - (excl:shell - (format nil "rm -f ~A; cat~{ ~A~} > ~A" - destination - (mapcar #'namestring - (files-in-system system :all :binary))))) - -(defun files-which-need-compilation (system) - (mapcar #'(lambda (comp) (namestring (component-full-pathname comp :source))) - (remove nil - (file-components-in-component - (get-system system) :new-source)))) - -(defun files-in-system (name &optional (force :all) (type :source) version - &aux system) - ;; Returns a list of the pathnames in system in load order. - (setq system (get-system name)) - (unless system (error "Can't find system named ~A." name)) - (multiple-value-bind (*version-dir* *version-replace*) - (translate-version version) - (let ((*version* version)) - (file-pathnames-in-component system type force)))) - -(defun file-pathnames-in-component (component type &optional (force :all)) - (mapcar #'(lambda (comp) (component-full-pathname comp type)) - (file-components-in-component component force))) - -(defun file-components-in-component (component &optional (force :all) - &aux result changed) - (case (component-type component) - ((:file :private-file) - (when (setq changed - (or (find force '(:all t) :test #'eq) - (and (not (non-empty-listp force)) - (needs-compilation component)))) - (setq result - (list component)))) - ((:module :system) - (dolist (module (component-components component)) - (multiple-value-bind (r c) - (file-components-in-component - module - (cond ((and (some #'(lambda (dependent) - (member dependent changed)) - (component-depends-on module)) - (or (non-empty-listp force) - (eq force :new-source-and-dependents))) - ;; The component depends on a changed file and force agrees. - :all) - ((and (non-empty-listp force) - (member (component-name module) force - :test #'string-equal :key #'string)) - ;; Force is a list of modules and the component is one of them. - :all) - (t force))) - (when c - (push module changed) - (setq result (append result r))))))) - (values result changed)) - -(setf (symbol-function 'oos) (symbol-function 'operate-on-system)) - -;;; *END OF FILE* diff --git a/contrib/defsystem/defsystem.ps b/contrib/defsystem/defsystem.ps deleted file mode 100644 index a6daf15fac2a874bfd015fd51e6c60e97d78258c..0000000000000000000000000000000000000000 --- a/contrib/defsystem/defsystem.ps +++ /dev/null @@ -1,1118 +0,0 @@ -%!PS-Adobe-1.0 -%%Title: defsystem.mss -%%DocumentFonts: (atend) -%%Creator: Mark Kantrowitz and Scribe 6(1600) -%%CreationDate: 31 January 1990 12:40 -%%Pages: (atend) -%%EndComments -% PostScript Prelude for Scribe. -/BS {/SV save def 0.0 792.0 translate .01 -.01 scale} bind def -/ES {showpage SV restore} bind def -/SC {setrgbcolor} bind def -/FMTX matrix def -/RDF {WFT SLT 0.0 eq - {SSZ 0.0 0.0 SSZ neg 0.0 0.0 FMTX astore} - {SSZ 0.0 SLT neg sin SLT cos div SSZ mul SSZ neg 0.0 0.0 FMTX astore} - ifelse makefont setfont} bind def -/SLT 0.0 def -/SI { /SLT exch cvr def RDF} bind def -/WFT /Courier findfont def -/SF { /WFT exch findfont def RDF} bind def -/SSZ 1000.0 def -/SS { /SSZ exch 100.0 mul def RDF} bind def -/AF { /WFT exch findfont def /SSZ exch 100.0 mul def RDF} bind def -/MT /moveto load def -/XM {currentpoint exch pop moveto} bind def -/UL {gsave newpath moveto dup 2.0 div 0.0 exch rmoveto - setlinewidth 0.0 rlineto stroke grestore} bind def -/LH {gsave newpath moveto setlinewidth - 0.0 rlineto - gsave stroke grestore} bind def -/LV {gsave newpath moveto setlinewidth - 0.0 exch rlineto - gsave stroke grestore} bind def -/BX {gsave newpath moveto setlinewidth - exch - dup 0.0 rlineto - exch 0.0 exch neg rlineto - neg 0.0 rlineto - closepath - gsave stroke grestore} bind def -/BX1 {grestore} bind def -/BX2 {setlinewidth 1 setgray stroke grestore} bind def -/PB {/PV save def newpath translate - 100.0 -100.0 scale pop /showpage {} def} bind def -/PE {PV restore} bind def -/GB {/PV save def newpath translate rotate - div dup scale 100.0 -100.0 scale /showpage {} def} bind def -/GE {PV restore} bind def -/FB {dict dup /FontMapDict exch def begin} bind def -/FM {cvn exch cvn exch def} bind def -/FE {end /original-findfont /findfont load def /findfont - {dup FontMapDict exch known{FontMapDict exch get} if - original-findfont} def} bind def -/BC {gsave moveto dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto closepath clip} bind def -/EC /grestore load def -/SH /show load def -/MX {exch show 0.0 rmoveto} bind def -/W {0 32 4 -1 roll widthshow} bind def -/WX {0 32 5 -1 roll widthshow 0.0 rmoveto} bind def -%%EndProlog -%%Page: 1 1 -BS -0 SI -15 /Helvetica-Bold AF -11090 8294 MT -(Defsystem: A Portable Make Facility for Common Lisp)SH -13 SS -24641 15620 MT -(by Mark Kantrowitz)SH -21752 19236 MT -(School of Computer Science)SH -22256 22852 MT -(Carnegie Mellon University)SH -26480 26468 MT -(January 1990)SH -12 SS -7200 32344 MT -(Introduction)SH -10 /Helvetica AF -7200 35777 MT -(This document describes the defsystem system definition macro, a portable "Make" facility for) -87 W( Common)86 W -7200 37297 MT -(Lisp.)SH -7200 40793 MT -(Support is provided for organizing systems into hierarchical layers of modules, with matching directory)133 W -7200 42313 MT -(structure. Moreover, the components of the system may be listed in any order) -49 W( the user desires, because)48 W -7200 43833 MT -(the defsystem command reorganizes them according) -69 W( to the file-dependency constraints specified by the)70 W -7200 45353 MT -(user. Since it accomplishes this by performing a topological sort of the constraint-graph,) -351 W( cyclical)350 W -7200 46873 MT -(dependencies are not supported \050the graph must be a DAG\051.)SH -7200 50369 MT -(Only two operations, compile and load, are currently defined. The) -87 W( interface for defining new operations,)88 W -7200 51889 MT -(however, is simple and extendible.)SH -7200 55385 MT -(Though home-grown, the syntax was inspired by fond) -108 W( memories of the defsystem facility on Symbolics)107 W -7200 56905 MT -(3600 series lisp) -100 W( machines. The exhaustive lists of filename extensions for various lisps and the idea to)101 W -7200 58425 MT -(have one)240 W -/Helvetica-Oblique SF -12072 XM -(operate-on-system)SH -/Helvetica SF -20925 XM -(function instead of separate)239 W -/Helvetica-Oblique SF -34444 XM -(compile-system)SH -/Helvetica SF -41906 XM -(and)SH -/Helvetica-Oblique SF -44091 XM -(load-system)SH -/Helvetica SF -49998 XM -(functions)SH -7200 59945 MT -(were taken from Xerox Corporation's PCL \050Portable Common Loops\051 system.)SH -7200 63441 MT -(The code for the defsystem facility and this documentation may be found in the files)SH -11648 65030 MT -(/afs/cs.cmu.edu/user/mkant/Defsystem/defsystem.{text,lisp})SH -7200 68526 MT -(Please send bug reports, comments and suggestions to mkant@cs.cmu.edu.)SH -ES -%%Page: 2 2 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(2)SH -12 SS -7200 8075 MT -(Using the System)SH -10 /Helvetica AF -7200 11508 MT -(To use this system,)SH -9424 12909 MT -(1.)SH -10536 XM -(If you want to have a central) -55 W( directory where system definition files will be kept, modify the)56 W -10536 14052 MT -(value of *central-registry* in defsystem.lisp to be the pathname of that directory.)SH -9424 15867 MT -(2.)SH -10536 XM -(Save and load the file defsystem.lisp)SH -9424 17682 MT -(3.)SH -10536 XM -(Load the) -235 W( file containing the defsystem form defining your system. If the name of your)234 W -10536 18825 MT -(system is foo, the) -43 W( file will be named "foo.system". [If you are going to load the system and)44 W -10536 19968 MT -(not compile it, you can use \050require "foo"\051) -10 W( to load it if the definition file is in either the current)9 W -10536 21111 MT -(directory or the central registry.])SH -9424 22926 MT -(4.)SH -10536 XM -(Use the function)60 W -/Helvetica-Oblique SF -18220 XM -(operate-on-system)SH -/Helvetica SF -26894 XM -(to do things to your system.) -60 W( For example \050operate-on-)61 W -10536 24069 MT -(system "foo" 'load\051 will load the system, while \050operate-on-system "foo" 'compile\051 will)306 W -10536 25212 MT -(compile it.)SH -12 /Helvetica-Bold AF -7200 29013 MT -(External Interface)SH -10 /Helvetica AF -7200 32446 MT -(The external interface to) -226 W( the defsystem facility are the defsystem macro and the operate-on-system)227 W -7200 33966 MT -(function. Defsystem is used to define a new system and operate-on-system) -43 W( to compile it and load it. The)42 W -7200 35486 MT -(definition of require has been modified to mesh well with systems) -104 W( defined using defsystem, and is fully)105 W -7200 37006 MT -(backward-compatible.)SH -7200 40502 MT -(In addition, the function) -107 W( afs-binary-directory has been provided for immitating the behavior of the @sys)106 W -7200 42022 MT -(feature of the Andrew File System on systems not) -123 W( running AFS. The @sys feature allows soft links to)124 W -7200 43542 MT -(point to different directories depending on) -86 W( which platform is accessing the files. A common setup would)85 W -7200 45062 MT -(be to have the bin directory soft linked to .bin/@sys and to have subdirectories of .bin corresponding) -84 W( to)85 W -7200 46582 MT -(each platform \050.bin/vax_mach, .bin/unix, .bin/pmax_mach, etc.\051. The afs-binary-directory) -81 W( function returns)80 W -7200 48102 MT -(the appropriate binary directory for use as the :binary-pathname) -99 W( argument in the defsystem macro. For)100 W -7200 49622 MT -(example, if we evaluate \050afs-binary-directory) -220 W( "foodir/"\051 on a vax running the Mach operating system,)219 W -7200 51142 MT -("foodir/.bin/vax_mach/" would be returned.)SH -12 /Helvetica-Bold AF -7200 54485 MT -(Defining Systems with Defsystem)SH -10 /Helvetica AF -7200 57918 MT -(A system is a set of components with associated properties. These properties include the type,) -126 W( name,)127 W -7200 59438 MT -(source and binary pathnames,) -523 W( package, component-dependencies, initializations, and a set of)522 W -7200 60958 MT -(components.)SH -7200 64454 MT -(Components may be of three types: :system, :module, or) -259 W( :file. Components of type :system have)260 W -7200 65974 MT -(absolute pathnames and are used to define a multi-system system. The) -93 W( toplevel system defined by the)92 W -7200 67494 MT -(defsystem macro) -174 W( is implicitly of type :system. Components of type :module have pathnames that are)175 W -7200 69014 MT -(relative to their containing system or module,) -89 W( and may contain a set of files and modules. This enables)88 W -7200 70534 MT -(one to define subsystems, subsubsystems, submodules, and so on.)SH -ES -%%Page: 3 3 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(3)SH -/Helvetica SF -7200 7929 MT -(Foreign systems \050systems defined using some other system definition tool\051, may be) -16 W( included by providing)17 W -7200 9449 MT -(separate compile and load forms for them \050using) -189 W( the :compile-form and :load-form keywords\051. These)188 W -7200 10969 MT -(forms will be run if and only if they are included in) -33 W( a module with no components. [In some future version)34 W -7200 12489 MT -(of the defsystem) -120 W( facility there will be new component types corresponding to each possible operation.])119 W -7200 14009 MT -(This is useful if it isn't possible to convert these systems to the defsystem format all at once.)SH -7200 17505 MT -(The name of a component may be a symbol or a string. For ease of access the definition) -29 W( of a system \050its)30 W -7200 19025 MT -(component\051 is stored under the system properties of the symbol corresponding to its uppercase name.) -28 W( If)332 W -7200 20545 MT -(the system name is a symbol, for all other purposes the name is converted to) -34 W( a lowercase string \050system)35 W -7200 22065 MT -(names that are strings are left alone\051. It is usually best to) -20 W( use the string version of a system's name when)19 W -7200 23585 MT -(defining or referring to it. A system defined as 'foo will) -16 W( have an internal name of "foo" and will be stored in)17 W -7200 25105 MT -(the file "foo.system". A system defined as "Foo" will have an internal name of "Foo" and) -52 W( will be stored in)51 W -7200 26625 MT -(the file "Foo.system".)SH -7200 30121 MT -(The absolute \050for components of type :system\051 and relative) -70 W( \050for all other components\051 pathnames of the)71 W -7200 31641 MT -(binary and source files may be specified using the :source-pathname and :binary-pathname keywords in)60 W -7200 33161 MT -(the component definition. The pathnames associated with a module correspond to subdirectories of the)94 W -7200 34681 MT -(containing module or system. If) -86 W( no binary pathname is specified, the binaries are distributed among the)85 W -7200 36201 MT -(sources. If no source pathname is given for a component, it defaults to the name of the) -9 W( component. Since)10 W -7200 37721 MT -(the names are converted to lowercase, pathnames must be provided for each component if) -26 W( the operating)25 W -7200 39241 MT -(system is) -244 W( case sensitive \050unless the pathnames are all lowercase\051. Similarly, if a module does not)245 W -7200 40761 MT -(correspond to a subdirectory, a null-string pathname \050""\051 must be provided.)SH -7200 44257 MT -(File types \050e.g., "lisp" and "fasl"\051 for source and binary files may be specified using the) -40 W( :source-extension)39 W -7200 45777 MT -(and :binary-extension keywords. If) -27 W( these are not specified or given as nil, the makes a reasonable choice)28 W -7200 47297 MT -(of defaults based on the machine type and underlying operating system. These) -28 W( file types are inherited by)27 W -7200 48817 MT -(the components of the system.)SH -7200 52313 MT -(At system definition time, every relative directory is replaced with the corresponding cumulative) -103 W( relative)104 W -7200 53833 MT -(pathname with all the components incorporated.)SH -7200 57329 MT -(One may also specify the package) -219 W( to be used and any initializations and finalizations. Initializations)218 W -7200 58849 MT -(\050specified with the keyword :initially-do\051 are) -210 W( evaluated before the system is loaded or compiled, and)211 W -7200 60369 MT -(finalizations \050specified with the keyword :finally-do\051 are evaluated after) -92 W( the system is finished loading or)91 W -7200 61889 MT -(compiling. The argument to the keyword is a form which is evaluated. Multiple forms may be evaluated) -10 W( by)11 W -7200 63409 MT -(wrapping a progn around the forms.)SH -7200 66905 MT -(The components of a system, module or file are specified with the :components keyword, and are) -14 W( defined)13 W -7200 68425 MT -(in a manner analogous to the way in which a system is defined.)SH -7200 71921 MT -(The dependencies of a system, module or file are specified with the :depends-on keyword,) -45 W( followed by a)46 W -ES -%%Page: 4 4 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(4)SH -/Helvetica SF -7200 7929 MT -(list of the names of the components the system, module) -56 W( or file depends on. The components referred to)55 W -7200 9449 MT -(must exist at the same level of the hierarchy as the referring component. This enforces the modularity of)31 W -7200 10969 MT -(the defined system. If module A depends on a file) -25 W( contained within module B, then module A depends on)24 W -7200 12489 MT -(module B) -175 W( and should be specified as such. Any other use would make a mockery of the concept of)176 W -7200 14009 MT -(modularity. This requirement is not enforced in the software, but) -216 W( any use contrary to it will produce)215 W -7200 15529 MT -(unpredictable results.)SH -7200 19025 MT -(Thus the only requirement in how the files are organized is that at the) -8 W( level of each module or system, the)9 W -7200 20545 MT -(dependency graph) -312 W( of the components must be a DAG \050directed)311 W -/Helvetica-Bold SF -38659 XM -(acyclic)SH -/Helvetica SF -42584 XM -(graph\051. If there are any)311 W -7200 22065 MT -(dependency cycles \050i.e., module A uses definitions from module) -96 W( B, and module B uses definitions from)97 W -7200 23585 MT -(module A\051, the defsystem macro will not be) -48 W( able to compute a total ordering of the files \050a linear order in)47 W -7200 25105 MT -(which they should be compiled and loaded\051. Usually the defsystem will detect such cycles and halt) -80 W( with)81 W -7200 26625 MT -(an error.)SH -7200 30121 MT -(If no dependencies are provided for the system, modules and files, it may load them in) -229 W( any order.)228 W -7200 31641 MT -(Currently, however, it loads them in serial order. In a future version of defsystem this will) -233 W( probably)234 W -7200 33161 MT -(become a supported feature. [In other words, this) -56 W( feature hasn't been tested to make sure that they files)55 W -7200 34681 MT -(are not) -2 W( accidentally loaded in the opposite order in some cases. It all depends on whether the definition of)3 W -7200 36201 MT -(topological-sort used is a stable sort or not.])SH -7200 39697 MT -(The basic algorithm used is to topologically sort the DAG at each level) -195 W( of abstraction \050system level,)194 W -7200 41217 MT -(module level, submodule) -45 W( level, etc.\051 to insure that the system's files are compiled and loaded in the right)46 W -7200 42737 MT -(order. This occurs at system) -86 W( definition time, rather than at system use time, since it probably saves the)85 W -7200 44257 MT -(user some time.)SH -12 /Helvetica-Bold AF -7200 47600 MT -(BNF for Components)SH -10 /Helvetica AF -7200 51033 MT -(The general format of a component's definition is:)SH -/Courier-Bold SF -7200 52838 MT -(<definition> ::= \050<type> <name> [:host <host>] [:device <device>])SH -26400 53969 MT -([:source-pathname <pathname>])SH -26400 55100 MT -([:source-extension <extension>])SH -26400 56231 MT -([:binary-pathname <pathname>])SH -26400 57362 MT -([:binary-extension <extension>])SH -26400 58493 MT -([:package <package>])SH -26400 59624 MT -([:initially-do <form>])SH -26400 60755 MT -([:finally-do <form>])SH -26400 61886 MT -([:components \050<definition>*\051])SH -26400 63017 MT -([:depends-on \050<name>*\051])SH -26400 64148 MT -([:compile-form <form>])SH -26400 65279 MT -([:load-form <form>]\051)SH -7200 66410 MT -(<type> ::= :system | :module | :file)SH -/Helvetica SF -7200 69906 MT -(The toplevel defsystem form substitutes defsystem for :system.)SH -ES -%%Page: 5 5 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(5)SH -12 SS -7200 8075 MT -(Using Systems with Operate-on-System)SH -10 /Helvetica AF -7200 11508 MT -(The function operate-on-system is used) -166 W( to compile or load a system, or do any other operation on a)167 W -7200 13028 MT -(system. At present only compile and load operations are defined, but other operations such as edit,)200 W -7200 14548 MT -(hardcopy, or applying arbitrary functions \050e.g., enscript, lpr\051 to every file in the system) -125 W( could be added)126 W -7200 16068 MT -(easily.)SH -7200 19564 MT -(The syntax of operate-on-system is as follows:)SH -/Helvetica-Bold SF -7200 23060 MT -(OPERATE-ON-SYSTEM)SH -/Helvetica-Oblique SF -18640 XM -(system-name operation)50 W -/Helvetica SF -29466 XM -(&key)SH -/Helvetica-Oblique SF -32017 XM -(force test) -50 W( verbose dribble load-source-instead-of-)49 W -7200 24580 MT -(binary load-source-if-no-binary bother-user-if-no-binary)SH -/Symbol SF -9242 26052 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(system-name)SH -/Helvetica SF -16649 XM -(is the name of the system and may be a symbol or string.)SH -/Symbol SF -9242 27867 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(operation)SH -/Helvetica SF -14940 XM -(is 'compile \050or :compile\051 or 'load \050or :load\051 or any new operation) -126 W( defined by the)127 W -9980 29010 MT -(user.)SH -/Symbol SF -9242 30825 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(force)SH -/Helvetica SF -12703 XM -(determines what files are operated on:)SH -7 /Symbol AF -12160 32076 MT -(\267)SH -10 /Helvetica-Oblique AF -12760 32226 MT -(:all)SH -/Helvetica SF -14316 XM -(\050or T\051 specifies that all files in the system should be used)SH -7 /Symbol AF -12160 33891 MT -(\267)SH -10 /Helvetica-Oblique AF -12760 34041 MT -(:new-source)SH -/Helvetica SF -18573 XM -(If the operation is 'compile, compiles only those files whose sources are)88 W -12760 35184 MT -(more recent than the binaries. If the operation is) -114 W( 'load, loads the source if it is more)115 W -12760 36327 MT -(recent than the binaries. This allows you to load the most up) -139 W( to date version of the)138 W -12760 37470 MT -(system even if it isn't compiled.)SH -7 /Symbol AF -12160 39135 MT -(\267)SH -10 /Helvetica-Oblique AF -12760 39285 MT -(:new-sources-and-dependents)SH -/Helvetica SF -26688 XM -(uses all files used by :new-source,) -144 W( plus any files that)145 W -12760 40428 MT -(depend on the those files or their dependents \050recursively\051.)SH -7 /Symbol AF -12160 42093 MT -(\267)SH -10 /Helvetica AF -12760 42243 MT -(Force may also be a list) -289 W( of the specific modules or files to be used \050plus their)288 W -12760 43386 MT -(dependents\051.)SH -9980 44787 MT -(The default for 'load is :all and for 'compile is :new-source-and-dependents.)SH -/Symbol SF -9242 46602 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(version)SH -/Helvetica SF -13989 XM -(indicates which version of the system should be used. If nil, then the usual root)174 W -9980 47745 MT -(directory is) -101 W( used. If a symbol, such as 'alpha, 'beta, 'omega, :alpha, or 'mark, it substitutes)100 W -9980 48888 MT -(the appropriate) -19 W( \050lowercase\051 subdirectory of the root directory for the root directory. If a string,)20 W -9980 50031 MT -(it replaces the entire root directory with the given directory. \050default *version*, which is nil\051)SH -/Symbol SF -9242 51846 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(verbose)SH -/Helvetica SF -14146 XM -(is T to print out what it is doing) -53 W( \050compiling, loading of modules and files\051 as it does)52 W -9980 52989 MT -(it. \050default nil\051)SH -/Symbol SF -9242 54804 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(test)SH -/Helvetica SF -12051 XM -(is T) -15 W( to print out what it would do without actually doing it. If test is T it automatically sets)16 W -9980 55947 MT -(verbose to T. \050default nil\051)SH -/Symbol SF -9242 57762 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(dribble)SH -/Helvetica SF -13873 XM -(should be the pathname of a dribble file if you want to keep a record of) -281 W( the)280 W -9980 58905 MT -(compilation. \050default nil\051)SH -/Symbol SF -9242 60720 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(load-source-instead-of-binary)SH -/Helvetica SF -24392 XM -(is T to force) -21 W( the system to load source files instead of binary)22 W -9980 61863 MT -(files. \050default nil\051)SH -/Symbol SF -9242 63678 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(load-source-if-no-binary)SH -/Helvetica SF -22022 XM -(is T to have the) -263 W( system load source files if the binary file is)262 W -9980 64821 MT -(missing. \050default nil\051)SH -/Symbol SF -9242 66636 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(bother-user-if-no-binary)SH -/Helvetica SF -21818 XM -(is T to) -171 W( have the system bother the user about missing binaries)172 W -9980 67779 MT -(before it goes ahead and loads them if load-source-if-no-binary is T. \050default) -67 W( t\051 Times out in)66 W -9980 68922 MT -(60 seconds unless *use-timeouts* is set to nil.)SH -ES -%%Page: 6 6 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(6)SH -/Helvetica SF -7200 7929 MT -(An implicit assumption is that if we need to) -10 W( load a file for some reason, then we should be able to compile)11 W -7200 9449 MT -(it immediately before we need to) -138 W( load it. This obviates the need to specify separate load and compile)137 W -7200 10969 MT -(dependencies in the modules.)SH -7200 14465 MT -(Files which must not) -117 W( be compiled should be loaded in the initializations or finalizations of a module by)118 W -7200 15985 MT -(means of an explicit load form.)SH -7200 19481 MT -(Note that under this assumption, the example given) -207 W( in the PCL defsystem becomes quite ludicrous.)206 W -7200 21001 MT -(Those constraints are of the form:)SH -9424 22402 MT -(1.)SH -10536 XM -(C must be loaded before A&B are loaded)SH -9424 24217 MT -(2.)SH -10536 XM -(A&B must be loaded before C is compiled)SH -7200 25737 MT -(When you add in the reasonable assumption that before you load C, you must compile C, you get a cycle.)SH -7200 29233 MT -(The only case is which this might not be true is in a system which worked on) -86 W( the dependency graph of)87 W -7200 30753 MT -(individual definitions. But we have restricted) -112 W( ourselves to file dependencies and will stick with that. \050In)111 W -7200 32273 MT -(situations where a file defining macros must have the sources loaded before compiling them, most often) -7 W( it)8 W -7200 33793 MT -(is because the macros are used before they are defined, and) -82 W( hence assumed to be functions. This can)81 W -7200 35313 MT -(be fixed by organizing the macros better, or including them in a separate file.\051)SH -12 /Helvetica-Bold AF -7200 38656 MT -(Defining New Operations)SH -10 /Helvetica AF -7200 42089 MT -(To define a new) -203 W( operation, write a function with parameters component and force that performs the)204 W -7200 43609 MT -(operation. The) -82 W( function component-pathname may be used to extract the source and binary pathnames)81 W -7200 45129 MT -(from the component. [Component-pathname takes parameters component and file-type,) -10 W( where file-type is)11 W -7200 46649 MT -(either :source or :binary,) -120 W( and returns the appropriate pathname.] If the component has "changed" as a)119 W -7200 48169 MT -(result of the operation, T should) -3 W( be returned; otherwise nil. See the definition of compile-file-operation and)4 W -7200 49689 MT -(load-file-operation for examples.)SH -7200 53185 MT -(Then install the definition using component-operation, which takes as) -99 W( parameters the symbol which will)98 W -7200 54705 MT -(be used) -58 W( to name the operation in operate-on-system, and the name of the function. For example, here's)59 W -7200 56225 MT -(the definition of the 'compile and :compile operations:)SH -/Courier-Bold SF -13200 58030 MT -(\050component-operation :compile 'compile-and-load-operation\051)SH -13200 59161 MT -(\050component-operation 'compile 'compile-and-load-operation\051)SH -/Helvetica SF -7200 61021 MT -(Eventually this system will include portable definitions of 'hardcopy and 'edit.)SH -12 /Helvetica-Bold AF -7200 64364 MT -(Changes to Require)SH -10 /Helvetica AF -7200 67797 MT -(This defsystem interacts smoothly) -138 W( with the require and provide facilities of Common Lisp. Operate-on-)137 W -7200 69317 MT -(system automatically provides the name of any system it loads, and uses the new definition of) -49 W( require to)50 W -7200 70837 MT -(load any dependencies of the toplevel system.)SH -ES -%%Page: 7 7 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(7)SH -/Helvetica SF -7200 7929 MT -(To facilitate this, three new optional arguments have been added) -174 W( to require. Thus the new syntax of)173 W -7200 9449 MT -(require is as follows:)SH -/Helvetica-Bold SF -7200 12945 MT -(REQUIRE)SH -/Helvetica-Oblique SF -12034 XM -(system-name)SH -/Helvetica SF -18313 XM -(&optional)SH -/Helvetica-Oblique SF -22760 XM -(pathname definition-pname default-action version)SH -/Helvetica SF -7200 16441 MT -(If pathname is provided, the new require behaves just like the old) -46 W( definition. Otherwise it first tries to find)47 W -7200 17961 MT -(the definition of the system-name \050if it is not already defined it will load the definition file if it is in the)143 W -7200 19481 MT -(current-directory, the central-registry directory, or the directory specified by definition-pname\051 and) -147 W( runs)148 W -7200 21001 MT -(operate-on-system on the system definition. If no definition is to be found, it) -160 W( will evaluate the default-)159 W -7200 22521 MT -(action if there) -52 W( is one. Otherwise it will try running the old definition of require on just the system name. If)53 W -7200 24041 MT -(all else fails, it will print out a warning.)SH -12 /Helvetica-Bold AF -7200 27384 MT -(A Sample System Definition and Its Use)SH -10 /Helvetica AF -7200 30817 MT -(Here's a system definition for the files in the following directory structure:)SH -/Courier-Bold SF -8400 32622 MT -(% du -a test)SH -8400 33753 MT -(1 test/fancy/macros.lisp)3600 W -8400 34884 MT -(1 test/fancy/primitives.lisp)3600 W -8400 36015 MT -(3 test/fancy)3600 W -8400 37146 MT -(1 test/macros.lisp)3600 W -8400 38277 MT -(1 test/primitives.lisp)3600 W -8400 39408 MT -(1 test/graphics/macros.lisp)3600 W -8400 40539 MT -(1 test/graphics/primitives.lisp)3600 W -8400 41670 MT -(3 test/graphics)3600 W -8400 42801 MT -(1 test/os/macros.lisp)3600 W -8400 43932 MT -(1 test/os/primitives.lisp)3600 W -8400 45063 MT -(3 test/os)3600 W -8400 46194 MT -(12 test)3000 W -8400 49587 MT -(\050defsystem test)SH -9600 50718 MT -(:source-pathname "/afs/cs.cmu.edu/user/mkant/Defsystem/test/")SH -9600 51849 MT -(:source-extension "lisp")SH -9600 52980 MT -(:binary-pathname nil)SH -9600 54111 MT -(:binary-extension nil)SH -9600 55242 MT -(:components \050\050:module basic)SH -22800 56373 MT -(:source-pathname "")SH -22800 57504 MT -(:components \050\050:file "primitives"\051)SH -30600 58635 MT -(\050:file "macros")SH -34800 59766 MT -(:depends-on \050"primitives"\051\051\051\051)SH -17400 60897 MT -(\050:module graphics)SH -22800 62028 MT -(:source-pathname "graphics")SH -22800 63159 MT -(:components \050\050:file "macros")SH -34800 64290 MT -(:depends-on \050"primitives"\051\051)SH -30600 65421 MT -(\050:file "primitives"\051\051)SH -22800 66552 MT -(:depends-on \050basic\051\051)SH -17400 67683 MT -(\050:module fancy-stuff)SH -22800 68814 MT -(:source-pathname "fancy")SH -22800 69945 MT -(:components \050\050:file "macros")SH -34800 71076 MT -(:depends-on \050"primitives"\051\051)SH -ES -%%Page: 8 8 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(8)SH -/Courier-Bold SF -30600 7874 MT -(\050:file "primitives"\051\051)SH -22800 9005 MT -(:depends-on \050graphics operating-system\051\051)SH -17400 10136 MT -(\050:module operating-system)SH -22800 11267 MT -(:source-pathname "os")SH -22800 12398 MT -(:components \050\050:file "primitives"\051)SH -30600 13529 MT -(\050:file "macros")SH -34800 14660 MT -(:depends-on \050"primitives"\051\051\051)SH -22800 15791 MT -(:depends-on \050basic\051\051\051)SH -9600 16922 MT -(:depends-on nil\051)SH -8400 19184 MT -(<cl> \050operate-on-system 'test 'compile :verbose t\051)SH -8400 21446 MT -(; -) -600 W( Compiling system "test")SH -8400 22577 MT -(; -) -1800 W( Compiling module "basic")SH -8400 23708 MT -(; -) -3000 W( Compiling source file)SH -8400 24839 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.lisp")4200 W -8400 25970 MT -(; -) -3000 W( Loading binary file)SH -8400 27101 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.fasl")4200 W -8400 28232 MT -(; -) -3000 W( Compiling source file)SH -8400 29363 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.lisp")4200 W -8400 30494 MT -(; -) -3000 W( Loading binary file)SH -8400 31625 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.fasl")4200 W -8400 32756 MT -(; -) -1800 W( Compiling module "graphics")SH -8400 33887 MT -(; -) -3000 W( Compiling source file)SH -8400 35018 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.lisp)4200 W -8400 36149 MT -(; -) -3000 W( Loading binary file)SH -8400 37280 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.fasl)4200 W -8400 38411 MT -(; -) -3000 W( Compiling source file)SH -8400 39542 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.lisp")4200 W -8400 40673 MT -(; -) -3000 W( Loading binary file)SH -8400 41804 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.fasl")4200 W -8400 42935 MT -(; -) -1800 W( Compiling module "operating-system")SH -8400 44066 MT -(; -) -3000 W( Compiling source file)SH -8400 45197 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.lisp")4200 W -8400 46328 MT -(; -) -3000 W( Loading binary file)SH -8400 47459 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.fasl")4200 W -8400 48590 MT -(; -) -3000 W( Compiling source file)SH -8400 49721 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.lisp")4200 W -8400 50852 MT -(; -) -3000 W( Loading binary file)SH -8400 51983 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.fasl")4200 W -8400 53114 MT -(; -) -1800 W( Compiling module "fancy-stuff")SH -8400 54245 MT -(; -) -3000 W( Compiling source file)SH -8400 55376 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.lisp")4200 W -8400 56507 MT -(; -) -3000 W( Loading binary file)SH -8400 57638 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.fasl")4200 W -8400 58769 MT -(; -) -3000 W( Compiling source file)SH -8400 59900 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.lisp")4200 W -8400 61031 MT -(; -) -3000 W( Loading binary file)SH -8400 62162 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.fasl")4200 W -8400 63293 MT -(; -) -600 W( Providing system test)SH -8400 64424 MT -(NIL)SH -8400 66686 MT -(<cl> \050operate-on-system 'test 'load :verbose t\051)SH -8400 68948 MT -(; -) -600 W( Loading system "test")SH -8400 70079 MT -(; -) -1800 W( Loading module "basic")SH -8400 71210 MT -(; -) -3000 W( Loading binary file)SH -ES -%%Page: 9 9 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(9)SH -/Courier-Bold SF -8400 7874 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.fasl")4200 W -8400 9005 MT -(; -) -3000 W( Loading binary file)SH -8400 10136 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.fasl")4200 W -8400 11267 MT -(; -) -1800 W( Loading module "graphics")SH -8400 12398 MT -(; -) -3000 W( Loading binary file)SH -8400 13529 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.fasl)4200 W -8400 14660 MT -(; -) -3000 W( Loading binary file)SH -8400 15791 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.fasl")4200 W -8400 16922 MT -(; -) -1800 W( Loading module "operating-system")SH -8400 18053 MT -(; -) -3000 W( Loading binary file)SH -8400 19184 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.fasl")4200 W -8400 20315 MT -(; -) -3000 W( Loading binary file)SH -8400 21446 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.fasl")4200 W -8400 22577 MT -(; -) -1800 W( Loading module "fancy-stuff")SH -8400 23708 MT -(; -) -3000 W( Loading binary file)SH -8400 24839 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.fasl")4200 W -8400 25970 MT -(; -) -3000 W( Loading binary file)SH -8400 27101 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.fasl")4200 W -8400 28232 MT -(; -) -600 W( Providing system test)SH -8400 29363 MT -(NIL)SH -12 /Helvetica-Bold AF -7200 33623 MT -(Miscellaneous Notes)SH -10 /Helvetica AF -7200 37056 MT -(Macintosh pathnames are) -27 W( not fully supported at this time because of irregularities in the Allegro Common)26 W -7200 38576 MT -(Lisp definition of the pathname functions. Thus) -92 W( system definitions will not be portable to the Macintosh.)93 W -7200 40096 MT -(To convert them, include the device in the toplevel pathname and include trailing colons in) -7 W( the pathnames)6 W -7200 41616 MT -(of each module.)SH -7200 45112 MT -(We currently assume that) -205 W( compilation-load dependencies and if-changed dependencies are identical.)206 W -7200 46632 MT -(However, in some cases this might not be true. For example, if we change) -21 W( a macro we have to recompile)20 W -7200 48152 MT -(functions that depend on it, but not if we change) -239 W( a function. Splitting these apart \050with appropriate)240 W -7200 49672 MT -(defaulting\051 would be nice, but not worth doing immediately since it may save only a) -252 W( couple of file)251 W -7200 51192 MT -(recompilations, while making the defsystem much) -222 W( more complex. And if someone has such a large)223 W -7200 52712 MT -(system that this matters, they've got more important problems.)SH -ES -%%Trailer -%%Pages: 9 -%%DocumentFonts: Helvetica Helvetica-Bold Helvetica-Oblique Courier-Bold Symbol diff --git a/contrib/demos/demos.catalog b/contrib/demos/demos.catalog deleted file mode 100644 index c38ec9a8fa1633008d4de8c329cb99ba794a279f..0000000000000000000000000000000000000000 --- a/contrib/demos/demos.catalog +++ /dev/null @@ -1,38 +0,0 @@ -Package Name: - DEMOS - -Description: - Graphics demonstration programs for CMU Common Lisp using version 11 of the -X Window System. - -Author: - CMU Common Lisp Group. - -Maintainer: - CMU Common Lisp Group. - -Address: - Carnegie-Mellon University - Computer Science Department - Pittsburgh, PA 15213 - -Net Address: - slisp-group@b - -Copyright Status: - Public Domain. - -Files: - demos.lisp, demos.fasl, demos.catalog. - -How to Get: - The following unix command will copy the pertinent files into directory -<spec>: - cp /afs/cs.cmu.edu/project/slisp/library/demos/* <spec> - -Portability: - Should run in any Common Lisp supporting CLX V11R3. - -Instructions: - The function DEMOS:DO-ALL-DEMOS will run through each of the demos once, and -the function DEMOS:DEMO will present a menu of all the demos. diff --git a/contrib/demos/demos.lisp b/contrib/demos/demos.lisp deleted file mode 100644 index 91aa7e7b1067eecf839f5cb2d5203ea2606e24ff..0000000000000000000000000000000000000000 --- a/contrib/demos/demos.lisp +++ /dev/null @@ -1,1038 +0,0 @@ -;;; -*- Mode: Lisp; Package: Demos -*- -;;; -;;; This file contains various graphics hacks written and ported over the -;;; years by various and numerous persons. -;;; -;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. -;;; - -(in-package "DEMOS" :use '("LISP")) - -(export '(do-all-demos demo)) - - - -;;;; Graphic demos wrapper macro. - -;;; This wrapper macro should be reconsidered with respect to its property -;;; list usage. Possibly a demo structure should be used with *demos* -;;; pointing to these instead of function names. Also, something should -;;; be done about a title window that displays the name of the demo while -;;; it is running. - -(defparameter *demos* nil) - -(defvar *display* nil) -(defvar *screen* nil) -(defvar *root* nil) -(defvar *black-pixel* nil) -(defvar *white-pixel* nil) -(defvar *window* nil) - -(defmacro defdemo (fun-name demo-name args x y width height doc &rest forms) - `(progn - (defun ,fun-name ,args - ,doc - (cond (*display* - (xlib:with-state (*window*) - (setf (xlib:drawable-x *window*) ,x) - (setf (xlib:drawable-y *window*) ,y) - (setf (xlib:drawable-width *window*) ,width) - (setf (xlib:drawable-height *window*) ,height))) - (t - #+:cmu - (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #-:cmu - (progn - ;; Portable method - (setf *display* (xlib:open-display (machine-instance))) - (setf *screen* (xlib:display-default-screen *display*))) - (setf *root* (xlib:screen-root *screen*)) - (setf *black-pixel* (xlib:screen-black-pixel *screen*)) - (setf *white-pixel* (xlib:screen-white-pixel *screen*)) - (setf *window* (xlib:create-window :parent *root* - :x ,x :y ,y - :event-mask nil - :width ,width :height ,height - :background *white-pixel* - :border *black-pixel* - :border-width 2 - :override-redirect :on)))) - (xlib:map-window *window*) - ;; - ;; I hate to do this since this is not something any normal - ;; program should do ... - (setf (xlib:window-priority *window*) :above) - (xlib:display-finish-output *display*) - (unwind-protect - (progn ,@forms) - (xlib:unmap-window *window*) - (xlib:display-finish-output *display*))) - (setf (get ',fun-name 'demo-name) ',demo-name) - (setf (get ',fun-name 'demo-doc) ',doc) - (export ',fun-name) - (pushnew ',fun-name *demos*) - ',fun-name)) - - -;;;; Main entry points. - -(defun do-all-demos () - (dolist (demo *demos*) - (funcall demo) - (sleep 3))) - -;;; DEMO is a hack to get by. It should be based on creating a menu. At -;;; that time, *name-to-function* should be deleted, since this mapping will -;;; be manifested in the menu slot name cross its action. Also the -;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for -;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi". -;;; - -(defvar *name-to-function* (make-hash-table :test #'eq)) -(defvar *keyword-package* (find-package "KEYWORD")) - -(defun demo () - (macrolet ((read-demo () - `(let ((*package* *keyword-package*)) - (read)))) - (dolist (d *demos*) - (setf (gethash (intern (string-upcase (get d 'demo-name)) - *keyword-package*) - *name-to-function*) - d)) - (loop - (fresh-line) - (dolist (d *demos*) - (write-string " ") - (write-line (get d 'demo-name))) - (write-string " ") - (write-line "Help <demo name>") - (write-string " ") - (write-line "Quit") - (write-string "Enter demo name: ") - (let ((demo (read-demo))) - (case demo - (:help - (let* ((demo (read-demo)) - (fun (gethash demo *name-to-function*))) - (fresh-line) - (if fun - (format t "~&~%~A~&~%" (get fun 'demo-doc)) - (format t "Unknown demo name -- ~A." demo)))) - (:quit (return t)) - (t - (let ((fun (gethash demo *name-to-function*))) - (if fun - (funcall fun) - (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) - - -;;;; Shared demo utilities. - -(defun full-window-state (w) - (xlib:with-state (w) - (values (xlib:drawable-width w) (xlib:drawable-height w) - (xlib:drawable-x w) (xlib:drawable-y w) - (xlib:window-map-state w)))) - - -;;;; Greynetic. - -;;; GREYNETIC displays random sized and shaded boxes in a window. This is -;;; real slow. It needs work. -;;; -(defun greynetic (window duration) - (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1 - :drawable window)) - (gcontext (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel* - :tile pixmap - :fill-style :tiled))) - (multiple-value-bind (width height) (full-window-state window) - (dotimes (i duration) - (let* ((pixmap-data (greynetic-pixmapper)) - (image (xlib:create-image :width 32 :height 32 - :depth 1 :data pixmap-data))) - (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) - (xlib:draw-rectangle window gcontext - (- (random width) 5) - (- (random height) 5) - (+ 4 (random (truncate width 3))) - (+ 4 (random (truncate height 3))) - t)) - (xlib:display-force-output *display*))) - (xlib:free-gcontext gcontext) - (xlib:free-pixmap pixmap))) - -(defvar *greynetic-pixmap-array* - (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel)) - -(defun greynetic-pixmapper () - (let ((pixmap-data *greynetic-pixmap-array*)) - (dotimes (i 4) - (declare (fixnum i)) - (let ((nibble (random 16))) - (setf nibble (logior nibble (ash nibble 4)) - nibble (logior nibble (ash nibble 8)) - nibble (logior nibble (ash nibble 12)) - nibble (logior nibble (ash nibble 16))) - (dotimes (j 32) - (let ((bit (if (logbitp j nibble) 1 0))) - (setf (aref pixmap-data i j) bit - (aref pixmap-data (+ 4 i) j) bit - (aref pixmap-data (+ 8 i) j) bit - (aref pixmap-data (+ 12 i) j) bit - (aref pixmap-data (+ 16 i) j) bit - (aref pixmap-data (+ 20 i) j) bit - (aref pixmap-data (+ 24 i) j) bit - (aref pixmap-data (+ 28 i) j) bit))))) - pixmap-data)) - -(defdemo greynetic-demo "Greynetic" (&optional (duration 300)) - 100 100 600 600 - "Displays random grey rectangles." - (greynetic *window* duration)) - - -;;;; Qix. - -(defstruct qix - buffer - (dx1 5) - (dy1 10) - (dx2 10) - (dy2 5)) - -(defun construct-qix (length) - (let ((qix (make-qix))) - (setf (qix-buffer qix) (make-circular-list length)) - qix)) - -(defun make-circular-list (length) - (let ((l (make-list length))) - (rplacd (last l) l))) - - -(defun qix (window lengths duration) - "Each length is the number of lines to put in a qix, and that many qix - (of the correct size) are put up on the screen. Lets the qix wander around - the screen for Duration steps." - (let ((histories (mapcar #'construct-qix lengths))) - (multiple-value-bind (width height) (full-window-state window) - (declare (fixnum width height)) - (xlib:clear-area window) - (xlib:display-force-output *display*) - (do ((h histories (cdr h)) - (l lengths (cdr l))) - ((null h)) - (do ((x (qix-buffer (car h)) (cdr x)) - (i 0 (1+ i))) - ((= i (car l))) - (rplaca x (make-array 4)))) - ;; Start each qix at a random spot on the screen. - (dolist (h histories) - (let ((x (random width)) - (y (random height))) - (rplaca (qix-buffer h) - (make-array 4 :initial-contents (list x y x y))))) - (rplacd (last histories) histories) - (let (x1 y1 x2 y2 dx1 dy1 dx2 dy2 tem line next-line qix - (gc (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel* - :line-width 0 :line-style :solid - :function boole-c2))) - (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2)) - (dotimes (i duration) - ;; Line is the next line in the next qix. Rotate this qix and - ;; the qix ring. - (setq qix (car histories)) - (setq line (car (qix-buffer qix))) - (setq next-line (cadr (qix-buffer qix))) - (setf (qix-buffer qix) (cdr (qix-buffer qix))) - (setq histories (cdr histories)) - (setf x1 (svref line 0)) - (setf y1 (svref line 1)) - (setf x2 (svref line 2)) - (setf y2 (svref line 3)) - (xlib:draw-line window gc x1 y1 x2 y2) - (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1)) - (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1)) - (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1)) - (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1)) - (cond ((> dx1 10) (setq dx1 10)) - ((< dx1 -10) (setq dx1 -10))) - (cond ((> dy1 10) (setq dy1 10)) - ((< dy1 -10) (setq dy1 -10))) - (cond ((> dx2 10) (setq dx2 10)) - ((< dx2 -10) (setq dx2 -10))) - (cond ((> dy2 10) (setq dy2 10)) - ((< dy2 -10) (setq dy2 -10))) - (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem)) - (setq dx1 (- dx1)))) - (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem)) - (setq dx2 (- dx2)))) - (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem)) - (setq dy1 (- dy1)))) - (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem)) - (setq dy2 (- dy2)))) - (setf (qix-dy2 qix) dy2) - (setf (qix-dx2 qix) dx2) - (setf (qix-dy1 qix) dy1) - (setf (qix-dx1 qix) dx1) - (when (svref next-line 0) - (xlib:draw-line window gc - (svref next-line 0) (svref next-line 1) - (svref next-line 2) (svref next-line 3))) - (setf (svref next-line 0) (+ x1 dx1)) - (setf (svref next-line 1) (+ y1 dy1)) - (setf (svref next-line 2) (+ x2 dx2)) - (setf (svref next-line 3) (+ y2 dy2)) - (xlib:display-force-output *display*)))))) - - -(defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000)) - 0 0 700 700 - "Hypnotic wandering lines." - (qix *window* lengths duration)) - - - -;;;; Petal. - -;;; Fast sine constants: - -(defconstant d360 #o5500) -(defconstant d270 #o4160) -(defconstant d180 #o2640) -(defconstant d90 #o1320) -(defconstant vecmax 2880) - -(defconstant sin-array - '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 - #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145 - #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 - #o12743 #o13357 #o13771 #o14401 #o15007 #o15414 - #o16016 #o16416 #o17013 #o17407 #o20000 #o20366 - #o20752 #o21333 #o21711 #o22265 #o22636 #o23204 - #o23546 #o24106 #o24443 #o24774 #o25323 #o25645 - #o26165 #o26501 #o27011 #o27316 #o27617 #o30115 - #o30406 #o30674 #o31156 #o31434 #o31706 #o32154 - #o32416 #o32654 #o33106 #o33333 #o33554 #o33771 - #o34202 #o34406 #o34605 #o35000 #o35167 #o35351 - #o35526 #o35677 #o36043 #o36203 #o36336 #o36464 - #o36605 #o36721 #o37031 #o37134 #o37231 #o37322 - #o37407 #o37466 #o37540 #o37605 #o37646 #o37701 - #o37730 #o37751 #o37766 #o37775 #o40000)) - -(defmacro psin (val) - `(let* ((val ,val) - neg - frac - sinlo) - (if (>= val d180) - (setq neg t - val (- val d180))) - (if (>= val d90) - (setq val (- d180 val))) - (setq frac (logand val 7)) - (setq val (ash val -3)) - ;; - (setq sinlo (if (>= val 90) - (svref sin-array 90) - (svref sin-array val))) - ;; - (if (< val 90) - (setq sinlo - (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) - -3)))) - ;; - (if neg - (- sinlo) - sinlo))) - -(defmacro pcos (x) - `(let ((tmp (- ,x d270))) - (psin (if (minusp tmp) (+ tmp d360) tmp)))) - - -;;;; Miscellaneous petal hackery. - -(defmacro high-16bits-* (a b) - `(let ((a-h (ash ,a -8)) - (b-h (ash ,b -8))) - (+ (* a-h b-h) - (ash (* a-h (logand ,b 255)) -8) - (ash (* b-h (logand ,a 255)) -8)))) - -(defun complete (style petal) - (let ((repnum 1) - factor cntval needed) - (dotimes (i 3) - (case i - (0 (setq factor 2 cntval 6)) - (1 (setq factor 3 cntval 2)) - (2 (setq factor 5 cntval 1))) - (do () - ((or (minusp cntval) (not (zerop (rem style factor))))) - (setq repnum (* repnum factor)) - (setq cntval (1- cntval)) - (setq style (floor style factor)))) - (setq needed (floor vecmax repnum)) - (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed))) - - -;;;; Petal Parameters and Petal itself - -(defparameter continuous t) -(defparameter styinc 2) -(defparameter petinc 1) -(defparameter scalfac-fac 8192) - -(defun petal (petal-window &optional (how-many 10) (style 0) (petal 0)) - (let ((width 512) - (height 512)) - (xlib:clear-area petal-window) - (xlib:display-force-output *display*) - (let ((veccnt 0) - (nustyle 722) - (nupetal 3) - (scalfac (1+ (floor scalfac-fac (min width height)))) - (ctrx (floor width 2)) - (ctry (floor height 2)) - (tt 0) - (s 0) - (lststyle 0) - (lstpetal 0) - (petstyle 0) - (vectors 0) - (r 0) - (x1 0) - (y1 0) - (x2 0) - (y2 0) - (i 0) - (gc (xlib:create-gcontext :drawable petal-window - :foreground *black-pixel* - :background *white-pixel* - :line-width 0 :line-style :solid))) - (loop - (when (zerop veccnt) - (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal - style nustyle petstyle (rem (* petal style) d360) - vectors (complete style petal)) - (when continuous - (setq nupetal (+ nupetal petinc) - nustyle (+ nustyle styinc))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (xlib:clear-area petal-window) - (xlib:display-force-output *display*))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 - tt (rem (+ tt style) d360) - s (rem (+ s petstyle) d360) - r (pcos s)) - (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) - y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) - (when (/= i 1) - (xlib:draw-line petal-window gc x1 y1 x2 y2) - (xlib:display-force-output *display*))) - (when (> veccnt vectors) - (setq veccnt 0) - (setq how-many (1- how-many)) - (sleep 2) - (when (zerop how-many) (return))))))) - -(defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0)) - 100 100 512 512 - "Flower-like display." - (petal *window* how-many style petal)) - - -;;;; Hanoi. - -;;; Random parameters: - -(defparameter disk-thickness 15 "The thickness of a disk in pixels.") -(defparameter disk-spacing (+ disk-thickness 3) - "The amount of vertical space used by a disk on a needle.") -(defvar *horizontal-velocity* 20 "The speed at which disks slide sideways.") -(defvar *vertical-velocity* 12 "The speed at which disks move up and down.") - -;;; These variables are bound by the main function. - -(defvar *hanoi-window* () "The window that Hanoi is happening on.") -(defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.") -(defvar *transfer-height* () "The height at which disks are transferred.") -(defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.") - -;;; Needle Functions - -(defstruct disk - size) - -(defstruct needle - position - disk-stack) - -;;; Needle-Top-Height returns the height of the top disk on NEEDLE. - -(defun needle-top-height (needle) - (- *hanoi-window-height* - (* disk-spacing (length (the list (needle-disk-stack needle)))))) - -(defvar available-disks - (do ((i 10 (+ i 10)) - (dlist () (cons (make-disk :size i) dlist))) - ((> i 80) dlist))) - -(defvar needle-1 (make-needle :position 184)) -(defvar needle-2 (make-needle :position 382)) -(defvar needle-3 (make-needle :position 584)) - -;;; Graphic interface abstraction: - -;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p" -;;; set to T. Update-Screen forces the display output. -;;; -(defmacro invert-rectangle (x y height width) - `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext* - ,x ,y ,width ,height t)) - -(defmacro update-screen () - `(xlib:display-force-output *display*)) - - -;;;; Moving disks up and down - -;;; Slide-Up slides the image of a disk up from the coordinates X, -;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to -;;; move. START-Y must be greater than END-Y - -(defun slide-up (start-y end-y x disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- start-y end-y) *vertical-velocity*) - (do ((x (- x disk-size)) - (width (* disk-size 2)) - (old-y start-y (- old-y *vertical-velocity*)) - (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle x (- old-y pixels-left) disk-thickness width) - (invert-rectangle x old-y disk-thickness width) - (update-screen))) - ;; Loop body writes disk at new height & erases at old height. - (invert-rectangle x old-y disk-thickness width) - (invert-rectangle x new-y disk-thickness width) - (update-screen)))) - -;;; Slide-Down slides the image of a disk down from the coordinates X, -;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to -;;; move. START-Y must be less than END-Y. - -(defun slide-down (start-y end-y x disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- end-y start-y) *vertical-velocity*) - (do ((x (- x disk-size)) - (width (* disk-size 2)) - (old-y start-y (+ old-y *vertical-velocity*)) - (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle x (+ old-y pixels-left) disk-thickness width) - (invert-rectangle x old-y disk-thickness width) - (update-screen))) - ;; Loop body writes disk at new height & erases at old height. - (invert-rectangle X old-y disk-thickness width) - (invert-rectangle X new-y disk-thickness width) - (update-screen)))) - - -;;;; Lifting and Droping Disks - -;;; Lift-disk pops the top disk off of needle and raises it up to the -;;; transfer height. The disk is returned. - -(defun lift-disk (needle) - "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it." - (let* ((height (needle-top-height needle)) - (disk (pop (needle-disk-stack needle)))) - (slide-up height - *transfer-height* - (needle-position needle) - (disk-size disk)) - disk)) - -;;; Drop-disk drops a disk positioned over needle at the transfer height -;;; onto needle. The disk is pushed onto needle. - -(defun drop-disk (disk needle) - "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." - (push disk (needle-disk-stack needle)) - (slide-down *transfer-height* - (needle-top-height needle) - (needle-position needle) - (disk-size disk)) - t) - - -;;; Drop-initial-disk is the same as drop-disk except that the disk is -;;; drawn once before dropping. - -(defun drop-initial-disk (disk needle) - "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." - (let* ((size (disk-size disk)) - (lx (- (needle-position needle) size))) - (invert-rectangle lx *transfer-height* disk-thickness (* size 2)) - (push disk (needle-disk-stack needle)) - (slide-down *transfer-height* - (needle-top-height needle) - (needle-position needle) - (disk-size disk)) - t)) - - -;;;; Sliding Disks Right and Left - -;;; Slide-Right slides the image of a disk located at START-X, Y to the -;;; position END-X, Y. DISK-SIZE is the size of the disk. START-X is -;;; less than END-X. - -(defun slide-right (start-x end-x Y disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- end-x start-x) *horizontal-velocity*) - (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*)) - (left-x (- start-x disk-size) (+ left-x *horizontal-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle right-x Y disk-thickness pixels-left) - (invert-rectangle left-x Y disk-thickness pixels-left) - (update-screen))) - ;; Loop body adds chunk *horizontal-velocity* pixels wide to right - ;; side of disk, then chops off left side. - (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) - (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) - (update-screen)))) - -;;; Slide-Left is the same as Slide-Right except that START-X is greater -;;; than END-X. - -(defun slide-left (start-x end-x Y disk-size) - (multiple-value-bind (number-moves pixels-left) - (truncate (- start-x end-x) *horizontal-velocity*) - (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*) - (- right-x *horizontal-velocity*)) - (left-x (- (- start-x disk-size) *horizontal-velocity*) - (- left-x *horizontal-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left)) - (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left)) - (invert-rectangle left-x Y disk-thickness pixels-left) - (invert-rectangle right-x Y disk-thickness pixels-left) - (update-screen))) - ;; Loop body adds chunk *horizontal-velocity* pixels wide to left - ;; side of disk, then chops off right side. - (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) - (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) - (update-screen)))) - - -;;;; Transferring Disks - -;;; Transfer disk slides a disk at the transfer height from a position -;;; over START-NEEDLE to a position over END-NEEDLE. Modified disk is -;;; returned. - -(defun transfer-disk (disk start-needle end-needle) - "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE." - (let ((start (needle-position start-needle)) - (end (needle-position end-needle))) - (if (< start end) - (slide-right start end *transfer-height* (disk-size disk)) - (slide-left start end *transfer-height* (disk-size disk))) - disk)) - - -;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE. - -(defun move-one-disk (start-needle end-needle) - "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE." - (drop-disk (transfer-disk (lift-disk start-needle) - start-needle - end-needle) - end-needle) - t) - -;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE -;;; obeying the rules of the towers of hannoi problem. To move the -;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage. - -(defun move-n-disks (n start-needle end-needle temp-needle) - "Moves the top N disks from START-NEEDLE to END-NEEDLE. - Uses TEMP-NEEDLE for temporary storage." - (cond ((= n 1) - (move-one-disk start-needle end-needle)) - (t - (move-n-disks (1- n) start-needle temp-needle end-needle) - (move-one-disk start-needle end-needle) - (move-n-disks (1- n) temp-needle end-needle start-needle))) - t) - - -;;;; Hanoi itself. - -(defun hanoi (window n) - (multiple-value-bind (width height) (full-window-state window) - (declare (ignore width)) - (let* ((*hanoi-window* window) - (*hanoi-window-height* height) - (*transfer-height* (- height (* disk-spacing n))) - (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* - :foreground *white-pixel* - :background *black-pixel* - :fill-style :solid - :function boole-c2))) - (xlib:clear-area *hanoi-window*) - (xlib:display-force-output *display*) - (setf (needle-disk-stack needle-1) ()) - (setf (needle-disk-stack needle-2) ()) - (setf (needle-disk-stack needle-3) ()) - (do ((n n (1- n)) - (available-disks available-disks (cdr available-disks))) - ((zerop n)) - (drop-initial-disk (car available-disks) needle-1)) - (move-n-disks n needle-1 needle-3 needle-2) - t))) - -;;; Change the names of these when the DEMO loop isn't so stupid. -;;; -(defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4)) - 0 100 768 300 - "Solves the Towers of Hanoi problem before your very eyes." - (let ((*horizontal-velocity* 3) - (*vertical-velocity* 1)) - (hanoi *window* how-many))) -;;; -(defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7)) - 0 100 768 300 - "Solves the Towers of Hanoi problem before your very eyes." - (hanoi *window* how-many)) - - - -;;;; Bounce window. - -;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of -;;; the screen. Optionally, the window can have an initial x velocity, -;;; screen border elasticity, and gravity value. The outer loop is -;;; entered the first time with the window at its initial height, but -;;; each iteration after this, the loop starts with the window at the -;;; bottom of the screen heading upward. The inner loop, except for the -;;; first execution, carries the window up until the negative velocity -;;; becomes positive, carrying the window down to bottom when the -;;; velocity is positive. Due to number lossage, ROUND'ing and -;;; TRUNC'ing when the velocity gets so small will cause the window to -;;; head upward with the same velocity over two iterations which will -;;; cause the window to bounce forever, so we have prev-neg-velocity and -;;; number-problems to check for this. This is not crucial with the x -;;; velocity since the loop terminates as a function of the y velocity. -;;; -(defun bounce-window (window &optional - (x-velocity 0) (elasticity 0.85) (gravity 2)) - (unless (< 0 elasticity 1) - (error "Elasticity must be between 0 and 1.")) - (unless (plusp gravity) - (error "Gravity must be positive.")) - (multiple-value-bind (width height x y mapped) (full-window-state window) - (when (eq mapped :viewable) - (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height)) - (left-of-window-at-right (- (xlib:drawable-width *root*) width)) - (y-velocity 0) - (prev-neg-velocity most-negative-fixnum) - (number-problems nil)) - (declare (fixnum top-of-window-at-bottom left-of-window-at-right - y-velocity)) - (loop - (when (= prev-neg-velocity 0) (return t)) - (let ((negative-velocity (minusp y-velocity))) - (loop - (let ((next-y (+ y y-velocity)) - (next-y-velocity (+ y-velocity gravity))) - (declare (fixnum next-y next-y-velocity)) - (when (> next-y top-of-window-at-bottom) - (cond - (number-problems - (setf y-velocity (incf prev-neg-velocity))) - (t - (setq y-velocity - (- (truncate (* elasticity y-velocity)))) - (when (= y-velocity prev-neg-velocity) - (incf y-velocity) - (setf number-problems t)) - (setf prev-neg-velocity y-velocity))) - (setf y top-of-window-at-bottom) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*) - (return)) - (setq y-velocity next-y-velocity) - (setq y next-y)) - (when (and negative-velocity (>= y-velocity 0)) - (setf negative-velocity nil)) - (let ((next-x (+ x x-velocity))) - (declare (fixnum next-x)) - (when (or (> next-x left-of-window-at-right) - (< next-x 0)) - (setq x-velocity (- (truncate (* elasticity x-velocity))))) - (setq x next-x)) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*)))))))) - -;;; Change the name of this when DEMO is not so stupid. -;;; -(defdemo shove-bounce-demo "Shove-bounce" () - 100 100 300 300 - "Drops the demo window with an inital X velocity which bounces off - screen borders." - (bounce-window *window* 30)) - -(defdemo bounce-demo "Bounce" () - 100 100 300 300 - "Drops the demo window which bounces off screen borders." - (bounce-window *window*)) - - -;;;; Recurrence Demo - -;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu) - -;;; Permission is granted to any individual or institution to use, copy, -;;; modify, and distribute this software, provided that this complete -;;; copyright and permission notice is maintained, intact, in all copies and -;;; supporting documentation. - -;;; The author provides this software "as is" without express or -;;; implied warranty. - -;;; This routine plots the recurrence -;;; x <- y(1+sin(0.7x)) - 1.2(|x|)^.5 -;;; y <- .21 - x -;;; As described in a ?? 1983 issue of the Mathematical Intelligencer - -(defun recurrence (display window &optional (point-count 10000)) - (let ((gc (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel*))) - (multiple-value-bind (width height) (full-window-state window) - (xlib:clear-area window) - (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) - (xlib:display-force-output display) - (sleep 4)) - (xlib:free-gcontext gc))) - -;;; Draw points. X assumes points are in the range of width x height, -;;; with 0,0 being upper left and 0,H being lower left. -;;; hw and hh are half-width and half-height of screen - -(defun draw-ppict (win gc count x y hw hh) - "Recursively draw pretty picture" - (unless (zerop count) - (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture - (yf (floor (* (+ 0.7 y) hh )))) - (xlib:draw-point win gc xf yf) - (draw-ppict win gc (1- count) - (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x)))) - (- 0.21 x) - hw - hh)))) - -(defdemo recurrence-demo "Recurrence" () - 10 10 700 700 - "Plots a cool recurrence relation." - (recurrence *display* *window*)) - - -;;;; Plaid - -;;; -;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover. -;;; - -(defmacro rect-x (rects n) - `(svref ,rects (ash ,n 2))) -(defmacro rect-y (rects n) - `(svref ,rects (+ (ash ,n 2) 1))) -(defmacro rect-width (rects n) - `(svref ,rects (+ (ash ,n 2) 2))) -(defmacro rect-height (rects n) - `(svref ,rects (+ (ash ,n 2) 3))) - -(defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10)) - (let ((gcontext (xlib:create-gcontext :drawable window - :function boole-c2 - :plane-mask (logxor *white-pixel* - *black-pixel*) - :background *white-pixel* - :foreground *black-pixel* - :fill-style :solid)) - (rectangles (make-array (* 4 num-rectangles) - :element-type 'number - :initial-element 0))) - (multiple-value-bind (width height) (full-window-state window) - (let ((center-x (ash width -1)) - (center-y (ash height -1)) - (x-dir -2) - (y-dir -2) - (x-off 2) - (y-off 2)) - (dotimes (iter (truncate num-iterations num-rectangles)) - (dotimes (i num-rectangles) - (setf (rect-x rectangles i) (- center-x x-off)) - (setf (rect-y rectangles i) (- center-y y-off)) - (setf (rect-width rectangles i) (ash x-off 1)) - (setf (rect-height rectangles i) (ash y-off 1)) - (incf x-off x-dir) - (incf y-off y-dir) - (when (or (<= x-off 0) (>= x-off center-x)) - (decf x-off (ash x-dir 1)) - (setf x-dir (- x-dir))) - (when (or (<= y-off 0) (>= y-off center-y)) - (decf y-off (ash y-dir 1)) - (setf y-dir (- y-dir)))) - (xlib:draw-rectangles window gcontext rectangles t) - (xlib:display-force-output display)))) - (xlib:free-gcontext gcontext))) - -(defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10)) - 10 10 101 201 - "Plaid, man." - (plaid *display* *window* iterations num-rectangles)) - - -;;;; Bball demo - -;;; -;;; Ported to CLX by Blaine Burks -;;; - -(defvar *ball-size-x* 38) -(defvar *ball-size-y* 34) - -(defmacro xor-ball (pixmap window gcontext x y) - `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y* - ,window ,x ,y)) - -(defconstant bball-gravity 1) -(defconstant maximum-x-drift 7) - -(defvar *max-bball-x*) -(defvar *max-bball-y*) - -(defstruct ball - (x (random (- *max-bball-x* *ball-size-x*))) - (y (random (- *max-bball-y* *ball-size-y*))) - (dx (if (zerop (random 2)) (random maximum-x-drift) - (- (random maximum-x-drift)))) - (dy 0)) - -(defun get-bounce-image () - "Returns the pixmap to be bounced around the screen." - (xlib::bitmap-image #*000000000000000000000000000000000000 - #*000000000000000000000000000000000000 - #*000000000000000000001000000010000000 - #*000000000000000000000000000100000000 - #*000000000000000000000100001000000000 - #*000000000000000010000000010000000000 - #*000000000000000000100010000000000000 - #*000000000000000000001000000000000000 - #*000000000001111100000000000101010000 - #*000000000010000011000111000000000000 - #*000000000100000000111000000000000000 - #*000000000100000000000000000100000000 - #*000000000100000000001000100010000000 - #*000000111111100000010000000001000000 - #*000000111111100000100000100000100000 - #*000011111111111000000000000000000000 - #*001111111111111110000000100000000000 - #*001111111111111110000000000000000000 - #*011111111111111111000000000000000000 - #*011111111111111111000000000000000000 - #*111111111111110111100000000000000000 - #*111111111111111111100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111111100000000000000000 - #*111111111111110111100000000000000000 - #*011111111111111111000000000000000000 - #*011111111111011111000000000000000000 - #*001111111111111110000000000000000000 - #*001111111111111110000000000000000000 - #*000011111111111000000000000000000000 - #*000000111111100000000000000000000000 - #*000000000000000000000000000000000000)) - - -(defun bounce-1-ball (pixmap window gcontext ball) - (let ((x (ball-x ball)) - (y (ball-y ball)) - (dx (ball-dx ball)) - (dy (ball-dy ball))) - (xor-ball pixmap window gcontext x y) - (setq x (+ x dx)) - (setq y (+ y dy)) - (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*))) - (setq x (- x dx) - dx (- dx))) - (if (> y (- *max-bball-y* *ball-size-y*)) - (setq y (- y dy) - dy (- dy))) - (setq dy (+ dy bball-gravity)) - (setf (ball-x ball) x) - (setf (ball-y ball) y) - (setf (ball-dx ball) dx) - (setf (ball-dy ball) dy) - (xor-ball pixmap window gcontext x y))) - -(defun bounce-balls (display window how-many duration) - (xlib:clear-area window) - (xlib:display-force-output display) - (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) - (let* ((balls (do ((i 0 (1+ i)) - (list () (cons (make-ball) list))) - ((= i how-many) list))) - (gcontext (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel* - :function boole-xor - :exposures :off)) - (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1 - :drawable window)) - (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap - :foreground *white-pixel* - :background *black-pixel*))) - (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image) - :x 0 :y 0 :width 38 :height 34) - (xlib:free-gcontext pixmap-gc) - (dolist (ball balls) - (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) - (xlib:display-force-output display) - (dotimes (i duration) - (dolist (ball balls) - (bounce-1-ball bounce-pixmap window gcontext ball)) - (xlib:display-force-output display)) - (xlib:free-pixmap bounce-pixmap) - (xlib:free-gcontext gcontext)))) - -(defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500)) - 34 34 700 500 - "Bouncing balls in space." - (bounce-balls *display* *window* how-many duration)) diff --git a/contrib/follow-mouse/follow-mouse.catalog b/contrib/follow-mouse/follow-mouse.catalog deleted file mode 100644 index dfc32e7579b1797371920e8ba8bd4fbd7884f2d5..0000000000000000000000000000000000000000 --- a/contrib/follow-mouse/follow-mouse.catalog +++ /dev/null @@ -1,46 +0,0 @@ -Name: - Follow Mouse. - -Package Name: - HEMLOCK - -Description: - This Hemlock customization causes Hemlock's current window to be set to -whatever Hemlock window the mouse enters, except the echo area. - -Author: - Todd Kaufmann, modified by Dave Touretzky. - -Maintainer: - Todd Kaufmann. - -Address: - Carnegie-Mellon University - Computer Science Department - Pittsburgh, PA 15213 - -Net Address: - Todd.Kaufmann@CS.CMU.EDU - -Copyright Status: - Public Domain. - -Files: - follow-mouse.lisp, follow-mouse.fasl, follow-mouse.catalog. - -How to Get: - The following unix command will copy the pertinent files into directory -<spec>: - cp /afs/cs.cmu.edu/project/slisp/library/follow-mouse/* <spec> - -Portability: - This should work in any Common Lisp supporting Hemlock and CLX V11R3. - -Instructions: - Load the fasl file into your editor Lisp. A value of T for the hemlock -variable "Follow Mouse To Read-Only Buffers", which is the default, means -follow mouse is on. Anything else means hemlock will behave normally. - -Bugs: - A few more PROMPT-FOR-... functions need to be modified. They are mentioned -in the source code. diff --git a/contrib/follow-mouse/follow-mouse.lisp b/contrib/follow-mouse/follow-mouse.lisp deleted file mode 100644 index d45c3a505fdbc10823617a463889271d27f03b75..0000000000000000000000000000000000000000 --- a/contrib/follow-mouse/follow-mouse.lisp +++ /dev/null @@ -1,152 +0,0 @@ -;;; -*- Mode: Lisp; Package: HEMLOCK-INTERNALS -*- - -(in-package "HEMLOCK-INTERNALS") - -;;; todd kaufmann 24 mar 88 - -;;; because we will have lots of windows, with users moving between them lots, -;;; we would like the window the mouse is in to be the one input goes to. -;;; -;;; also, this is more in line with the way most X windows work -;;; (unless you like to use focus) - -;;; Modified by Dave Touretzky 5/23/88 to fix incremental search problem, -;;; to change windows upon leaving the echo area if the mouse moves -;;; while we're prompting for input, and to select the correct window -;;; when we split a window, based on where the mouse ends up. - -;;; Bugs: -;;; - a few more prompt-for-* functions need to be modified. they're -;;; flagged below. - -(defhvar "Follow Mouse to Window" - "When T, the current window becomes the one the mouse enters; when NIL, - behaves the old way" - :value T) - -(defhvar "Follow Mouse To Read-only Buffers" - "Whether to follow the mouse to Read-only buffers or not" - :value T) - -(defvar *last-window-mouse-entered* nil) ;set to the most recent LEGAL window entered - -(defun change-to-current-entered-window (window) - "Make the buffer the mouse has moved to be the current buffer." - (let ((buffer (window-buffer window))) - (when - (and *in-the-editor* - (value ed::follow-mouse-to-window) - ;; don't move cursor to menus - (not (string= (buffer-major-mode buffer) "HMenu")) - ;; don't move TO echo area - (not (eq buffer *echo-area-buffer*)) - ;; can move to read-only buffers if user says it's okay - (if (buffer-writable buffer) t - (value ed::follow-mouse-to-read-only-buffers)) - ;; if we get here, this is a valid window to move to: remember it - (setf *last-window-mouse-entered* window) - ;; but don't move OUT of the echo area if it's currently prompting. - (not (eq (current-window) *echo-area-window*)) - ;; and don't move out of current window during an incremental search - (not *during-incremental-search*) - ;; Make sure it's not a random typeout buffer. - (member window *window-list*) - ) - (setf (current-window) window - (current-buffer) buffer - *last-window-mouse-entered* nil)))) - - -(add-hook ed::enter-window-hook 'change-to-current-entered-window) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; If the user is being prompted in the echo area and moves the -;;; mouse, we can't switch windows. So remember where the mouse -;;; has gone to, and switch when he leaves the echo area buffer. - -(defun change-windows-if-mouse-moved () - (when (and *last-window-mouse-entered* - (not (eq (current-window) *last-window-mouse-entered*))) - (change-to-current-entered-window *last-window-mouse-entered*))) - - -;from echo.lisp - -(defun parse-for-something () - (display-prompt-nicely) - (let ((start-window (current-window))) - (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*)) - (setf (current-window) *echo-area-window*) - (unwind-protect - (use-buffer *echo-area-buffer* - (recursive-edit nil)) - (setf (current-window) start-window) - (change-windows-if-mouse-moved)))) ; <--- here's the change - -;---> Note: must make the same change to the following: -; prompt-for-y-or-n -; prompt-for-character* -; prompt-for-key - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Fix for the problem of switching buffers in the middle of an -;;; incremental search. -;;; -;;; Modify %i-search from searchcoms.lisp to bind a global variable -;;; hi::*during-incremental-search* to T. Check for this in body of -;;; change-to-current-entered-window above. - -(defvar *during-incremental-search* nil) - -(in-package "HEMLOCK") - -(defun %i-search (string point trailer direction failure) - (unwind-protect ;<---- here's the change - (do* ((hi::*during-incremental-search* t) ;<---- here's the change - (curr-point (copy-mark point :temporary)) - (curr-trailer (copy-mark trailer :temporary)) - (next-char (get-key-event *editor-input* t) - (get-key-event *editor-input* t))) - (nil) - (case (%i-search-char-eval next-char string point trailer direction failure) - (:cancel - (%i-search-echo-refresh string direction failure) - (unless (zerop (length string)) - (i-search-pattern string direction))) - (:return-cancel - (unless (zerop (length string)) (return :cancel)) - (beep)) - (:control-g - (when failure (return :control-g)) - (%i-search-echo-refresh string direction nil) - (unless (zerop (length string)) - (i-search-pattern string direction)))) - (move-mark point curr-point) - (move-mark trailer curr-trailer)) - (hi::change-windows-if-mouse-moved))) ;<---- here's the change - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Fix Split Window to not change the current window. -;;; That way, if the mouse is still in the current window, -;;; everything's fine. If the mouse ended up in the new -;;; window, a mouse-entered-window event will handle the -;;; change to the new window. - -; From filecoms.lisp: - -(defcommand "Split Window" (p) - "Make a new window by splitting the current window. - The new window is made the current window and displays starting at - the same place as the current window." - "Create a new window which displays starting at the same place - as the current window." - (declare (ignore p)) - (let ((new (make-window (window-display-start (current-window))))) - (unless new (editor-error "Could not make a new window.")) -; (setf (current-window) new) <--- commented out this line - )) diff --git a/contrib/games/feebs/brains.lisp b/contrib/games/feebs/brains.lisp deleted file mode 100644 index a5c953bc5d08161dd7210fb1d81224cff5ffa123..0000000000000000000000000000000000000000 --- a/contrib/games/feebs/brains.lisp +++ /dev/null @@ -1,58 +0,0 @@ -;;; -*- Mode: Lisp; Package: Sample-Brains; Log: feebs.log -*- -;;; -;;; Some Feeb brains. -;;; Written by Skef Wholey and Scott Fahlman. -;;; -;;; The file Feebs.Lisp contains some feebs that are built-in for noise -;;; purposes while running: RANDOM-BRAIN, WANDERING-BRAIN, and -;;; CONSERVATIVE-BRAIN. This file contains some other simply examples of -;;; feebs. -;;; - -(in-package "SAMPLE-BRAINS" :use '("LISP" "FEEBS")) - - -;;; Experimental brain. Like the built-in conservative brain, but without the -;;; range limitation. -;;; -(defun cautious-brain (status proximity vision vision-left vision-right) - (declare (ignore vision-left vision-right)) - (let ((stuff (my-square proximity))) - (cond ((and (consp stuff) (member :mushroom stuff :test #'eq)) - :eat-mushroom) - ((and (consp stuff) (member :carcass stuff :test #'eq)) - :eat-carcass) - ((and (ready-to-fire status) - (> (energy-reserve status) 30) - (dotimes (index (line-of-sight status)) - (let ((stuff (aref vision index))) - (if (listp stuff) - (if (dolist (thing stuff) - (if (feeb-image-p thing) - (return t))) - (return t)) - (if (feeb-image-p stuff) - (return t)))))) - :flame) - ((and (not (eq (left-square proximity) :rock)) - (> 0.2 (random 1.0))) - :turn-left) - ((and (not (eq (right-square proximity) :rock)) - (> 0.2 (random 1.0))) - :turn-right) - ((not (ready-to-fire status)) - :wait) - ((> (line-of-sight status) 0) - :move-forward) - ((not (eq (left-square proximity) :rock)) - :turn-left) - ((not (eq (right-square proximity) :rock)) - :turn-right) - (t - :turn-around)))) - -(define-feeb "Cau1" 'cautious-brain) -(define-feeb "Cau2" 'cautious-brain) -(define-feeb "Cau3" 'cautious-brain) - - diff --git a/contrib/games/feebs/feebs.catalog b/contrib/games/feebs/feebs.catalog deleted file mode 100644 index 3ae7ae87d00bb7f433f0065cf880ebc657a63da0..0000000000000000000000000000000000000000 --- a/contrib/games/feebs/feebs.catalog +++ /dev/null @@ -1,37 +0,0 @@ -[Name] FEEBS - -[Description] "Planet of the Feebs is a simulation game that is - intended as a training aid for beginning programmers in - Common Lisp. It is loosely based on the "Maze War" game, - written by Jim Guyton, Bruce Malasky, and assorted others - at Xerox PARC. In "Planet of the Feebs", however, the - players do not control their creatures by hand. Instead, - they supply programs which control the creatures as they - move around the maze trying to zap one another. The game - presents an open-ended challenge, and advanced players may - find themselves reaching deep into the AI bag of tricks as - they try to build ever more clever and adaptable creatures. - -[Author] Skef Wholey, Scott Fahlman, Dan Kuokka, Jim Healy - -[Maintainer] Members of the CMU Common Lisp Group. -[Address] Carnegie-Mellon University - Computer Science Department - Pittsburgh, PA 15213 - -[Net Address] Slisp@C.CS.CMU.EDU (at CMU send mail to Gripe) - -[Copywrite Status] Public domain. - -[Files] feebs.lisp, feebs.fasl, feebs.catalog, feebs.mss, - feebs.log, brains.lisp, brains.fasl, mazes.lisp - -[How to Get] source /../spice/usr/slisp/library/rt/feebs/get-feebs.cmd - -[Portability] Dependent on Version 10 of the X Window Manager. - -[Instructions] Load feebs.fasl and brains.fasl. - call FEEBS:FEEBS. - -[Wish List] Add egocentric display for one selected feeb. - diff --git a/contrib/games/feebs/feebs.lisp b/contrib/games/feebs/feebs.lisp deleted file mode 100644 index b48340a562d7daf9302953afafc9f1b50618387a..0000000000000000000000000000000000000000 --- a/contrib/games/feebs/feebs.lisp +++ /dev/null @@ -1,1779 +0,0 @@ -;;; -*- Mode: Lisp; Package: Feebs; Log: feebs.log -*- -;;; -;;; Planet of the Feebs. -;;; A somewhat educational simulation game. -;;; -;;; Written by Skef Wholey. -;;; Modified by Scott Fahlman. -;;; Modified by Dan Kuokka. -;;; Modified by Jim Healy. - - -(in-package "FEEBS" :use "LISP") - -;;; Export everything we want the players to get their hands on. - -(export '(*single-step* *delay* - *number-of-feebs* *game-length* - *points-for-killing* *points-for-dying* *maze-i-size* - *maze-j-size* *flame-energy* *mushroom-energy* - *carcass-energy* *maximum-energy* *minimum-starting-energy* - *maximum-starting-energy* *number-of-mushrooms* - *number-of-mushroom-sites* *carcass-guaranteed-lifetime* - *carcass-rot-probability* *fireball-dissipation-probability* - *fireball-reflection-probability* *flame-recovery-probability* - *slow-feeb-noop-switch* *slow-feeb-noop-factor* - name facing i-position j-position peeking line-of-sight - energy-reserve score kills ready-to-fire aborted last-move - feeb-image-p feeb-image-name feeb-image-facing - fireball-image-p fireball-image-direction - my-square left-square right-square rear-square - list-parameter-settings - define-feeb feebs load-feebs north south east west)) - -;;; Macro for computing whether a random event has occurred, given the -;;; chance of occurrence as a ratio. - -(defmacro chance (ratio) - `(< (random (denominator ,ratio)) (numerator ,ratio))) - -;;; Directions - -(defconstant north 0) -(defconstant east 1) -(defconstant south 2) -(defconstant west 3) - -;;; These control the user interface. - -(defvar *single-step* nil - "If non-null, wait for a mouse click at the end of each round.") - -(defvar *delay* nil - "If non-null, sleep this many seconds after each round.") - -(defvar *continue* t - "If null, quit the game immediately.") - -(defvar *feep-dead-feebs* nil - "If non-null, feep every-time a feep dies or is killed.") - - -;;; Parameters that affect strategy of the game. - -(defvar *feeb-parameters* nil) - -(defmacro def-feeb-parm (name value doc) - `(progn - (defvar ,name ,value ,doc) - (pushnew ',name *feeb-parameters*))) - -(defun list-parameter-settings () - (let ((settings nil)) - (dolist (parm *feeb-parameters*) - (push (cons parm (symbol-value parm)) settings)) - settings)) - - -;;; General game parameters: - -(def-feeb-parm *number-of-feebs* 10 - "Number of feebs that will play in the game.") - -(def-feeb-parm *game-length* 1000 - "Number of cycles in the simulation.") - -(def-feeb-parm *slow-feeb-noop-switch* t - "If non-null, each feeb has a chance of having its orders aborted in - proportion to the time it takes to produce them.") - -(def-feeb-parm *slow-feeb-noop-factor* .25 - "If *slow-feeb-noop-switch* is non-null, a feeb's orders will be aborted - with probability equal to the product of this factor times the time - taken by this feeb divided by the total time taken by all feebs this turn.") - -(def-feeb-parm *feep-dead-feebs-volume* 1 - "An integer between -7 and 7 which determines the volume of the feep - emitted when a feeb dies. The softest volume is 0 and the loudest - is 7. Negative volumes are usually not heard.") - -;;; Scoring: - -(def-feeb-parm *points-for-killing* 1 - "Added to one's score for killing an opponent.") - -(def-feeb-parm *points-for-dying* -2 - "Added to one's score for being killed or starving.") - - -;;; Characteristics of the maze: - -(def-feeb-parm *maze-i-size* 32 - "Number of rows in the maze.") - -(def-feeb-parm *maze-j-size* 32 - "Number of columns in the maze.") - -(def-feeb-parm *number-of-mushrooms* 10 - "Average number of mushrooms in the maze at any given time.") - -(def-feeb-parm *number-of-mushroom-sites* 0 - "Number of places at which mushrooms might grow.") - - -;;; Energies: - -(def-feeb-parm *flame-energy* 10 - "Energy used when a feeb flames.") - -(def-feeb-parm *mushroom-energy* 50 - "Energy gained when a mushroom is eaten.") - -(def-feeb-parm *carcass-energy* 30 - "Energy gained by feeding on a carcass.") - -(def-feeb-parm *maximum-energy* 200 - "The most energy a feeb can accumulate.") - -(def-feeb-parm *minimum-starting-energy* 50 - "Smallest amount of energy a feeb will start with.") - -(def-feeb-parm *maximum-starting-energy* 100 - "Greatest amount of energy a feeb will start with.") - - -;;; Carcasses: - -(def-feeb-parm *carcass-guaranteed-lifetime* 3 - "Minimum number of turns a carcass will hang around.") - -(def-feeb-parm *carcass-rot-probability* 1/3 - "Chance of a carcass rotting away each turn after its guaranteed lifetime.") - - -;;; Fireballs: - -(def-feeb-parm *fireball-dissipation-probability* 1/4 - "Chance that a fireball will dissipate each turn after it is fired.") - -(def-feeb-parm *fireball-reflection-probability* 1/2 - "Chance that a fireball will reflect when it hits a wall.") - -(def-feeb-parm *flame-recovery-probability* 1/2 - "Chance a feeb will regain its ability to flame each turn after flaming once.") - - -;;; Structures: - -;;; The Feeb structure contains all of the info relevant to a particular feeb. -;;; The info available to the brain function is in the Status sub-structure. - -(defstruct (feeb - (:print-function print-feeb) - (:constructor make-feeb (id brain))) - id - brain - image - status - proximity - time - last-score - last-kills - (dead-p nil) - (turns-dead 0) - (turns-since-flamed 0) - (vision (make-array (max *maze-j-size* *maze-j-size*))) - (vision-left (make-array (max *maze-j-size* *maze-j-size*))) - (vision-right (make-array (max *maze-j-size* *maze-j-size*)))) - -(defstruct (status - (:conc-name nil) - (:constructor make-status (name facing i-position j-position))) - name - facing - i-position - j-position - peeking - line-of-sight - (energy-reserve (+ *minimum-starting-energy* - (random (- *maximum-starting-energy* - *minimum-starting-energy*)))) - (score 0) - (kills 0) - (ready-to-fire t) - (aborted nil) - (last-move :dead)) - - -(defun print-feeb (structure stream depth) - (declare (ignore depth)) - (format stream "#<Feeb ~S>" - (name (feeb-status structure)))) - - -(defstruct (proximity - (:conc-name nil)) - my-square - rear-square - left-square - right-square) - - -;;; These image structures are used to represent feebs and fireballs in -;;; the sensory displays of other feebs. - -(defstruct (feeb-image - (:print-function print-feeb-image) - (:constructor make-feeb-image (name facing feeb))) - name - facing - feeb) - -(defun print-feeb-image (structure stream depth) - (declare (ignore depth)) - (format stream "#<Feeb-Image of ~S facing ~S>" - (feeb-image-name structure) - (feeb-image-facing structure))) - - -(defstruct (fireball-image - (:print-function print-fireball-image) - (:constructor make-fireball-image (direction owner i j di dj))) - direction - owner - i - j - di - dj - (new t)) - -(defun print-fireball-image (structure stream depth) - (declare (ignore depth)) - (format stream "#<Fireball moving ~S>" - (fireball-image-direction structure))) - -(defstruct (position - (:constructor make-position (i j)) - (:print-function print-position)) - i - j) - -(defun print-position (structure stream depth) - (declare (ignore depth)) - (format stream "#<Position (~A, ~A)>" - (position-i structure) - (position-j structure))) - - -;;; Setting up the maze. - -;;; The default maze. -;;; X represents a wall, -;;; * represents a mushroom patch, and -;;; e is a feeb entry point. - -(defparameter default-layout - '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "Xe * XXXXXXX XXXXXXXXXX" - "XXXXX XXXXXXX XXXXXXX * XXXXX" - "XXXXX XXXXXXX XXXXXXX XXX XXXXXX" - "XXXXX XXX XXX XXXXXXeXXX XXXXXX" - "XXXXX XXX XXXX XXXXXXXXXX XXXXXX" - "XXXXX XXX XXXX XX XXXXXXX XXXXXX" - "XXXXX * XX XX XXXXXXX XXXXXX" - "XXXXX XXXX XXX XX* * XXXXXX" - "XX *XXXX XXX XX XXXX XXXXXXXXX" - "XX XX XXXXeXXX XX XXXX XXXXXXXXX" - "XX XX XXXX XXX * * * X" - "XX XX XXXX XXXXXXXX XXXXXXXXXXeX" - "XXeXX XXXX XXXXXXXX XXXXXXXXXX X" - "XX XX * * XXXXXXXX X" - "XX XXXXXXXXXXX XXXX XXXXXXXX XXX" - "XX eXXXXXXXXXX XXXe XXXXXX XXX" - "XX XXXXXXXXXXXXe XXXXXXXXXXX XXX" - "XX* XXX XXXXXXX XXXXXXXXXX XXX" - "XX X XX XXXXXXXX eXXXXXXXXX XXX" - "XX XX X XXXXXXXXX XXXXXXXX XXX" - "X XXX * XXXXXX* * X" - "X XXXXXX XXX XXXXXX XXXXXXXXXX X" - "X XXXXXX XXX XXXXXX X X X" - "X XXXXXX XXX XXXXXX X XXXXXX X X" - "X * * XX X X *eX X X" - "XXXXX XXXX XXXXXXXX X XXX XX X X" - "XXXXX XXXX XXXXX *X XXX XX X X" - "XXXXX XXXX XXXXX XX X e X X" - "XXXXX XXXX e XX XXX*XXXXXX X" - "XXXXX XXXXXXXXXXXXX X" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX")) - -(defvar maze (make-array (list *maze-i-size* *maze-j-size*) - :initial-element ())) - -(defvar *mushroom-sites*) -(defvar *entry-points*) -(defvar *number-of-entry-points*) - -(defun init-maze (maze-strings) - (setq *mushroom-sites* nil) - (setq *entry-points* nil) - (do ((rows maze-strings (cdr rows)) - (i 0 (1+ i))) - ((null rows)) - (let ((str (car rows))) - (dotimes (j (length str)) - (setf (aref maze i j) nil) - (case (schar str j) - (#\X - (setf (aref maze i j) :rock)) - (#\* - (push (make-position i j) *mushroom-sites*)) - (#\e - (push (make-position i j) *entry-points*)) - (#\space - ) - (t - (error "Bad thing in maze spec: ~C." (schar str j))))))) - (setq *number-of-mushroom-sites* (length *mushroom-sites*)) - (setq *number-of-entry-points* (length *entry-points*))) - -(defun create-mushrooms () - (dotimes (i *number-of-mushrooms*) - (do ((site (nth (random *number-of-mushroom-sites*) *mushroom-sites*) - (nth (random *number-of-mushroom-sites*) *mushroom-sites*))) - ((null (aref maze (position-i site) (position-j site))) - (setf (aref maze (position-i site) (position-j site)) :mushroom))))) - - -;;; Setting up the feebs. - -(defvar *feebs* nil - "A list of all the feebs in the current game.") - -(defvar *next-feeb-id* 0 - "A counter used to assign a unique numerical code to each feeb.") - -(defun create-feeb (name brain) - (let* ((feeb (make-feeb *next-feeb-id* brain)) - (facing (random 4)) - (position (pick-random-entry-point))) - (setf (feeb-image feeb) - (make-feeb-image name facing feeb)) - (setf (feeb-status feeb) - (make-status name facing (position-i position) - (position-j position))) - (setf (feeb-proximity feeb) (make-proximity)) - (push feeb *feebs*) - (incf *next-feeb-id*) - (setf (aref maze (position-i position) (position-j position)) - (feeb-image feeb)) - feeb)) - -;;; Start at some randomly chosen entry point. If this one is occupied, -;;; scan successive entry points until a winner is found. Circle back -;;; to start of list if necessary. - -(defun pick-random-entry-point () - (do ((points (nthcdr (random *number-of-entry-points*) *entry-points*) - (cdr points))) - (nil) - (when (null points) - (setq points *entry-points*)) - (when (null (aref maze (position-i (car points)) - (position-j (car points)))) - (return (car points))))) - - -;;; Define-Feeb builds a list of feebs to create. Create-Feebs actually -;;; builds the feebs on this list. - -(defvar *feebs-to-be* nil) - -(defun define-feeb (name brain) - (push (cons name brain) *feebs-to-be*)) - -(defun create-feebs () - (when (> (length *feebs-to-be*) *number-of-entry-points*) - (error "More feebs than entry points.")) - (setq *feebs* nil) - (setq *next-feeb-id* 0) - (dolist (feeb-spec (reverse *feebs-to-be*)) - (create-feeb (car feeb-spec) (cdr feeb-spec)))) - - -;;; Vision calculation. - -;;; Some macros for directional arithmetic. - -(defmacro left-of (facing) - `(mod (+ ,facing 3) 4)) - -(defmacro right-of (facing) - `(mod (+ ,facing 1) 4)) - -(defmacro behind (facing) - `(mod (+ ,facing 2) 4)) - -;;; These guys tell us offsets given an orientation. - -(defconstant facing-vector-1 '#(-1 0 1 0)) -(defconstant facing-vector-2 '#(0 1 0 -1)) - -(defmacro forward-di (facing) - `(svref facing-vector-1 ,facing)) - -(defmacro forward-dj (facing) - `(svref facing-vector-2 ,facing)) - -(defmacro left-di (facing) - `(forward-di (left-of ,facing))) - -(defmacro left-dj (facing) - `(forward-dj (left-of ,facing))) - -(defmacro right-di (facing) - `(forward-di (right-of ,facing))) - -(defmacro right-dj (facing) - `(forward-dj (right-of ,facing))) - -(defmacro behind-di (facing) - `(forward-di (behind ,facing))) - -(defmacro behind-dj (facing) - `(forward-dj (behind ,facing))) - -(defun compute-vision (feeb) - (let* ((status (feeb-status feeb)) - (proximity (feeb-proximity feeb)) - (vision (feeb-vision feeb)) - (vision-left (feeb-vision-left feeb)) - (vision-right (feeb-vision-right feeb)) - (facing (facing status)) - vision-di - vision-dj - (i (i-position status)) - (j (j-position status))) - ;; First fill in proximity info. - (setf (my-square proximity) - (aref maze i j)) - (setf (left-square proximity) - (aref maze (+ i (left-di facing)) (+ j (left-dj facing)))) - (setf (right-square proximity) - (aref maze (+ i (right-di facing)) (+ j (right-dj facing)))) - (setf (rear-square proximity) - (aref maze (+ i (behind-di facing)) (+ j (behind-dj facing)))) - ;; The vision vector starts in the square the feeb is facing. - (setq i (+ i (forward-di facing))) - (setq j (+ j (forward-dj facing))) - ;; Figure out which direction to scan in. - (case (peeking status) - (nil) - (:left (setq facing (left-of facing))) - (:right (setq facing (right-of facing)))) - (setq vision-di (forward-di facing)) - (setq vision-dj (forward-dj facing)) - (do* ((i i (+ i vision-di)) - (j j (+ j vision-dj)) - (left-wall-i (+ i (left-di facing)) (+ left-wall-i vision-di)) - (left-wall-j (+ j (left-dj facing)) (+ left-wall-j vision-dj)) - (right-wall-i (+ i (right-di facing)) (+ right-wall-i vision-di)) - (right-wall-j (+ j (right-dj facing)) (+ right-wall-j vision-dj)) - (index 0 (1+ index))) - ((eq (aref maze i j) :rock) - (setf (line-of-sight status) index)) - (setf (aref vision index) (aref maze i j)) - (setf (aref vision-left index) - (side-imagify (aref maze left-wall-i left-wall-j) - (right-of facing))) - (setf (aref vision-right index) - (side-imagify (aref maze right-wall-i right-wall-j) - (left-of facing)))))) - -;;; Compute the info to be put into the vision-left and vision-right vectors. -;;; A peeking feeb must be facing in the specified direction in order to count. - -(defun side-imagify (stuff facing) - (cond ((eq stuff :rock) :rock) - ((and (feeb-image-p stuff) - (= facing (feeb-image-facing stuff)) - (peeking (feeb-status (feeb-image-feeb stuff)))) - :peeking) - ((listp stuff) - (do ((stuff stuff (cdr stuff))) - ((null stuff) nil) - (when (and (feeb-image-p (car stuff)) - (= facing (feeb-image-facing (car stuff))) - (peeking (feeb-status (feeb-image-feeb (car stuff))))) - (return :peeking)))) - (t nil))) - - -;;; Movement. - -;;; Each turn, the following stuff has to happen: -;;; 1. Bump the turn counter; end the game if we should. -;;; 2. Maybe grow some mushrooms. -;;; 3. Maybe disappear some carcasses. -;;; 4. Move fireballs around. -;;; 5. See if any feebs have starved. -;;; 6. See if any feebs can flame again. -;;; 7. Compute vision and stuff for feebs. -;;; 8. Collect the feebs' moves. -;;; 9. Do the feeb's moves. - -(defvar *current-turn* 0) - -(defvar *mushrooms-alive*) -(defvar *dead-feebs*) -(defvar *fireballs-flying*) - -(defun init-play () - (setq *mushrooms-alive* *number-of-mushrooms*) - (setq *dead-feebs* nil) - (setq *fireballs-flying* nil)) - -(defun play () - (dotimes (*current-turn* *game-length*) - (play-one-turn) - (when (plusp (x:xpending)) (system:server)) - (redisplay) - (display-status) - (cond ((not *continue*) (return-from play)) - (*single-step* (get-mouse-buttonpress)) - (*delay* (sleep-with-server *delay*))))) - -(defun play-one-turn () - ;; Grow some mushrooms: - (dotimes (i (- *number-of-mushrooms* *mushrooms-alive*)) - (let* ((site (nth (random *number-of-mushroom-sites*) *mushroom-sites*)) - (i (position-i site)) - (j (position-j site)) - (stuff (aref maze (position-i site) (position-j site)))) - (cond ((null stuff) - (place-object :mushroom i j)) - ((atom stuff) - (unless (eq stuff :mushroom) - (place-object :mushroom i j))) - (t - (unless (member :mushroom stuff) - (place-object :mushroom i j)))))) - ;; Rot some carcasses: - (dolist (feeb *dead-feebs*) - (incf (feeb-turns-dead feeb)) - (when (> (feeb-turns-dead feeb) *carcass-guaranteed-lifetime*) - (when (chance *carcass-rot-probability*) - (delete-object :carcass - (i-position (feeb-status feeb)) - (j-position (feeb-status feeb))) - (setq *dead-feebs* (delete feeb *dead-feebs*)) - (reincarnate-feeb feeb)))) - ;; Move some fireballs: - (dolist (fireball *fireballs-flying*) - (move-one-fireball fireball)) - ;; Starve some feebs: - (dolist (feeb *feebs*) - (unless (feeb-dead-p feeb) - (when (<= (decf (energy-reserve (feeb-status feeb))) 0) - (kill-feeb feeb)))) - ;; Let some feebs regain the power to flame: - (dolist (feeb *feebs*) - (unless (feeb-dead-p feeb) - (unless (ready-to-fire (feeb-status feeb)) - (incf (feeb-turns-since-flamed feeb)) - (when (and (> (feeb-turns-since-flamed feeb) 1) - (chance *flame-recovery-probability*)) - (setf (ready-to-fire (feeb-status feeb)) t))))) - ;; Compute vision for all the feebs. - (dolist (feeb *feebs*) - (unless (feeb-dead-p feeb) - (compute-vision feeb))) - ;; Collect all the feebs' moves, keeping track of the time each one takes. - (let ((total-time 1)) - (dolist (feeb *feebs*) - (unless (feeb-dead-p feeb) - (let ((time (get-internal-real-time))) - (setf (last-move (feeb-status feeb)) - (funcall (feeb-brain feeb) - (feeb-status feeb) - (feeb-proximity feeb) - (feeb-vision feeb) - (feeb-vision-left feeb) - (feeb-vision-right feeb))) - (setq time (- (get-internal-real-time) time)) - (incf total-time time) - (setf (feeb-time feeb) time)))) - ;; Do all the feebs' moves, or perhaps abort the move according - ;; to the time taken by the feeb. - (setq total-time (float total-time)) - (dolist (feeb *feebs*) - (unless (feeb-dead-p feeb) - (cond ((and *slow-feeb-noop-switch* - (< (random 1.0) - (* *slow-feeb-noop-factor* - (/ (float (feeb-time feeb)) total-time)))) - (setf (aborted (feeb-status feeb)) t)) - (t (setf (aborted (feeb-status feeb)) nil) - (do-move feeb (last-move (feeb-status feeb))))) - ;; Make the image consistent with the feeb. - (setf (feeb-image-facing (feeb-image feeb)) - (facing (feeb-status feeb))))))) - -(defun move-one-fireball (fireball) - (let ((i (fireball-image-i fireball)) - (j (fireball-image-j fireball))) - ;; Remove fireball from current square, unless it is new. - (if (fireball-image-new fireball) - (setf (fireball-image-new fireball) nil) - (delete-object fireball i j)) - ;; The fireball might dissipate. - (when (chance *fireball-dissipation-probability*) - (setq *fireballs-flying* (delete fireball *fireballs-flying*)) - (return-from move-one-fireball nil)) - ;; Now move it to new coordinates. - (incf i (fireball-image-di fireball)) - (incf j (fireball-image-dj fireball)) - ;; If it hits rock, either reflect or dissipate. - (when (eq (aref maze i j) :rock) - (cond ((chance *fireball-reflection-probability*) - (setf (fireball-image-di fireball) - (- (fireball-image-di fireball))) - (setf (fireball-image-dj fireball) - (- (fireball-image-dj fireball))) - (setf (fireball-image-direction fireball) - (behind (fireball-image-direction fireball))) - (setq i (fireball-image-i fireball)) - (setq j (fireball-image-j fireball))) - (t (setq *fireballs-flying* - (delete fireball *fireballs-flying*)) - (return-from move-one-fireball nil)))) - ;; Now put the fireball into the new square. - (setf (fireball-image-i fireball) i) - (setf (fireball-image-j fireball) j) - (place-object fireball i j) - ;; And destroy whatever is there. - (let ((stuff (aref maze i j))) - ;; If there is other stuff in the square, the contents will be a list. - (when (listp stuff) - (dolist (thing stuff) - (cond ((fireball-image-p thing) nil) - ((eq thing :mushroom) - (delete-object :mushroom i j)) - ((feeb-image-p thing) - (setq thing (feeb-image-feeb thing)) - (score-kill fireball thing)))))))) - -;;; The fireball kills the feeb. Update score for killer and victims. -;;; No credit for the kill if you shoot yourself. - -(defun score-kill (fireball feeb) - (unless (eq (fireball-image-owner fireball) feeb) - (incf (score (feeb-status (fireball-image-owner fireball))) - *points-for-killing*) - (incf (kills (feeb-status (fireball-image-owner fireball))))) - (kill-feeb feeb)) - - -;;; Doing feeb moves. - -(defun do-move (feeb move) - (let ((status (feeb-status feeb))) - ;; Redisplay the feeb's old square, whatever the action is. - (queue-redisplay (i-position status) (j-position status)) - ;; If feeb was peeking last move, redisplay the square it is facing - ;; to get rid of the periscope. - (when (peeking status) - (queue-redisplay (+ (i-position status) (forward-di (facing status))) - (+ (j-position status) (forward-dj (facing status))))) - ;; Peeking gets undone every move. - (setf (peeking status) nil) - (case move - (:turn-left - (setf (facing status) (left-of (facing status)))) - (:turn-right - (setf (facing status) (right-of (facing status)))) - (:turn-around - (setf (facing status) (behind (facing status)))) - (:move-forward - (let* ((facing (facing status)) - (old-i (i-position status)) - (old-j (j-position status)) - (new-i (+ (forward-di facing) old-i)) - (new-j (+ (forward-dj facing) old-j)) - (stuff (aref maze new-i new-j))) - (when (eq stuff :rock) (return-from do-move nil)) - (delete-object (feeb-image feeb) old-i old-j) - (setf (i-position status) new-i) - (setf (j-position status) new-j) - (place-object (feeb-image feeb) new-i new-j) - ;; Look for a fireball in the destination square. - (when (fireball-image-p stuff) - (score-kill stuff feeb) - (return-from do-move nil)) - (when (consp stuff) - (dolist (thing stuff) - (when (fireball-image-p thing) - (score-kill thing feeb) - (return-from do-move nil)))))) - (:flame - (when (ready-to-fire status) - (let* ((facing (facing status)) - (i (i-position status)) - (j (j-position status)) - (fireball (make-fireball-image - facing feeb i j - (forward-di facing) (forward-dj facing)))) - ;; Queue the fireball, marked as new, but don't put it on map yet. - (push fireball *fireballs-flying*) - (decf (energy-reserve status) *flame-energy*) - (setf (ready-to-fire status) nil) - (setf (feeb-turns-since-flamed feeb) 0)))) - (:eat-mushroom - (let* ((i (i-position status)) - (j (j-position status)) - (stuff (aref maze i j))) - (when (and (listp stuff) - (member :mushroom stuff)) - (delete-object :mushroom i j) - (setf (energy-reserve status) - (min (+ (energy-reserve status) *mushroom-energy*) - *maximum-energy*))))) - (:eat-carcass - (let* ((i (i-position status)) - (j (j-position status)) - (stuff (aref maze i j))) - (when (and (listp stuff) - (member :carcass stuff)) - (setf (energy-reserve status) - (min (+ (energy-reserve status) *carcass-energy*) - *maximum-energy*))))) - (:peek-left - (unless (eq (aref maze (+ (i-position status) - (forward-di (facing status))) - (+ (j-position status) - (forward-dj (facing status)))) - :rock) - (setf (peeking status) :left))) - (:peek-right - (unless (eq (aref maze (+ (i-position status) - (forward-di (facing status))) - (+ (j-position status) - (forward-dj (facing status)))) - :rock) - (setf (peeking status) :right))) - (:wait - )))) - -;;; Movement/Redisplay interface. - -(defun delete-object (thing i j) - (when (eq thing :mushroom) - (decf *mushrooms-alive*)) - (let ((stuff (aref maze i j))) - (cond ((atom stuff) - (setf (aref maze i j) nil)) - ((null (cddr stuff)) - (setf (aref maze i j) - (if (eq (car stuff) thing) - (cadr stuff) - (car stuff)))) - (t - (setf (aref maze i j) (delete thing stuff))))) - (queue-redisplay i j)) - -(defun place-object (thing i j) - (when (eq thing :mushroom) - (incf *mushrooms-alive*)) - (let ((stuff (aref maze i j))) - (cond ((null stuff) - (setf (aref maze i j) thing)) - ((consp stuff) - (setf (aref maze i j) (cons thing stuff))) - (t - (setf (aref maze i j) (list thing stuff))))) - (queue-redisplay i j)) - -(defun reincarnate-feeb (feeb) - (let ((position (nth (random (length *entry-points*)) *entry-points*)) - (facing (random 4)) - (status (feeb-status feeb))) - (place-object (feeb-image feeb) - (position-i position) (position-j position)) - (setf (i-position status) (position-i position)) - (setf (j-position status) (position-j position)) - (setf (facing status) facing) - (setf (feeb-dead-p feeb) nil) - (setf (ready-to-fire status) t) - (setf (energy-reserve status) - (+ *minimum-starting-energy* - (random (- *maximum-starting-energy* - *minimum-starting-energy*)))) - (setf (last-move status) :dead))) - -(defun kill-feeb (feeb) - (push feeb *dead-feebs*) - (setf (feeb-dead-p feeb) t) - (setf (feeb-turns-dead feeb) 0) - (setf (energy-reserve (feeb-status feeb)) 0) - (let* ((status (feeb-status feeb)) - (i (i-position status)) - (j (j-position status))) - (incf (score status) *points-for-dying*) - ;; Clean up the periscope when a peeking feeb dies. - (when (peeking status) - (queue-redisplay (+ i (forward-di (facing status))) - (+ j (forward-dj (facing status))))) - (delete-object (feeb-image feeb) i j) - (place-object :carcass i j) - (when *feep-dead-feebs* - (feep *feep-dead-feebs-volume*)))) - -;;; Display routines for Feebs under X (Version 10). All display -;;; primitives used in this program are defined here. This was -;;; written for a monochrome display but could easily be adapted -;;; for a color display. - -(defvar *birds-eye-window*) -(defvar *status-window*) -(defvar *banner-window*) - -(defvar *status-font-id*) -(defvar *banner-font-id*) - -(defparameter bordercolor nil) -(defparameter background nil) -(defparameter borderwidth 1) - -(defparameter birds-eye-width 704) -(defparameter birds-eye-height 704) -(defparameter birds-eye-x 36) -(defparameter birds-eye-y 60) - -(defparameter status-window-width 248) -(defparameter status-window-height 704) -(defparameter status-window-x 740) -(defparameter status-window-y 60) - -(defparameter banner-window-width 952) -(defparameter banner-window-height 27) -(defparameter banner-window-x 36) -(defparameter banner-window-y 32) - -(defparameter feebs-font "8x13") -(defparameter *char-width* 8) -(defparameter *char-height* 13) - -(defparameter banner-font "micr25") -(defparameter feebs-banner - "Planet of the Feebs: A Somewhat Educational Simulation Game") - -(defconstant redisplay-scale 22) -(defconstant pixel-character #\X) - -(defun init-graphics () - (x:open-console) - (setf bordercolor (x:blackpixmap)) - (setf background (x:whitepixmap)) - (setq *status-font-id* (x:xgetfont feebs-font)) - (setq *banner-font-id* (x:xgetfont banner-font))) - -(defun tini-graphics () - (x:xfreefont *status-font-id*) - (x:xfreefont *banner-font-id*)) - -(defmacro create-window (x y width height) - (declare (fixnum x y width height)) - `(x:xcreatewindow (x:rootwindow) ,x ,y ,width ,height borderwidth - bordercolor background)) - -(defmacro prepare-for-xevents (window) - `(progn (x:xselectinput ,window important-xevents) - (system:add-xwindow-object ,window ,window *feebs-windows*))) - -(defmacro display-window (window) - `(x:xmapwindow ,window)) - -(defmacro delete-window (window) - `(x:xdestroywindow ,window)) - -;;; Window event control section. Lots of hair necessary to deal -;;; with funny stuff of X windows. Ignore it if you want to, but -;;; it won't go away. - -(defconstant important-xevents - (logior x:exposeregion x:exposewindow x:buttonpressed x:keypressed)) - -(defvar *buttonpressed-flag* nil) -(defconstant blow-away-feebs-character #\q) -(defconstant single-step-feebs-character #\s) -(defconstant auto-mode-feebs-character #\a) - -;;; Create an object set of windows to receive certain events from X. - -(defvar *feebs-windows* (system:make-object-set "Feebs Windows")) - -;;; Sleep-with-server sleeps the appropriate amount of time but -;;; still processes xevents with the system server. - -(defun sleep-with-server (time) - (let ((end (+ (get-internal-real-time) - (truncate (* time internal-time-units-per-second))))) - (loop - (let ((left (- end (get-internal-real-time)))) - (unless (plusp left) (return nil)) - (system:server (* left (truncate 1000 internal-time-units-per-second))))))) - -;;; Redraws a specific window if an exposure event (either exposewindow -;;; or exposeregion) occurs. - -(defun redraw-all-exposed-regions (object width height x y subwindow) - (declare (ignore width height x y subwindow)) - (cond ((eq object *birds-eye-window*) - (redisplay-all)) - ((eq object *status-window*) - (display-all-status)) - ((eq object *banner-window*) - (redisplay-banner)))) - -(defun redraw-all-exposed-windows (object subwindow) - (declare (ignore object subwindow)) - (cond ((eq object *birds-eye-window*) - (redisplay-all)) - ((eq object *status-window*) - (display-all-status)) - ((eq object *banner-window*) - (redisplay-banner)))) - -;;; Sets the buttonpressed flag to true when a mouse button is pressed. - -(defun set-buttonpressed-flag (object mod-bits scan-code x y - subwindow time abs-x abs-y) - (declare (ignore object mod-bits scan-code x y subwindow time abs-x abs-y)) - (setq *buttonpressed-flag* t)) - -;;; Check which key was pressed and do the appropriate thing. - -(defun check-keypressed (object mod-bits scan-code x y - subwindow time abs-x abs-y) - (declare (ignore object x y subwindow time abs-x abs-y)) - (cond ((eq (hemlock-internals::translate-character scan-code mod-bits) - blow-away-feebs-character) - (format t "Feebs was interrupted at turn ~D.~%" *current-turn*) - (setq *continue* nil)) - ((eq (hemlock-internals::translate-character scan-code mod-bits) - single-step-feebs-character) - (setq *single-step* t)) - ((eq (hemlock-internals::translate-character scan-code mod-bits) - auto-mode-feebs-character) - (setq *single-step* nil)))) - -;;; Stops and waits until any one of the mouse buttons is pressed. - -(defun get-mouse-buttonpress () - (loop - (when *buttonpressed-flag* - (setq *buttonpressed-flag* nil) - (return)) - (system:server))) - -;;; Tell the X server which functions will handle which events when -;;; they occur. - -(x:serve-exposeregion *feebs-windows* #'redraw-all-exposed-regions) -(x:serve-exposewindow *feebs-windows* #'redraw-all-exposed-windows) -(x:serve-buttonpressed *feebs-windows* #'set-buttonpressed-flag) -(x:serve-keypressed *feebs-windows* #'check-keypressed) - -;;; Rings the keyboard bell. - -(defun feep (feep-volume) - (x:xfeep feep-volume)) - -;;; The following section of code is used to manipulate an array -;;; of 16-bit unsigned integers (a "bit-array"). This array -;;; can be encoded with a graphic pattern from strings with -;;; "X"'s in them and then passed to X window manager routines to -;;; create a bitmap for display. - -;;; Computes the number of 16-bit unsigned integers needed for -;;; the bit-array. - -(defmacro bit-array-size (width height) - (declare (fixnum width height)) - `(* (truncate (+ ,width 15) 16) ,height)) - -;;; Computes how many bits each line of the bit-array has. - -(defmacro bit-array-line-len (width) - (declare (fixnum width)) - `(truncate (+ ,width 15) 16)) - -;;; Allows referencing of individual bits in the bit-array. - -(defun bit-array-ref (array x y width) - (declare (fixnum x y width)) - (multiple-value-bind (words bits) (truncate x 16) - (ldb (byte 1 bits) - (aref array - (+ (* y (bit-array-line-len width)) - words)))))) - -;;; Defines bit-array-ref as a setfable form to allow setting -;;; of the individual bits in the bit-array. - -(defsetf bit-array-ref (array x y width) (new) - (declare (fixnum x y width)) - (let ((words (gensym)) - (bits (gensym))) - `(multiple-value-bind (,words ,bits) (truncate ,x 16) - (setf (ldb (byte 1 ,bits) - (aref ,array - (+ (* ,y (bit-array-line-len ,width)) - ,words))) - ,new)))) - -;;; Creates an array of 16-bit unsigned integers with the bits -;;; in this array set to 1 or 0 according to where there is an -;;; "X" in the strings. This bit-array can then be passed to -;;; the X routines to create a bitmap. - -(defun make-bit-array-from-strings (strings width height) - (declare (list strings) (integer width height)) - (let ((bit-array (make-array (bit-array-size width height) - :element-type '(unsigned-byte 16) - :initial-element 0))) - (do ((strings strings (cdr strings)) - (row 0 (1+ row))) - ((eq row height)) - (let ((string (car strings))) - (declare (simple-string string)) - (dotimes (column width) - (if (char= (schar string column) pixel-character) - (setf (bit-array-ref bit-array column row width) 1))))) - bit-array)) - -(defmacro make-bitmap (bit-array width height) - (declare (fixnum width height)) - `(x:xstorebitmap ,width ,height ,bit-array)) - -(defmacro delete-bitmap (bitmap) - `(x:xfreebitmap ,bitmap)) - -;;; Rotates the image in the bit-array to face in the -;;; specified direction relative to the current. - -(defun rotate-bit-array (bit-array width height direction) - (declare (fixnum width height)) - (if (eq width height) - (let ((rotated-bit-array (make-array (bit-array-size width height) - :element-type '(unsigned-byte 16) - :initial-element 0))) - (cond ((eq direction east) - (dotimes (j height) - (dotimes (i width) - (if (eq (bit-array-ref bit-array i j width) 1) - (setf (bit-array-ref rotated-bit-array - (- width j) i width) 1))))) - ((eq direction south) - (dotimes (j height) - (dotimes (i width) - (if (eq (bit-array-ref bit-array i j width) 1) - (setf (bit-array-ref rotated-bit-array - (- width i) (- height j) - width) 1))))) - ((eq direction west) - (dotimes (j height) - (dotimes (i width) - (if (eq (bit-array-ref bit-array i j width) 1) - (setf (bit-array-ref rotated-bit-array - j (- height i) width) 1)))))) - rotated-bit-array))) - -;;; Completely shades in a rectangular region of the screen at -;;; x and y coordinates and specified width and height. (or -;;; shades the region white if :undraw is t.) - -(defmacro draw-rectangle (window x y width height &key (undraw nil)) - (declare (fixnum x y width height)) - `(x:xpixset ,window ,x ,y ,width ,height (if ,undraw x:whitepixel x:blackpixel))) - -;;; Draws an X bitmap to the screen at x and y coordinates with -;;; the specified width and height. - -(defmacro draw-bitmap (window x y width height bitmap) - (declare (fixnum x y width height)) - `(x:xpixfill ,window ,x ,y ,width ,height x:blackpixel ,bitmap - x:gxclear x:allplanes)) - -;;; Prints a string of characters in the specified location. - -(defmacro draw-string (window x y string) - (declare (fixnum x y) (simple-string string)) - `(x:xtext ,window ,x ,y ,string (length ,string) - *status-font-id* x:blackpixel x:whitepixel)) - -;;; Prints a feeb-id in inverse video in the specified location. - -(defmacro draw-feeb-id (window x y string) - (declare (fixnum x y) (simple-string string)) - `(x:xtext ,window ,x ,y ,string (length ,string) - *status-font-id* x:whitepixel x:blackpixel)) - - -;;; Redisplay functions. Control the movement of the feebs in the -;;; maze window. - -(defun init-banner () - (setq *banner-window* - (create-window banner-window-x banner-window-y - banner-window-width banner-window-height)) - (x:xsync 1) - (prepare-for-xevents *banner-window*) - (display-window *banner-window*) - (redisplay-banner)) - -(defun tini-banner () - (x:xflush) - (delete-window *banner-window*)) - -(defun init-redisplay () - (setq *birds-eye-window* - (create-window birds-eye-x birds-eye-y birds-eye-width birds-eye-height)) - (init-bitmaps) - (x:xsync 1) - (prepare-for-xevents *birds-eye-window*) - (display-window *birds-eye-window*) - (redisplay-all)) - -(defun tini-redisplay () - (x:xflush) - (delete-window *birds-eye-window*) - (tini-bitmaps)) - -(defun redisplay-banner () - (x:xtextpad *banner-window* 40 3 feebs-banner 59 *banner-font-id* - 0 8 x:blackpixel x:whitepixel x:gxcopy x:allplanes)) - -(defvar *redisplay-map* (make-array (list *maze-i-size* *maze-j-size*) - :element-type 'bit)) - -(defvar *redisplay-hints* (make-array *maze-i-size*)) - -(defun queue-redisplay (i j) - (setf (aref *redisplay-map* i j) 1) - (setf (aref *redisplay-hints* i) t)) - -(defun redisplay () - (dotimes (i *maze-i-size*) - (when (aref *redisplay-hints* i) - (setf (aref *redisplay-hints* i) nil) - (dotimes (j *maze-j-size*) - (when (/= (aref *redisplay-map* i j) 0) - (setf (aref *redisplay-map* i j) 0) - (redisplay-square i j))))) - (dolist (feeb *feebs*) - (draw-periscope feeb))) - -(defun redisplay-all () - (dotimes (i *maze-i-size*) - (setf (aref *redisplay-hints* i) nil) - (dotimes (j *maze-j-size*) - (setf (aref *redisplay-map* i j) 0) - (redisplay-square i j))) - (dolist (feeb *feebs*) - (unless (feeb-dead-p feeb) - (draw-periscope feeb)))) - -(defun redisplay-square (i j) - (let ((stuff (aref maze i j)) - (display-x (* j redisplay-scale)) - (display-y (* i redisplay-scale))) - (if (eq stuff :rock) - (draw-rectangle *birds-eye-window* display-x display-y - redisplay-scale redisplay-scale) - (draw-rectangle *birds-eye-window* display-x display-y - redisplay-scale redisplay-scale :undraw t)) - (if (consp stuff) - (dolist (substuff stuff) - (display-one-item substuff display-x display-y)) - (display-one-item stuff display-x display-y)))) - -(defun display-one-item (stuff display-x display-y) - (cond ((null stuff) - ) - ((eq stuff :rock) - ) - ((eq stuff :mushroom) - (draw-mushroom display-x display-y)) - ((eq stuff :carcass) - (draw-carcass display-x display-y)) - ((feeb-image-p stuff) - (setq stuff (feeb-image-feeb stuff)) - (draw-feeb display-x display-y stuff)) - ((fireball-image-p stuff) - (draw-fireball display-x display-y - (fireball-image-direction stuff))) - (t - (error "Some strange thing in the maze: ~S." stuff)))) - - -;;; String-maps for images. These will be transformed into bitmaps -;;; that can be displayed in a small area. The scale of the string- -;;; maps is given by the variable redisplay-scale. - -(defvar *mushroom-bitmap*) -(defvar *carcass-bitmap*) -(defvar *fireball-bitmaps* (make-array 4)) - -(defun init-bitmaps () - (setq *mushroom-bitmap* - (make-bitmap - (make-bit-array-from-strings - '(" " - " " - " " - " " - " XXXXXXX " - " XXXX X X XXX " - " XX X X X X X X " - " XX X X X X X X X " - " XX X X X X X X X X " - " XX XXX X XXX XXX X X " - " X X " - " X X " - " X X " - " X X " - " X X " - " X X " - " X X " - " X X " - " XXXXXX XXXX " - " " - " " - " ") - redisplay-scale redisplay-scale) - redisplay-scale redisplay-scale)) - (setq *carcass-bitmap* - (make-bitmap - (make-bit-array-from-strings - '(" " - " " - " XXXXX XXXXX " - " XXXXX XXXXX " - " XXX XXX " - " XXX XXX " - " XXXXXXXXXXXXXXXXXXXX " - " XXXXXXXXXXXXXXXXXXXX " - " XXXXXXXXXXXXXXXXXXXX " - " XXXXXXXXXXXXXXXXXXXX " - " XXXXXXXXXXXXXXXXXXXX " - " XXXXXXXXXXXXXXXXXXXX " - " XXXXXXXXXXXXXXXXXXXX " - " XXXX XXXXXX XXXX " - " XXX X X XXXX X X XXX " - " XXX X XXXX X XXX " - " XXX X X XXXX X X XXX " - " XXXX XXXXXX XXXX " - " XXXXXXXXXXXXXXXXXXXX " - " XXXXXXXXXXXXXXXXXXXX " - " " - " ") - redisplay-scale redisplay-scale) - redisplay-scale redisplay-scale)) - (let ((bit-array (make-bit-array-from-strings - '(" " - " X " - " X X X " - " X X X XX X " - " X X " - " X X X X " - " X XXXX X " - " X XXXX X " - " X XX X X " - " X X X " - " X X X " - " X X X X " - " X X " - " X X X " - " X X X " - " X X " - " X " - " X X " - " X " - " X " - " X " - " ") - redisplay-scale redisplay-scale))) - (setf (svref *fireball-bitmaps* 0) - (make-bitmap bit-array redisplay-scale redisplay-scale)) - (setf (svref *fireball-bitmaps* 1) - (make-bitmap (rotate-bit-array bit-array redisplay-scale - redisplay-scale east) - redisplay-scale redisplay-scale)) - (setf (svref *fireball-bitmaps* 2) - (make-bitmap (rotate-bit-array bit-array redisplay-scale - redisplay-scale south) - redisplay-scale redisplay-scale)) - (setf (svref *fireball-bitmaps* 3) - (make-bitmap (rotate-bit-array bit-array redisplay-scale - redisplay-scale west) - redisplay-scale redisplay-scale)))) - -(defun tini-bitmaps () - (delete-bitmap *mushroom-bitmap*) - (delete-bitmap *carcass-bitmap*) - (dotimes (i 4) - (delete-bitmap (svref *fireball-bitmaps* i)))) - -(defun draw-mushroom (x y) - (draw-bitmap *birds-eye-window* x y redisplay-scale redisplay-scale - *mushroom-bitmap*)) - -(defun draw-carcass (x y) - (draw-bitmap *birds-eye-window* x y redisplay-scale redisplay-scale - *carcass-bitmap*)) - -(defun draw-feeb (x y feeb) - (let ((id (make-string 1 :initial-element (digit-char (feeb-id feeb))))) - (draw-rectangle *birds-eye-window* (+ x 1) (+ y 1) 20 20) - (case (facing (feeb-status feeb)) - (0 - ;; Draw the feeb-id on the feeb's chest. - (draw-feeb-id *birds-eye-window* (+ x 7) (+ y 8) id) - ;; Draw the feeb's eye-outline. - (draw-rectangle *birds-eye-window* (+ x 4) (+ y 3) 5 5 :undraw t) - (draw-rectangle *birds-eye-window* (+ x 14) (+ y 3) 5 5 :undraw t) - ;; Put pupils in the feeb's eyes. - (draw-rectangle *birds-eye-window* (+ x 5) (+ y 4) 3 3) - (draw-rectangle *birds-eye-window* (+ x 15) (+ y 4) 3 3) - (draw-rectangle *birds-eye-window* (+ x 6) (+ y 5) 1 1 :undraw t) - (draw-rectangle *birds-eye-window* (+ x 16) (+ y 5) 1 1 :undraw t)) - (1 - ;; Draw the feeb-id on the feeb's chest. - (draw-feeb-id *birds-eye-window* (+ x 3) (+ y 5) id) - ;; Draw the feeb's eye-outline. - (draw-rectangle *birds-eye-window* (+ x 14) (+ y 4) 5 5 :undraw t) - (draw-rectangle *birds-eye-window* (+ x 14) (+ y 14) 5 5 :undraw t) - ;; Put pupils in the feeb's eyes. - (draw-rectangle *birds-eye-window* (+ x 15) (+ y 5) 3 3) - (draw-rectangle *birds-eye-window* (+ x 15) (+ y 15) 3 3) - (draw-rectangle *birds-eye-window* (+ x 16) (+ y 6) 1 1 :undraw t) - (draw-rectangle *birds-eye-window* (+ x 16) (+ y 16) 1 1 :undraw t)) - (2 - ;; Draw the feeb-id on the feeb's chest. - (draw-feeb-id *birds-eye-window* (+ x 7) (+ y 1) id) - ;; Draw the feeb's eye-outline. - (draw-rectangle *birds-eye-window* (+ x 14) (+ y 14) 5 5 :undraw t) - (draw-rectangle *birds-eye-window* (+ x 4) (+ y 14) 5 5 :undraw t) - ;; Put pupils in the feeb's eyes. - (draw-rectangle *birds-eye-window* (+ x 15) (+ y 15) 3 3) - (draw-rectangle *birds-eye-window* (+ x 5) (+ y 15) 3 3) - (draw-rectangle *birds-eye-window* (+ x 16) (+ y 16) 1 1 :undraw t) - (draw-rectangle *birds-eye-window* (+ x 6) (+ y 16) 1 1 :undraw t)) - (3 - ;; Draw the feeb-id on the feeb's chest. - (draw-feeb-id *birds-eye-window* (+ x 11) (+ y 5) id) - ;; Draw the feeb's eye-outline. - (draw-rectangle *birds-eye-window* (+ x 4) (+ y 14) 5 5 :undraw t) - (draw-rectangle *birds-eye-window* (+ x 4) (+ y 4) 5 5 :undraw t) - ;; Put pupils in the feeb's eyes. - (draw-rectangle *birds-eye-window* (+ x 5) (+ y 15) 3 3) - (draw-rectangle *birds-eye-window* (+ x 5) (+ y 5) 3 3) - (draw-rectangle *birds-eye-window* (+ x 6) (+ y 16) 1 1 :undraw t) - (draw-rectangle *birds-eye-window* (+ x 6) (+ y 6) 1 1 :undraw t))))) - -;;; Must draw a peeking feeb's periscope in a separate operation, so that it -;;; doesn't get clobbered by other drawing in the square being peeked at. - -(defun draw-periscope (feeb) - (when (and (not (feeb-dead-p feeb)) - (peeking (feeb-status feeb))) - (let* ((status (feeb-status feeb)) - (peeking (peeking status)) - (x (* redisplay-scale (j-position status))) - (y (* redisplay-scale (i-position status)))) - (case (facing status) - (0 - (draw-rectangle *birds-eye-window* (+ x 11) (- y 5) 2 7) - (if (eq peeking :left) - (draw-rectangle *birds-eye-window* (+ x 9) (- y 5) 2 2) - (draw-rectangle *birds-eye-window* (+ x 13) (- y 5) 2 2))) - (1 - (draw-rectangle *birds-eye-window* (+ x 22) (+ y 11) 7 2) - (if (eq peeking :left) - (draw-rectangle *birds-eye-window* (+ x 27) (+ y 9) 2 2) - (draw-rectangle *birds-eye-window* (+ x 27) (+ y 13) 2 2))) - (2 - (draw-rectangle *birds-eye-window* (+ x 11) (+ y 22) 2 7) - (if (eq peeking :left) - (draw-rectangle *birds-eye-window* (+ x 13) (+ y 27) 2 2) - (draw-rectangle *birds-eye-window* (+ x 9) (+ y 27) 2 2))) - (3 - (draw-rectangle *birds-eye-window* (- x 5) (+ y 11) 7 2) - (if (eq peeking :left) - (draw-rectangle *birds-eye-window* (- x 5) (+ y 13) 2 2) - (draw-rectangle *birds-eye-window* (- x 5) (+ y 9) 2 2))))))) - -(defun draw-fireball (x y facing) - (declare (fixnum x y facing)) - (draw-bitmap *birds-eye-window* x y redisplay-scale redisplay-scale - (svref *fireball-bitmaps* facing))) - - -;;; Status display. - -(defconstant turn-column 6) -(defconstant id-column 0) -(defconstant name-column 3) -(defconstant score-column 8) -(defconstant kill-column 13) -(defconstant energy-column 18) -(defconstant last-move-column 23) - -(defun init-status-display () - (setq *status-window* (create-window status-window-x status-window-y - status-window-width status-window-height)) - (x:xsync 1) - (prepare-for-xevents *status-window*) - (display-window *status-window*) - (display-all-status)) - -(defun tini-status-display () - (x:xflush) - (delete-window *status-window*)) - -;;; Energy values change every turn, and always are in the range -;;; from 0 to 200, so just pre-compute all the strings for efficiency. - -(defvar *small-number-strings* - '#(" 0" " 1" " 2" " 3" " 4" " 5" " 6" " 7" " 8" " 9" - " 10" " 11" " 12" " 13" " 14" " 15" " 16" " 17" " 18" " 19" - " 20" " 21" " 22" " 23" " 24" " 25" " 26" " 27" " 28" " 29" - " 30" " 31" " 32" " 33" " 34" " 35" " 36" " 37" " 38" " 39" - " 40" " 41" " 42" " 43" " 44" " 45" " 46" " 47" " 48" " 49" - " 50" " 51" " 52" " 53" " 54" " 55" " 56" " 57" " 58" " 59" - " 60" " 61" " 62" " 63" " 64" " 65" " 66" " 67" " 68" " 69" - " 70" " 71" " 72" " 73" " 74" " 75" " 76" " 77" " 78" " 79" - " 80" " 81" " 82" " 83" " 84" " 85" " 86" " 87" " 88" " 89" - " 90" " 91" " 92" " 93" " 94" " 95" " 96" " 97" " 98" " 99" - "100" "101" "102" "103" "104" "105" "106" "107" "108" "109" - "110" "111" "112" "113" "114" "115" "116" "117" "118" "119" - "120" "121" "122" "123" "124" "125" "126" "127" "128" "129" - "130" "131" "132" "133" "134" "135" "136" "137" "138" "139" - "140" "141" "142" "143" "144" "145" "146" "147" "148" "149" - "150" "151" "152" "153" "154" "155" "156" "157" "158" "159" - "160" "161" "162" "163" "164" "165" "166" "167" "168" "169" - "170" "171" "172" "173" "174" "175" "176" "177" "178" "179" - "180" "181" "182" "183" "184" "185" "186" "187" "188" "189" - "190" "191" "192" "193" "194" "195" "196" "197" "198" "199" - "200")) - -(defmacro energy-to-string (energy) - `(svref *small-number-strings* (max ,energy 0))) - -;;; This refreshes or initializes all parts of the display. - -(defun display-all-status () - (display-string "*STATUS*" 1 8 8) - (display-string "Turn: " 3 0 6) - (display-number *current-turn* 3 8 6) - ;; 00000000001111111111222222222233333333334444444444 - ;; 01234567890123456789012345678901234567890123456789 - (display-string - "ID Name Sco. Kill Eng. LM" 4 0 25) - (display-string - "-------------------------" 5 0 25) - (dolist (feeb *feebs*) - (let ((status (feeb-status feeb)) - (line (+ (feeb-id feeb) 6))) - (display-number (feeb-id feeb) line 0 3) - (display-string (name status) line 3 4) - (setf (feeb-last-score feeb) (score status)) - (display-number (score status) line 8 4) - (setf (feeb-last-kills feeb) (kills status)) - (display-number (kills status) line 13 4) - (display-string (energy-to-string (energy-reserve status)) line 18 4) - (display-string (cond ((feeb-dead-p feeb) "De") - ((aborted status) "Ab") - (t (case (last-move status) - (:turn-left "TL") - (:turn-right "TR") - (:turn-around "TA") - (:move-forward "MF") - (:eat-mushroom "EM") - (:eat-carcass "EC") - (:peek-left "PL") - (:peek-right "PR") - (:wait "WA") - (T "NM")))) - line 23 2))) - (display-string - "Click any mouse button to" 22 0 25) - (display-string - "zap windows at the end." 23 3 23) - (display-string - "Press the \"q\" key to quit" 25 0 25) - (display-string - "at any time." 26 3 12) - (display-string - "Press the \"s\" key to jump" 28 0 25) - (display-string - "into single-step mode." 29 3 22) - (display-string - "Click any mouse button to" 31 0 25) - (display-string - "single-step." 32 3 12) - (display-string - "Press the \"a\" key to jump" 34 0 25) - (display-string - "back to automatic mode." 35 3 13)) - -(defun display-status () - (display-number *current-turn* 3 8 6) - (dolist (feeb *feebs*) - (let ((status (feeb-status feeb)) - (line (+ (feeb-id feeb) 6)) - temp) - (unless (= (feeb-last-score feeb) - (setq temp (score status))) - (setf (feeb-last-score feeb) temp) - (display-number temp line 8 4)) - (unless (= (feeb-last-kills feeb) - (setq temp (kills status))) - (setf (feeb-last-kills feeb) temp) - (display-number temp line 13 4)) - (display-string (energy-to-string (energy-reserve status)) line 18 4) - (display-string (cond ((feeb-dead-p feeb) "De") - ((aborted status) "Ab") - (t (case (last-move status) - (:turn-left "TL") - (:turn-right "TR") - (:turn-around "TA") - (:move-forward "MF") - (:eat-mushroom "EM") - (:eat-carcass "EC") - (:peek-left "PL") - (:peek-right "PR") - (:wait "WA") - (T "NM")))) - line 23 2)))) - -(defun display-string (string line column field-width) - (draw-rectangle *status-window* - (* (+ column 2) *char-width*) (* line *char-height*) - (* field-width *char-width*) *char-height* :undraw t) - (draw-string *status-window* (* (+ column 2) *char-width*) - (* line *char-height*) - string)) - -;;; Print a number plus optionally a leading minus sign. Buffers the -;;; characters in a pre-existing string, so does no consing. The number -;;; is printed right-justified within a field of the specified length, -;;; starting at the specified line and column. - -(defvar *number-string-length* 5) -(defvar *number-string-buffer* (make-array *number-string-length* - :element-type 'string-char)) - -(defun display-number (n line column field ) - (let ((charpos *number-string-length*) - (quotient (abs n)) - (remainder 0)) - (cond ((zerop n) - ;; Special-case zero so it doesn't print as nothing at all. - (decf charpos) - (setf (schar *number-string-buffer* charpos) #\0)) - (t - ;; Stuff digits into the string from right to left. - (do () - ((zerop quotient)) - (multiple-value-setq (quotient remainder) - (truncate quotient 10)) - (decf charpos) - (setf (schar *number-string-buffer* charpos) - (digit-char remainder))) - ;; And output the minus sign if needed. - (when (minusp n) - (decf charpos) - (setf (schar *number-string-buffer* charpos) #\-)))) - (do () - ((<= charpos 0)) - (decf charpos) - (setf (schar *number-string-buffer* charpos) #\space)) - ;; Now print it. - (draw-rectangle *status-window* - (* column *char-width*) (* line *char-height*) - (* field *char-width*) *char-height* :undraw t) - (draw-string *status-window* - (* (+ column field (- *number-string-length*)) *char-width*) - (* line *char-height*) - *number-string-buffer*))) - -;;; It. - -(defun feebs (&key (layout default-layout) - single-step - delay - files - feep-dead-feebs) - "This starts the simulation. Takes some options as keyword arguments. - :Single-step, if non-null, says to wait for any mouse click after each round. - :Delay, if non-null, is a number of seconds to wait after each round. - :Layout is the layout of the maze to use, if you don't want the default. - :Files is a list of files containing feeb definitions." - (let ((*single-step* single-step) - (*delay* delay) - (*feep-dead-feebs* feep-dead-feebs) - (*continue* t)) - (when files (apply #'load-feebs files)) - (let ((n (- *number-of-feebs* (length *feebs-to-be*)))) - (cond ((minusp n) - (error "Too many pre-defined feebs: ~S.~%" - (length *feebs-to-be*))) - ((zerop n)) - (t (format t "Making ~S dumb auto-feebs.~%" n) - (make-auto-feebs n)))) - (init-maze layout) - (create-mushrooms) - (create-feebs) - (init-play) - (unwind-protect - (progn - (init-graphics) - (init-banner) - (init-redisplay) - (init-status-display) - (play)) - (when (and (not *single-step*) *continue*) - (display-string "THE END." 19 8 8) - (get-mouse-buttonpress)) - (x:xsync 1) - (tini-redisplay) - (tini-status-display) - (tini-banner) - (x:xflush) - (tini-graphics)) - (write-line "Final scores:") - (dolist (feeb (reverse *feebs*)) - (format t "(~A) ~20A ~5D~%" - (feeb-id feeb) - (feeb-image-name (feeb-image feeb)) - (score (feeb-status feeb)))))) - - -;;; Feeb creation. - -(defun reset-feebs () - (setq *feebs-to-be* nil)) - -(defun load-feebs (&rest files) - (reset-feebs) - (dolist (file files) - (load file))) - -(defun make-auto-feebs (n) - (let* ((nrandoms (floor n 3)) - (nwanders (floor n 3)) - (nconserve (- n nrandoms nwanders))) - (dotimes (i nrandoms) - (push (cons (concatenate 'string "Rnd" (princ-to-string (1+ i))) - 'random-brain) - *feebs-to-be*)) - (dotimes (i nwanders) - (push (cons (concatenate 'string "Wnd" (princ-to-string (1+ i))) - 'wandering-brain) - *feebs-to-be*)) - (dotimes (i nconserve) - (push (cons (concatenate 'string "Cns" (princ-to-string (1+ i))) - 'conservative-brain) - *feebs-to-be*)))) - - -;;; Here are some simple auto-feeb brains to use until we get better ones. - -;;; About the stupidest brain possible. Something for everyone to feel -;;; superior to. - -(defun random-brain (status proximity vision vision-left vision-right) - (declare (ignore status proximity vision vision-left vision-right)) - (svref '#(:turn-left :turn-right :turn-around :move-forward - :flame :eat-mushroom :eat-carcass :peek-left :peek-right - :wait) - (random 10))) - - -;;; This one wanders around, feeds when it can, and shoots at any visible -;;; opponent. - -(defun wandering-brain (status proximity vision vision-left vision-right) - (declare (ignore vision-left vision-right)) - (let ((stuff (my-square proximity))) - (cond ((and (consp stuff) (member :mushroom stuff :test #'eq)) - :eat-mushroom) - ((and (consp stuff) (member :carcass stuff :test #'eq)) - :eat-carcass) - ((and (ready-to-fire status) - (dotimes (index (line-of-sight status)) - (let ((stuff (aref vision index))) - (if (listp stuff) - (if (dolist (thing stuff) - (if (feeb-image-p thing) - (return t))) - (return t)) - (if (feeb-image-p stuff) - (return t)))))) - :flame) - ((and (not (eq (left-square proximity) :rock)) - (> 0.2 (random 1.0))) - :turn-left) - ((and (not (eq (right-square proximity) :rock)) - (> 0.2 (random 1.0))) - :turn-right) - ((not (ready-to-fire status)) - :wait) - ((> (line-of-sight status) 0) - :move-forward) - ((not (eq (left-square proximity) :rock)) - :turn-left) - ((not (eq (right-square proximity) :rock)) - :turn-right) - (t - :turn-around)))) - -;;; This one is similar to the wandering brain, but doesn't shoot if -;;; energy reserves are too low or the opponent is too far away. - -(defun conservative-brain (status proximity vision vision-left vision-right) - (declare (ignore vision-left vision-right)) - (let ((stuff (my-square proximity))) - (cond ((and (consp stuff) (member :mushroom stuff :test #'eq)) - :eat-mushroom) - ((and (consp stuff) (member :carcass stuff :test #'eq)) - :eat-carcass) - ((and (ready-to-fire status) - (> (energy-reserve status) 30) - (dotimes (index (min (line-of-sight status) 5)) - (let ((stuff (aref vision index))) - (if (listp stuff) - (if (dolist (thing stuff) - (if (feeb-image-p thing) - (return t))) - (return t)) - (if (feeb-image-p stuff) - (return t)))))) - :flame) - ((and (not (eq (left-square proximity) :rock)) - (> 0.2 (random 1.0))) - :turn-left) - ((and (not (eq (right-square proximity) :rock)) - (> 0.2 (random 1.0))) - :turn-right) - ((not (ready-to-fire status)) - :wait) - ((> (line-of-sight status) 0) - :move-forward) - ((not (eq (left-square proximity) :rock)) - :turn-left) - ((not (eq (right-square proximity) :rock)) - :turn-right) - (t - :turn-around)))) diff --git a/contrib/games/feebs/feebs.log b/contrib/games/feebs/feebs.log deleted file mode 100644 index bcd02a8ee47465688d68713b38e26041559733a0..0000000000000000000000000000000000000000 --- a/contrib/games/feebs/feebs.log +++ /dev/null @@ -1,90 +0,0 @@ -/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 16:33:43, Edit by Chiles. - Made FEEBS bind, instead of set, *single-step*,*delay*, - *feep-dead-feebs*, and *continue*. These values were being retained - between runs. - -/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 15:35:47, Edit by Chiles. - Fixed X interaction by calling X:OPEN-CONSOLE in INIT-GRAPHICS. Also, - set bordercolor and background parameters in INIT-GRAPHICS. Made - KILL-FEEB look at the value of *feep-dead-feebs*. - -/usr2/lisp/library/rt/feebs/brains.lisp, 11-Oct-87 12:01:50, Edit by Chiles. - Written by Skef and Scott. This is just a file of sample feebs that are - pretty dumb. - -/usr2/lisp/library/rt/feebs/mazes.lisp, 11-Oct-87 11:57:15, Edit by Chiles. - Created by Jim Healy, July 1987. This file contains some sample mazes - with various curious properties. - -/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:53:54, Edit by Chiles. - No time stamp for this either, but it is close to the previous line's. - - ;;; Modifications by Jim Healy: - ;;; - ;;; Ported the graphics to the IBM RT PC using the X window manager. - ;;; Added functions to create and store bitmaps for X. - ;;; Added event-handling routines to catch incoming events from the - ;;; X server and redisplay the windows if exposed. - ;;; Changed :single-step option to work by clicking a mouse button. - ;;; Added keypress features to quit the game prematurely (q), jump - ;;; into single-step mode (s), and go back to automatic mode (a). - ;;; Added the neat "Planet of the Feebs" banner at the top. - ;;; Added feature to zap windows at end of game by clicking a mouse - ;;; button. - ;;; Fixed the disembodied periscopes bug. - -/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:52:55, Edit by Chiles. - No time stamp on this entry. - - ;;; Modifications by Dan Kuokka: - ;;; - ;;; Built the interface to a generalized set of graphics primitives. - ;;; Wrote rotate-bitmap. - -/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:51:54, Edit by Chiles. - No time stamp on this entry either. - - ;;; The following by Scott Fahlman, for initial public release: - ;;; - ;;; Installed CHANCE macro to speed up random events. - ;;; Modified points for being killed from -5 to -2. - ;;; When you zap yourself, you get no points for the kill. - ;;; Eliminated random length of game. Now *GAME-LENGTH* = 1000. - ;;; Modified default maze slightly so that no two entry points are - ;;; line of sight, regardless of how the feebs are facing. - ;;; Changed directions from keywords to constants, with integer values: - ;;; north = 1, east = 2, etc. - ;;; Randomize initial entry points for feebs. - ;;; Display more interesting stuff in text area: score, energy, last move. - ;;; Keep energy in range 0 to 200 always, fix bug that caused any eating - ;;; to push energy to maximum. - ;;; Display kills in status area, along with score. - ;;; ABORTED status field was not being maintained. - ;;; Install a smoother function for aborting moves of slow feebs. - ;;; Add single-step and slow motion. - ;;; Put in proximity sense, start vision array in space in front of the - ;;; the feeb's current location, going forward, left, or right from there. - ;;; Store the appropriate image list in each maze cell, eliminating the - ;;; IMAGIFY operations. Add a pointer from the feeb-image back to the - ;;; full feeb-structure. - ;;; Allow *maze-i-size* and *maze-j-size* to be different. - ;;; Fixed a couple of bugs in fireball motion. - ;;; Feebs running into fireballs get zapped. - ;;; Make sure image is updated between action and redisplay. - ;;; Queue redisplay for a feeb's old square on every move. - ;;; Improve mushroom image to not hit edges of square. - ;;; Improve fireball display to show direction of travel. - ;;; On reflection, update fireball DIRECTION as well as DI, DJ. - ;;; Display current turn. Improve kludgy number printing. - ;;; Display periscope-like appendage when feeb is peeking. - ;;; Do not execute peek command if the feeb is facing a rock wall. - ;;; When a feeb was peeking last move, queue the forward square for - ;;; redisplay to get rid of the periscope. - ;;; Set up auto-feeb creation and add some stupid auto-feebs. - ;;; Remove the terse printing function for the status structure to make - ;;; it somewhat easier to debug things. - ;;; Fixed a bug in the DI and DJ macros. - -/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:50:10, Edit by Chiles. - Created by Skef Wholey -- No time stamp. - diff --git a/contrib/games/feebs/feebs.mss b/contrib/games/feebs/feebs.mss deleted file mode 100644 index 450d2e97cf996830a9e8b77dbb4149af219720ea..0000000000000000000000000000000000000000 --- a/contrib/games/feebs/feebs.mss +++ /dev/null @@ -1,556 +0,0 @@ -@make [article] -@device [dover] - -@begin [titlepage] -@begin [titlebox] -@majorheading [Planet of the Feebs] -@heading [A Somewhat Educational Simulation Game] - -Scott E. Fahlman -Computer Science Department -Carnegie-Mellon University - -Version: @value [filedate] -@end [titlebox] - -@copyrightnotice [Scott E. Fahlman] -@end[titlepage] -@newpage -@section [Introduction] - -@i[Planet of the Feebs] is a simulation game that is intended as a -training aid for beginning programmers in Common Lisp. It is loosely -based on the "Maze War" game, written by Jim Guyton, Bruce Malasky, and -assorted others at Xerox PARC. In @i[Planet of the Feebs], however, the -players do not control their creatures by hand. Instead, they supply -programs which control the creatures as they move around the maze trying -to zap one another. The game presents an open-ended challenge, and -advanced players may find themselves reaching deep into the AI bag of -tricks as they try to build ever more clever and adaptable creatures. - -The current version of the program runs in CMU Common Lisp on the IBM RT -PC under the Mach operating system. It uses the X window manager. It -was designed by Scott Fahlman and programmed by Fahlman, Skef Wholey, -and Dan Kuokka. Other members of the Spice Lisp group at CMU have -contributed ideas and have helped to tune and polish the system. - -The Feebs environment is easily reconfigurable by changing certain -global parameters. Normally, the parameters to be used in a given -contest are announced to the players before they begin writing their -programs, since very different strategies may be appropriate with -different parameters. In this document, we will indicate the names of -those parameters in boldface, followed by the usual value of this -parameter in parentheses. To see how any given feebs world is -configured, execute the function (list-parameter-settings), which will -create and return an A-list of all the interesting parameters: - -@begin [example] -((*number-of-feebs* . 10) - (*carcass-rot-probability* . 1/3) ...) -@end [example] - -@section [Life Among The Feebs] - -Deep below the surface of a medium-sized planet, in a long-forgotten -maze of tunnels, live a race of strange creatures, the feebs. The -origin of the name "feebs" is lost in the mists of antiquity. Some say -that the name is short for "feeble minded", which most of the creatures -certainly are; some say that the name is a contraction of the term -"flaming bogons", a phrase whose origins are also, unfortunately, lost -in antiquity; most likely, the name comes from the feebing noise that -the creatures occasionally make as they wander the maze. - -Locked in their isolated world, the feebs compete fiercely for the -two types of available food: large mushrooms that sometimes appear at -certain places in the labyrinth, and each other. Life is tough in the -labyrinth; it's every feeb for itself. The goal is survival, and any -competitors must be ruthlessly eliminated. - -Physically very similar to one another, the feebs must try to survive by -superior intelligence. Each feeb has an electrical organ which can use -to "flame" at its competitors, emitting a lethal "fireball" -- actually -an unstable ball of high-energy plasma, similar to ball lightning. The -fireball travels erratically down the tunnel in the direction the -creature is facing. The flame is the feeb's only weapon. The only -defense is to stay out of the line of fire or to outrun the oncoming -fireball, but a feeb who hides in a secluded corner of the maze will -eventually starve. Unfortunately, the mushrooms tend to grow at tunnel -junctions and in dead-end corridors, places where feeding creatures run -a considerable risk of ambush or entrapment. - -The walls of the maze emit a soft glow due to a coating of -phosphorescent (but inedible) fungi. Even in this dim light, the feebs -can see well. The feebs can peek around corners without exposing -themselves to hostile fire, but a peeking feeb can be seen by opponents -in the tunnel he is peeking into. - -The simple feeb world does not allow for much variety of action. Feebs -can turn by 90 or 180 degrees, move one step forward, flame, feed, peek -around corners, or stay put. Feebs cannot back up or move sideways; -they must turn in the direction they want to go. Some feebs are -moderately intelligent, but none of them has much coordination. -Consequently, a feeb can only perform one of these basic actions at -once. (Very early in feeb evolution they learned not to chew gum.) All -of the feebs suffer from the same limitations, so cleverness -- and -sometimes a bit of luck -- are all-important. - -@section [The Game] - -@subsection [Overview] - -@i[Planet of the Feebs] is played by up to @b[*number-of-feebs*] (10) -human players at once. Each player controls one of the feebs in the -maze. This control is not exerted directly, but rather by supplying a -program, called the @i[behavior function], that controls the creature's -actions. All of the programmed feebs are turned loose in the maze at -once, and the competition for survival begins. The game runs for a -number of turns specified by @b[*game-length*] (1000). Zapping an -opponent gives a feeb @b[*points-for-killing*] (+1) point, while being -zapped or dying of hunger gives it a penalty of @b[*points-for-dying*] -(-2) points. Feebs that manage to shoot themselves do not get credit -for the kill. A dead feeb is reincarnated as soon as his carcass has -rotted, which takes a few turns. These newly reincarnated creatures -re-enter the maze at some randomly-chosen entry point. - -Being highly evolved creatures, the feebs think using Common Lisp. (At -one time there were feebs who thought using Pascal, but all of these -have attained a provably correct extinction.) Each feeb's behavior, at -each turn of the game, is supplied by a Common Lisp function (which may -be a lexical closure). This function receives as its arguments the -feeb's sensory inputs (including some internal sensations such as the -degree of hunger) and it returns one of the simple actions of which the -feeb is capable. - -The game proceeds as a series of synchronous turns. At the start of -each turn various natural phenomena occur: mushrooms grow, flame-balls -move (destroying things as they go), and feebs occasionally die of -starvation. Next, the behavior function for each feeb receives its -sensory inputs and computes its desired action. Occasionally an action -is turned to a no-op because the feeb has responded too slowly (see -below). Finally, all remaining actions are executed at once. - -The maze is laid out as a array of size @b[*maze-i-size*] by -@b[*maze-j-size*] (32 x 32). Some locations or "squares" contain rock, -others empty space. All tunnels are one unit wide. There are T, L and -+ junctions, as well as dead ends, but no large rooms. There are no -disconnected parts of the maze: it is possible to reach any tunnel -square from any other tunnel square. The feebs may or may not know the -specific layout of the maze in advance (see the section on Contest -Rules), but a feeb in a strange maze may build up some sort of map as he -wanders around. Feebs do have a mysterious navigational sense that -tells them their own I and J coordinates at any given time, as well as -the direction in which they are facing. - -A feeb always faces North, South, East, or West, and never anything in -between. Any number of feebs may occupy a given square at once. A feeb -has a short-range sense of "proximity" that tells it what is in its own -square and certain adjacent squares. However, a feeb cannot flame into -its own square or engage in hand-to-hand combat (feebs have no hands, -and their rubbery beaks are only strong enough to attack mushrooms and -flame-broiled opponents). It is rather awkward for two feebs in the -same square to disengage without becoming targets for one another, but -it is also dangerous to remain together, since a successful shot into -this square by another feeb will kill all the occupants. Mushrooms and -carcasses do not impede the movement of live feebs. - -A maze normally contains @b[*number-of-feebs*] (10) feebs, usually -representing that many different players. If fewer than the specified -number of players are participating, the remaining niches are filled by -the addition of "autofeebs" supplied by the system. These creatures -come in several types, but all have rather simple behavior patterns. -Some are almost suicidally aggressive, for example, while others run -from trouble whenever possible. - -The maze designer pre-designates a set of entry points. These may be -close to one another, but no entry point will be visible from any other. -There must be at least as many of these entry points as there are feebs -in the maze. At the start of the game, each feeb is assigned a -different entry point, randomly chosen from this predefined set, facing -in a randomly chosen direction. A feeb being reincarnated will appear -at one of the original entry points, chosen at random. This might -result in two feebs suddenly facing one another, but the new feeb is in -considerably greater danger than the existing ones, since it may well -materialize facing a wall or dead end -- yet another reason not to get -yourself killed in the first place. - -@subsection [Food] - -Feebs have to eat. At each turn, the behavior function receives an -indication of the creature's current energy reserves, measured in Zots. -This energy reserve is decreased by one Zot after each turn, regardless -of what the creature did during that turn. Flaming uses up an -additional @b[*flame-energy*] (10) Zots. The energy is decremented when -the action is executed; if the remaining energy at the start of a turn -is zero or negative, the creature starves to death immediately, leaving -a carcass. - -A feeb feeds by executing the :EAT-MUSHROOM or :EAT-CARCASS command -while in a square occupied by the specified type of food. A feeding -feeb can do nothing else in that turn, and hence is rather vulnerable. -Feeding on a mushroom increments the feeb's energy reserve by -@b[*mushroom-energy*] (50) Zots, but destroys the mushroom. Feeding on -a carcass increments the energy reserve by @b[*carcass-energy*] (30) -Zots per turn, and may go on for several turns before the carcass rots. -Feebs have a maximum capacity of @b[*maximum-energy*] (200) Zots -- -gorging beyond that point does not increase the creature's reserves, -though it may be useful as a way of keeping food away from opponents. -Feebs start the game moderately hungry, with a reserve randomly chosen -between @b[*minimum-starting-energy*] (50) and -@b[*maximum-starting-energy*] (100) Zots. - -The maze designer pre-designates certain squares as mushroom-growing -locations. Typically, there will be @b[*number-of-mushrooms*] (10) -mushrooms in the maze at any given time and -@b[*number-of-mushroom-sites*] (30) places where they may appear. The -initial locations of the mushrooms are chosen at random from this set of -locations. Once a mushroom appears, it will remain in that square until -it is eaten or destroyed by a fireball. Whenever a mushroom is -destroyed, a new one appears at some vacant mushroom-growing location, -chosen at random. There can never be more than one mushroom in a square -at any given time. Since an eaten mushroom reappears somewhere else and -an uneaten mushroom will stay around forever, as the game progresses the -mushrooms will tend to be found in parts of the maze that are seldom -visited or at exposed locations where feeding is too risky. - -Whenever a feeb dies, either from incineration or starvation, a carcass -is left behind in the square where the death occurred. Unlike -mushrooms, which disappear when eaten, a carcass may be fed upon -repeatedly, by any number of feebs, until it rots away. A feeb killed -during Turn T will not begin to rot until turn T+N, where N is the value -of @b[*carcass-guaranteed-lifetime*] (3). At the end of that turn, and -at the end of each turn thereafter, it has a -@b[*carcass-rot-probability*] (1/3) chance of rotting away (disappearing -completely). The feeb that died is not reincarnated until after the -carcass has rotted away. At that point, the feeb appears in one of the -starting squares, pointing in some random direction, and with energy -reserves computed as at the start of the game. - -@subsection [Flaming] - -When a feeb flames, the fireball travels down the tunnel in the direction -the feeb is facing, moving at one square per turn. More precisely, if a -feeb gives the :FLAME command during turn T, the fireball appears in the -adjacent square at the start of turn T+1, destroying the contents. (The -intended victim may, however, have moved away during turn T.) The fireball -enters the next square at the start of turn T+2, and so on. - -As the fireball tries to enter each new square, including the first one, it -has a certain probability of dissipating: this is controlled by -@b[*fireball-dissipation-probability*] (1/4). When a fireball enters a -square containing a mushroom, that mushroom is destroyed. When a fireball -enters a square containing a live feeb, that feeb is killed, leaving a -carcass. Existing carcasses are already burned, so they are not affected -by subsequent fireballs. A feeb will also be killed if it moves into a -square currently occupied by a fireball. - -The fireball proceeds in this manner, killing everything in its path, -until it either dissipates or encounters the wall at the end of the -straight-line corridor. When the fireball hits the wall, it often -dissipates, but it may be reflected back in the direction it came from -with probability @b[*fireball-reflection-probability*] (1/2). More -precisely, if the fireball is in square S, the last space of a corridor, -at time T, and would move into a solid-rock square at T+1, and it -happens to be successfully reflected, its direction is reversed and it -appears to be entering square S from the solid rock square at the start -of time T+1. In addition to the possibility that it will not be -reflected, the fireball must face the usual dissipation probability on -this turn as well. A reflected fireball then proceeds to travel back in -the direction it came from until it dissipates or is reflected again. -Fireballs pass through one another with no interference. - -The relatively slow motion of the fireballs has some interesting -consequences. If a feeb sees a fireball coming, it may well be able to -outrun it or to duck into a side corridor, though time wasted in turning -may be fatal. It is safe to dash past the mouth of a tunnel in which -another feeb is lurking unless the second feeb happens to flame in -anticipation of the move. However, it is unwise to stop or turn while -in such an intersection. Because of the rule that a feeb moving into a -square occupied by a fireball is killed, a feeb cannot avoid a fireball -by rushing toward it, attempting to swap places. However, a feeb can -safely move into the square of an enemy feeb that is firing on the -current turn. It is very unhealthy for a feeb to move forward in the -turn immediately following one in which it fires. - -After flaming, the feeb must wait an unpredictable amount of time before -it can flame again. On the turn after it fires, a feeb definitely will -be unable to fire. On every every turn thereafter, the flamer will have -a probability of @b[*flame-recovery-probability*] (1/2) of recovering -and being able to flame again. A feeb can sense whether it is ready to -fire or not, but cannot tell whether an opponent is able to fire. Thus, -a certain amount of bluffing is possible. - -@subsection [Timing] - -It is dangerous for a feeb to spend too much time thinking about what to do -next. The time taken by each of the behavior functions is recorded. The -action ordered by the feeb has a chance of being aborted (turned into a -no-op) with a probability that is proportional to the time the feeb took to -generate the order. This can be particularly awkward in the middle of a -shootout or when running from a fireball. - -More precisely, if @b[*slow-feeb-noop-switch*] (T) is non-nil, then the -probability of aborting a feeb's move is the product of the time the feeb -took and @b[*slow-feeb-noop-factor*] (.25), divided by the total time taken -by all feebs on this turn. If @b[*slow-feeb-noop-switch*] is NIL, this -feature is disabled and no moves are aborted; this mode is recommended when -some of the feebs are being controlled by hand. - -@subsection [Actions] - -Behavior functions are only called when the creature is alive. -A behavior function indicates its selected action by returning one of -the following keyword symbols: - -@Begin[Description] -:TURN-LEFT @\Turn left by 90 degrees, staying in the current square. - -:TURN-RIGHT @\Turn right by 90 degrees, staying in the current square. - -:TURN-AROUND @\Turn around 180 degrees, staying in the current square. - -:MOVE-FORWARD @\Move forward one square. - -:FLAME @\Shoot a flame in the direction the creature is facing. - -:EAT-MUSHROOM @\Feed on a mushroom if one is available in the current -square. Otherwise, do nothing. - -:EAT-CARCASS @\Feed on a carcass if at least one is available in the -current square. Otherwise, do nothing. - -:PEEK-LEFT @\The creature does not actually move, but the visual input -received next turn will be what the creature would see if it were to move -forward one square and turn left. If the creature wishes to continue -peeking left, this command must be repeated each turn. - -:PEEK-RIGHT @\Analogous to PEEK-LEFT. - -:WAIT @\Stay put and do nothing. -@End[Description] - -Any output that is not one of the symbols listed above is interpreted as -a :WAIT. - -@subsection [Sensory Inputs] - -The behavior function always receives five arguments, representing its -various sensory inputs. The programmer can call these whatever he -likes, but I will call them STATUS, PROXIMITY, VISION, VISION-LEFT, and -VISION-RIGHT. Each of these is a data structure that the program can -access, but not modify, using a variety of accessing functions. The -system will destructively modify these structures from one turn to the -next. - -The information in the STATUS structure can be accessed as follows: - -@Begin[Description] - -(name status) @\A string. Whatever name the user supplied for this -creature at the start of the game. - -(facing status) @\The direction the feeb is facing, encoded as a small -integer: 0 = north, 1 = east, 2 = south, 3 = west. Note: for -convenience, NORTH, EAST, SOUTH, and WEST are defined as constants with -the integer values specified above. - -(i-position status) @\An integer from zero (inclusive) to @b[*maze-i-size*] -(exclusive) indicating the creature's current I position. - -(j-position status) @\Analogous to i-position. - -(peeking status) @\One of :LEFT, :RIGHT, or NIL. Indicates whether the -visual information coming in this turn is the result of a peek command -in the previous turn. - -(line-of-sight status) @\An integer indicating the number of squares -that can be seen in the direction the feeb is facing or peeking. Thus, -the number of valid entries in the VISION vector. - -(energy-reserve status) @\An integer indicating how many energy units -the creature has, equivalent to the number of turns it can live (without -flaming) before it starves to death. - -(score status) @\The creature's current score. - -(kills status) @\The total number of rivals killed by this feeb (not -counting suicides). - -(ready-to-fire status) @\T if the creature is able to fire this turn, -NIL if not. - -(aborted status) @\T if the creature's last move was aborted because it -took too long. - -(last-move status) @\The last move issued by the creature. Any of the -action symbols listed above, or :DEAD if the creature has just been -reincarnated. -@End[Description] - -The PROXIMITY input is also a read-only structure, with slots describing -the contents of the creature's current square and the adjacent ones to -its rear, left, and right. The slots are accessed as follows: - -@Begin[Description] -(my-square proximity) @\Returns the contents of the current square. A -feeb does not see himself in this square, even though he is there. - -(rear-square proximity) @\Returns the contents of the square behind the -creature. - -(left-square proximity) @\Returns the contents of the square to the -creature's left. - -(right-square proximity) @\Returns the contents of the square to the -creature's right. -@End[Description] - -The values returned by these functions can be any of the following: - -@Begin[Description] -NIL @\The square is empty space. - -:ROCK @\A solid rock wall in this direction. - -:MUSHROOM @\The square contains a mushroom. - -:CARCASS @\The square contains a carcass. - -A structure of type FEEB-IMAGE @\This represents a feeb. One can call -(feeb-image-name x) on this image to get the feeb's name and -(feeb-image-facing x) to get the direction it is facing, expressed as an -integer from 0 to 3. - -A structure of type FIREBALL-IMAGE @\This represents a fireball. One -can call (fireball-image-direction x) on this image to get the direction -the fireball is moving, expressed as an integer from 0 to 3. - -A list @\This is used when more than one item is in the square at once. -The list can contain any number of image structures, plus perhaps a -:MUSHROOM and/or :CARCASS symbol. -@End[Description] - -The VISION argument receives a simple vector whose length is the maximum of -*maze-i-size* and *maze-j-size*. Thus, it can hold any possible linear -line of sight that can occur in the maze. However, only some of the -entries are really valid, as indicated by the value returned by the -(line-of-sight status) call; entries beyond the valid range may contain -garbage or hallucinations. - -Each item in the VISION vector describes what is in a given cell, using -the same notation as for the PROXIMITY argument. (svref vision 0) -should return information about the square into which the feeb is -facing, the same information that would be returned by (front-square -proximity). If the feeb is looking straight ahead, (svref vision 1) -would return the contents of the next square in that direction, and so -on, until we reach (svref vision (line-of-sight status)), which contains -garbage. If the feeb is peeking left or right, (svref vision 0) -still accesses the square physically in front of the feeb, but higher -indices access a line of squares to the left or right of that square. - -The VISION-LEFT and VISION-RIGHT arguments are simple vectors whose -entries correspond to the entries in VISION. Instead of indicating what -is in each square along the line of sight, however, they tell the -creature what is to the left or right of that square, along the -direction in which you are looking (or peeking). Each entry will have -one of three values: NIL (an opening on that side), :ROCK (a solid rock -wall on that side), or :PEEKING (an opening from which some creature is -peeking into your corridor). There is no way to tell whether the peeker -is peeking in your feeb's direction or the other way or whether there are -more than one of them. - -@section [Contest Rules] - -The rules for a feeb contest, including the settings of all the control -parameters, are announced in advance so that the programmers know what -kind of strategy to program into their behavior functions. Knowledge -about the maze itself may or may not be available, depending on how -difficult the contest organizers want to make the game. There are four -levels of complexity: - -@begin [description] -Level 0:@\The players are told in advance what the maze will look like, -with or without information about the location of mushroom spaces and -starting spaces. This information can be used in writing the behavior -functions. - -Level 1:@\No information is available about the maze in advance, but -once the game begins a feeb can examine a map of the entire maze and -plan a global strategy. The map is an array of dimensions *maze-i-size* -by *maze-j-size*, capable of holding any Lisp object in each element. -Initially, each array cell will be either :ROCK or NIL (open space). To -obtain a map, call (GET-MAZE-MAP). Each call produces a distinct map -array, so it is possible to write into the map array, perhaps to take -notes. - -Level 2:@\No map is available. If a feeb wants information about the -shape of the maze, it must explore the maze for itself. Calls to -(GET-MAZE-MAP) return NIL. - -Level 3:@\No map is available, and the feeb's location sense is -disabled. The I-POSITION and J-POSITION cells of the status object will -always read 0. This makes it much harder to create a map, since -sections of map developed during different incarnations must be fitted -together. -@end [description] - -Each player will supply a feeb-creation function with some unique name. -This function, which should be compiled, is loaded and then called with -no arguments. It returns two values: a behavior function for one feeb -and a string that will be used as that feeb's name. To avoid name -conflicts, each player should choose a different package. A complete -feeb definition file might look like this: - -@begin [example] -;;; -*- Package: Darth-Feeb -*- - -(in-package "DARTH-FEEB" :use '("LISP" "FEEBS")) - -;;; This feeb probably won't do too well against any other feebs. - -(defun darth-feeb-creator () - (values - #'(lambda (status vision vision-left vision-right) - (declare (ignore status vision vision-left vision-right)) - (svref '#(:turn-left :move-forward :flame) (random 3))) - "Darth Feeb")) - -@end [example] - -In a new Lisp, load "feebs.fasl" and any files containing feeb creation -functions. Then call (feebs:create-feeb <foo>) for each of the feeb -creation functions. Finally type (feebs:feebs) to start the show. -Auto-feebs will be created as needed. At the end, the final scores of -all the feebs will be printed. - -Team play is possible, with a sort of telepathic communication between -feebs on the same team. This is accomplished by calling each -feeb-creation function more than once. All feebs "hatched" from the -same creation function are team-mates, and their scores can be added -together at the end of the game. The creation function should return a -different name for each team member; it can return the same behavior -function for all team members, or a different function for each. It is -possible for these behavior functions to communicate via shared lexical -variables. - -@section [Ideas for Future Extensions] - -It would be possible to create a large set of attributes and abilities -that feebs might possess, and to make some of the existing ones -optional. Each of these abilities could be assigned a certain value, -and players could select which combination of abilities their feebs will -have from this menu. There could be a fixed limit on the total value of -features chosen, or a feeb too heavily loaded with features might just -become slower or less energy-efficient than the others. - -Among the features that might be on the menu would be the ability to -move backwards or sideways, the ability to peek, some ability to kill -opponents in one's own square, extended range for the omni-directional -proximity sense, a limited range for the visual sense, some ability to -survive a fireball hit, a sense of smell that indicates the distance to -the nearest food, the ability to see through a fireball (taken for -granted now), the ability to obtain a complete or partial map, -cold-bloodedness (a stationary feeb uses much less energy), and so on. - -We might also create a much more diverse and interesting set of -non-player flora and fauna, and perhaps a more interesting landscape. - diff --git a/contrib/games/feebs/mazes.lisp b/contrib/games/feebs/mazes.lisp deleted file mode 100644 index 0b7cc587a81bac3f968dadbfc9dd6698cba8069b..0000000000000000000000000000000000000000 --- a/contrib/games/feebs/mazes.lisp +++ /dev/null @@ -1,238 +0,0 @@ -;;; -*- Mode: Lisp; Package: Feebs; Log: feebs.log -*- -;;; -;;; Mazes for Planet of the Feebs. -;;; A somewhat educational simulation game. -;;; -;;; Created by Jim Healy, July 1987. -;;; -;;; ************************************************** -;;; Maze guidelines: -;;; Maze should be *maze-i-size* by *maze-j-size* -;;; (currently 32 x 32). -;;; X represents a wall. -;;; * represents a mushroom patch. -;;; e is a feeb entry point. -;;; ************************************************** - -;;; Maze1 has a good number of dead ends and little nooks. - -(defparameter maze1 - '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXX *eXXXX *e ** X" - "XXX XXXXX XXXX XXXXXXXXXXXX XX X" - "XXX XXX XXXXXX X X" - "XXXXX XXXXXXX XXXXXXX XXXXXXX XX" - "X * XXX XX * XeXX XX" - "X XXXXXXX XXX XXXXXXX X XXX XXXX" - "X XXXXXX XXX XX X *XX" - "X XXXXXXX XXX XXXXXXX XXXXXXXXXX" - "X XXXXXXX XXX* e XXXXXX XXX" - "X XXXXX XXXXXXXXX * XXX" - "X XXXXX XXXXXX XXXXXX XX XX" - "X eXXXX XXXXXX XXX XXXXX XX XXX" - "X XXXXX* XXXXe XXXX XX XX" - "X XXXXX XXXXXX XXXXX XXX XXX XX" - "X eXXXX e XXXXXX *XX XX XX" - "X XXXXX XXXXXX XXXXXXX X XXeXXX" - "X XXX XXXXXXXX XX XX" - "X XXXXX XXXXXX XXXXXXXXXX XXXXXX" - "X XXXXX * XXXXX XX" - "X* XXX XXXXXX XXXXX XXXXXX X XX" - "X XXXXX e XXXXX X e X XX" - "X XX XX XXXXXX XXXXX X XXXXXX XX" - "X *XXX XXXXX * XX" - "X XX XX XXXXXX XXXXXXXXXX XXXXXX" - "X XXXXX XXXXXX * * XX" - "X XXX XXXXXXXXXXXXXXXXXXXXX XX" - "X XXXX X X eX X XX" - "X XXX XX X XX X XX X XX X XX XX" - "X XXXX XX X XX X XX X XX*X XX XX" - "X e * XX XX * XX XX XXeXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX")) - -;;; Maze2 doesn't have any really long corridors. - -(defparameter maze2 - '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "X eXXXXX * X XXXXXX X e XXXXX" - "X XXXX X X XXXX X X XXXXX" - "X XX XXXX XXXX X* X X XXXXX" - "XX XX XXX XXXX XX XX X X" - "XX e XXX XXXXXXX XX XXXXXXXX*X" - "XXXX XXX XXXXX X e XXX XX X" - "XXXX XXX XXXXXXXX XXXX X X" - "XX * XX XXe XXXXXXXXXX XX XXX" - "XX XXXX X XX X XXX XXXXX XXX" - "XX XX XXX X XX XXXXX" - "XXXXX XXX *XXX X XXXXXXXX" - "XX* XXXXXX XXXX XXXX XXXXXXXX" - "XXXXX XX XXXX XXXXXXXXX XXXXXXXX" - "XXXXX e XXXX *XXXXXX eXXXXX" - "XXXXXXXX XXXXXXX XXXXXXXXX XXXXX" - "XXXXXX XXXXX eXXXXX XXXXX" - "XXXXXX XXX XXXXXXX XXXXX XXXXXXX" - "XX XXX X XXX XX X XX" - "XX XXX XXXXX XX XX XXX XX XX" - "XX XXXXX *X XX X XX XXXXXX*XX" - "X XXXXX XXXX X XX XX" - "X XX XXXXXXX XXXXX*X X Xe XXXX" - "X XXXX e X XXXXX*XX XX XXXX" - "X XX XXXXXX XX XXX*XXX XXX" - "XXXX eXXX XXXX XX XXXXX X X" - "XXXXXX XXXXXXXXX XX XXXX XXX X" - "XXX * X X XX XXXX XXX X X" - "XX XXXX X XX XXXX XXX X e X" - "XX XX * X * X XXXX XX XXX*X" - "XX XXX XXX XX eXXX XXX*X" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX")) - -;;; Maze3 has the minimum number of mushroom sites, most -;;; of which are between a rock and a hard place. Those -;;; poor feebs! - -(defparameter maze3 - '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "X e XXXXXX XXXXXXX*XXXXXXXXX" - "X X XXX XXXXX e XXXX XXX e X" - "X XXX XXXXXX XX XX XXX XXX X" - "XXX XXX XXXXXX XX XX X X e X" - "Xe XXX*XXXX* XX XXeX X XXXXX X" - "X X XXX XXXXXX XX XX X XXXXX X" - "X XXX XXXXXX XX* XXXXXXXXX X" - "X XXXXX XX e XX XXXXXXXX XXX X" - "X X XXX XXX XXXXX XXXXXX XXX X" - "Xe XXX XXXX XXXX X X X" - "XXX XXXX XXXXXXXX X XXX XXX" - "XXX eXX XXXXXXXXX XXXXX XXXXX" - "XXXXX XXXXXXXXXXXX XXXXXX XXX" - "XXXXX * XX eXX XXX XX XXX" - "XX*XXXX XXXXXX XX XXX XXX XX XXX" - "XX X XXXXX X XXX eXX XXX" - "X XXXXXXXX XX XXXX XXX XX XXX" - "X XXXXeXXXXXX XXXX XXX XX XXX" - "X XX*XXXXX XXXXXXXXX XXX" - "XXXXXX XXX XXXX XXXXXX XXX" - "XXXXXXXXX XXX XXXXXX XXXXXX XXX" - "XXX XX e eX XXXX" - "XX XXXXX XXXX XXXX XXXX XXXX" - "XX XXXXX XX XXXX XXXX XXXX XX" - "XX eXXXX XX XXXX XXXX XXXXXX XX" - "XXX XX XXX * XXX XX" - "XX XX XXXX* XXXX XXXX XXXXXX XX" - "XXX X XXXXX XXXX XXXX X XX" - "XXXX e XXXX XXXX X XX X X" - "XXXXXXXXXXXX *e X e XX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX")) - - -;;; Maze4 is symmetric about the vertical axis. (Wow...) - -(defparameter maze4 - '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "X* eXXXXXXXXXXe *X" - "X XXXXXXXX XXXXXXXX X" - "X XX XXXXXXX XX XXXXXXX XX X" - "X XeXXXXXXX XX XXXXXXXeX X" - "XX X XXXXXXX eXXe XXXXXXX X XX" - "XX X XXXXXXX XXXXXX XXXXXXX X XX" - "XX * XXXXXXX XXXXXX XXXXXXX * XX" - "XX X XXXe eXXX X XX" - "XX X XXX XXXXXXXXXXXXXX XXX X XX" - "XX e XXX XXXXXXXX XXX e XX" - "XX X XXXXXX XXXXXXXX XXXXXX X XX" - "XX X XXXX XXXXXXXX XXXX X XX" - "XX XXXX XXXe eXXXX XXXX XX" - "XXX XXXXX XXX XXX XXXX XXXXX XXX" - "XXX XXXXX XXX XXX XXXXX XXX" - "X* XXXXX XXXX XXXXX *X" - "X XXXXX XX XX ** XX XX XXXXX X" - "X XXXXX XX XX XXXX XX XX XXXXX X" - "X XXX e XX XX XXXX XX XX e XXX X" - "X XXXXX XX XXXX XX XXXXX X" - "X XXXXX XXXXX XXXX XXXXX XXXXX X" - "X X XXXXX XXXX XXXXX X X" - "XXXXX * * XXXXX" - "XXXXX XXXXXXXX XX XXXXXXXX XXXXX" - "XXXXX XXXXXXXX XX XXXXXXXX XXXXX" - "XXXXX XXXXX XX XXXXX XXXXX" - "XXXX XX XXXXeXXeXXXX XX XXXX" - "XXX XXXX XXX XX XXX XXXX XXX" - "XXX XXXXXX XXX XX XXX XXXXXX XXX" - "XX* e XX e *XX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX")) - -;;; Maze5 has a lot of long corridors good for feeb showdowns. -;;; Furthermore, all the feeb entry-points are in the corridors. -;;; You can run but you can't hide! - -(defparameter maze5 - '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "X e e X" - "X XXXXXXX*XXXXXXXXXXXX XXXXXXX X" - "X e X" - "X X XXXXX XXXXXXXXXXXX XXXXX X X" - "X * X" - "X X XX XX XXXXXXXXXXXX XX XX X X" - "X X XX XX XXXXXXXXXXXX XXeXX X X" - "X X XX XX * XX XX X X" - "XeX XX XX XXXXXXXXXXXX XX XX X X" - "X X XX XX XXXXXXXXXXXX XX XX X X" - "X X XX XX e XX XXeX X" - "X X XXeXX XXXXXXXXXXXX XX XX X X" - "X X XX XX XXXXXXXXXXXX XX XX XeX" - "X*X XX XX XX XX X X" - "X X XX XX XXXXXXXXXXXX XX XX X X" - "X XeXX XX XXXXXXXXXXXX*XX XX X X" - "X X XX XX * XX XX*X X" - "X X XX XX XXXXXXXXXXXX XX XX X X" - "X X XX XX XXXXXXXXXXXX XX XX X X" - "X X XX XX e XX XX*X X" - "X X XX*XX XXXXXXXXXXXX XX XX X X" - "X X XX XX XXXXXXXXXXXX XX XX X X" - "X X XX XX XX XXeX X" - "X X XX XX XXXXXXXXXXXX XX XX X X" - "X X XX XX XXXXXXXXXXXX XX XX X X" - "X e X" - "X*X XXXXX XXXXXXXXXXXX XXXXX X*X" - "X e * X" - "X XXXXXXX XXXXXXXXXXXX XXXXXXX X" - "X e * X" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX")) - -;;; Don't try to run this next one! Just use it to create -;;; new mazes. - -(defparameter maze-template - '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX")) - diff --git a/contrib/hist/hist.catalog b/contrib/hist/hist.catalog deleted file mode 100644 index e6858e5e332903b8ed1bba1d78ba5aae8119fa39..0000000000000000000000000000000000000000 --- a/contrib/hist/hist.catalog +++ /dev/null @@ -1,53 +0,0 @@ -Package Name: - HIST - -Description: - Simple histogram facility using Format strings for output. - -Author: - Scott E. Fahlman - -Address: - Carnegie-Mellon University - Computer Science Department - Pittsburgh, PA 15213 - -Net Address: - Scott.Fahlman@CS.CMU.EDU - -Copyright Status: - Public Domain. - -Files: - hist.lisp, hist.fasl, hist.catalog - -How to Get: - The following unix command will copy the pertinent files into directory -<spec>. - cp /afs/cs.cmu.edu/project/slisp/library/hist/* <spec> - -Portability: - Should run in any legal Common Lisp. - -Instructions: - Hist is a macro of form (HIST (min max [bucket-size]) . body) - -Creates a histogram with buckets of the specified size (defaults to 1), -spanning the range from Low (inclusive) to High (exclusive), with two -additional buckets to catch values below and above this range. The body is -executed as a progn, and every call to Hist-Record within the body provides a -value for the histogram to count. When Body exits, the histogram is printed -out and Hist returns Nil. - -A simple example: - (hist (0 10) (dotimes (i 1000) (random 10))) -This example may make the RANDOM distribution look more normal: - (hist (0 10 2) (dotimes (i 1000) (random 10))) -This example will show you overflow buckets: - (hist (2 12) (dotimes (i 1000) (random 15))) - -Wish List: - Some sort of automatic scaling for the number and size of buckets would be -nice, if the user chooses not to supply these. This would probably require -running the body twice, once to determine the spread of values, and again to -actually produce the histogram. diff --git a/contrib/hist/hist.lisp b/contrib/hist/hist.lisp deleted file mode 100644 index 40f212416371cae068f458448a8f71ac5c84cbdb..0000000000000000000000000000000000000000 --- a/contrib/hist/hist.lisp +++ /dev/null @@ -1,89 +0,0 @@ -;;; -*- Mode: Lisp; Package: Hist; Log: Hist.Log -*- -;;; -;;; This code has been placed in the public domain by the author. -;;; It is distributed without warranty of any kind. -;;; -;;; Description: Simple Histogram facility. Just prints out the result -;;; using Format. No fancy graphics. -;;; -;;; Author: Scott E. Fahlman -;;; -;;; Current maintainer: Scott E. Fahlman -;;; -;;; Address: Carnegie-Mellon University -;;; Computer Science Department -;;; Pittsburgh, PA 15213 -;;; -;;; Net address: Scott.Fahlman@cmu-cs-a -;;; -;;; Copyright status: Public domain. -;;; -;;; Compatibility: Should run in any legal Common Lisp implementation. -;;; -;;; Dependencies: Depends only on standard Common Lisp facilities. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(in-package "HIST") -(export '(hist hist-record)) - -;;; Uses a bunch of specials for communication. - -(proclaim '(special *hist-lower-limit* - *hist-upper-limit* - *hist-bucket-size* - *hist-nbuckets* - *hist-array*)) - -(defconstant hist-limit 60 - "The maximum number of #'s that are to be printed.") - -(defmacro hist ((low high &optional (bucket-size 1)) - &body body) - "Format is (HIST (low high [bucket-size]) . body). - Creates a histogram with buckets of the specified size (defaults to 1), - spanning the range from Low (inclusive) to High (exclusive), with two - additional buckets to catch values below and above this range. - The body is executed as a progn, and every call to Hist-Record within - the body provides a value for the histogram to count. - When Body exits, the histogram is printed out and Hist returns Nil." - `(let* ((*hist-lower-limit* ,low) - (*hist-upper-limit* ,high) - (*hist-bucket-size* ,bucket-size) - (*hist-nbuckets* - (+ 2 (ceiling (- *hist-upper-limit* *hist-lower-limit*) - *hist-bucket-size*))) - (*hist-array* (make-array *hist-nbuckets* :initial-element 0))) - (progn ,@body) - (let ((biggest 0) (scale 1)) - (dotimes (b (- *hist-nbuckets* 2)) - (when (> (svref *hist-array* b) biggest) - (setq biggest (svref *hist-array* b)))) - (when (> biggest hist-limit) - (setq scale (ceiling biggest hist-limit)) - (format t "~&Each \"#\" equals ~S units. The \".\" indicates a fraction." - scale)) - (format t "~&< ~S: ~12,8T~S~%" - *hist-lower-limit* - (svref *hist-array* (1- *hist-nbuckets*))) - (do ((b 0 (1+ b)) - (bval *hist-lower-limit* (+ bval *hist-bucket-size*)) - (bcount 0)) - ((= b (- *hist-nbuckets* 2))) - (setq bcount (svref *hist-array* b)) - (multiple-value-bind (q r) (truncate bcount scale) - (format t "~S: ~12,8T~S~20,8T~V,1,0,'#@A~%" - bval bcount (1+ q) (if (zerop r) #\ #\.)))) - (format t "> ~S: ~12,8T~S~%" - *hist-upper-limit* - (svref *hist-array* (- *hist-nbuckets* 2)))) - nil)) - -(defun hist-record (value) - "This function should only be called within the body of a HIST form. - Increments the proper histogram counter to record this value." - (cond ((< value *hist-lower-limit*) - (incf (svref *hist-array* (1- *hist-nbuckets*)))) - ((>= value *hist-upper-limit*) - (incf (svref *hist-array* (- *hist-nbuckets* 2)))) - (t (incf (svref *hist-array* (floor (- value *hist-lower-limit*) - *hist-bucket-size*)))))) diff --git a/contrib/library-maintenance/catalog-cat.lisp b/contrib/library-maintenance/catalog-cat.lisp deleted file mode 100644 index 4d2493896adae6dc08f02c1300adf74b9f3257f5..0000000000000000000000000000000000000000 --- a/contrib/library-maintenance/catalog-cat.lisp +++ /dev/null @@ -1,64 +0,0 @@ -;;; -*- Mode: Lisp; Package: library -*- -;;; -;;; This contains somewhat specific code for gathering all the pertinent -;;; .catalog files from the CMU Common Lisp Library subdirectories to -;;; construct one catalog.txt file from them. -;;; -;;; This code uses at least one implementation internal function, hacks -;;; pathnames as strings, accepts CMU Common Lisp logical names, tries -;;; to determine what a directory name looks like, uses CMU Common Lisp -;;; extensions, and generally tries not to be portable in any way. -;;; -;;; Written by Bill Chiles -;;; - -(in-package "LIBRARY" :nicknames '("LIB")) - -(export 'build-catalog) - - -(defun build-catalog (dir) - "Gather all the .catalog files from the subdirectories of dir, bashing them - into a file named \"new-catalog.txt\" in dir. The argument must be a - logical name or end with a slash (/)" - (with-open-file (stream (merge-pathnames dir "new-catalog.txt") - :direction :output :if-exists :new-version) - (let* ((files (catalog-files dir)) - (last (car (last files)))) - (dolist (f files) - (with-open-file (catalog f) - (do ((line (read-line catalog nil :eof) - (read-line catalog nil :eof))) - ((eq line :eof)) - (write-line line stream)) - (unless (equal f last) - (format stream "~%~|~%"))))))) - - -;;; CATALOG-FILES does a DIRECTORY (CMU Common Lisp) of dir returning a -;;; list of file names containing the string ".catalog". The directory -;;; listing may include subdirectories, but these subdirs contain only -;;; files (one of which is a catalog file). The subdirectory catalog -;;; files are included in the result list in order of the subdirectory's -;;; appearance. -;;; -(defun catalog-files (dir) - (let ((listing (directory dir)) - result) - (dolist (f listing (nreverse result)) - (let ((name (namestring f))) - (declare (simple-string name)) - (if (directoryp f) - (dolist (f (directory name)) - (let ((name (namestring f))) - (declare (simple-string name)) - (when (search ".catalog" name :test #'char=) - (push name result) - (return)))) - (if (search ".catalog" name :test #'char=) - (push name result))))))) - -(defun directoryp (p) - (let ((p (pathname p))) - (string= (the simple-string (directory-namestring p)) - (the simple-string (namestring p))))) diff --git a/contrib/library-maintenance/compile-lib.lisp b/contrib/library-maintenance/compile-lib.lisp deleted file mode 100644 index 8525db0fdab037d62a4ed9f1994348451be8fee6..0000000000000000000000000000000000000000 --- a/contrib/library-maintenance/compile-lib.lisp +++ /dev/null @@ -1,21 +0,0 @@ -;;; -*- Mode: Lisp; Package: library -*- -;;; -;;; This file contains stupid code to simply compile all the library entries. -;;; -;;; Written by Blaine Burks. -;;; - -(in-package "LIBRARY" :nicknames '("LIB")) - -(export '(compile-entries)) - -(defun compile-entries () - (let ((lib-directory (directory ed::*lisp-library-directory*))) - (dolist (lib-spec lib-directory) - (let* ((path-parts (pathname-directory lib-spec)) - (last (svref path-parts (1- (length path-parts)))) - (raw-pathname (merge-pathnames last lib-spec))) - (when (and (ed::directoryp lib-spec) - (probe-file (merge-pathnames ".catalog" raw-pathname))) - (compile-file (merge-pathnames raw-pathname ".lisp") :error-file nil) - (write-string last)))))) diff --git a/contrib/library-maintenance/old-catalog-format.txt b/contrib/library-maintenance/old-catalog-format.txt deleted file mode 100644 index d6ea1d00eec4d0a342b3c12e7ce2c1f6b0b23982..0000000000000000000000000000000000000000 --- a/contrib/library-maintenance/old-catalog-format.txt +++ /dev/null @@ -1,72 +0,0 @@ - -CATALOG ENTRY FORMAT FOR CATALOG.TXT. - -Each entry is on a separate page, separated by the page mark Control-L. - -Each entry consists of fields. Each new field begins with a field name in -square brackets, then an arbitrary amount of text. This rather rigid -format is designed to make it easy to build various sorts of software to -automatically manipulate catalogs. The field names are sensitive to -spelling, but insensitive to case and extra whitespace. - -Fields currently recognized are as follows: - -[Name] or [Module Name]: The name of the program or set of programs. If no -Package Name is supplied, then this is assumed to name of the package in -which the code lives. - -[Package Name]: If the programs are loaded into a package of their own, the -name of this package. If no Name or Module Name is supplied, the package -name will be used as the name for everything. - -[Description]: A brief description of what the program does. - -[Author]: Name of the author, or "anonymous". - -[Maintainer]: Name of current maintainer, if different from the author. If -a program is not being maintained by anyone, the Maintainer is "none". - -[Address], [Address of Author], [Address of Maintainer]: Physical mailing -address of author or maintainer. If the field is just "address", it is -assumed to be the maintainer if one is specified, and the author otherwise. - -[Net Address], [Net Address of Author], [Net Address of Maintainer]: A -network address that can be reached from the arpanet. - -[Copyright Status]: "Public domain" or some sort of copyright notice. - -[Files]: A list of the files comprising this facility. If a system whose -name is "Foo" is distributed as files "foo.slisp", "foo.sfasl", and -(optionally) "foo.doc" or "foo.press" for documentation. In order to -minimize maintenance headaches and encourage people to build on the work of -others, we want all programs in the library to include complete sources. - -[How to Get]: This can either be a shell command using such programs as lcp -or cp. There will usually be a .cmd file that will copy all the sources, -binaries, catalog, and log files to the user's current directory. This -.cmd file will try to preserve write date (such as using -p with cp). - -[Portability]: If the program will run in any legal Common Lisp, say so. -If there are known dependencies on CMU Common Lisp specific or -Mach/RT specific features, describe them here. - -[Dependencies]: If the program requires other library packages not built -into the standard CMU Common Lisp core image, list those other packages -here. - -[Instructions]: Place here any instructions for use that are too lengthy to -be mere documentation strings, but that are not lengthy enough to deserve a -separate document. - -[Recent Changes]: What is different between this version and the one that -preceded it, if any. (May go back several versions at the author's -discretion.) - -[Bugs]: Describe here any known bugs or treacherous features. - -[Future Plans]: Describe here any improvements planned by the author. - -[Wish List]: Describe here any desirable features that the author does not -plan to work on in the near future. - -[Notes]: Anything else that users or potential users ought to know about. diff --git a/contrib/ops/b.ops b/contrib/ops/b.ops deleted file mode 100644 index b774bd1d1090962a46ff755a4c2b4ef0911c3343..0000000000000000000000000000000000000000 --- a/contrib/ops/b.ops +++ /dev/null @@ -1,181 +0,0 @@ - - -(literalize primer zero role count zero) -(literalize maker role count fin zero) -(literalize goal count zero) - - -(p run - (goal ^count <c>) - --> - (bind <z> (compute <c> + 1)) - (modify 1 ^count <z>)) - - -(p makeprimer - (maker ^count <c> ^fin > <c> ^role <r>) - --> - (make primer ^role <r> ^zero 0 ^count <c>) - (bind <z> (compute <c> + 1)) - (modify 1 ^count <z>)) - - -(p beginrun - (maker ^count <c> ^fin = <c> ^role left) - (maker ^count <d> ^fin = <d> ^role right) - --> - (remove 1) - (remove 1) - (make goal ^count 0 ^zero 0)) - - -(p start - (start) - --> - (remove 1) - (make maker ^role left ^count 1 ^fin 50) - (make maker ^role right ^count 1 ^fin 50)) - - -(p leftrule10 - (goal ^zero <c>) - (primer ^role left ^zero <> <c> ^count <> 10) - --> - (remove 1)) - - -(p leftrule9 - (goal ^zero <c>) - (primer ^role left ^zero <> <c> ^count <> 9) - --> - (remove 1)) - - -(p leftrule8 - (goal ^zero <c>) - (primer ^role left ^zero <> <c> ^count <> 8) - --> - (remove 1)) - - -(p leftrule7 - (goal ^zero <c>) - (primer ^role left ^zero <> <c> ^count <> 7) - --> - (remove 1)) - - -(p leftrule6 - (goal ^zero <c>) - (primer ^role left ^zero <> <c> ^count <> 6) - --> - (remove 1)) - - -(p leftrule5 - (goal ^zero <c>) - (primer ^role left ^zero <> <c> ^count <> 5) - --> - (remove 1)) - - -(p leftrule4 - (goal ^zero <c>) - (primer ^role left ^zero <> <c> ^count <> 4) - --> - (remove 1)) - - -(p leftrule3 - (goal ^zero <c>) - (primer ^role left ^zero <> <c> ^count <> 3) - --> - (remove 1)) - - -(p leftrule2 - (goal ^zero <c>) - (primer ^role left ^zero <> <c> ^count <> 2) - --> - (remove 1)) - - -(p leftrule1 - (goal ^zero <c>) - (primer ^role left ^zero <> <c> ^count <> 1) - --> - (remove 1)) - - - - -(p rightrule10 - (primer ^role right ^zero <c> ^count <> 10) - (goal ^zero <> <c>) - --> - (remove 1)) - - -(p rightrule9 - (primer ^role right ^zero <c> ^count <> 9) - (goal ^zero <> <c>) - --> - (remove 1)) - - -(p rightrule8 - (primer ^role right ^zero <c> ^count <> 8) - (goal ^zero <> <c>) - --> - (remove 1)) - - -(p rightrule7 - (primer ^role right ^zero <c> ^count <> 7) - (goal ^zero <> <c>) - --> - (remove 1)) - - -(p rightrule6 - (primer ^role right ^zero <c> ^count <> 6) - (goal ^zero <> <c>) - --> - (remove 1)) - - -(p rightrule5 - (primer ^role right ^zero <c> ^count <> 5) - (goal ^zero <> <c>) - --> - (remove 1)) - - -(p rightrule4 - (primer ^role right ^zero <c> ^count <> 4) - (goal ^zero <> <c>) - --> - (remove 1)) - - -(p rightrule3 - (primer ^role right ^zero <c> ^count <> 3) - (goal ^zero <> <c>) - --> - (remove 1)) - - -(p rightrule2 - (primer ^role right ^zero <c> ^count <> 2) - (goal ^zero <> <c>) - --> - (remove 1)) - - -(p rightrule1 - (primer ^role right ^zero <c> ^count <> 1) - (goal ^zero <> <c>) - --> - (remove 1)) - - diff --git a/contrib/ops/bug.ops b/contrib/ops/bug.ops deleted file mode 100644 index b907f35f38a4de343c12512db3ff7123238c15dd..0000000000000000000000000000000000000000 --- a/contrib/ops/bug.ops +++ /dev/null @@ -1,15 +0,0 @@ -(literalize wme val) - -(p sort - (wme ^val <x>) - - (wme ^val < <x>) - --> - (write <x> (crlf)) - (remove 1)) - -(p start - (start) - --> - (make wme ^val 0) - (make wme ^val 1) - (make wme ^val -1)) diff --git a/contrib/ops/ceramic.ops b/contrib/ops/ceramic.ops deleted file mode 100644 index a49dee19b05eccfd41eaec654f3b3c93cda6b8f3..0000000000000000000000000000000000000000 --- a/contrib/ops/ceramic.ops +++ /dev/null @@ -1,348 +0,0 @@ - - -(literalize component) (literalize context) (literalize pcon) (literalize datum) -(literalize computation) (literalize setattr) (literalize template) (literalize interaction) -(literalize lineitem) (literalize local) (literalize discrlist) (literalize task) -(literalize arg) (literalize call) (literalize order) (literalize wip) -(literalize location) (literalize input) (literalize object) (literalize x) -(literalize status) (literalize place) (literalize time) (literalize port) -(literalize module) (literalize link) (literalize lists) (literalize outnode) -(literalize operator) (literalize current) (literalize attval) (literalize choice) -(literalize applied) (literalize stateop) (literalize exit) -(literalize component0) (literalize context0) (literalize pcon0) (literalize datum0) -(literalize computation0) (literalize setattr0) (literalize template0) (literalize interaction0) -(literalize lineitem0) (literalize local0) (literalize discrlist0) (literalize task0) -(literalize arg0) (literalize call0) (literalize order0) (literalize wip0) -(literalize location0) (literalize input0) (literalize object0) (literalize x0) -(literalize status0) (literalize place0) (literalize time0) (literalize port0) -(literalize module0) (literalize link0) (literalize lists0) (literalize outnode0) -(literalize operator0) (literalize current0) (literalize attval0) (literalize choice0) -(literalize applied0) (literalize stateop0) (literalize exit0) -(literalize tank) (literalize pipe) (literalize measurement) (literalize reading) -(literalize goal) (literalize material) - -(literalize primer - spacer - role - cnt - null) - -(literalize count - spacer - role - null - val - delta - null2) - - - -(p start - (start) - --> - (remove 1) - (make primer ^role exist ^cnt 1) - (make primer ^role exist ^cnt 2) - (make primer ^role exist ^cnt 3) - (make primer ^role exist ^cnt 4) - (make primer ^role exist ^cnt 5) - (make primer ^role exist ^cnt 6) - (make primer ^role exist ^cnt 7) - (make primer ^role exist ^cnt 8) - (make primer ^role exist ^cnt 9) - (make primer ^role exist ^cnt 10) - (make primer ^role exist ^cnt 11) - (make primer ^role exist ^cnt 12) - (make primer ^role exist ^cnt 13) - (make primer ^role exist ^cnt 14) - (make primer ^role exist ^cnt 15) - (make primer ^role exist ^cnt 16) - (make primer ^role exist ^cnt 17) - (make primer ^role exist ^cnt 18) - (make primer ^role exist ^cnt 19) - (make primer ^role exist ^cnt 20) - (make primer ^role exist ^cnt 21) - (make primer ^role exist ^cnt 22) - (make primer ^role exist ^cnt 23) - (make primer ^role exist ^cnt 24) - (make primer ^role exist ^cnt 25) - (make primer ^role exist ^cnt 26) - (make primer ^role exist ^cnt 27) - (make primer ^role exist ^cnt 28) - (make primer ^role exist ^cnt 29) - (make primer ^role exist ^cnt 30) - (make count ^role exist ^val 1 ^delta 7) - (make count ^role exist ^val 2 ^delta 7) - (make count ^role exist ^val 3 ^delta 7) - (make count ^role exist ^val 4 ^delta 7) - (make count ^role exist ^val 5 ^delta 7) - (make count ^role exist ^val 6 ^delta 7) - (make count ^role exist ^val 7 ^delta 7) - (make primer ^role driver ^cnt -1)) - - - -(p driver - (primer ^role driver ^null <x>) - (count ^null <x> ^val <val> ^delta <delta>) - - (count ^val < <val>) - --> - (modify 2 ^val (compute <val> + <delta>))) - - -(p driverCopy - (primer ^role driver ^null <x>) - (count ^null <x> ^val <val> ^delta <delta>) - - (count ^val < <val>) - --> - (modify 2 ^val (compute <val> + <delta>))) - - -(p alphamem - (primer ^role nonexist) - (count) - (count) - (count) - (count) - (count) - (count) - (count) - --> - (halt)) - - -(p betamem1 - (count ^null <> betamem1) - (primer ^role nonexist) - --> - (halt)) - - -(p betamem2 - (count ^null <> betamem2) - (primer ^role nonexist) - --> - (halt)) - - -(p betamem3 - (count ^null <> betamem3) - (primer ^role exist ^cnt < 1) - --> - (halt)) - - -(p betaleft1 - (count ^null <> betamem3 ^null <n>) - (primer ^role exist ^cnt <= 25 ^role <n>) - --> - (halt)) - - -(p betaleft2 - (count ^null <> betamem3 ^null <n>) - (primer ^role exist ^cnt <= 24 ^role <n>) - --> - (halt)) - - -(p andrightnull1 - (primer ^role nonexist1) - (count) - (count) - (count) - (count) - (count) - (count) - (count) - --> - (halt)) - - -(p andrightnull2 - (primer ^role nonexist2) - (count) - (count) - (count) - (count) - --> - (halt)) - - -(p andrightloop - (primer ^role exist ^cnt <= 13 ^null <n>) - (count ^role <n>) - --> - (halt)) - - -(p notleft - (primer ^role driver ^null <x>) - (count ^null <x>) - - (primer ^role exist ^cnt <= 23 ^null <x> ^null <x>) - --> - (halt)) - - -(p notrnull1 - (primer ^role notex1) - - (count) - --> - (halt)) - - -(p notrnull2 - (primer ^role notex2) - - (count) - --> - (halt)) - - -(p notrnull3 - (primer ^role notex3) - - (count) - --> - (halt)) - - -(p notrnull4 - (primer ^role notex4) - - (count) - --> - (halt)) - - -(p notrnull5 - (primer ^role notex5) - - (count) - --> - (halt)) - - -(p notrnull6 - (primer ^role notex6) - - (count) - --> - (halt)) - - -(p notright - (primer ^role exist ^cnt <= 8 ^null <x>) - - (count ^null <x> ^null2 <x>) - --> - (halt)) - - -(p object12 - (component) (context) (pcon) (datum) - (computation) (setattr) (template) (interaction) - (lineitem) (local) (discrlist) (task) - --> - (halt)) - -(p object24 - (arg) (call) (order) (wip) - (location) (input) (object) (x) - (status) (place) (time) (port) - --> - (halt)) - -(p object36 - (module) (link) (lists) (outnode) - (operator) (current) (attval) (choice) - (operator) (applied) (stateop) (exit) - --> - (halt)) - - -(p object48 - (component0) (context0) (pcon0) (datum0) - (computation0) (setattr0) (template0) (interaction0) - (lineitem0) (local0) (discrlist0) (task0) - --> - (halt)) - -(p object60 - (arg0) (call0) (order0) (wip0) - (location0) (input0) (object0) (x0) - (status0) (place0) (time0) (port0) - --> - (halt)) - -(p object72 - (module0) (link0) (lists0) (outnode0) - (operator0) (current0) (attval0) (choice0) - (operator0) (applied0) (stateop0) (exit0) - --> - (halt)) - -(p object78 - (tank) (pipe) (measurement) (reading) - (goal) (material) - --> - (halt)) - - -(p tnea0 - (count ^null a) - (count ^null b) - (count ^null c) - (count ^null d) - (count ^null e) - (count ^null f) - (count ^null g) - (count ^null h) - (count ^null i) - (count ^null j) - --> - (halt)) - -(p tnea1 - (count ^null a1) - (count ^null b1) - (count ^null c1) - (count ^null d1) - (count ^null e1) - (count ^null f1) - (count ^null g1) - (count ^null h1) - (count ^null i1) - (count ^null j1) - --> - (halt)) - -(p tnea2 - (count ^null a2) - (count ^null b2) - (count ^null c2) - (count ^null d2) - (count ^null e2) - (count ^null f2) - (count ^null g2) - (count ^null h2) - (count ^null i2) - (count ^null j2) - --> - (halt)) - -(p tnea3 - (count ^null a3) - (count ^null b3) - (count ^null c3) - (count ^null d3) - (count ^null e3) - (count ^null f3) - (count ^null g3) - --> - (halt)) - - -(p cs - (primer ^role exist ^cnt <= 2) - (primer ^role exist ^cnt <= 2) - (primer ^role exist ^cnt <= 2) - (primer ^role exist ^cnt <= 1) - (primer ^role exist ^cnt <= 1) - (primer ^role exist ^cnt <= 1) - --> - (halt)) diff --git a/contrib/ops/compile-ops.lisp b/contrib/ops/compile-ops.lisp deleted file mode 100644 index e4ef985dd7373dd5ae195798aa58f609a5f75e72..0000000000000000000000000000000000000000 --- a/contrib/ops/compile-ops.lisp +++ /dev/null @@ -1,12 +0,0 @@ -(unless (find-package "OPS") (make-package "OPS")) - -(compile-file - '("library:contrib/ops/ops-util.lisp" - "library:contrib/ops/ops-compile.lisp" - "library:contrib/ops/ops-rhs.lisp" - "library:contrib/ops/ops-match.lisp" - "library:contrib/ops/ops-main.lisp" - "library:contrib/ops/ops-backup.lisp" - "library:contrib/ops/ops-io.lisp" - "library:contrib/ops/ops.lisp") - :output-file "library:contrib/ops/ops.fasl") diff --git a/contrib/ops/dec.ops b/contrib/ops/dec.ops deleted file mode 100644 index de2b04a6c5658c8afcb8061c8788447c97511c11..0000000000000000000000000000000000000000 --- a/contrib/ops/dec.ops +++ /dev/null @@ -1,299 +0,0 @@ - -(literalize player - number - nights-scheduled) - -(literalize foursome - night - group - north - south - east - west) - -(literalize context - name) - -(literalize scheduling - night) - -(literalize already-played - player1 - player2) - -(literalize candidate - group - chosen - south - east - west) - - -(p startup - (start) ---> - (make player ^number 1 ^nights-scheduled 0) - (make player ^number 2 ^nights-scheduled 0) - (make player ^number 3 ^nights-scheduled 0) - (make player ^number 4 ^nights-scheduled 0) - (make player ^number 5 ^nights-scheduled 0) - (make player ^number 6 ^nights-scheduled 0) - (make player ^number 7 ^nights-scheduled 0) - (make player ^number 8 ^nights-scheduled 0) - (make player ^number 9 ^nights-scheduled 0) - (make player ^number 10 ^nights-scheduled 0) - (make player ^number 11 ^nights-scheduled 0) - (make player ^number 12 ^nights-scheduled 0) - (make player ^number 13 ^nights-scheduled 0) - (make player ^number 14 ^nights-scheduled 0) - (make player ^number 15 ^nights-scheduled 0) - (make player ^number 16 ^nights-scheduled 0) - (make foursome ^night 1 ^group a ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 1 ^group b ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 1 ^group c ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 1 ^group d ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 2 ^group a ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 2 ^group b ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 2 ^group c ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 2 ^group d ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 3 ^group a ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 3 ^group b ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 3 ^group c ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 3 ^group d ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 4 ^group a ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 4 ^group b ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 4 ^group c ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 4 ^group d ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 5 ^group a ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 5 ^group b ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 5 ^group c ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 5 ^group d ^north nil ^south nil ^east nil ^west nil) - (make context ^name north) - (make scheduling ^night 1) - (write (tabto 32) |Tournament Schedule| (crlf) (crlf) - (tabto 15) |N S E W| - (tabto 42) |N S E W| - (tabto 68) |N S E W| (crlf) - (tabto 15) |= = = =| - (tabto 42) |= = = =| - (tabto 68) |= = = =| (crlf))) - -(p north:pick-one-1 - (context ^name north) - (scheduling ^night <n>) - { <THE-FOURSOME> (foursome ^night <n> ^north nil) } - { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) } - (foursome ^night <n> ^north { <p1> <> nil }) - (foursome ^night <n> ^north { <p2> <> <p1> <> nil }) - (foursome ^night <n> ^north { <p3> <> <p2> <> <p1> <> nil }) - (already-played ^player1 <p> ^player2 <p1>) - (already-played ^player1 <p> ^player2 <p2>) - (already-played ^player1 <p> ^player2 <p3>) ---> - (modify <THE-PLAYER> ^nights-scheduled <n>) - (modify <THE-FOURSOME> ^north <p>) ) - -(p north:pick-one-2 - (context ^name north) - (scheduling ^night <n>) - { <THE-FOURSOME> (foursome ^night <n> ^north nil) } - { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) } - (foursome ^night <n> ^north { <p1> <> nil }) - (foursome ^night <n> ^north { <p2> <> <p1> <> nil }) - (already-played ^player1 <p> ^player2 <p1>) - (already-played ^player1 <p> ^player2 <p2>) ---> - (modify <THE-PLAYER> ^nights-scheduled <n>) - (modify <THE-FOURSOME> ^north <p>) ) - -(p north:pick-one-3 - (context ^name north) - (scheduling ^night <n>) - { <THE-FOURSOME> (foursome ^night <n> ^north nil) } - { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) } - (foursome ^night <n> ^north { <p1> <> nil }) - (already-played ^player1 <p> ^player2 <p1>) ---> - (modify <THE-PLAYER> ^nights-scheduled <n>) - (modify <THE-FOURSOME> ^north <p>) ) - -(p north:pick-one-4 - (context ^name north) - (scheduling ^night <n>) - { <THE-FOURSOME> (foursome ^night <n> ^north nil) } - { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) } ---> - (modify <THE-PLAYER> ^nights-scheduled <n>) - (modify <THE-FOURSOME> ^north <p>) ) - -(p north:done - { <THE-CONTEXT> (context ^name north) } ---> - (modify <THE-CONTEXT> ^name make-candidates)) - -(p make-candidates:make-candidate - (context ^name make-candidates) - (scheduling ^night { <n> < 3 }) - (foursome ^night <n> ^group <g> ^north <yankee>) - (player ^number <redneck> ^nights-scheduled < <n>) - (player ^number { <oriental> < <redneck> } ^nights-scheduled < <n>) - (player ^number { <cowboy> < <oriental> } ^nights-scheduled < <n>) - - (already-played ^player1 <yankee> ^player2 <redneck>) - - (already-played ^player1 <yankee> ^player2 <oriental>) - - (already-played ^player1 <yankee> ^player2 <cowboy>) - - (already-played ^player1 <redneck> ^player2 <oriental>) - - (already-played ^player1 <redneck> ^player2 <cowboy>) - - (already-played ^player1 <oriental> ^player2 <cowboy>) - - (candidate ^group <g> ^chosen no ^south <redneck> ^east <oriental>) - - (candidate ^group <g> ^chosen no ^south <redneck> ^west <cowboy>) - - (candidate ^group <g> ^chosen no ^east <oriental> ^west <cowboy>) ---> - (make candidate ^group <g> ^chosen no - ^south <redneck> ^east <oriental> ^west <cowboy>)) - -(p make-candidates:make-candidate-late - (context ^name make-candidates) - (scheduling ^night { <n> > 2 }) - (foursome ^night <n> ^group <g> ^north <yankee>) - (player ^number <redneck> ^nights-scheduled < <n>) - (player ^number { <oriental> < <redneck> } ^nights-scheduled < <n>) - (player ^number { <cowboy> < <oriental> } ^nights-scheduled < <n>) - - (already-played ^player1 <yankee> ^player2 <redneck>) - - (already-played ^player1 <yankee> ^player2 <oriental>) - - (already-played ^player1 <yankee> ^player2 <cowboy>) - - (already-played ^player1 <redneck> ^player2 <oriental>) - - (already-played ^player1 <redneck> ^player2 <cowboy>) - - (already-played ^player1 <oriental> ^player2 <cowboy>) ---> - (make candidate ^group <g> ^chosen no - ^south <redneck> ^east <oriental> ^west <cowboy>)) - -(p make-candidates:done - { <THE-CONTEXT> (context ^name make-candidates) } ---> - (modify <THE-CONTEXT> ^name make-choice)) - -(p make-choice:doit - { <THE-CONTEXT> (context ^name make-choice) } - { <WINNER-A> (candidate ^group a ^chosen no - ^south <sa> - ^east <ea> - ^west <wa>) } - { <WINNER-B> (candidate ^group b ^chosen no - ^south { <sb> <> <sa> <> <ea> <> <wa> } - ^east { <eb> <> <sa> <> <ea> <> <wa> } - ^west { <wb> <> <sa> <> <ea> <> <wa> }) } - { <WINNER-C> (candidate ^group c ^chosen no - ^south { <sc> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> } - ^east { <ec> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> } - ^west { <wc> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> }) } - { <WINNER-D> (candidate ^group d ^chosen no - ^south { <sd> - <> <sa> <> <ea> <> <wa> - <> <sb> <> <eb> <> <wb> - <> <sc> <> <ec> <> <wc> } - ^east { <ed> - <> <sa> <> <ea> <> <wa> - <> <sb> <> <eb> <> <wb> - <> <sc> <> <ec> <> <wc> } - ^west { <wd> - <> <sa> <> <ea> <> <wa> - <> <sb> <> <eb> <> <wb> - <> <sc> <> <ec> <> <wc> }) } ---> - (modify <WINNER-A> ^chosen yes) - (modify <WINNER-B> ^chosen yes) - (modify <WINNER-C> ^chosen yes) - (modify <WINNER-D> ^chosen yes) - (modify <THE-CONTEXT> ^name remove-candidates)) - -(p remove-candidates:bye - (context ^name remove-candidates) - { <THE-CANDIDATE> (candidate ^chosen no) } ---> - (remove <THE-CANDIDATE>)) - -(p remove-candidates:done - { <THE-CONTEXT> (context ^name remove-candidates) } ---> - (modify <THE-CONTEXT> ^name apply-choice)) - -(p apply-choice:doit - (context ^name apply-choice) - (scheduling ^night <n>) - { <THE-FOURSOME> (foursome ^night <n> ^group <g> ^north <yankee>) } - { <THE-CHOICE> (candidate ^group <g> ^chosen yes - ^south <redneck> ^east <oriental> ^west <cowboy>) } ---> - (modify <THE-FOURSOME> ^south <redneck> ^east <oriental> ^west <cowboy>) - (remove <THE-CHOICE>) - (make already-played ^player1 <yankee> ^player2 <redneck>) - (make already-played ^player2 <yankee> ^player1 <redneck>) - (make already-played ^player1 <yankee> ^player2 <oriental>) - (make already-played ^player2 <yankee> ^player1 <oriental>) - (make already-played ^player1 <yankee> ^player2 <cowboy>) - (make already-played ^player2 <yankee> ^player1 <cowboy>) - (make already-played ^player1 <redneck> ^player2 <oriental>) - (make already-played ^player2 <redneck> ^player1 <oriental>) - (make already-played ^player1 <redneck> ^player2 <cowboy>) - (make already-played ^player2 <redneck> ^player1 <cowboy>) - (make already-played ^player1 <oriental> ^player2 <cowboy>) - (make already-played ^player2 <oriental> ^player1 <cowboy>)) - -(p apply-choice:done - { <THE-CONTEXT> (context ^name apply-choice) } ---> - (modify <THE-CONTEXT> ^name report)) - -(p report:night-schedule - { <THE-CONTEXT> (context ^name report) } - (scheduling ^night <n>) - (foursome ^night <n> ^group a ^north <an> ^south <as> ^east <ae> ^west <aw>) - (foursome ^night <n> ^group b ^north <bn> ^south <bs> ^east <be> ^west <bw>) - (foursome ^night <n> ^group c ^north <cn> ^south <cs> ^east <ce> ^west <cw>) - (foursome ^night <n> ^group d ^north <dn> ^south <ds> ^east <de> ^west <dw>) ---> - (modify <THE-CONTEXT> ^name next-night) - (bind <n2> (compute <n> + 5)) - (bind <n3> (compute <n> + 10)) - (write (crlf) (rjust 1) |#| (rjust 1) <n> (rjust 1) : (tabto 5) - |Group A:| (rjust 3) <an> (rjust 3) <as> (rjust 3) <ae> (rjust 3) <aw> - (tabto 27) (rjust 1) |#| (rjust 2) <n2> (rjust 1) : (tabto 32) - |Group A:| (rjust 3) <an> (rjust 3) <ae> (rjust 3) <as> (rjust 3) <aw> - (tabto 53) (rjust 1) |#| (rjust 2) <n3> (rjust 1) : (tabto 58) - |Group A:| (rjust 3) <an> (rjust 3) <aw> (rjust 3) <ae> (rjust 3) <as>) - (write (crlf) - (tabto 5) - |Group B:| (rjust 3) <bn> (rjust 3) <bs> (rjust 3) <be> (rjust 3) <bw> - (tabto 32) - |Group B:| (rjust 3) <bn> (rjust 3) <be> (rjust 3) <bs> (rjust 3) <bw> - (tabto 58) - |Group B:| (rjust 3) <bn> (rjust 3) <bw> (rjust 3) <be> (rjust 3) <bs>) - (write (crlf) - (tabto 5) - |Group C:| (rjust 3) <cn> (rjust 3) <cs> (rjust 3) <ce> (rjust 3) <cw> - (tabto 32) - |Group C:| (rjust 3) <cn> (rjust 3) <ce> (rjust 3) <cs> (rjust 3) <cw> - (tabto 58) - |Group C:| (rjust 3) <cn> (rjust 3) <cw> (rjust 3) <ce> (rjust 3) <cs>) - (write (crlf) - (tabto 5) - |Group D:| (rjust 3) <dn> (rjust 3) <ds> (rjust 3) <de> (rjust 3) <dw> - (tabto 32) - |Group D:| (rjust 3) <dn> (rjust 3) <de> (rjust 3) <ds> (rjust 3) <dw> - (tabto 58) - |Group D:| (rjust 3) <dn> (rjust 3) <dw> (rjust 3) <de> (rjust 3) <ds> - (crlf))) - -(p next-night:more - { <THE-CONTEXT> (context ^name next-night) } - { <THE-NIGHT> (scheduling ^night { <n> < 5 }) } ---> - (modify <THE-CONTEXT> ^name north) - (modify <THE-NIGHT> ^night (compute <n> + 1))) - -(p next-night:done - (context ^name next-night) ---> - (write (tabto 32) |End of Scheduling| (crlf) (crlf))) - diff --git a/contrib/ops/fbug.ops b/contrib/ops/fbug.ops deleted file mode 100644 index 878f005255daf0311a6972b80d497b1a946db36b..0000000000000000000000000000000000000000 --- a/contrib/ops/fbug.ops +++ /dev/null @@ -1,3089 +0,0 @@ - - -(literal wme-type = 1) - - - - - - - - (literal - geometry = 2 - row = 3 - column = 4 ) - - - - - - (literal - length = 3 - delta = 2 - nb = 4 - nb+d = 5 - nb+2d = 6 - nb+3d = 7 - nb+4d = 8 - nb+5d = 9 - nb+6d = 10 ) - - - - - - (literal - nb = 4 - nb-incremented = 2 ) - - - - - - (literal - value = 3 ) - - - - - - (literal - name = 5 - length = 3 - geometry = 2 - owner = 4 - position-1-state = 6 - position-2-state = 7 - position-3-state = 8 - position-4-state = 9 - position-5-state = 10 - position-6-state = 11 - position-7-state = 12 - position-1-counter-to-update = 13 - position-2-counter-to-update = 14 - position-3-counter-to-update = 15 - position-4-counter-to-update = 16 - position-5-counter-to-update = 17 - position-6-counter-to-update = 18 - position-7-counter-to-update = 19 ) - - - - - - (literal - row = 3 - column = 4 - point-of-view = 2 - name = 5 ) - - - - - - (literal - row = 3 - column = 4 - point-of-view = 2 - nb-of-compulsory-answer-creations = 5 - nb-of-fragile-winners = 6 - nb-of-strong-winners = 7 ) - - - - - - (literal - type = 2 - is-better-than-type = 3 ) - - - - - - (literal - type = 2 - state = 5 - row = 3 - column = 4 - score = 6 ) - - - - - - (literal - name = 5 - point-of-views&counters-to-add = 6 - comment = 2 ) - - - - - - (literal - type = 2 - value = 3 ) - - - - - - (literal - beginning-row = 2 - beginning-column = 3 - ending-row = 4 - ending-column = 5 ) - - - - - - (literal - state = 5 - row = 3 - column = 4 ) - - - - - - (literal - meaning = 2 - drawing-character = 3 ) - - - - - - (literal - nb-of-columns = 2 - nb-of-rows = 3 - nb-of-columns-incr = 4 - nb-of-rows-incr = 5 - max-board-size = 6 - max-board-size-incr = 7 ) - - - - - - (literal - board-row = 3 - board-column = 4 - type = 2 - line-type = 5 - previous-board-position-row = 6 - previous-board-position-column = 7 - next-board-position-row = 8 - next-board-position-column = 9 - nw-board-position-row = 10 - nw-board-position-column = 11 - ne-board-position-row = 12 - ne-board-position-column = 13 - se-board-position-row = 14 - se-board-position-column = 15 - sw-board-position-row = 16 - sw-board-position-column = 17 ) - - - - - - (literal - of = 2 - is = 3 ) - - - - - - (literal - row = 3 - column = 4 - state = 5 - vertical-state = 2 - horizontal-state = 6 - right-bent-state = 7 - left-bent-state = 8 ) - - - - - - (literal - current-context = 2 - current-sub-context = 3 - current-player = 4 - human-score = 5 - computer-score = 6 ) - - - -(p board-analyse::segment-updating-of-length-5 - (incrementation-table ^length 5 ^delta <i> ^nb <nb1> ^nb+d <nb1+i> - ^nb+2d <nb1+2i> ^nb+3d <nb1+3i> ^nb+4d <nb1+4i>) - (incrementation-table ^length 5 ^delta <j> ^nb <nb2> ^nb+d <nb2+j> - ^nb+2d <nb2+2j> ^nb+3d <nb2+3j> ^nb+4d <nb2+4j>) - (direction ^geometry <geometry> ^row <i> ^column <j>) - (segment-type - ^length 5 ^geometry <geometry> - ^owner <owner> - ^position-1-state <position-1-state> - ^position-2-state <position-2-state> - ^position-3-state <position-3-state> - ^position-4-state <position-4-state> - ^position-5-state <position-5-state> - ^position-1-counter-to-update <position-1-counter-to-update> - ^position-2-counter-to-update <position-2-counter-to-update> - ^position-3-counter-to-update <position-3-counter-to-update> - ^position-4-counter-to-update <position-4-counter-to-update> - ^position-5-counter-to-update <position-5-counter-to-update>) - (position ^row <nb1> ^column <nb2> ^state <position-1-state>) - (position ^row <nb1+i> ^column <nb2+j> ^state <position-2-state>) - (position ^row <nb1+2i> ^column <nb2+2j> ^state <position-3-state>) - (position ^row <nb1+3i> ^column <nb2+3j> ^state <position-4-state>) - (position ^row <nb1+4i> ^column <nb2+4j> ^state <position-5-state>) ---> - (make counter-to-update - ^point-of-view <owner> - ^row <nb1> ^column <nb2> - ^name <position-1-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+i> ^column <nb2+j> - ^name <position-2-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+2i> ^column <nb2+2j> - ^name <position-3-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+3i> ^column <nb2+3j> - ^name <position-4-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+4i> ^column <nb2+4j> - ^name <position-5-counter-to-update>)) - -(p board-analyse::segment-updating-of-length-6 - (incrementation-table ^length 6 ^delta <i> ^nb <nb1> ^nb+d <nb1+i> - ^nb+2d <nb1+2i> ^nb+3d <nb1+3i> ^nb+4d <nb1+4i> ^nb+5d <nb1+5i>) - (incrementation-table ^length 6 ^delta <j> ^nb <nb2> ^nb+d <nb2+j> - ^nb+2d <nb2+2j> ^nb+3d <nb2+3j> ^nb+4d <nb2+4j> ^nb+5d <nb2+5j>) - (direction ^geometry <geometry> ^row <i> ^column <j>) - (segment-type - ^length 6 ^geometry <geometry> - ^owner <owner> - ^position-1-state <position-1-state> - ^position-2-state <position-2-state> - ^position-3-state <position-3-state> - ^position-4-state <position-4-state> - ^position-5-state <position-5-state> - ^position-6-state <position-6-state> - ^position-1-counter-to-update <position-1-counter-to-update> - ^position-2-counter-to-update <position-2-counter-to-update> - ^position-3-counter-to-update <position-3-counter-to-update> - ^position-4-counter-to-update <position-4-counter-to-update> - ^position-5-counter-to-update <position-5-counter-to-update> - ^position-6-counter-to-update <position-6-counter-to-update>) - (position ^row <nb1> ^column <nb2> ^state <position-1-state>) - (position ^row <nb1+i> ^column <nb2+j> ^state <position-2-state>) - (position ^row <nb1+2i> ^column <nb2+2j> ^state <position-3-state>) - (position ^row <nb1+3i> ^column <nb2+3j> ^state <position-4-state>) - (position ^row <nb1+4i> ^column <nb2+4j> ^state <position-5-state>) - (position ^row <nb1+5i> ^column <nb2+5j> ^state <position-6-state>) ---> - (make counter-to-update - ^point-of-view <owner> - ^row <nb1> ^column <nb2> - ^name <position-1-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+i> ^column <nb2+j> - ^name <position-2-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+2i> ^column <nb2+2j> - ^name <position-3-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+3i> ^column <nb2+3j> - ^name <position-4-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+4i> ^column <nb2+4j> - ^name <position-5-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+5i> ^column <nb2+5j> - ^name <position-6-counter-to-update>)) - -(p board-analyse::segment-updating-of-length-7 - (incrementation-table ^length 7 ^delta <i> ^nb <nb1> ^nb+d <nb1+i> - ^nb+2d <nb1+2i> ^nb+3d <nb1+3i> ^nb+4d <nb1+4i> ^nb+5d <nb1+5i> ^nb+6d <nb1+6i>) - (incrementation-table ^length 7 ^delta <j> ^nb <nb2> ^nb+d <nb2+j> - ^nb+2d <nb2+2j> ^nb+3d <nb2+3j> ^nb+4d <nb2+4j> ^nb+5d <nb2+5j> ^nb+6d <nb2+6j>) - (direction ^geometry <geometry> ^row <i> ^column <j>) - (segment-type - ^length 7 ^geometry <geometry> - ^owner <owner> - ^position-1-state <position-1-state> - ^position-2-state <position-2-state> - ^position-3-state <position-3-state> - ^position-4-state <position-4-state> - ^position-5-state <position-5-state> - ^position-6-state <position-6-state> - ^position-7-state <position-7-state> - ^position-1-counter-to-update <position-1-counter-to-update> - ^position-2-counter-to-update <position-2-counter-to-update> - ^position-3-counter-to-update <position-3-counter-to-update> - ^position-4-counter-to-update <position-4-counter-to-update> - ^position-5-counter-to-update <position-5-counter-to-update> - ^position-6-counter-to-update <position-6-counter-to-update> - ^position-7-counter-to-update <position-7-counter-to-update>) - (position ^row <nb1> ^column <nb2> ^state <position-1-state>) - (position ^row <nb1+i> ^column <nb2+j> ^state <position-2-state>) - (position ^row <nb1+2i> ^column <nb2+2j> ^state <position-3-state>) - (position ^row <nb1+3i> ^column <nb2+3j> ^state <position-4-state>) - (position ^row <nb1+4i> ^column <nb2+4j> ^state <position-5-state>) - (position ^row <nb1+5i> ^column <nb2+5j> ^state <position-6-state>) - (position ^row <nb1+6i> ^column <nb2+6j> ^state <position-7-state>) ---> - (make counter-to-update - ^point-of-view <owner> - ^row <nb1> ^column <nb2> - ^name <position-1-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+i> ^column <nb2+j> - ^name <position-2-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+2i> ^column <nb2+2j> - ^name <position-3-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+3i> ^column <nb2+3j> - ^name <position-4-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+4i> ^column <nb2+4j> - ^name <position-5-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+5i> ^column <nb2+5j> - ^name <position-6-counter-to-update>) - (make counter-to-update - ^point-of-view <owner> - ^row <nb1+6i> ^column <nb2+6j> - ^name <position-7-counter-to-update>)) - -(p board-analyse::garbage-cleaning - (game-state - ^current-context board-analyse - ^current-sub-context garbage-cleaning) - (counter-to-update) ---> - (remove 2)) - -(p board-analyse::garbage-cleaning-end - (game-state - ^current-context board-analyse - ^current-sub-context garbage-cleaning) ---> - (modify 1 ^current-sub-context counters-decrementation)) - -(p board-analyse::initialisations-for-counters-decrementation - (game-state - ^current-context board-analyse - ^current-sub-context counters-decrementation) - (new-move ^row <row> ^column <column>) - (position ^row <row> ^column <column>) - (number-to-add-while-updating-counters ^value <> -1) ---> - (modify 4 ^value -1) - (modify 3 ^row <row>)) - -(p board-analyse::counters-decrementation-end - (game-state - ^current-context board-analyse - ^current-sub-context counters-decrementation) ---> - (modify 1 ^current-sub-context counters-incrementation)) - -(p board-analyse::initialisations-for-counters-incrementation - (game-state - ^current-context board-analyse - ^current-sub-context counters-incrementation) - (new-move ^row <row> ^column <column> ^state <state>) - (position ^row <row> ^column <column>) - (number-to-add-while-updating-counters ^value <> 1) ---> - (remove 2) - (modify 4 ^value 1) - (modify 3 ^state <state>)) - -(p board-analyse::counters-incrementation-end - (game-state - ^current-context board-analyse - ^current-sub-context counters-incrementation) - (number-to-add-while-updating-counters) ---> - (modify 2 ^value ignore-it) - (modify 1 ^current-context choice-of-a-move - ^current-sub-context choice-of-segments)) - - -(p board-analyse::counter-updating - (game-state ^current-context board-analyse) - (counter-to-update - ^name {<name> <> garbage} - ^row <row> - ^column <column> - ^point-of-view <point-of-view>) - (number-to-add-while-updating-counters - ^value {<increment-value> <> ignore-it}) - (position-analyse - ^row <row> - ^column <column> - ^point-of-view <point-of-view>) - (position - ^row <row> - ^column <column> - ^state vacant) ---> - (bind <counter-value> (substr 4 <name> <name>)) - (modify 4 ^<name> (compute <increment-value> + <counter-value>)) - (remove 2)) - -(p board-analyse::making-of-two-position-analyses - (game-state ^current-context board-analyse) - (counter-to-update - ^name {<name> <> garbage} - ^row <row> - ^column <column>) - (number-to-add-while-updating-counters - ^value <> ignore-it) - -(position-analyse - ^row <row> - ^column <column>) - (position - ^row <row> - ^column <column> - ^state vacant) - ---> - (make position-analyse - ^row <row> ^column <column> - ^point-of-view human - ^nb-of-compulsory-answer-creations 0 - ^nb-of-fragile-winners 0 - ^nb-of-strong-winners 0) - (make position-analyse - ^row <row> ^column <column> - ^point-of-view computer - ^nb-of-compulsory-answer-creations 0 - ^nb-of-fragile-winners 0 - ^nb-of-strong-winners 0)) - -(p board-analyse::removal-of-a-pointless-position-analyse - (game-state ^current-context board-analyse) - (number-to-add-while-updating-counters - ^value {<increment-value> <> ignore-it}) - (position-analyse - ^row <row> - ^column <column>) - (position - ^row <row> - ^column <column> - ^state <> vacant) ---> - (remove 3)) - - -(p board-analyse::removal-of-a-pointless-counter-updating - (counter-to-update - ^name garbage) ---> - (remove 1)) - - - - - -(p choice-of-a-move-by-the-computer::compulsory-answers-computation - (game-state - ^current-context choice-of-a-move - ^current-sub-context generation-of-the-best-possible-moves - ^current-player computer) - (position-analyse - ^point-of-view computer - ^row <row> - ^column <column> - ^nb-of-compulsory-answer-creations <nbcacc>) - (position-analyse - ^point-of-view human - ^row <row> - ^column <column> - ^nb-of-strong-winners <nbswh>) ---> - (make possible-move - ^state non-validated-nb-of-compulsory-answer-creations - ^row <row> - ^column <column> - ^score (compute <nbcacc> + <nbswh>))) - -(p choice-of-a-move-by-the-computer::compulsory-answers-validation - (game-state - ^current-context choice-of-a-move - ^current-sub-context generation-of-the-best-possible-moves - ^current-player computer) - {(possible-move - ^state non-validated-nb-of-compulsory-answer-creations - ^row <row> - ^column <column> - ^score {<score> >= 2 }) <possible-move>} ---> - (modify <possible-move> - ^state validated-nb-of-compulsory-answer-creations)) - -(p choice-of-a-move-by-the-computer::compulsory-answers-validation-to-0 - (game-state - ^current-context choice-of-a-move - ^current-sub-context generation-of-the-best-possible-moves - ^current-player computer) - {(possible-move - ^state non-validated-nb-of-compulsory-answer-creations - ^row <row> - ^column <column> - ^score {<score> < 2 }) <possible-move>} ---> - (modify <possible-move> - ^score 0 - ^state validated-nb-of-compulsory-answer-creations)) - -(p choice-of-a-move-by-the-computer::score-computation - (game-state - ^current-context choice-of-a-move - ^current-sub-context generation-of-the-best-possible-moves - ^current-player computer) - {(possible-move - ^state validated-nb-of-compulsory-answer-creations - ^row <row> - ^column <column> - ^score <score>) <possible-move>} - (position-analyse - ^point-of-view computer - ^row <row> - ^column <column> - ^nb-of-fragile-winners <nbfwc> - ^nb-of-strong-winners <nbswc>) - (position-analyse - ^point-of-view human - ^row <row> - ^column <column> - ^nb-of-fragile-winners <nbfwh> - ^nb-of-compulsory-answer-creations <nbcach>) ---> - (modify <possible-move> - ^state computed - ^score (compute (100 * (<nbfwh> + <nbfwc>)) + - (10 * <score>) + - <nbcach> + (2 * <nbswc>)))) - - -(p choice-of-a-move-by-the-computer::selection-of-the-best-moves - (game-state - ^current-context choice-of-a-move - ^current-sub-context generation-of-the-best-possible-moves - ^current-player computer) - {(possible-move - ^state computed - ^score <score-i>) <possible-move-i>} - (possible-move - ^state computed - ^score > <score-i>) ---> - (remove <possible-move-i>)) - -(p choice-of-a-move-by-the-computer::generation-of-the-best-possible-moves-end - (game-state - ^current-context choice-of-a-move - ^current-sub-context generation-of-the-best-possible-moves - ^current-player computer) ---> - (modify 1 - ^current-sub-context choice-of-the-move)) - -(p choice-of-a-move-by-the-computer::removal-of-all-possible-moves - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move - ^current-player computer) - (possible-move - ^row <row> - ^column <column>) - (new-move) ---> - (remove 2)) - -(p choice-of-a-move-by-the-computer::blind-pick-up-of-one-of-the-best - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move - ^current-player computer) - (possible-move - ^row <row> - ^column <column>) - -(new-move) ---> - (make last-computer-move <row> <column>) - (make new-move - ^state computer - ^row <row> - ^column <column>)) - -(p choice-of-a-move-by-the-computer::blind-pick-up-of-a-vacant-position - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move - ^current-player computer) - -(possible-move) - -(new-move) - (position ^state << human computer >>) - (position - ^state vacant - ^row <row> - ^column <column>) ---> - (make last-computer-move <row> <column>) - (make new-move - ^state computer - ^row <row> - ^column <column>)) - -(p choice-of-a-move-by-the-computer::first-move - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move - ^current-player computer) - -(position ^state << computer human >>) ---> - (make last-computer-move 6 5) - (make new-move - ^state computer - ^row 6 - ^column 5)) - -(p choice-of-a-move-by-the-computer::end-of-the-choice-of-the-move - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move - ^current-player computer) ---> - (modify 1 ^current-context board-analyse - ^current-sub-context garbage-cleaning)) - -(p choice-of-a-move-by-the-computer::vertical-segment-choice - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^computer-score <computer-score> - ^current-player computer) - (incrementation-table ^length 4 ^delta 1 ^nb <nb1> ^nb+d <nb1+i> - ^nb+2d <nb1+2i> ^nb+3d <nb1+3i>) - (incrementation-table ^length 4 ^delta 0 ^nb <nb2> ^nb+d <nb2+j> - ^nb+2d <nb2+2j> ^nb+3d <nb2+3j>) - (position ^row <nb1> ^column <nb2> - ^state computer ^vertical-state << free end-of-a-segment >>) - (position ^row <nb1+i> ^column <nb2+j> - ^state computer ^vertical-state << free end-of-a-segment >>) - (position ^row <nb1+2i> ^column <nb2+2j> - ^state computer ^vertical-state << free end-of-a-segment >>) - (position ^row <nb1+3i> ^column <nb2+3j> - ^state computer ^vertical-state << free end-of-a-segment >>) ---> - (modify 1 ^computer-score (compute <computer-score> + 1)) - (modify 4 ^vertical-state end-of-a-segment) - (modify 5 ^vertical-state inside-a-segment) - (modify 6 ^vertical-state inside-a-segment) - (modify 7 ^vertical-state end-of-a-segment)) - -(p choice-of-a-move-by-the-computer::horizontal-segment-choice - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^computer-score <computer-score> - ^current-player computer) - (incrementation-table ^length 4 ^delta 0 ^nb <nb1> ^nb+d <nb1+i> - ^nb+2d <nb1+2i> ^nb+3d <nb1+3i>) - (incrementation-table ^length 4 ^delta 1 ^nb <nb2> ^nb+d <nb2+j> - ^nb+2d <nb2+2j> ^nb+3d <nb2+3j>) - (position ^row <nb1> ^column <nb2> - ^state computer ^horizontal-state << free end-of-a-segment >>) - (position ^row <nb1+i> ^column <nb2+j> - ^state computer ^horizontal-state << free end-of-a-segment >>) - (position ^row <nb1+2i> ^column <nb2+2j> - ^state computer ^horizontal-state << free end-of-a-segment >>) - (position ^row <nb1+3i> ^column <nb2+3j> - ^state computer ^horizontal-state << free end-of-a-segment >>) ---> - (modify 1 ^computer-score (compute <computer-score> + 1)) - (modify 4 ^horizontal-state end-of-a-segment) - (modify 5 ^horizontal-state inside-a-segment) - (modify 6 ^horizontal-state inside-a-segment) - (modify 7 ^horizontal-state end-of-a-segment)) - -(p choice-of-a-move-by-the-computer::right-bent-segment-choice - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^computer-score <computer-score> - ^current-player computer) - (incrementation-table ^length 4 ^delta -1 ^nb <nb1> ^nb+d <nb1+i> - ^nb+2d <nb1+2i> ^nb+3d <nb1+3i>) - (incrementation-table ^length 4 ^delta 1 ^nb <nb2> ^nb+d <nb2+j> - ^nb+2d <nb2+2j> ^nb+3d <nb2+3j>) - (position ^row <nb1> ^column <nb2> - ^state computer ^right-bent-state << free end-of-a-segment >>) - (position ^row <nb1+i> ^column <nb2+j> - ^state computer ^right-bent-state << free end-of-a-segment >>) - (position ^row <nb1+2i> ^column <nb2+2j> - ^state computer ^right-bent-state << free end-of-a-segment >>) - (position ^row <nb1+3i> ^column <nb2+3j> - ^state computer ^right-bent-state << free end-of-a-segment >>) ---> - (modify 1 ^computer-score (compute <computer-score> + 1)) - (modify 4 ^right-bent-state end-of-a-segment) - (modify 5 ^right-bent-state inside-a-segment) - (modify 6 ^right-bent-state inside-a-segment) - (modify 7 ^right-bent-state end-of-a-segment)) - -(p choice-of-a-move-by-the-computer::left-bent-segment-choice - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^computer-score <computer-score> - ^current-player computer) - (incrementation-table ^length 4 ^delta 1 ^nb <nb1> ^nb+d <nb1+i> - ^nb+2d <nb1+2i> ^nb+3d <nb1+3i>) - (incrementation-table ^length 4 ^delta 1 ^nb <nb2> ^nb+d <nb2+j> - ^nb+2d <nb2+2j> ^nb+3d <nb2+3j>) - (position ^row <nb1> ^column <nb2> - ^state computer ^left-bent-state << free end-of-a-segment >>) - (position ^row <nb1+i> ^column <nb2+j> - ^state computer ^left-bent-state << free end-of-a-segment >>) - (position ^row <nb1+2i> ^column <nb2+2j> - ^state computer ^left-bent-state << free end-of-a-segment >>) - (position ^row <nb1+3i> ^column <nb2+3j> - ^state computer ^left-bent-state << free end-of-a-segment >>) ---> - (modify 1 ^computer-score (compute <computer-score> + 1)) - (modify 4 ^left-bent-state end-of-a-segment) - (modify 5 ^left-bent-state inside-a-segment) - (modify 6 ^left-bent-state inside-a-segment) - (modify 7 ^left-bent-state end-of-a-segment)) - -(p choice-of-a-move-by-the-computer::end-of-choice-of-segments - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^computer-score <computer-score> - ^current-player computer) ---> - (modify 1 - ^current-context board-drawing - ^current-player human)) - - - - - - - - -(p generation-of-incrementation - (game-state ^current-context initialisations) - (board-parameters - ^max-board-size-incr <mbs+1>) - (incrementation - ^nb <nb> - ^nb-incremented {<nb-incremented> < <mbs+1>}) - -(incrementation - ^nb <nb-incremented>) ---> - (make incrementation - ^nb <nb-incremented> - ^nb-incremented (compute <nb-incremented> + 1))) - - -(p generation-of-incrementation-table - (game-state ^current-context initialisations) - (delta <delta>) - (nb <nb>) - (length <length>) ---> - (make incrementation-table - ^length <length> - ^delta <delta> - ^nb <nb> - ^nb+d (compute <nb> + <delta>) - ^nb+2d (compute <nb> + ( 2 * <delta>)) - ^nb+3d (compute <nb> + ( 3 * <delta>)) - ^nb+4d (compute <nb> + ( 4 * <delta>)) - ^nb+5d (compute <nb> + ( 5 * <delta>)) - ^nb+6d (compute <nb> + ( 6 * <delta>)))) - -(p cleaning-of-superfluous-incrementation-tables-2 - (game-state ^current-context initialisations) - (board-parameters - ^max-board-size-incr <mbs+1>) - {(incrementation-table ^length 7 ^nb+6d > <mbs+1>) - <incrementation-table>} ---> - (remove <incrementation-table>)) - -(p cleaning-of-superfluous-incrementation-tables-3 - (game-state ^current-context initialisations) - (board-parameters - ^max-board-size-incr <mbs+1>) - {(incrementation-table ^length 6 ^nb+5d > <mbs+1>) - <incrementation-table>} ---> - (remove <incrementation-table>)) - -(p cleaning-of-superfluous-incrementation-tables-4 - (game-state ^current-context initialisations) - (board-parameters - ^max-board-size-incr <mbs+1>) - {(incrementation-table ^length 5 ^nb+4d > <mbs+1>) - <incrementation-table>} ---> - (remove <incrementation-table>)) - -(p cleaning-of-superfluous-incrementation-tables-5 - (game-state ^current-context initialisations) - (board-parameters - ^max-board-size <mbs>) - {(incrementation-table ^length 4 ^nb+3d > <mbs>) - <incrementation-table>} ---> - (remove <incrementation-table>)) - -(p cleaning-of-superfluous-incrementation-tables-2-bis - (game-state ^current-context initialisations) - {(incrementation-table ^length 7 ^nb+6d < 0) - <incrementation-table>} ---> - (remove <incrementation-table>)) - -(p cleaning-of-superfluous-incrementation-tables-3-bis - (game-state ^current-context initialisations) - {(incrementation-table ^length 6 ^nb+5d < 0) - <incrementation-table>} ---> - (remove <incrementation-table>)) - -(p cleaning-of-superfluous-incrementation-tables-4-bis - (game-state ^current-context initialisations) - {(incrementation-table ^length 5 ^nb+4d < 0) - <incrementation-table>} ---> - (remove <incrementation-table>)) - -(p cleaning-of-superfluous-incrementation-tables-5-bis - (game-state ^current-context initialisations) - {(incrementation-table ^length 4 ^nb+3d <= 0) - <incrementation-table>} ---> - (remove <incrementation-table>)) - -(p generation-of-an-edge-horizontally - (game-state ^current-context initialisations) - (board-parameters - ^nb-of-columns <nbbc>) - (position - ^row {<< 0 11 >> <existing-position-row>} - ^column {<= <nbbc> <existing-position-column>}) - (incrementation - ^nb <existing-position-column> - ^nb-incremented <existing-position-column-incremented>) - -(position - ^row <existing-position-row> - ^column <existing-position-column-incremented>) ---> - (make position - ^row <existing-position-row> - ^column <existing-position-column-incremented> - ^state edge - ^vertical-state nil - ^horizontal-state nil - ^right-bent-state nil - ^left-bent-state nil)) - -(p generation-of-an-edge-vertically - (game-state ^current-context initialisations) - (board-parameters - ^nb-of-rows <nbbr>) - (position - ^column {<< 0 11 >> <existing-position-column>} - ^row {<= <nbbr> <existing-position-row>}) - (incrementation - ^nb <existing-position-row> - ^nb-incremented <existing-position-row-incremented>) - -(position - ^column <existing-position-column> - ^row <existing-position-row-incremented>) ---> - (make position - ^column <existing-position-column> - ^row <existing-position-row-incremented> - ^state edge - ^vertical-state nil - ^horizontal-state nil - ^right-bent-state nil - ^left-bent-state nil)) - -(p generation-of-an-empty-board-horizontally - (game-state ^current-context initialisations) - (board-parameters - ^nb-of-rows <nbbr> - ^nb-of-columns <nbbc>) - (position - ^row {<existing-position-row> > 0 <= <nbbr>} - ^column {< <nbbc> <existing-position-column>}) - (incrementation - ^nb <existing-position-column> - ^nb-incremented <existing-position-column-incremented>) - -(position - ^row <existing-position-row> - ^column <existing-position-column-incremented>) ---> - (make position - ^row <existing-position-row> - ^column <existing-position-column-incremented> - ^state vacant - ^vertical-state free - ^horizontal-state free - ^right-bent-state free - ^left-bent-state free)) - -(p generation-of-an-empty-board-vertically - (game-state ^current-context initialisations) - (board-parameters - ^nb-of-rows <nbbr> - ^nb-of-columns <nbbc>) - (position - ^column {<existing-position-column> > 0 <= <nbbc>} - ^row {< <nbbr> <existing-position-row>}) - (incrementation - ^nb <existing-position-row> - ^nb-incremented <existing-position-row-incremented>) - -(position - ^column <existing-position-column> - ^row <existing-position-row-incremented>) ---> - (make position - ^column <existing-position-column> - ^row <existing-position-row-incremented> - ^state vacant - ^vertical-state free - ^horizontal-state free - ^right-bent-state free - ^left-bent-state free)) - -(p determination-of-the-player-who-is-going-to-start - {<game-state> - (game-state - ^current-context initialisations - ^current-player {<> human <> computer})} - (symbol - ^meaning human - ^drawing-character <human-drawing-character>) - (symbol - ^meaning computer - ^drawing-character <computer-drawing-character>) - (board-parameters - ^nb-of-columns <nbbc> - ^nb-of-rows <nbbr>) ---> - (write |___________________________________________| - (crlf) - (crlf) - | The board has | <nbbc> | rows and | <nbbc> | columns.| - (crlf) - | You are | <human-drawing-character> |, I am | - <computer-drawing-character> |.| - (crlf) - | ___________________________________________| - (crlf) - (crlf) - |Do you want to start (return: yes, anything else: no)? |) - (make input ^type first-player ^value (acceptline human read))) - -(p validation-of-the-answer-1 - {<game-state> - (game-state - ^current-context initialisations)} - {(input ^type first-player ^value human) <input>} ---> - (remove <input>) - (modify <game-state> - ^current-player human - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move)) - -(p validation-of-the-answer-2 - {<game-state> - (game-state - ^current-context initialisations)} - {(input ^type first-player ^value <> human) <input>} ---> - (remove <input>) - (modify <game-state> - ^current-player computer - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move)) - - - -(p initialisations-for-board-drawing - {<game-state> - (game-state ^current-context board-drawing)} - {(last-computer-move <row> <column>) <last-computer-move>} - -(drawing-position-printed) ---> - (write (crlf) - (crlf) - |score: human | - (substr <game-state> human-score human-score) - | computer | - (substr <game-state> computer-score computer-score) - |. I just played| <row> <column> |.| - (crlf) - (crlf)) - (remove <last-computer-move>) - (make drawing-position-printed - ^type outside-board - ^line-type first-line - ^board-row nil - ^board-column 1)) - -(p drawing-of-the-first-line - (game-state ^current-context board-drawing) - (board-parameters - ^nb-of-columns <nbbc>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type first-line - ^board-column {<> <nbbc> <board-column>})} - ---> - (bind <tab> (compute (2 + (<board-column> * 4)))) - (write (tabto <tab>) - <board-column>) - (modify <drawing-position-printed> - ^board-column (compute <board-column> + 1))) - -(p end-of-the-drawing-of-the-first-line - (game-state ^current-context board-drawing) - (board-parameters - ^nb-of-columns <nb-of-columns>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type first-line - ^board-column <nb-of-columns>)} ---> - (bind <tab> (compute (2 + (4 * <nb-of-columns>)))) - (write (tabto <tab>) - <nb-of-columns> - (crlf) (crlf)) - (modify <drawing-position-printed> - ^board-row 1 - ^line-type board-line - ^type outside-board)) - -(p drawing-of-the-beginning-of-a-board-line - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type board-line - ^type outside-board - ^board-row <board-row>)} ---> - (write <board-row>) - (modify <drawing-position-printed> - ^type board-position - ^board-column 1 - ^previous-board-position-column 1 - ^previous-board-position-row <board-row> - ^next-board-position-column 2 - ^next-board-position-row <board-row>)) - -(p drawing-of-a-board-position - (game-state ^current-context board-drawing) - (board-parameters - ^nb-of-columns <nbbc>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type board-line - ^type board-position - ^board-row <board-row> - ^board-column {<> <nbbc> <board-column>})} - (position - ^state <board-position-state> - ^row <board-row> - ^column <board-column>) - (symbol - ^meaning <board-position-state> - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute (2 + (4 * <board-column>)))) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-horizontal-segment)) - -(p drawing-of-the-end-of-a-board-line - (game-state ^current-context board-drawing) - (board-parameters - ^nb-of-rows <nbbr> - ^nb-of-columns <nbbc>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type board-line - ^type board-position - ^board-row {<> <nbbr> <board-row>} - ^board-column <nbbc>)} - (position - ^state <board-position-state> - ^row <board-row> - ^column <nbbc>) - (symbol - ^meaning <board-position-state> - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute (2 + (4 * <nbbc>)))) - (write (tabto <tab>) - <drawing-character> - (crlf)) - (modify <drawing-position-printed> - ^type outside-board - ^line-type intermediate-line)) - -(p drawing-of-the-end-of-the-board - {<game-state> - (game-state ^current-context board-drawing)} - (board-parameters - ^nb-of-rows <nbbr> - ^nb-of-columns <nbbc>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type board-line - ^type board-position - ^board-row <nbbr> - ^board-column <nbbc>)} - (position - ^state <board-position-state> - ^row <nbbr> - ^column <nbbc>) - (symbol - ^meaning <board-position-state> - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute (2 + (4 * <nbbc>)))) - (write (tabto <tab>) - <drawing-character> - (crlf) (crlf)) - (remove <drawing-position-printed>) - (modify <game-state> - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move - ^current-player human)) - -(p drawing-of-an-horizontal-piece-of-segment-1 - - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type board-line - ^type possibly-a-piece-of-horizontal-segment - ^board-column <board-column> - ^board-row <board-row> - ^next-board-position-column <nbpc> - ^previous-board-position-column <pbpc>)} - (position - ^row <board-row> - ^column <pbpc> - ^state <> vacant - ^horizontal-state inside-a-segment) - (symbol - ^meaning piece-of-horizontal-segment - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute (2 + (4 * <board-column>) + 2))) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type board-position - ^board-column (compute <board-column> + 1) - ^previous-board-position-column <nbpc> - ^next-board-position-column (compute <nbpc> + 1))) - -(p drawing-of-an-horizontal-piece-of-segment-2 - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type board-line - ^type possibly-a-piece-of-horizontal-segment - ^board-column <board-column> - ^board-row <board-row> - ^next-board-position-column <nbpc> - ^previous-board-position-column <pbpc>)} - (position - ^row <board-row> - ^column <nbpc> - ^state <> vacant - ^horizontal-state inside-a-segment) - (symbol - ^meaning piece-of-horizontal-segment - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute (2 + (4 * <board-column>) + 2))) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type board-position - ^board-column (compute <board-column> + 1) - ^previous-board-position-column <nbpc> - ^next-board-position-column (compute <nbpc> + 1))) - - -(p non-drawing-of-an-horizontal-piece-of-segment - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type board-line - ^type possibly-a-piece-of-horizontal-segment - ^board-column <board-column> - ^board-row <board-row> - ^next-board-position-column <nbpc> - ^previous-board-position-column <pbpc>)} ---> - (modify <drawing-position-printed> - ^type board-position - ^board-column (compute <board-column> + 1) - ^previous-board-position-column <nbpc> - ^next-board-position-column (compute <nbpc> + 1))) - -(p drawing-of-the-beginning-of-an-intermediate-line - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type outside-board - ^board-row <board-row>)} ---> - (modify <drawing-position-printed> - ^type possibly-a-piece-of-vertical-segment - ^nw-board-position-row <board-row> - ^nw-board-position-column 1 - ^sw-board-position-row (compute 1 + <board-row>) - ^sw-board-position-column 1 - ^ne-board-position-row <board-row> - ^ne-board-position-column 2 - ^se-board-position-row (compute 1 + <board-row>) - ^se-board-position-column 2)) - -(p drawing-of-a-vertical-piece-of-segment-1 - (game-state ^current-context board-drawing) - (board-parameters - ^nb-of-columns <nbbc>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-vertical-segment - ^nw-board-position-column {<> <nbbc> <board-column>} - ^nw-board-position-row <nwbpr>)} - (position - ^row <nwbpr> - ^column <board-column> - ^state <> vacant - ^vertical-state inside-a-segment) - (symbol - ^meaning piece-of-vertical-segment - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <board-column>))) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-bent-segment)) - -(p drawing-of-a-vertical-piece-of-segment-2 - (game-state ^current-context board-drawing) - (board-parameters - ^nb-of-columns <nbbc>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-vertical-segment - ^nw-board-position-column {<> <nbbc> <board-column>} - ^sw-board-position-row <swbpr>)} - (position - ^row <swbpr> - ^column <board-column> - ^state <> vacant - ^vertical-state inside-a-segment) - (symbol - ^meaning piece-of-vertical-segment - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <board-column>))) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-bent-segment)) - -(p non-drawing-of-a-vertical-piece-of-segment - (game-state ^current-context board-drawing) - (board-parameters - ^nb-of-columns <nbbc>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-vertical-segment - ^nw-board-position-column {<> <nbbc> <board-column>} - ^sw-board-position-row <swbpr>)} ---> - (modify <drawing-position-printed> - ^type possibly-a-piece-of-bent-segment)) - -(p drawing-of-a-piece-of-right-bent-segment-1 - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-bent-segment - ^nw-board-position-column <board-column> - ^board-row <board-row> - ^sw-board-position-column <swbpc> - ^nw-board-position-column <nwbpc> - ^se-board-position-column <sebpc> - ^ne-board-position-column <nebpc> - ^sw-board-position-row <swbpr>)} - (position - ^row <swbpr> - ^column <swbpc> - ^state <> vacant - ^right-bent-state inside-a-segment) - (symbol - ^meaning piece-of-right-bent-segment - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <board-column>) + 2)) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-vertical-segment - ^sw-board-position-column <sebpc> - ^nw-board-position-column <nebpc> - ^se-board-position-column (compute <sebpc> + 1) - ^ne-board-position-column (compute <nebpc> + 1))) - -(p drawing-of-a-piece-of-right-bent-segment-2 - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-bent-segment - ^nw-board-position-column <board-column> - ^board-row <board-row> - ^sw-board-position-column <swbpc> - ^nw-board-position-column <nwbpc> - ^se-board-position-column <sebpc> - ^ne-board-position-column <nebpc> - ^ne-board-position-row <nebpr>)} - (position - ^row <nebpr> - ^column <nebpc> - ^state <> vacant - ^right-bent-state inside-a-segment) - (symbol - ^meaning piece-of-right-bent-segment - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <board-column>) + 2)) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-vertical-segment - ^sw-board-position-column <sebpc> - ^nw-board-position-column <nebpc> - ^se-board-position-column (compute <sebpc> + 1) - ^ne-board-position-column (compute <nebpc> + 1))) - -(p drawing-of-a-piece-of-left-bent-segment-1 - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-bent-segment - ^nw-board-position-column <board-column> - ^board-row <board-row> - ^sw-board-position-column <swbpc> - ^nw-board-position-column <nwbpc> - ^se-board-position-column <sebpc> - ^ne-board-position-column <nebpc> - ^se-board-position-row <sebpr>)} - (position - ^row <sebpr> - ^column <sebpc> - ^state <> vacant - ^left-bent-state inside-a-segment) - (symbol - ^meaning piece-of-left-bent-segment - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <board-column>) + 2)) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-vertical-segment - ^sw-board-position-column <sebpc> - ^nw-board-position-column <nebpc> - ^se-board-position-column (compute <sebpc> + 1) - ^ne-board-position-column (compute <nebpc> + 1))) - -(p drawing-of-a-piece-of-left-bent-segment-2 - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-bent-segment - ^nw-board-position-column <board-column> - ^board-row <board-row> - ^sw-board-position-column <swbpc> - ^nw-board-position-column <nwbpc> - ^se-board-position-column <sebpc> - ^ne-board-position-column <nebpc> - ^nw-board-position-row <nwbpr>)} - (position - ^row <nwbpr> - ^column <nwbpc> - ^state <> vacant - ^left-bent-state inside-a-segment) - (symbol - ^meaning piece-of-left-bent-segment - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <board-column>) + 2)) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-vertical-segment - ^sw-board-position-column <sebpc> - ^nw-board-position-column <nebpc> - ^se-board-position-column (compute <sebpc> + 1) - ^ne-board-position-column (compute <nebpc> + 1))) - -(p drawing-of-a-crossing-of-segments-1 - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-bent-segment - ^nw-board-position-column <board-column> - ^board-row <board-row> - ^sw-board-position-column <swbpc> - ^nw-board-position-column <nwbpc> - ^se-board-position-column <sebpc> - ^ne-board-position-column <nebpc> - ^se-board-position-row <sebpr> - ^sw-board-position-row <swbpr>)} - (position - ^row <swbpr> - ^column <swbpc> - ^state <> vacant - ^right-bent-state inside-a-segment) - (position - ^row <sebpr> - ^column <sebpc> - ^state <> vacant - ^left-bent-state inside-a-segment) - (symbol - ^meaning crossing-of-two-bent-segments - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <board-column>) + 2)) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-vertical-segment - ^sw-board-position-column <sebpc> - ^nw-board-position-column <nebpc> - ^se-board-position-column (compute <sebpc> + 1) - ^ne-board-position-column (compute <nebpc> + 1))) - -(p drawing-of-a-crossing-of-segments-2 - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-bent-segment - ^nw-board-position-column <board-column> - ^board-row <board-row> - ^sw-board-position-column <swbpc> - ^nw-board-position-column <nwbpc> - ^se-board-position-column <sebpc> - ^ne-board-position-column <nebpc> - ^ne-board-position-row <nebpr> - ^nw-board-position-row <nwbpr>)} - (position - ^row <nwbpr> - ^column <nwbpc> - ^state <> vacant - ^left-bent-state inside-a-segment) - (position - ^row <nebpr> - ^column <nebpc> - ^state <> vacant - ^right-bent-state inside-a-segment) - (symbol - ^meaning crossing-of-two-bent-segments - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <board-column>) + 2)) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-vertical-segment - ^sw-board-position-column <sebpc> - ^nw-board-position-column <nebpc> - ^se-board-position-column (compute <sebpc> + 1) - ^ne-board-position-column (compute <nebpc> + 1))) - -(p drawing-of-a-crossing-of-segments-3 - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-bent-segment - ^nw-board-position-column <board-column> - ^board-row <board-row> - ^sw-board-position-column <swbpc> - ^nw-board-position-column <nwbpc> - ^se-board-position-column <sebpc> - ^ne-board-position-column <nebpc> - ^ne-board-position-row <nebpr> - ^se-board-position-row <sebpr>)} - (position - ^row <sebpr> - ^column <sebpc> - ^state <> vacant - ^left-bent-state inside-a-segment) - (position - ^row <nebpr> - ^column <nebpc> - ^state <> vacant - ^right-bent-state inside-a-segment) - (symbol - ^meaning crossing-of-two-bent-segments - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <board-column>) + 2)) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-vertical-segment - ^sw-board-position-column <sebpc> - ^nw-board-position-column <nebpc> - ^se-board-position-column (compute <sebpc> + 1) - ^ne-board-position-column (compute <nebpc> + 1))) - -(p drawing-of-a-crossing-of-segments-4 - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-bent-segment - ^nw-board-position-column <board-column> - ^board-row <board-row> - ^sw-board-position-column <swbpc> - ^nw-board-position-column <nwbpc> - ^se-board-position-column <sebpc> - ^ne-board-position-column <nebpc> - ^nw-board-position-row <nwbpr> - ^sw-board-position-row <swbpr>)} - (position - ^row <swbpr> - ^column <swbpc> - ^state <> vacant - ^right-bent-state inside-a-segment) - (position - ^row <nwbpr> - ^column <nwbpc> - ^state <> vacant - ^left-bent-state inside-a-segment) - (symbol - ^meaning crossing-of-two-bent-segments - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <board-column>) + 2)) - (write (tabto <tab>) - <drawing-character>) - (modify <drawing-position-printed> - ^type possibly-a-piece-of-vertical-segment - ^sw-board-position-column <sebpc> - ^nw-board-position-column <nebpc> - ^se-board-position-column (compute <sebpc> + 1) - ^ne-board-position-column (compute <nebpc> + 1))) - -(p non-drawing-of-an-intermediate-position-of-an-intermediate-line - (game-state ^current-context board-drawing) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-bent-segment - ^board-row <board-row> - ^sw-board-position-column <swbpc> - ^nw-board-position-column <nwbpc> - ^se-board-position-column <sebpc> - ^ne-board-position-column <nebpc> - ^nw-board-position-row <nwbpr> - ^sw-board-position-row <swbpr>)} ---> - (modify <drawing-position-printed> - ^type possibly-a-piece-of-vertical-segment - ^sw-board-position-column <sebpc> - ^nw-board-position-column <nebpc> - ^se-board-position-column (compute <sebpc> + 1) - ^ne-board-position-column (compute <nebpc> + 1))) - -(p drawing-of-the-end-of-an-intermediate-line-1 - (game-state ^current-context board-drawing) - (board-parameters - ^nb-of-columns <nbbc>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-vertical-segment - ^nw-board-position-column <nbbc> - ^board-row <board-row> - ^sw-board-position-row <swbpr>)} - (position - ^row <swbpr> - ^column <nbbc> - ^state <> vacant - ^vertical-state inside-a-segment) - (symbol - ^meaning piece-of-vertical-segment - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <nbbc>))) - (write (tabto <tab>) - <drawing-character> - (crlf)) - (modify <drawing-position-printed> - ^type outside-board - ^line-type board-line - ^board-row (compute <board-row> + 1))) - -(p drawing-of-the-end-of-an-intermediate-line-2 - (game-state ^current-context board-drawing) - (board-parameters - ^nb-of-columns <nbbc>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-vertical-segment - ^nw-board-position-column <nbbc> - ^board-row <board-row> - ^nw-board-position-row <nwbpr>)} - (position - ^row <nwbpr> - ^column <nbbc> - ^state <> vacant - ^vertical-state inside-a-segment) - (symbol - ^meaning piece-of-vertical-segment - ^drawing-character <drawing-character>) ---> - (bind <tab> (compute 2 + (4 * <nbbc>))) - (write (tabto <tab>) - <drawing-character> - (crlf)) - (modify <drawing-position-printed> - ^type outside-board - ^line-type board-line - ^board-row (compute <board-row> + 1))) - -(p non-drawing-of-the-end-of-an-intermediate-line - (game-state ^current-context board-drawing) - (board-parameters - ^nb-of-columns <nbbc>) - {<drawing-position-printed> - (drawing-position-printed - ^line-type intermediate-line - ^type possibly-a-piece-of-vertical-segment - ^nw-board-position-column <nbbc> - ^board-row <board-row> - ^nw-board-position-row <nwbpr>)} ---> - (modify <drawing-position-printed> - ^type outside-board - ^line-type board-line - ^board-row (compute <board-row> + 1)) - (write (crlf))) - - - -(p choice-of-a-move-by-human - {<game-state> - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move - ^current-player human)} ---> - (write |Where do you play (row column)?|) - (make input ^type position ^value (acceptline))) - -(p correction-of-a-move-by-human - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move - ^current-player human) - {(input ^type position) <input>} ---> - (write |Your move is illegal.| - (crlf) - |Where do you play (row column)?|) - (modify <input> - ^value (acceptline))) - -(p end-of-the-choice-of-the-move - {<game-state> - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-the-move - ^current-player human)} - {(input - ^type position - ^value <row> <column>) <input>} - (position - ^row <row> - ^column <column> - ^state vacant) ---> - (make new-move - ^row <row> - ^column <column> - ^state human) - (remove <input>) - (modify <game-state> - ^current-context board-analyse - ^current-sub-context garbage-cleaning)) - -(p asking-the-human-whether-he-wants-to-draw-a-segment - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^current-player human) - -(segment) - -(input) ---> -(write |Segment to draw (ret., or beginning row & column, ending ...)?|) - (make input - ^type segment - ^value (acceptline no read))) - -(p asking-the-human-whether-he-wants-to-draw-another-segment - {<game-state> - (game-state - ^current-context choice-of-a-move - ^current-player human)} ---> - (modify <game-state> - ^current-context choice-of-a-move)) - -(p removal-of-a-negative-segment-input - {(game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^current-player human) <game-state>} - {(input - ^type segment - ^value no) <input>} ---> - (remove <input>) - (modify <game-state> - ^current-context choice-of-a-move - ^current-sub-context generation-of-the-best-possible-moves - ^current-player computer)) - -(p drawing-of-a-segment-by-human - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^current-player human) - {(input - ^type segment - ^value {<> no <beginning-row>} - <beginning-column> - <ending-row> - <ending-column>) <input>} ---> - (make segment - ^beginning-row <beginning-row> - ^beginning-column <beginning-column> - ^ending-row <ending-row> - ^ending-column <ending-column>) - (remove <input>)) - -(p orientation-of-a-non-vertical-segment - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^current-player human) - {<segment> - (segment - ^beginning-row <beginning-row> - ^ending-row <ending-row> - ^beginning-column <beginning-column> - ^ending-column {<ending-column> < <beginning-column>})} ---> - (modify <segment> - ^beginning-row <ending-row> - ^ending-row <beginning-row> - ^beginning-column <ending-column> - ^ending-column <beginning-column>)) - - (p orientation-of-a-vertical-segment - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^current-player human) - {<segment> - (segment - ^beginning-column <column> - ^ending-column <column> - ^beginning-row <beginning-row> - ^ending-row {<ending-row> < <beginning-row>})} ---> - (modify <segment> - ^beginning-row <ending-row> - ^ending-row <beginning-row>)) - -(p checking-of-the-legality-of-a-horizontal-oriented-segment - {<game-state> - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^current-player human - ^human-score <human-score>)} - {<segment> - (segment - ^beginning-row <row> - ^ending-row <row> - ^beginning-column <beginning-column> - ^ending-column <ending-column>)} - (incrementation - ^nb <beginning-column> - ^nb-incremented <column2>) - (incrementation - ^nb <column2> - ^nb-incremented <column3>) - (incrementation - ^nb <column3> - ^nb-incremented <column4>) - {<position1> - (position - ^column <beginning-column> - ^row <row> - ^state human - ^horizontal-state << free end-of-a-segment >>)} - {<position2> - (position - ^column <column2> - ^row <row> - ^state human - ^horizontal-state << free end-of-a-segment >>)} - {<position3> - (position - ^column <column3> - ^row <row> - ^state human - ^horizontal-state << free end-of-a-segment >>)} - {<position4> - (position - ^column {<ending-column> <column4>} - ^row <row> - ^state human - ^horizontal-state << free end-of-a-segment >>)} ---> - (modify <position1> - ^horizontal-state end-of-a-segment) - (modify <position2> - ^horizontal-state inside-a-segment) - (modify <position3> - ^horizontal-state inside-a-segment) - (modify <position4> - ^horizontal-state end-of-a-segment) - (modify <game-state> - ^human-score (compute <human-score> + 1)) - (remove <segment>)) - -(p checking-of-the-legality-of-a-vertical-oriented-segment - {<game-state> - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^current-player human - ^human-score <human-score>)} - {<segment> - (segment - ^beginning-column <column> - ^ending-column <column> - ^beginning-row <beginning-row> - ^ending-row <ending-row>)} - (incrementation - ^nb <beginning-row> - ^nb-incremented <row2>) - (incrementation - ^nb <row2> - ^nb-incremented <row3>) - (incrementation - ^nb <row3> - ^nb-incremented <row4>) - {<position1> - (position - ^row <beginning-row> - ^column <column> - ^state human - ^vertical-state << free end-of-a-segment >>)} - {<position2> - (position - ^row <row2> - ^column <column> - ^state human - ^vertical-state << free end-of-a-segment >>)} - {<position3> - (position - ^row <row3> - ^column <column> - ^state human - ^vertical-state << free end-of-a-segment >>)} - {<position4> - (position - ^row {<ending-row> <row4>} - ^column <column> - ^state human - ^vertical-state << free end-of-a-segment >>)} ---> - (modify <position1> - ^vertical-state end-of-a-segment) - (modify <position2> - ^vertical-state inside-a-segment) - (modify <position3> - ^vertical-state inside-a-segment) - (modify <position4> - ^vertical-state end-of-a-segment) - (modify <game-state> - ^human-score (compute <human-score> + 1)) - (remove <segment>)) - -(p checking-of-the-legality-of-a-left-bent-oriented-segment - {<game-state> - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^current-player human - ^human-score <human-score>)} - {<segment> - (segment - ^beginning-column <beginning-column> - ^ending-column <ending-column> - ^beginning-row <beginning-row> - ^ending-row <ending-row>)} - (incrementation - ^nb <beginning-row> - ^nb-incremented <row2>) - (incrementation - ^nb <row2> - ^nb-incremented <row3>) - (incrementation - ^nb <row3> - ^nb-incremented <row4>) - (incrementation - ^nb <beginning-column> - ^nb-incremented <column2>) - (incrementation - ^nb <column2> - ^nb-incremented <column3>) - (incrementation - ^nb <column3> - ^nb-incremented <column4>) - {<position1> - (position - ^row <beginning-row> - ^column <beginning-column> - ^state human - ^left-bent-state << free end-of-a-segment >>)} - {<position2> - (position - ^row <row2> - ^column <column2> - ^state human - ^left-bent-state << free end-of-a-segment >>)} - {<position3> - (position - ^row <row3> - ^column <column3> - ^state human - ^left-bent-state << free end-of-a-segment >>)} - {<position4> - (position - ^row {<ending-row> <row4>} - ^column {<ending-column> <column4>} - ^state human - ^left-bent-state << free end-of-a-segment >>)} ---> - (modify <position1> - ^left-bent-state end-of-a-segment) - (modify <position2> - ^left-bent-state inside-a-segment) - (modify <position3> - ^left-bent-state inside-a-segment) - (modify <position4> - ^left-bent-state end-of-a-segment) - (modify <game-state> - ^human-score (compute <human-score> + 1)) - (remove <segment>)) - -(p checking-of-the-legality-of-a-right-bent-oriented-segment - {<game-state> - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^current-player human - ^human-score <human-score>)} - {<segment> - (segment - ^beginning-row <beginning-row> - ^ending-row <ending-row> - ^beginning-column <beginning-column> - ^ending-column <ending-column>)} - (incrementation - ^nb <beginning-column> - ^nb-incremented <column2>) - (incrementation - ^nb <column2> - ^nb-incremented <column3>) - (incrementation - ^nb <column3> - ^nb-incremented <column4>) - (incrementation - ^nb <ending-row> - ^nb-incremented <row3>) - (incrementation - ^nb <row3> - ^nb-incremented <row2>) - (incrementation - ^nb <row2> - ^nb-incremented <row1>) - {<position1> - (position - ^column <beginning-column> - ^row {<row1> <beginning-row>} - ^state human - ^right-bent-state << free end-of-a-segment >>)} - {<position2> - (position - ^column <column2> - ^row <row2> - ^state human - ^right-bent-state << free end-of-a-segment >>)} - {<position3> - (position - ^column <column3> - ^row <row3> - ^state human - ^right-bent-state << free end-of-a-segment >>)} - {<position4> - (position - ^column {<ending-column> <column4>} - ^row <ending-row> - ^state human - ^right-bent-state << free end-of-a-segment >>)} ---> - (modify <position1> - ^right-bent-state end-of-a-segment) - (modify <position2> - ^right-bent-state inside-a-segment) - (modify <position3> - ^right-bent-state inside-a-segment) - (modify <position4> - ^right-bent-state end-of-a-segment) - (modify <game-state> - ^human-score (compute <human-score> + 1)) - (remove <segment>)) - -(p correction-of-a-segment - {<game-state> - (game-state - ^current-context choice-of-a-move - ^current-sub-context choice-of-segments - ^current-player human - ^human-score <human-score>)} - {<segment> - (segment - ^beginning-row <beginning-row> - ^ending-row <ending-row> - ^beginning-column <beginning-column> - ^ending-column <ending-column>)} ---> - (remove <segment>) - (write |Your segment is illegal.| - (crlf) - |Segment to draw (ret., or beginning row & column, ending ...)?|) - (make input - ^type segment - ^value (acceptline no read))) - - - - - - - - - - - - - - - - -(p fbug-start - (start) - --> - (make position - ^row 0 - ^column 0 - ^state edge - ^vertical-state nil - ^horizontal-state nil - ^right-bent-state nil - ^left-bent-state nil) - (make opposite ^of human ^is computer) - (make opposite ^of computer ^is human) - (make board-parameters - ^nb-of-columns 10 - ^nb-of-rows 10 - ^nb-of-columns-incr 11 - ^nb-of-rows-incr 11 - ^max-board-size 10 - ^max-board-size-incr 11) - (make symbol - ^meaning vacant - ^drawing-character |.|) - (make symbol - ^meaning human - ^drawing-character |o|) - (make symbol - ^meaning computer - ^drawing-character |*|) - (make symbol - ^meaning piece-of-horizontal-segment - ^drawing-character |-|) - (make symbol - ^meaning piece-of-vertical-segment - ^drawing-character |l|) - (make symbol - ^meaning piece-of-right-bent-segment - ^drawing-character |/|) - (make symbol - ^meaning piece-of-left-bent-segment - ^drawing-character |\|) - (make symbol - ^meaning crossing-of-two-bent-segments - ^drawing-character |x|) - (make game-state - ^current-context initialisations - ^human-score 0 - ^computer-score 0) - (make delta 0) - (make delta 1) - (make delta -1) - (make nb 0) - (make nb 1) - (make nb 2) - (make nb 3) - (make nb 4) - (make nb 5) - (make nb 6) - (make nb 7) - (make nb 8) - (make nb 9) - (make nb 10) - (make nb 11) - (make length 4) - (make length 5) - (make length 6) - (make length 7) - (make incrementation - ^nb 0 - ^nb-incremented 1) - (make direction ^geometry assymetric ^row 0 ^column 1) - (make direction ^geometry assymetric ^row 1 ^column 1) - (make direction ^geometry assymetric ^row 1 ^column 0) - (make direction ^geometry assymetric ^row 1 ^column -1) - (make direction ^geometry assymetric ^row 0 ^column -1) - (make direction ^geometry assymetric ^row -1 ^column -1) - (make direction ^geometry assymetric ^row -1 ^column 0) - (make direction ^geometry assymetric ^row -1 ^column 1) - (make direction ^geometry symetric ^row 0 ^column 1) - (make direction ^geometry symetric ^row 1 ^column 1) - (make direction ^geometry symetric ^row 1 ^column 0) - (make direction ^geometry symetric ^row 1 ^column -1) - (make number-to-add-while-updating-counters ^value ignore-it) - (make segment-type - ^name opcxcpo - ^length 7 - ^geometry symetric - ^owner computer - ^position-1-state human - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state computer - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state human - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage - ^position-7-counter-to-update garbage) - (make segment-type - ^name ipcxcpo - ^length 7 - ^geometry assymetric - ^owner computer - ^position-1-state edge - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state computer - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state human - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage - ^position-7-counter-to-update garbage) - (make segment-type - ^name ipcxcpi - ^length 7 - ^geometry symetric - ^owner computer - ^position-1-state edge - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state computer - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state edge - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage - ^position-7-counter-to-update garbage) - (make segment-type - ^name pccxccp - ^length 7 - ^geometry symetric - ^owner computer - ^position-1-state vacant - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state computer - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update nb-of-compulsory-answer-creations - ^position-7-counter-to-update garbage) - (make segment-type - ^name opcxccp - ^length 7 - ^geometry assymetric - ^owner computer - ^position-1-state human - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state computer - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update nb-of-compulsory-answer-creations - ^position-7-counter-to-update garbage) - (make segment-type - ^name ipcxccp - ^length 7 - ^geometry assymetric - ^owner computer - ^position-1-state edge - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state computer - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update nb-of-compulsory-answer-creations - ^position-7-counter-to-update garbage) - (make segment-type - ^name cxfxc - ^length 5 - ^geometry symetric - ^owner computer - ^position-1-state vacant - ^position-2-state computer - ^position-3-state vacant - ^position-4-state computer - ^position-5-state vacant - ^position-1-counter-to-update nb-of-compulsory-answer-creations - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-fragile-winners - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name oxxcc - ^length 5 - ^geometry assymetric - ^owner human - ^position-1-state human - ^position-2-state computer - ^position-3-state computer - ^position-4-state vacant - ^position-5-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update nb-of-compulsory-answer-creations - ^position-5-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name ixxcc - ^length 5 - ^geometry assymetric - ^owner human - ^position-1-state edge - ^position-2-state computer - ^position-3-state computer - ^position-4-state vacant - ^position-5-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update nb-of-compulsory-answer-creations - ^position-5-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name oxxfx - ^length 5 - ^geometry assymetric - ^owner computer - ^position-1-state human - ^position-2-state computer - ^position-3-state computer - ^position-4-state vacant - ^position-5-state computer - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update nb-of-fragile-winners - ^position-5-counter-to-update garbage) - (make segment-type - ^name ixxfx - ^length 5 - ^geometry assymetric - ^owner computer - ^position-1-state edge - ^position-2-state computer - ^position-3-state computer - ^position-4-state vacant - ^position-5-state computer - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update nb-of-fragile-winners - ^position-5-counter-to-update garbage) - (make segment-type - ^name ocxxco - ^length 6 - ^geometry symetric - ^owner computer - ^position-1-state human - ^position-2-state vacant - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-6-state human - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage) - (make segment-type - ^name icxxco - ^length 6 - ^geometry assymetric - ^owner computer - ^position-1-state edge - ^position-2-state vacant - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-6-state human - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage) - (make segment-type - ^name icxxci - ^length 6 - ^geometry symetric - ^owner computer - ^position-1-state edge - ^position-2-state vacant - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-6-state edge - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage) - (make segment-type - ^name ocxxfc - ^length 6 - ^geometry assymetric - ^owner computer - ^position-1-state human - ^position-2-state vacant - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-6-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name icxxfc - ^length 6 - ^geometry assymetric - ^owner computer - ^position-1-state edge - ^position-2-state vacant - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-6-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name ocxxfx - ^length 6 - ^geometry assymetric - ^owner computer - ^position-1-state human - ^position-2-state vacant - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-6-state computer - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update garbage) - (make segment-type - ^name icxxfx - ^length 6 - ^geometry assymetric - ^owner computer - ^position-1-state edge - ^position-2-state vacant - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-6-state computer - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update garbage) - (make segment-type - ^name cfxxfc - ^length 6 - ^geometry symetric - ^owner computer - ^position-1-state vacant - ^position-2-state vacant - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-6-state vacant - ^position-1-counter-to-update nb-of-compulsory-answer-creations - ^position-2-counter-to-update nb-of-fragile-winners - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name xfxxfc - ^length 6 - ^geometry assymetric - ^owner computer - ^position-1-state computer - ^position-2-state vacant - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-6-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-fragile-winners - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name xwxxwx - ^length 6 - ^geometry symetric - ^owner computer - ^position-1-state computer - ^position-2-state vacant - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-6-state computer - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-strong-winners - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-strong-winners - ^position-6-counter-to-update garbage) - (make segment-type - ^name oxxxf - ^length 5 - ^geometry assymetric - ^owner computer - ^position-1-state human - ^position-2-state computer - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners) - (make segment-type - ^name ixxxf - ^length 5 - ^geometry assymetric - ^owner computer - ^position-1-state edge - ^position-2-state computer - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners) - (make segment-type - ^name wxxxw - ^length 5 - ^geometry symetric - ^owner computer - ^position-1-state vacant - ^position-2-state computer - ^position-3-state computer - ^position-4-state computer - ^position-5-state vacant - ^position-1-counter-to-update nb-of-strong-winners - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-strong-winners) - (make segment-type - ^name opcxcpo - ^length 7 - ^geometry symetric - ^owner human - ^position-1-state computer - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state human - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state computer - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage - ^position-7-counter-to-update garbage) - (make segment-type - ^name ipcxcpo - ^length 7 - ^geometry assymetric - ^owner human - ^position-1-state edge - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state human - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state computer - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage - ^position-7-counter-to-update garbage) - (make segment-type - ^name ipcxcpi - ^length 7 - ^geometry symetric - ^owner human - ^position-1-state edge - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state human - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state edge - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage - ^position-7-counter-to-update garbage) - (make segment-type - ^name pccxccp - ^length 7 - ^geometry symetric - ^owner human - ^position-1-state vacant - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state human - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update nb-of-compulsory-answer-creations - ^position-7-counter-to-update garbage) - (make segment-type - ^name opcxccp - ^length 7 - ^geometry assymetric - ^owner human - ^position-1-state computer - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state human - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update nb-of-compulsory-answer-creations - ^position-7-counter-to-update garbage) - (make segment-type - ^name ipcxccp - ^length 7 - ^geometry assymetric - ^owner human - ^position-1-state edge - ^position-2-state vacant - ^position-3-state vacant - ^position-4-state human - ^position-5-state vacant - ^position-6-state vacant - ^position-7-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-compulsory-answer-creations - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update nb-of-compulsory-answer-creations - ^position-7-counter-to-update garbage) - (make segment-type - ^name cxfxc - ^length 5 - ^geometry symetric - ^owner human - ^position-1-state vacant - ^position-2-state human - ^position-3-state vacant - ^position-4-state human - ^position-5-state vacant - ^position-1-counter-to-update nb-of-compulsory-answer-creations - ^position-2-counter-to-update garbage - ^position-3-counter-to-update nb-of-fragile-winners - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name oxxcc - ^length 5 - ^geometry assymetric - ^owner computer - ^position-1-state computer - ^position-2-state human - ^position-3-state human - ^position-4-state vacant - ^position-5-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update nb-of-compulsory-answer-creations - ^position-5-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name ixxcc - ^length 5 - ^geometry assymetric - ^owner computer - ^position-1-state edge - ^position-2-state human - ^position-3-state human - ^position-4-state vacant - ^position-5-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update nb-of-compulsory-answer-creations - ^position-5-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name oxxfx - ^length 5 - ^geometry assymetric - ^owner human - ^position-1-state computer - ^position-2-state human - ^position-3-state human - ^position-4-state vacant - ^position-5-state human - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update nb-of-fragile-winners - ^position-5-counter-to-update garbage) - (make segment-type - ^name ixxfx - ^length 5 - ^geometry assymetric - ^owner human - ^position-1-state edge - ^position-2-state human - ^position-3-state human - ^position-4-state vacant - ^position-5-state human - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update nb-of-fragile-winners - ^position-5-counter-to-update garbage) - (make segment-type - ^name ocxxco - ^length 6 - ^geometry symetric - ^owner human - ^position-1-state computer - ^position-2-state vacant - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-6-state computer - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage) - (make segment-type - ^name icxxco - ^length 6 - ^geometry assymetric - ^owner human - ^position-1-state edge - ^position-2-state vacant - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-6-state computer - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage) - (make segment-type - ^name icxxci - ^length 6 - ^geometry symetric - ^owner human - ^position-1-state edge - ^position-2-state vacant - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-6-state edge - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-compulsory-answer-creations - ^position-6-counter-to-update garbage) - (make segment-type - ^name ocxxfc - ^length 6 - ^geometry assymetric - ^owner human - ^position-1-state computer - ^position-2-state vacant - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-6-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name icxxfc - ^length 6 - ^geometry assymetric - ^owner human - ^position-1-state edge - ^position-2-state vacant - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-6-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name ocxxfx - ^length 6 - ^geometry assymetric - ^owner human - ^position-1-state computer - ^position-2-state vacant - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-6-state human - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update garbage) - (make segment-type - ^name icxxfx - ^length 6 - ^geometry assymetric - ^owner human - ^position-1-state edge - ^position-2-state vacant - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-6-state human - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-compulsory-answer-creations - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update garbage) - (make segment-type - ^name cfxxfc - ^length 6 - ^geometry symetric - ^owner human - ^position-1-state vacant - ^position-2-state vacant - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-6-state vacant - ^position-1-counter-to-update nb-of-compulsory-answer-creations - ^position-2-counter-to-update nb-of-fragile-winners - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name xfxxfc - ^length 6 - ^geometry assymetric - ^owner human - ^position-1-state human - ^position-2-state vacant - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-6-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-fragile-winners - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners - ^position-6-counter-to-update nb-of-compulsory-answer-creations) - (make segment-type - ^name xwxxwx - ^length 6 - ^geometry symetric - ^owner human - ^position-1-state human - ^position-2-state vacant - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-6-state human - ^position-1-counter-to-update garbage - ^position-2-counter-to-update nb-of-strong-winners - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-strong-winners - ^position-6-counter-to-update garbage) - (make segment-type - ^name oxxxf - ^length 5 - ^geometry assymetric - ^owner human - ^position-1-state computer - ^position-2-state human - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners) - (make segment-type - ^name ixxxf - ^length 5 - ^geometry assymetric - ^owner human - ^position-1-state edge - ^position-2-state human - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-1-counter-to-update garbage - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-fragile-winners) - (make segment-type - ^name wxxxw - ^length 5 - ^geometry symetric - ^owner human - ^position-1-state vacant - ^position-2-state human - ^position-3-state human - ^position-4-state human - ^position-5-state vacant - ^position-1-counter-to-update nb-of-strong-winners - ^position-2-counter-to-update garbage - ^position-3-counter-to-update garbage - ^position-4-counter-to-update garbage - ^position-5-counter-to-update nb-of-strong-winners) - (make move-type-classification - ^type fragile-winner - ^is-better-than-type multiple-fragile-winners-creation) - (make move-type-classification - ^type fragile-winner - ^is-better-than-type agressivity) - (make move-type-classification - ^type multiple-fragile-winners-creation - ^is-better-than-type agressivity) - (make move-type - ^name agressivity - ^point-of-views&counters-to-add - human nb-of-compulsory-answer-creations - computer nb-of-strong-winners - ^comment nil) - (make move-type - ^name multiple-fragile-winners-creation - ^point-of-views&counters-to-add - computer nb-of-compulsory-answer-creations - human nb-of-strong-winners - ^comment need-to-be-validated-separetely) - (make move-type - ^name fragile-winner - ^point-of-views&counters-to-add - computer nb-of-fragile-winners human nb-of-fragile-winners - ^comment nil) -) - - - diff --git a/contrib/ops/haunt.ops b/contrib/ops/haunt.ops deleted file mode 100644 index 4de108e6e8944de0ecb147b921dae9dfc12185f0..0000000000000000000000000000000000000000 --- a/contrib/ops/haunt.ops +++ /dev/null @@ -1,6745 +0,0 @@ -;;; Source code for the haunt program by John Laird - -;;; Added comment, -BGM 2/3/89 -(defmacro comment (&rest r) `',r) - -(comment Haunt mps OPS5 productions for haunt) - -(strategy mea) - -(literalize current type name) - -(literalize links id name type) - -(literalize object name holds state inside scored xscore alive -place side north south east up contains covered tied wears asleep treasure) - -(literalize location name side north south east up underwater book book2 -ontop siton general) - - (literalize portal name door status) - - (literalize place name visited state water virgin) - - (literalize history atetoken northpole forever hiwater grave_status -grave_status2 hungry clue bus_stopped) - - (literalize command string) - - (literalize control state special) - - (literalize time realtime cancer morning midnight orc_status orc_time - oil_status oil_time btime) - - (literalize status score die died bdie likes sound went going answer noway - quit notreasure cut) - -(comment **************** Start the show ****************) - -(p name01 - (x 0) - (current ^type operator ^name readfirst) - (input) - --> - (remove 3) - (write (crlf) |I assume that means yes.|) - (modify 2 ^type operator ^name read)) - -(p name02 - (x 10) - (current ^type operator ^name readfirst) - (input << yes y oui nothing >>) - --> - (remove 3) - (modify 2 ^type operator ^name read)) - -(p name06 - (x 0) - (current ^type operator ^name process) - (input) - --> - (write (crlf) |What?|) - (remove 3) - (modify 2 ^name read)) - -(p name07 - (x 10) - (current ^type operator ^name process) - (status ^going <> nil) - --> - (write (crlf) |You can't go that way.|) - (modify 2 ^name read) - (modify 3 ^going nil)) - -(p name08 - (x 10) - (current ^type operator ^name process) - (status ^going nil) --(input) - --> - (modify 2 ^type operator ^name read)) - -(p name09 - (x 10) - (current ^type operator ^name read) - (status ^going nil) - (time ^realtime <x>) --(input) - --> - (modify 2 ^type operator ^name process) - (write (crlf) |*|) - (make input (acceptline nothing read)) - (modify 4 ^realtime (compute <x> + 2))) - -(p name010 - (x 50) - (current ^type operator ^name readfirst) - --> - (write (crlf) |This is HAUNT. Version 4.6|) - (write (crlf) |See NEWS for news.|) - (write (crlf) |Have you played before?| (crlf) |*|) - (make input (accept)) - (write (crlf) | |)) - -(p name011 - (x 20) - (current ^type operator ^name read) --(location) - --> - (make location ^name bus_stop)) - -(p name012 - (x 40) - (current ^type operator ^name readfirst) - (input << n no >>) - --> - (remove 3) - (modify 2 ^name read) - (write (crlf) |Welcome novice. You are playing one of the world's largest|) - (write (crlf) |production systems. The purpose of this game is to find|) - (write (crlf) |treasure in a haunted house and then escape from the house.|) - (write (crlf) | |) - (write (crlf) |The program will give descriptions of locations and accept|) - (write (crlf) |commands to perform actions.|) - (write (crlf) |Give it directives with simple 1-5 word commands.|) - (write (crlf) |Its knowledge of English is limited but imaginative.|) - (write (crlf) |The directions are north, south, east, west,|) - (write (crlf) |up and down. Directions can be one letter (n,s,e,w,u,d).|) - (write (crlf) |Forward, back, left and right also work.|) - (write (crlf) |To string commands together use 'then'. (eg. west then s)|) - (write (crlf) |It will describe things to you, and a phrase enclosed in ' ' |) - (write (crlf) |is something it hears.|) - (write (crlf) | |) - (write (crlf) |Special commands: INVEN tells you what you hold.|) - (write (crlf) | SCORE gives your current score. |) - (write (crlf) | STOP ends the adventure. |) - (write (crlf) | LOOK describes your current position.|) - (write (crlf) | NEWS describes new features.|) - (write (crlf) | |) - (write (crlf) |*************************************************************|) - (write (crlf) |You get 15 points for finding a treasure and 5 points for|) - (write (crlf) |getting it to the lawn outside the house. You get an extra|) - (write (crlf) |bonus of 20 points for getting your body off the estate.|) - (write (crlf) |The maximum number of points is 440|) - (write (crlf) |Good luck, you'll need it. Ask for help if you want.|) - (write (crlf) |*************************************************************|) - (write (crlf) |Copyright (C) 1979, 1980, 1981, 1982, 1983 John Laird|) - (write (crlf) |*************************************************************|) - (write (crlf) | |) - (write (crlf) |On with the adventure!!|) - (write (crlf) | |) - (write (crlf) | |) - (write (crlf) | |) - (write (crlf) | |) - (write (crlf) | |) - (write (crlf) | |) - (write (crlf) | |) - (write (crlf) | |) - (write (crlf) | |) - (write (crlf) | |) - (write (crlf) |Along time ago, a young couple was picnicing near the woods|) - (write (crlf) |on the outskirts of town. They were celebrating the birth|) - (write (crlf) |of their first child. Unfortunately, a crazed moose|) - (write (crlf) |inhabited that area and attacked them. The child and husband|) - (write (crlf) |were unharmed, but the wife was gored to death by the moose.|) - (write (crlf) | |) - (write (crlf) |After the funeral, the man bought the land where the incident occurred|) - (write (crlf) |and constructed a large mansion: CHEZ MOOSE. He filled it|) - (write (crlf) |with the treasures of his family and claimed that his wife's|) - (write (crlf) |soul was still in the area. He vowed to remain in the|) - (write (crlf) |mansion until he had returned her soul to human flesh.|) - (write (crlf) |He tried to bridge the gap between life and death to reclaim her.|) - (write (crlf) |Some say he was insane with grief, but others claimed that the madness was|) - (write (crlf) |in his blood, and his wife's death brought it to the surface.|) - (write (crlf) |After he entered the house, he never returned, and was declared dead |) - (write (crlf) |seven years later. Several people have entered the mansion|) - (write (crlf) |looking for him but none of them have ever returned.|) - (write (crlf) |There were rumors that he and his wife now haunt the house.|) - (write (crlf) | |) - (write (crlf) |That would be the end of the story except that the house|) - (write (crlf) |still stands and is filled with priceless treasures.|) - (write (crlf) |The house and all its contents are willed to his only descendant.|) - (write (crlf) |Oh yes, I forgot to tell you, the day the mother was killed,|) - (write (crlf) |the child was stolen by Gypsies.|) - (write (crlf) |The Will claims that only the descendant will know|) - (write (crlf) |how to avoid going crazy and committing suicide|) - (write (crlf) |while spending a night in the mansion.|) - (write (crlf) |An obscure hereditary disease, Orkhisnoires sakioannes,|) - (write (crlf) |is supposed to play some part in this.|) - (write (crlf) | |) - (write (crlf) |So if your heritage is in doubt, you may be the descendant|) - (write (crlf) |that can claim the treasure in the mansion.|) - (write (crlf) |Many people, claiming to be descendants have died trying...|) - (write (crlf) | or at least never returned.|) - (write (crlf) | |) - (write (crlf) |The terms of the Will say you get to keep any treasure|) - (write (crlf) |you get to the lawn, but of course you must also get off the premises alive.|) - (write (crlf) |Because the house is haunted it must be destroyed, and nobody|) - (write (crlf) |would be crazy enough to try and recover the rest of the treasure.|) - (write (crlf) |If you do get out, the government has agreed to|) - (write (crlf) |buy the land and destroy the house.|) - (write (crlf) | |) - (write (crlf) |If you are insane enough to try, your adventure starts at a bus stop.|) - (write (crlf) |Remember, type STOP to end the adventure.|) - (write (crlf) | |)) - -(p name013 - (start) - --> - (make current ^type operator ^name readfirst) - (remove 1) - (make x 0) - (make x 10) - (make x 20) - (make x 30) - (make x 40) - (make x 50) - (make x 60)) - -(p name1005 - (x 60) - (current ^type operator ^name readfirst) - --> - (make status ^score 0 ^went w ^sound on) - (make object ^name elevator ^place H) - (make object ^name candlesticks ^place dining_room ^treasure t) - (make object ^name ghost ^place cheese_room) - (make object ^name candy ^place foyer) - (make object ^name jade ^place backroom ^treasure t) - (make object ^name soap ^place bathroom) - (make object ^name mattress ^place bedroom) - (make object ^name chest ^place ocean ^south 2 ^east 2 ^up 1 ^treasure t) - (make object ^name marijuana ^place secret_room ^treasure t) - (make object ^name bottle ^place bar) - (make object ^name painting ^place smelly_room ^covered t) - (make object ^name chair ^place main_hall ^treasure t) - (make object ^name stool ^place bar) - (make object ^name gold ^place small_closet ^treasure t) - (make object ^name Dracula ^place dark_room ^asleep t) - (make object ^name monster ^place laboratory) - (make object ^name coins ^place bathysphere ^treasure t) - (make object ^name corkscrew ^place wine_cellar ^treasure t) - (make object ^name wetsuit ^place closet) - (make object ^name speargun ^place bathysphere ^state loaded) - (make object ^name diamonds ^place cave ^treasure t) - (make object ^name cube ^place frig ^treasure t) - (make object ^name tokens ^place held) - (make object ^name orchid ^place lawn - ^side in ^east 3 ^north 7 ^state seed) - (make object ^name watch ^place held) - (make object ^name stairs ^state whole) - (make object ^name rope ^tied noose) - (make object ^name damsel ^alive t ^tied t) - (make object ^name turpentine ^inside bottle) - (make object ^name moray_eel ^alive t) - (make object ^name seamonster ^alive t) - (make object ^name octopus ^alive t) - (make portal ^name truck ^door closed) - (make portal ^name library ^door closed) - (make portal ^name casket ^door closed) - (make portal ^name grill ^door closed) - (make portal ^name elevator ^door closed) - (make portal ^name large_door ^door closed) - (make portal ^name safe ^door closed) - (make portal ^name rdoor ^door closed) - (make portal ^name wdoor ^door closed) - (make portal ^name closet ^door open) - (make portal ^name wall ^door closed) - (make time ^btime 2214 ^realtime 2200) - (make history ^grave_status undug) - (make place ^name bathtub ^water out) - (make place ^name foyer ^virgin t)) - -(p name1 - (x 50) - (location ^name <name>) -- (place ^name <name>) - --> - (make place ^name <name>)) - -(p name3 - (x 10) - (location ^name <y>) - (object ^name <x> ^place <> <y>) - (input <a> <x>) - --> - (remove 4) - (write (crlf) |The| <x> |is not here.|)) - -(p name4 - (x 30) - (input news) - --> - (remove 2) - (write (crlf) |Version 4.6, 6-21-82|) - (write (crlf) |As always, a few more bugs have been fixed.|) - (write (crlf) |Send gripes to John.Laird@CMUA.|) - (write (crlf) |Or John Laird, Computer Science Department|) - (write (crlf) |Carnegie-Mellon University, Pittsburgh, Pa. 15213|) - (write (crlf) |The max score is 440.|) - (write (crlf) |Copyright (C) 1979,1980,1981,1982,1983 John E. Laird|)) - -(p name5 - (x 30) - (input who is bzm <x>) - --> - (remove 2) - (write (crlf) |A famous graduate of CMU CSD.|)) - -(p name6 - (x 30) - (input xstat) - --> - (remove 2) - (halt)) - -(p name7 - (x 50) - (location ^name <x>) - (place ^name <x> ^visited t) - --> - (write (crlf) |You are in| <x> |.|)) - -(p name8 - (x 30) - (input <x> <y> on) - --> - (make input <x> on <y> (substr 2 5 inf)) - (remove 2)) - -(p name9 - (x 30) - (input <x> <y> off) - --> - (make input <x> off <y> (substr 2 5 inf)) - (remove 2)) - -(p name10 - (x 30) - (input <x> to <y>) - --> - (remove 2) - (make input <x> <y>)) - -(p name11 - (x 30) - (location ^name <x>) - (input gamma <y>) - --> - (remove 3) - (modify 2 ^name <y>)) - -(p name12 - (x 30) - (input <x> the) - --> - (remove 2) - (make input <x> (substr 2 4 inf))) - -(p name13 - (x 30) - (input <x> <y> the) - --> - (remove 2) - (make input <x> <y> (substr 2 5 inf))) - -(p name14 - (x 30) - (input <x> a) - --> - (remove 2) - (make input <x> (substr 2 4 inf))) - -(p name15 - (x 30) - (input <x> then) - --> - (remove 2) - (make input <x>) - (make input then (substr 2 4 inf))) - -(p name16 - (x 30) - (input <x> <y> then) - --> - (remove 2) - (make input <x> <y>) - (make input (substr 2 4 inf))) - -(p name17 - (x 30) - (input <x> <y> then <W> it) - --> - (remove 2) - (make input <x> <y>) - (make input then <W> <y> (substr 2 7 inf))) - -(p name18 - (x 30) - (input <x> {<> then <y>} <n> then) - --> - (remove 2) - (make input <x> <y> <n>) - (make input (substr 2 5 inf))) - -(p name19 - (x 30) - (input then) - (time ^realtime <y>) - --> - (remove 2) - (make input (substr 2 3 inf)) - (modify 3 ^realtime (compute <y> + 2))) - -(p name20 - (x 30) - (object ^name <y> ^place held) - (input <x> it) - --> - (remove 3) - (make input <x> <y> (substr 3 4 inf))) - -(p name21 - (x 30) - (object ^name <y> ^place <Z>) - (location ^name <Z>) - (input <x> it) - --> - (remove 4) - (make input <x> <y> (substr 4 4 inf))) - - -(comment ********Directions************************************************ ) - -(p name22 - (x 30) - (input {<< n s e w u d >> <direction>}) - (status) - --> - (remove 2) - (modify 3 ^going <direction> ^went <direction>)) - -(p name23 - (x 30) - (input << out leave >>) - --> - (make input exit (substr 2 3 inf)) - (remove 2)) - -(p name24 - (x 30) - (input get in) - --> - (remove 2) - (make input enter (substr 2 4 inf))) - -(p name25 - (x 30) - (input << walkin in inside >>) - --> - (remove 2) - (make input enter (substr 2 3 inf))) - -(p name26 - (x 30) - (input west) - (status) - --> - (remove 2) - (modify 3 ^going w ^went w)) - -(p name27 - (x 30) - (input east) - (status) - --> - (remove 2) - (modify 3 ^going e ^went e)) - -(p name28 - (x 30) - (input north) - (status) - --> - (remove 2) - (modify 3 ^going n ^went n)) - -(p name29 - (x 30) - (input south) - (status) - --> - (remove 2) - (modify 3 ^going s ^went s)) - -(p name30 - (x 30) - (input up) - (status) - --> - (remove 2) - (modify 3 ^going u ^went u)) - -(p name31 - (x 30) - (input down) - (status) - --> - (remove 2) - (modify 3 ^going d ^went d)) - -(p name32 - (x 30) - (status ^going n) - --> - (modify 2 ^going nil ^noway t)) - -(p name33 - (x 30) - (status ^going s) - --> - (modify 2 ^going nil ^noway t)) - -(p name34 - (x 30) - (status ^going w) - --> - (modify 2 ^going nil ^noway t)) - -(p name35 - (x 30) - (status ^going e) - --> - (modify 2 ^going nil ^noway t)) - -(p name36 - (x 30) - (status ^going d) - --> - (modify 2 ^going nil) - (write (crlf) |You can't go down from here.|)) - -(p name37 - (x 30) - (status ^going u) - --> - (modify 2 ^going nil) - (write (crlf) |There is nothing to go up on.|)) - -(p name38 - (x 30) - (status ^noway t) - --> - (write (crlf) |You can't go that way.|) - (modify 2 ^noway nil ^going nil)) - -(p name39 - (x 30) - (status ^went w) - (input right) - --> - (modify 2 ^going n ^went n) - (remove 3)) - -(p name40 - (x 30) - (status ^went <direction>) - (input forward) - --> - (modify 2 ^going <direction>) - (remove 3)) - -(p name41 - (x 30) - (status ^went s) - (input left) - --> - (modify 2 ^going e ^went e) - (remove 3)) - -(p name42 - (x 30) - (status ^went e) - (input left) - --> - (modify 2 ^going n ^went n) - (remove 3)) - -(p name43 - (x 30) - (status ^went e) - (input right) - --> - (modify 2 ^going s ^went s) - (remove 3)) - -(p name44 - (x 30) - (status ^went e) - (input back) - --> - (modify 2 ^going w ^went w) - (remove 3)) - -(p name45 - (x 30) - (status ^went s) - (input right) - --> - (modify 2 ^going w ^went w) - (remove 3)) - -(p name46 - (x 30) - (status ^went s) - (input back) - --> - (modify 2 ^going n ^went n) - (remove 3)) - -(p name47 - (x 30) - (status ^went n) - (input left) - --> - (modify 2 ^going w ^went w) - (remove 3)) - -(p name48 - (x 30) - (status ^went n) - (input right) - --> - (modify 2 ^going e ^went e) - (remove 3)) - -(p name49 - (x 30) - (status ^went n) - (input back) - --> - (modify 2 ^going s ^went s) - (remove 3)) - -(p name50 - (x 30) - (status ^went w) - (input left) - --> - (modify 2 ^going s ^went s) - (remove 3)) - -(p name51 - (x 30) - (status ^went u) - (input back) - --> - (modify 2 ^going d ^went d) - (remove 3)) - -(p name52 - (x 30) - (status ^went d) - (input back) - --> - (modify 2 ^going u ^went u) - (remove 3)) - -(p name53 - (x 30) - (status ^went w) - (input back) - --> - (modify 2 ^going e ^went e) - (remove 3)) - -(p name54 - (x 30) - (input ahead) - --> - (remove 2) - (make input forward)) - -(p name55 - (x 30) - (status ^went <y>) - (input direction) - --> - (remove 3) - (write (crlf) |You are facing | <y>)) - -(p name56 - (x 20) - (input exit) - --> - (remove 2) - (make input back)) - -(p name57 - (x 20) - (input enter <x>) - --> - (remove 2) - (write (crlf) |I can't enter| <x> |.|)) - -(p name58 - (x 30) - (input go nil) - --> - (make input forward) - (remove 2)) - -(p name59 - (x 30) - (input go <> nil) - --> - (remove 2) - (make input (substr 2 3 inf))) - - -(comment *****************Get and Drop************************************* ) - -(p name60 - (x 30) - (location ^name <x>) - (object ^name <n> ^place <x>) - (input get all) - --> - (make input get <n>)) - -(p name61 - (x 20) - (input get all) - --> - (remove 2) - (write (crlf) |OK, all done.|)) - -(p name62 - (x 30) - (object ^name <p> ^place held) - (input get <p>) - --> - (remove 3) - (write (crlf) |You already have| <p>)) - -(p name63 - (x 10) - (input get <p>) - --> - (remove 2) - (write (crlf) |I can't get| <p>)) - -(p name64 - (x 30) - (object ^name <x> ^place <p> ^side <s> ^north <n> ^east <e> ^state nil) - (location ^name <p> ^side <s> ^north <n> ^east <e>) - (input get <x>) - --> - (remove 4) - (modify 2 ^place held) - (write (crlf) |You just got| <x> |.|)) - -(p name65 - (x 40) - (object ^name monster ^place laboratory) - (location ^name laboratory) - (input get monster) - --> - (remove 4) - (write (crlf) |That would be a big mistake.|)) - -(p name66 - (x 40) - (object ^name cecil ^place <x>) - (location ^name <x>) - (input get cecil) - --> - (remove 4) - (write (crlf) |Cecil is a free spirit. He doesn't come with you.|)) - -(p name67 - (x 30) - (input << pull pickup grab pry lift take carry >> <x>) - --> - (remove 2) - (make input get <x>)) - -(p name68 - (x 30) - (input pick up <x>) - --> - (make input get <x>) - (remove 2)) - -(p name69 - (x 10) - (input drop all) - --> - (remove 2) - (write (crlf) |All dropped.|)) - -(p name70 - (x 30) - (input drop all) - (location ^name <p>) - (object ^name <n> ^place held) - --> - (make input drop <n>)) - -(p name71 - (x 20) - (object ^name <x> ^place held) - (location ^name <y> ^side <s> ^north <n> ^east <e>) - (input drop <x>) - --> - (remove 4) - (modify 2 ^place <y> ^side <s> ^north <n> ^east <e>)) - -(p name72 - (x 30) - (input << discard release >> <x>) - --> - (remove 2) - (make input drop <x>)) - -(p name73 - (x 10) - (object ^name <x> ^place <> held) - (input drop <x>) - --> - (remove 3) - (write (crlf) |You don't have| <x>)) - -(p name74 - (x 30) - (input put down <x>) - --> - (remove 2) - (make input drop <x>)) - -(p name75 - (x 30) - (input take off <x>) - --> - (remove 2) - (make input remove <x>)) - - -(comment *****************Inventory************************************ ) - -(p name76 - (x 30) - (object ^name <p> ^place held) - (input inven) - --> - (write (crlf) <p>)) - -(p name77 - (x 20) - (input inven) - --> - (remove 2)) - -(p name78 - (x 40) - (input inven) - --> - (write (crlf) |You have the following:|)) - -(p name79 - (x 30) - (input inventory) - --> - (remove 2) - (make input inven)) - -(p name80 - (x 30) - (object ^name <p> ^place held) - (object ^name <C> ^inside <p>) - (input inven) - --> - (write (crlf) <C>)) - -(p name81 - (x 50) --(object ^name <x> ^place held) - (input inven) - --> - (remove 2) - (write (crlf) |You're empty handed.|)) - - -(comment ******************Random inputs********************************* ) - -(p name82 - (x 30) - (input run nil) - --> - (remove 2) - (write (crlf) |I'm going as fast as I can.|)) - -(p name83 - (x 30) - (input run <> nil) - --> - (remove 2) - (write (crlf) |I can't go any faster.|)) - -(p name84 - (x 30) - (input listen) - --> - (remove 2) - (write (crlf) |Silence!|)) - - -(p name85 - (x 30) - (status ^sound on) - (input listen) - --> - (remove 3) - (modify 2 ^sound on)) - -(p name86 - (x 30) - (input whistle) - --> - (remove 2) - (write (crlf) |What, without an accompanying orchestra?|)) - -(p name87 - (x 30) - (input hum) - --> - (remove 2) - (write (crlf) |Hum de dum de dum, hum hum dum dum de dum.|)) - -(p name88 - (x 30) - (input sing) - --> - (remove 2) - (write (crlf) |In-A-Gadda-Da-Vida Baby, don't you know that I love you.|)) - -(p name89 - (x 30) - (input mumble) - --> - (remove 2) - (write (crlf) |mumbmaubmmmsms|)) - -(p name90 - (x 30) - (status) - (input << quit halt stop >>) - --> - (remove 3) - (modify 2 ^quit t) - (write (crlf) |The party's over.|)) - - -(comment ***********************Death*************************************** ) - -(p name1007 - (x 40) - (status ^die t ^died t ^quit nil) - --> - (write (crlf) |Well, you're one more that didn't get the treasure and live.|) - (modify 2 ^quit t)) - -(p name1008 - (x 40) - (status ^die t ^score <Q> ^died nil) - --> - (modify 2 ^score (compute <Q> - 20) ^died t) - (write (crlf) |Hmm... you went and got yourself killed.|) - (write (crlf) |But I'll let you play a bit longer.|)) - -(p name96 - (x 30) --(object ^name bottle ^place held) - (input pour) - --> - (remove 2) - (write (crlf) |You don't have a bottle full of anything.|)) - -(p name97 - (x 30) - (object ^name bottle ^place held) - (object ^name <x> ^inside bottle) - (input drink) ---> - (remove 4) - (remove 3) - (write (crlf) |I love that| <x> |for breakfast every morning.|)) - -(p name98 - (x 30) - (object ^name bottle ^place held) - (location ^name beach) - (input get sand) - --> - (remove 4) - (write (crlf) |The sand clogs in the neck of the bottle.|) - (write (crlf) |For all practical purposes you can't get any sand.|)) - -(p name99 - (x 30) - (object ^name bottle ^place held) - (location ^name beach) - (input fill bottle) - --> - (remove 4) - (make input get sand)) - - -(comment ********Treasure Objects***************************** ) - -(p name100 - (x 20) - (object ^name corkscrew ^place <x>) - (location ^name <x>) - --> - (write (crlf) |There is a diamond studded corkscrew here!|)) - -(p name101 - (x 30) - (object ^name corkscrew ^place held) - (input screw) - --> - (write (crlf)|Cork screwing is a little out of my league.|) - (remove 3)) - -(p name102 - (x 20) - (location ^name <x>) - (object ^name ring ^place <x>) - --> - (write (crlf) |There is a huge diamond ring here.|)) - - -(comment **************************Candy*************************************) - -(p name103 - (x 20) - (location ^name <x>) - (object ^name candy ^place <x>) - --> - (write (crlf) |There is a bowl of candy on the ground.|)) - -(p name104 - (x 30) - (input <x> bowl) - --> - (remove 2) - (make input <x> candy)) - -(p name105 - (x 30) - (object ^name candy ^place <x>) - (location ^name <x>) - (input eat candy) - --> - (write (crlf) |Candy tastes good; uhm!|) - (write (crlf) |Of course the pins in the Snickers take a little chewing.|) - (remove 2) - (remove 4)) - -(p name106 - (x 30) - (object ^name candy ^place held) - (input eat candy) - --> - (write (crlf) |You eat the candy; and get cavities.|) - (remove 2) - (remove 3)) - - -(comment *****************Marijuana************************************) - -(p name107 - (x 30) - (location ^name <x>) - (object ^name marijuana ^place <x>) - --> - (write (crlf) |There is some fine marijuana here! Good stuff.|)) - -(p name108 - (object ^name matches ^place held) - (location ^name lawn) - (input burn <x>) - --> - (remove 3) - (write (crlf) |The matches go out before you can burn| <x>)) - -(p name109 - (x 30) - (object ^name marijuana ^place held) - (object ^name matches ^place held) - (history ^hungry nil) - (location ^name lawn) - (input smoke marijuana) - --> - (remove 2) - (remove 3) - (remove 5) - (modify 4 ^hungry t) - (write (crlf) |You manage to light up,|) - (write (crlf) |the matches haved dried out here, this very expensive stuff.|) - (write (crlf) |Its very smooth, you begin to think you really don't|) - (write (crlf) |need to adventure anymore. You are hungry.|)) - -(p name110 - (x 30) - (object ^name marijuana ^place held) - (input smoke marijuana) - --> - (remove 3) - (write (crlf) |You don't have any matches.|)) - -(p name111 - (x 30) - (input smoke marijuana) - --> - (remove 2) - (write (crlf) |You don't have any.|)) - -(p name112 - (x 30) - (object ^name marijuana ^place held) - (object ^name matches ^place held) - (input smoke marijuana) - --> - (remove 4) - (write (crlf) |The matches are wet.|)) - -(p name113 - (x 30) - (history ^hungry t) - (object ^name <x> ^place held) - --> - (write (crlf) |I'm so hungry, I could eat a | <x> ) - (make input eat <x>)) - -(p name114 - (x 20) - (history ^hungry t) - --> - (modify 1 ^hungry nil)) - -(p name115 - (x 30) - (input <y> << maryjane marihuana dope grass pot >>) - --> - (remove 2) - (make input <y> marijuana)) - -(p name116 - (x 30) - (input << smoke light burn >> marijuana) - --> - (remove 2) - (make input smoke marijuana)) - - -(comment ***********************************CUBE*****************************) -(p name117 - (x 20) - (location ^name <x>) - (object ^name cube ^place <x>) - --> - (write (crlf) |There is a small white cube here.|)) - -(p name118 - (x 30) - (object ^name cube ^place held) - (input lick cube) - --> - (remove 3) - (write (crlf) |UHM! That tasted good!!!|)) - -(p name119 - (x 30) - (object ^name cube ^place held) - (input taste cube) - --> - (remove 3) - (write (crlf) |To taste it you should really eat the cube.|)) - -(p name120 - (x 30) - (object ^name cube ^place held) - (object ^name watch ^place held) - (input eat cube) - --> - (remove 2) - (remove 4) - (write (crlf) |The cube tastes like sugar. You are suddenly surrounded by|) - (write (crlf) |a herd of moose. They start talking to you about a moose-load of things.|) - (write (crlf) |One walks over to you and whispers, 'Fa Lowe, why her?'|) - (write (crlf) |You look at your watch , but the hands suddenly spin!|) - (write (crlf) |You find yourself staring at the|) - (write (crlf) |m|) - (write (crlf) | o|) - (write (crlf) | o|) - (write (crlf) | s|) - (write (crlf) | e|) - (write (crlf) | ?|) - (write (crlf) | for a long time, and enjoying it.|)) - -(p name121 - (x 30) - (object ^name cube ^place held) - (input eat cube) - --> - (remove 2) - (remove 3) - (write (crlf) |The cube tastes like sugar. You are suddenly surrounded by|) - (write (crlf) |a herd of moose. They start talking to you about a moose-load of things.|) - (write (crlf) |One walks over to you and whispers, 'Fa Lowe, why her?'|) - (write (crlf) |You find yourself staring at your toes|) - (write (crlf) | for a long time, and enjoying it.|)) - -(p name122 - (x 30) - (location ^name kitchen) - (object ^name cube ^place held) - (input eat cube) - --> - (remove 3) - (remove 4) - (write (crlf) |That was sweet.|) - (write (crlf) |This kitchen is real deary. A bad place to take acid.|) - (write (crlf) |You have to get out of here!!|) - (write (crlf) |You feel on fire, you need water to cool off.|) - (make input - w then push button then n then push b then exit then push red button)) - -(p name123 - (x 30) - (input <x> white cube) - --> - (remove 2) - (make input <x> cube)) - -(p name124 - (x 30) - (input <x> << sugar acid >>) - --> - (remove 2) - (make input <x> cube)) - -(comment *************************CANCER*************************************) - -(p name125 - (x 60) - (location) - (status ^likes <B>) - (time ^cancer <TIME> ^realtime <TIME>) - --> - (write (crlf) |Your wicked and lusty life has finally caught up with you.|) - (write (crlf) |That cigarette you had with the| <B> |has caused cancer to|) - (write (crlf) |spread throughout your lungs. COUGH!! COUGH!! You are|) - (write (crlf) |weakening. Hack! You're down on your knees. COUGH COUGH!!|) - (write (crlf) |You keel over and die....|) - (modify 3 ^quit t)) - - -(comment **********************Going Crazy******************************** ) - -(p name126 - (x 60) - (time ^orc_status sweat ^orc_time <x> ^realtime <x>) - --> - (modify 2 ^orc_status dizzy ^orc_time (compute <x> + 120)) - (write (crlf) | |) - (write (crlf) |You are starting to sweat. I think this place is getting to you.|)) - -(p name127 - (x 60) - (time ^orc_status dizzy ^orc_time <x> ^realtime <x>) - --> - (modify 2 ^orc_status mad ^orc_time (compute <x> + 60)) - (write (crlf) | |) - (write (crlf) |Your getting a little dizzy.|) - (write (crlf) |The area around seems to swim a little when you move.|)) - -(p name128 - (x 60) - (time ^orc_status mad ^orc_time <x> ^realtime <x>) - --> - (modify 2 ^orc_status suicide ^orc_time (compute <x> + 30)) - (write (crlf) | |) - (write (crlf) |I think you are definitely going insane. The sweaty palms and dizziness were|) - (write (crlf) |the first signs. If you don't do something quick, you'll commit suicide!|)) - -(p name129 - (x 60) - (time ^orc_status suicide ^orc_time <x> ^realtime <x>) - (status) - --> - (modify 2 ^orc_status nil ^orc_time nil) - (modify 3 ^die t) - (write (crlf) | |) - (write (crlf) |~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|) - (write (crlf) |You can't stand it anymore, you are now totally crazy!|) - (write (crlf) |You start laughing uncontrollably, but choke on your tongue.|) - (write (crlf) |Ugh! Well at least you died happy!|)) - -(p name130 - (x 30) - (time ^orc_status <> nil) - (command ^string eat_it) - --> - (modify 2 ^orc_status nil) - (remove 3) - (write (crlf) |You feel much saner.|) - (write (crlf) |You've managed to avoid the St. John curse!|)) - -(p name131 - (x 30) - (time ^orc_status suicide) - (command ^string eat_it) - --> - (modify 2 ^orc_status nil) - (remove 3) - (write (crlf) |You've done it! The orchid returns you to sanity.|)) - - -(comment **********************More Random********************************* ) - -(p name132 - (x 30) - (input << examine describe >> <x>) - --> - (remove 2) - (make input look <x>)) - -(p name133 - (x 30) - (place ^name <y> ^visited t) - (location ^name <y>) - (input look) - --> - (remove 4) - (modify 2 ^visited nil)) - -(p name134 - (x 30) - (input kill) - --> - (remove 2) - (write (crlf) |With what? Your bare hands?|)) - -(p name135 - (x 30) - (object ^name <x> ^place <z>) - (location ^name <z>) - (input kill <x> with <y>) - --> - (remove 4) - (write (crlf) |Even with that you can't kill it.|)) - -(p name136 - (x 30) - (object ^name football ^holds nil) - (input throw football) - --> - (remove 3) - (write (crlf) |You don't have a football Dummy!|)) - -(p name137 - (x 30) - (input throw) - --> - (remove 2) - (write (crlf) |I don't throw anything but a regulation NFL football.|)) - -(p name138 - (x 30) - (input throw up) - --> - (remove 2) - (write (crlf) |I don't have the stomach for that.|)) - -(p name139 - (x 30) - (input cut) - --> - (remove 2) - (write (crlf) |There is nothing to cut with.|)) - -(p name140 - (x 30) - (input cut <x> with <y>) - --> - (remove 2) - (write (crlf) |The| <y> |won't cut the| <x> |.|)) - -(p name141 - (x 30) - (input cut cheese) - --> - (remove 2) - (write (crlf) |Look, this room is smelly enough already without that.|)) - -(p name142 - (x 30) - (input break <x>) - --> - (remove 2) - (write (crlf) |You hurt your hand.|)) - -(p name143 - (x 30) - (input bust bust) - --> - (remove 2) - (write (crlf) |Homer looks hurt.|)) - -(p name144 - (x 30) - (input kick <x>) - --> - (remove 2) - (write (crlf) |Ouch! The| <x> |kicks back.|)) - -(p name145 - (x 30) - (object ^name <x> ^place held) - (location ^name <y> ^side <s> ^north <n> ^east <e>) - (input kick <x>) - --> - (modify 2 ^place <y> ^side <s> ^north <n> ^east <e>) - (remove 4) - (write (crlf) |Thud! Not much of a kicker I see.|)) - -(p name146 - (x 30) - (input kick football) - --> - (remove 2) - (write (crlf) |I see no football here.|)) - -(p name147 - (x 30) - (input punt <x>) - --> - (remove 2) - (make input kick <x>)) - -(p name148 - (x 20) - (input jump) - --> - (remove 2) - (write (crlf) |Up you go, down you come.|)) - -(p name149 - (x 20) - (input burn <x>) - --> - (remove 2) - (write (crlf) |You can't burn| <x> |without matches.|)) - -(p name150 - (x 30) - (object ^name matches ^place held) - (input burn) - --> - (remove 3) - (write (crlf) |You may have matches, but you didn't light one.|)) - -(p name151 - (x 30) - (input open) - --> - (remove 2) - (write (crlf) |I don't see anything that is closed.|)) - -(p name152 - (x 30) - (input open chest) - --> - (remove 2) - (write (crlf) |The chest can't be opened, but it is worth mucho closed.|)) - -(p name153 - (x 30) - (input help) - --> - (remove 2) - (write (crlf) |Help yourself|)) - -(p name154 - (x 20) - (current ^type operator ^name process) - (input yes) - --> - (remove 3) - (write (crlf) |Cute, but lets get on with the show.|)) - -(p name155 - (x 30) - (current ^type operator ^name process) - (input no) - --> - (remove 3) - (write (crlf) |That was rhetorical you fool.|)) - -(p name156 - (x 30) - (input spit <x>) - --> - (remove 2) - (write (crlf) |Your throat is too dry.|)) - -(p name157 - (x 30) - (input where <x>) - --> - (remove 2) - (write (crlf) |I don't know where| <x> |. I hope we aren't lost!!|)) - -(p name158 - (x 30) - (input find <x>) - --> - (remove 2) - (write (crlf) |That would be cheating if I did it.|)) - -(p name159 - (x 20) - (input drink <a>) - --> - (remove 2) - (write (crlf) |The| <a> |is not drinkable.|)) - -(p name160 - (x 20) - (input drink nil) - --> - (remove 2) - (write (crlf) |I don't know what to drink.|)) - -(p name161 - (x 30) - (input screw) - --> - (remove 2) - (write (crlf) |Sorry, but i don't have a screw driver.|)) - -(p name162 - (x 30) - (input fuck) - --> - (remove 2) - (write (crlf) |That would be pretty kinky.|)) - -(p name163 - (x 30) - (input fuck bust) - --> - (remove 2) - (write (crlf) |Homer is harder than you are.|)) - -(p name164 - (x 30) - (status ^wears wetsuit) - (input fuck <x>) - --> - (remove 3) - (write (crlf) |You can't do that with a wetsuit on!|)) - -(p name165 - (x 30) - (input up yours) - --> - (remove 2) - (write (crlf) |Up your own.|)) - -(p name166 - (x 30) - (input oh shit) - --> - (remove 2) - (write (crlf) |Isn't life a pisser?|)) - -(p name167 - (x 30) - (input oh no) - --> - (remove 2) - (write (crlf) |Mais oui.|)) - -(p name168 - (x 30) - (input shit) - --> - (remove 2) - (write (crlf) |Hey, let's not mess up the place!|)) - -(p name169 - (x 30) - (input rape <x>) - --> - (remove 2) - (make input torture <x>)) - -(p name170 - (x 30) - (input kiss) - --> - (remove 2) - (write (crlf) |SMACK!|)) - -(p name171 - (x 30) - (input << ball copulate hump >> <x>) - --> - (remove 2) - (make input fuck <x>)) - -(p name172 - (x 30) - (input make love) - (status ^likes <x>) - --> - (remove 2) - (make input fuck <x>)) - -(p name173 - (x 30) - (input masturbate) - --> - (remove 2) - (write (crlf) |You're too scared to get aroused at all.|)) - -(p name174 - (x 30) - (input god damn) - --> - (remove 2) - (make input pray)) - -(p name175 - (x 30) - (input tingle) - --> - (remove 2) - (write (crlf) |Nothing happens.|)) - -(p name176 - (x 30) - (input blow) - --> - (remove 2) - (write (crlf) |Whoooooosh!|)) - -(p name177 - (x 20) - (input knock) - --> - (remove 2) - (write (crlf) |Thud, thud.|)) - -(p name178 - (x 30) - (input eat <> orchid) - --> - (remove 2) - (write (crlf) |That is not part of a balanced diet.|)) - -(p name179 - (x 30) - (object ^name <x> ^holds nil) - (input eat <x>) - --> - (remove 3) - (write (crlf) |You don't have| <x> |on you.|)) - -(p name180 - (x 30) - (input eat shit) - --> - (remove 2) - (write (crlf) |YEACH! Fuck off!|)) - -(p name181 - (x 30) - (status) - (input go to hell) - --> - (remove 3) - (write (crlf) |Oh yeah! I'm fed up with you!!|) - (modify 2 ^quit t)) - -(p name182 - (x 30) - (input <x> moose) - --> - (remove 2) - (write (crlf) |I see no moose.|)) - -(p name183 - (x 30) - (input go blue) - --> - (remove 2) - (write (crlf) |Beat State.|)) - -(p name184 - (x 30) - (input pray) - --> - (remove 2) - (write (crlf) |GOD responds:|) - (make input help)) - -(p name185 - (x 30) - (input damn <x>) - --> - (remove 2) - (write (crlf) |Clean up your act.|)) - - -(p name186 - (x 30) - (input open sesame) - --> - (remove 2) - (write (crlf) |No says me!|)) - -(p name187 - (x 30) - (input I <x>) - --> - (remove 2) - (write (crlf) |Quit talking about yourself and give me a command.|)) - -(p name188 - (x 20) - (input give <x> to <y>) - --> - (remove 2) - (write (crlf) |The| <y> |doesn't take| <x> )) - -(p name189 - (x 20) - (input give <x> <y>) - --> - (remove 2) - (write (crlf) |The| <x> |doesn't want| <y> )) - -(p name190 - (x 30) - (object ^name <x> ^place held) - (input give <x>) - --> - (remove 3) - (write (crlf) |Hey, after we went through all the trouble to get | - (crlf) <x> |I ain't gonna let you give it away.|)) - -(p name191 - (x 20) - (input give <x>) - --> - (remove 2) - (write (crlf) |First we should get it.|)) - -(p name192 - (x 30) - (time ^realtime 0002) - (input follow moose) - --> - (remove 3) - (write (crlf) |Crash!! Into the wall you go.|)) - -(p name193 - (x 30) - (location ^name bus_stop) - (time ^realtime 0002) - (input follow moose) - --> - (remove 4) - (write (crlf) |Last I saw he went west, so away we go.|) - (make input west)) - -(p name194 - (x 30) - (input follow moose) - --> - (remove 2) - (write (crlf) |I see no moose here.|)) - -(p name195 - (x 30) - (input swim) - --> - (remove 2) - (write (crlf) |Why don't you wait until we are in the water.|)) - - -(comment **************Get on and off objects ****************************** ) - -(p name196 - (x 30) - (status) - (input mount) - --> - (remove 3) - (modify 2 ^going u ^went u)) - -(p name197 - (x 30) - (input stand on) - --> - (remove 2) - (make input mount)) - -(p name198 - (x 20) - (input get on) - --> - (remove 2) - (make input mount)) - -(p name199 - (x 30) - (input climb on) - --> - (remove 2) - (make input mount)) - -(p name200 - (x 30) - (status) - (input climb) - --> - (remove 3) - (modify 2 ^going u ^went u)) - -(p name201 - (x 30) - (location ^name <> bus) - (status) - (input get off) - --> - (remove 4) - (modify 3 ^going d ^went d)) - -(p name202 - (x 30) - (status) - (input get down) - --> - (remove 3) - (modify 2 ^going d ^went d)) - -(p name203 - (x 30) - (status) - (input dismount) - --> - (remove 3) - (modify 2 ^going d ^went d)) - -(p name204 - (x 30) - (input sit in) - --> - (remove 2) - (make input sit on)) - -(p name205 - (x 30) - (input sit) - --> - (remove 2) - (write (crlf) |I don't know how to sit on it.|)) - -(p name206 - (x 50) - (location ^ontop <> nil ^going d) - --> - (modify 2 ^ontop nil ^going nil) - (write (crlf) |You are back on Terra Firma.|)) - -(p name207 - (x 40) - (location ^ontop <> nil ^going <> nil) - --> - (modify 2 ^ontop nil ^going nil) - (write (crlf) |You just fell to the ground.|) - (make input look)) - -(p name208 - (x 40) - (location ^siton <> nil ^going <> nil) - --> - (modify 2 ^siton nil)) - -(p name209 - (x 30) - (location ^siton <> nil) - (input get up) - --> - (modify 2 ^siton nil) - (remove 3) - (write (crlf) |You are now standing.|)) - -(p name210 - (x 30) - (location siton <> nil) - (input stand <x>) - --> - (modify 2 ^siton nil) - (remove 3) - (write (crlf) |You are no longer sitting.|)) - -(p name211 - (x 30) - (location ^siton <Q>) - (input get <Q>) - --> - (remove 3) - (write (crlf) |You'll have to stand up first.|)) - -(p name212 - (x 30) - (location ^ontop <Q>) - (input get <Q>) - --> - (remove 3) - (write (crlf) |Cute, why don't you get off it first.|)) - -(p name213 - (x 30) - (object ^name <x> ^place held) - (input mount <x>) - --> - (remove 3) - (write (crlf) |Why don't you drop it first.|)) - - -(comment *****Touchy Feelie*************************************************) - -(p name214 - (x 30) - (input << fondle cuddle hug rub tap feel >>) - --> - (remove 2) - (make input touch)) - -(p name215 - (x 30) - (object ^name <x> ^place held) - (input touch <x>) - --> - (remove 3) - (write (crlf) |It is in your hands, and it feels like a| <x> |.|)) - -(p name216 - (x 30) - (input touch wall) - --> - (remove 2) - (write (crlf) |Surprize! The wall is flat and cold.|)) - -(p name217 - (x 30) - (object ^name painting ^place held) - (input touch painting) - --> - (remove 3) - (write (crlf) |The painting is still wet!!|)) - -(p name218 - (x 30) - (input touch) - --> - (remove 2) - (write (crlf) |You should get it first.|)) - - -(comment ********************Bottle*********************************** ) -(p name219 - (x 30) - (object ^name bottle ^place held) - (history ^grave_status2 oil) - (location ^name lawn ^side in ^east 8 ^north 8) - (input fill bottle) - --> - (remove 5) - (write (crlf) |The oil won't go into the bottle, sorry.|)) - -(p name220 - (x 30) - (history ^grave_status2 oil) - (object ^name bottle ^place held) - (location ^name lawn ^side in ^east 8 ^north 8) - (input get oil) - --> - (remove 5) - (write (crlf) |The oil is too thick to go into the bottle.|)) - -(p name221 - (x 20) - (location ^name <x>) - (object ^name bottle ^place <x>) --(object ^inside bottle) ---> - (write (crlf) |There is an empty bottle here.|)) - -(p name222 - (x 20) - (location ^name <x>) - (object ^name bottle ^place <x>) - (object ^name <q> ^inside bottle) ---> - (write (crlf) |There is a bottle of| <q> |here.|)) - -(p name223 - (x 30) - (object ^name <q> ^inside bottle) - (object ^name bottle ^place <x>) - (location ^name <x>) - (input get <q>) - --> - (modify 2 ^place held) - (remove 5) - (write (crlf) |You are now holding the bottle.|)) - -(p name224 - (x 30) - (object ^name bottle ^place held) - (location ^name bathroom) - (input fill bottle <g>) --(object ^inside bottle) - --> - (remove 4) - (make object ^name bathwater ^inside bottle) - (write (crlf) |The bottle is full of bathwater.|)) - -(p name225 - (x 30) - (object ^name bottle ^place held) - (location ^name beach ^east 3) - (input fill bottle <g>) --(object ^inside bottle) - --> - (remove 4) - (make object ^name water ^inside bottle) - (write (crlf) |The bottle is full of sparkling water.|)) - -(p name226 - (x 30) - (object ^name bottle ^place held) - (object ^inside bottle) - (location ^name beach ^east 3) - (input pour) - --> - (remove 3) - (remove 5) - (write (crlf) |The bottle is empty. The liquid disappears in the sand.|)) - -(p name227 - (x 30) - (object ^name bottle ^place held) - (object ^inside bottle) - (location ^name bathroom) - (input pour) - --> - (remove 3) - (remove 5) - (write (crlf) |The bottle is now empty.|)) -(comment ++++++++++++++++) -(p name228 - (location ^underwater t) - (object ^name bottle ^place held) - (input fill bottle) --(object ^name <> nil ^inside bottle) - --> - (remove 3) - (make object ^name seawater ^inside bottle) - (write (crlf) |The bottle is full of seawater.|)) - -(p name229 - (input get << seawater bathwater water >>) - --> - (remove 1) - (make input fill bottle)) - -(p name230 - (input fill up) - --> - (remove 1) - (make input fill bottle)) - -(p name231 - (object ^name bottle ^place held) - (input fill bottle <g>) --(object ^name <q> ^inside bottle) - --> - (remove 2) - (write (crlf) |There is nothing to fill the bottle with.|)) - -(p name232 - (object ^name bottle ^place held) - (object ^inside bottle) - (input fill bottle) - --> - (remove 3) - (write (crlf) |The bottle is already full.|)) - -(p name233 - (input fill bottle) - --> - (remove 1) - (write (crlf) |You don't have a bottle to fill.|)) - -(p name234 - (input pour) - (location ^underwater t) - --> - (remove 1) - (write (crlf) |Hmm, you want me to empty a bottle underwater.|) - (write (crlf) |I'm afraid that is out of my league.|)) - -(p name235 - (object ^name water ^place <x>) - (location ^name <x>) - --> - (write (crlf) |There is a wet spot here.|)) - -(p name236 - (object ^name seawater ^place <x>) - (location ^name <x>) - --> - (write (crlf) |There is a salty wet spot here.|)) - -(p name237 - (location ^name <x>) - (object ^name bathwater ^place <x>) - --> - (write (crlf) |There is a bit of a wet spot here.|)) - -(p name238 - (location ^name <x>) - (object ^name turpentine ^place <x>) - --> - (remove 2) - (write (crlf) |The turpentine evaporates as it leaves the bottle.|)) - -(p name239 - (location ^name <y>) - (object ^name bottle ^place held) - (object ^name <q> ^inside bottle) - (input drop <q>) - --> - (modify 2 ^place <y>) - (remove 4)) - -(p name240 - (location ^name <y>) - (object ^name bottle ^place held) - (object ^name <q> ^inside bottle) - (input pour) - --> - (remove 4) - (modify 3 ^inside nil ^place <y>)) - -(p name241 - (location ^name <x>) - (object ^name << water seawater bathwater >> ^place <x>) - (input fill bottle) - --> - (remove 3) - (write (crlf) |Sorry, I don't have a mop!|)) - -(p name242 - (location ^name <x>) - (object ^name water ^inside bottle) - (object ^name bottle ^place held) - (input drink water) - (status) - --> - (remove 1) - (remove 2) - (remove 4) - (write (crlf) |You have changed into a baby, the adventure must end.|) - (modify 5 ^quit t)) - -(p name243 - (object ^name bottle ^place held) - (object ^name seawater ^inside bottle) - (input drink) - --> - (remove 2) - (remove 3) - (write (crlf) |Yech! It tastes salty!!|)) - -(p name244 - (input << water empty >>) - --> - (remove 1) - (make input pour)) - - -(comment ********************MATCHES************************************* ) - -(p name245 - (location ^name <x>) - (object ^name matches ^place <x>) - --> - (write (crlf) |There are matches here.|)) - -(p name246 - (object ^name matches ^place held) - (input <x> match) - --> - (remove 2) - (make input <x> matches)) - -(p name247 - (object ^name matches ^place held) - (input << light strike dry >> matches) - --> - (remove 2) - (write (crlf) |This house is to damp to light the matches in.|)) - -(p name248 - (location ^name lawn) - (object ^name matches ^place held) - (input dry matches) - --> - (remove 3) - (write (crlf) |The matches dry out.|)) - -(p name249 - (location ^name lawn) - (object ^name matches ^place held) - (input << light strike >> matches) - --> - (remove 3) - (write (crlf) |The match lights but goes out quickly.|)) - -(p name250 - (input smoke <x>) - (object ^name <x> ^place <> holds) - --> - (remove 1) - (write (crlf) |You're not holding it.|)) - -(p name251 - (input light marijuana <x>) - --> - (remove 1) - (make input smoke marijuana)) - - -(comment *******************FOOTBALL****************************************) - -(p name252 - (location ^name <x>) - (object ^name football ^place <x>) - --> - (write (crlf) |There is an official NFL football here!|)) - -(p name253 - (location ^name <x>) - (object ^name football ^place held) - (input kick football) - --> - (remove 3) - (write (crlf) |Oh wow! You kick it around,|) - (write (crlf) |luckily nothing breaks.|) - (modify 2 ^place <x>)) - -(p name254 - (location ^name <x>) - (object ^name football ^place held) - (input throw football) - --> - (remove 3) - (write (crlf) |Throw is short. Incomplete pass. Fourth down, 10 to go.|) - (modify 2 ^place <x>)) - -(p name255 - (input <x> ball) - --> - (remove 1) - (make input <x> football)) - - -(comment ***************************TIME************************************ ) -(p name256 - (input what time) - (object ^name watch ^place held) - (time ^realtime <x>) - --> - (remove 1) - (write (crlf) |The time is| <x>)) - -(p name257 - (location ^name <x>) - (object ^name watch ^place <x>) - --> - (write (crlf) |There's a watch here, it even has a luminous dial.|)) - -(p name258 - (input time) - --> - (remove 1) - (make input what time)) - -(p name259 - (input read watch) - --> - (remove 1) - (make input what time)) - -(p name260 - (input tell time) - --> - (remove 1) - (make input what time)) - -(p name261 - (x 10) - (input what time) - --> - (remove 2) - (write (crlf) |I have no watch.|)) - -(p name262 - (input look at watch) - --> - (remove 1) - (make input what time)) - -(p name263 - (input put on watch) - --> - (remove 1) - (make input get watch)) - -(p name264 - (input wind watch) - --> - (remove 1) - (write (crlf) |The watch is electric.|)) - -(p name265 - (input open watch) - --> - (remove 1) - (write (crlf) |The watch is sealed shut.|)) - -(p name266 - (input break watch) - --> - (remove 1) - (write (crlf) |The watch is shock resistent too. It still works.|)) - -(p name267 - (time ^realtime 0600 ^morning nil) - --> - (modify 1 ^morning t) - (write (crlf) |'Cock-a-doodle-do'. You hear a rooster crow.|)) - -(p name268 - (time ^realtime 2000 ^morning t) - --> - (modify 1 ^morning nil) - (write (crlf) |'Clunk!' I think night just fell.|)) - -(p name269 - (time ^realtime 0000 ^midnight nil) - --> - (modify 1 ^midnight t)) - -(p name270 - (time ^midnight t) - --> - (modify 1 ^midnight nil) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |A moose comes running out of a wall at full speed straight at you!!!|) - (write (crlf) |He is right on top of you!!! He runs right through you and disappears.|)) - -(p name271 - (time ^midnight t) - (location ^name lawn) - --> - (modify 1 ^midnight nil) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |A moose comes running across the lawn at full speed straight at you!!!|) - (write (crlf) |He is right on top of you. He runs right through you and disappears.|)) - - -(p name272 - (time ^midnight t) - (location ^underwater t) - --> - (remove 1) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |BonG!|) - (write (crlf) |A moose comes swimming out of the darkness, at full speed straight at you.|) - (write (crlf) |He has on full scuba gear, and is really moving.|) - (write (crlf) |He is right on top of you. He runs right through you and disappears.|)) - - -(comment **************************PAINTING***************************) - -(p name273 - (input <x> art <y>) - --> - (remove 1) - (make input <x> painting <y>)) - -(p name274 - (location ^name <x>) - (object ^name painting ^place <x> ^covered t) - --> - (write (crlf) |There is a work of ugly modern art on the ground.|)) - -(p name275 - (location ^name <x>) - (object ^name painting ^place <x> ^covered nil) - --> - (write (crlf) |There is a valuable Rembrandt here.|)) - -(p name276 - (object ^name painting ^place held ^covered t) - (object ^name bottle ^place held) - (object ^name turpentine ^inside bottle) - (input << clean pour >>) - --> - (modify 1 ^covered nil ^treasure t) - (remove 3) - (remove 4) - (write (crlf) |The ugly paint comes off! Underneath is a Rembrandt|) - (write (crlf) |This will be very valuable.|) - (write (crlf) |It is a person and a bust in the painting.|)) - -(p name277 - (location ^name <x>) - (object ^name painting ^place <x> ^covered t) - (object ^name bottle ^place held) - (object ^name turpentine ^inside bottle) - (input << clean pour >>) - --> - (modify 2 ^covered nil ^treasure t) - (remove 4) - (remove 5) - (write (crlf) |The turpentine hits the painting and causes the paint to come off.|) - (write (crlf) |The painting has a person contemplating a bust.|)) - -(p name278 - (input remove paint) - --> - (remove 1) - (make input clean)) - -(p name279 - (object ^name painting ^place held ^covered t) - --> - (write (crlf) |Upon closer look, this is worthless!|)) - - -(comment *******************Money************************************* ) - -(p name280 - (location ^name <x>) - (object ^name money ^place <x>) - --> - (write (crlf) |The money is here!|)) - -(comment *******************Stereo************************************* ) - -(p name281 - (location ^name smelly_room) - (object ^name stereo ^place held) - (status ^sound on) - --> - (modify 3 ^sound off)) - -(p name282 - (object ^name stereo ^place smelly_room) - (location ^name smelly_room) - (status ^sound on) - (input turn off) - --> - (modify 3 ^sound off) - (remove 4) - (write (crlf) |The stereo is off. But you broke it, so it won't turn on.|)) - -(p name283 - (location ^name <x>) - (object ^name stereo ^place <x>) - --> - (write (crlf) |There is an expensive stereo here, worth many megabucks!!|)) - - -(comment *******************Book****************************** ) - -(p name284 - (location ^name <x>) - (object ^name book ^place <x>) - --> - (write (crlf) |There is a book on the ground.|)) - -(p name285 - (object ^name book ^place held) - (input read book) - --> - (remove 2) - (write (crlf) |Vampires can only be destroyed by a stake through the heart,|) - (write (crlf) |or by the light of day. They are invunerable to all other|) - (write (crlf) |attacks. They dislike garlic and fear crosses. They are known|) - (write (crlf) | to frequent dark rooms.|)) - -(comment ************************GOLD************************) - -(p name286 - (location ^name <x>) - (object ^name gold ^place <x>) - --> - (write (crlf) |There is gold here.|)) - - -(comment ************************HORN************************) - -(p name287 - (location ^name <x>) - (object ^name horn ^place <x>) - --> - (write (crlf) |There is a magic unicorn horn here.|)) - -(p name288 - (location ^name <x>) - (object ^name horn ^place <x>) - (object ^name horn ^place held) - (input drop horn) - --> - (remove 3) - (remove 4) - (write (crlf) |When you drop the horn, it and the one on the ground merge together.|)) - -(p name289 - (location ^name dining_room ^ontop stool) - (object ^name horn ^place held) - (input get horn) - --> - (remove 3) - (write (crlf) |The horn won't come off.|)) - -(p name290 - (object ^name horn ^place held) - (input blow horn) - (history ^clue nil) - --> - (remove 1) - (remove 2) - (write (crlf) |A terrific noise comes from the horn. BLAT!!!|) - (write (crlf) |The horn disappears from your hands.|) - (write (crlf) |Your body shakes and you black out ......|) - (modify 3 ^clue t)) - -(p name291 - (history ^clue t ^grave_status undug) - --> - (write (crlf) |A spirit appears to you in your sleep.|) - (write (crlf) |Your mind is filled with the following phrase:|) - (write (crlf) |'As your family is sheep, the gold that is YOUR color must be found|) - (write (crlf) |before you can escape this estate.' |) - (modify 1 ^clue nil)) - -(p name292 - (history ^clue t) - --> - (modify 1 ^clue nil) - (write (crlf) |When you wake you see smoke form the words:|) - (write (crlf) |EVERY OPTIon on A MACHINE HAS A PURPOSE. The smoke then dissapates.|)) - -(p name293 - (history ^clue t) - (object ^name orchid ^place lawn) - --> - (write (crlf) |You dream of a garden of flowers.|) - (modify 1 ^clue nil)) - -(comment ************************Candlesticks************************) - -(p name294 - (input <x> them) - --> - (remove 1) - (make input <x> candlesticks)) - -(p name295 - (location ^name <x>) - (object ^name candlesticks ^place <x>) - --> - (write (crlf) |There is a pair of silver candlesticks here!! No candles though.|)) - -(p name296 - (object ^name candlesticks ^place held) - (input form cross) - --> - (modify 1 ^state crossed) - (remove 2) - (write (crlf) |The candlesticks are in a cross.|)) - -(p name297 - (object ^name candlesticks ^place held) - (input make cross) - --> - (modify 1 ^state crossed) - (remove 2) - (write (crlf) |The candlesticks are in a cross.|)) - -(p name298 - (location ^name <x>) - (object ^name candlesticks ^place held ^state crossed) - (input drop candlesticks) - --> - (modify 2 ^place <x> ^state nil) - (remove 3)) - -(p name299 - (input << make form >> cross) - --> - (remove 1) - (write (crlf) |You have nothing to form a cross with, arms don't work.|)) - -(p name300 - (input cross candlesticks) - --> - (remove 1) - (make input make cross)) - -(comment *********************CHAIR*************************************) -(p name301 - (location ^name <x>) - (object ^name chair ^place <x>) - --> - (write (crlf) |There is an old style chair on the ground.|)) - -(p name302 - (object ^name chair ^place held) - --> - (write (crlf) |The plate of the back of the chair says 'MADE BY LOUIS XIV'|)) - -(p name303 - (location ^name <x>) - (object ^name chair ^place <x>) - (input mount chair) - --> - (remove 2) - (remove 3) - (write (crlf) |The priceless chair breaks under your weight.|) - (write (crlf) |It then disappears.|)) - -(p name304 - (location ^name <x>) - (object ^name chair ^place <x>) - (input sit on chair) - --> - (remove 2) - (remove 3) - (write (crlf) |You sat on the chair and it broke!|) - (write (crlf) |It disappears.|)) - - -(comment **********************STOOL*************************************) - -(p name305 - (location ^name <x>) - (object ^name stool ^place <x>) - --> - (write (crlf) |There is a sturdy stool here.|)) - -(p name306 - (location ^name <x>) - (object ^name stool ^place <x>) - (input sit) - --> - (remove 3) - (modify 1 ^siton stool) - (write (crlf) |You're sitting on the stool.|)) - -(p name307 - (object ^name stool ^place held) - (input sit) - --> - (remove 2) - (write (crlf) |I suggest you drop the stool first.|)) - -(p name308 - (location ^name <x>) - (object ^name stool ^place <x>) - (input mount stool) - --> - (modify 1 ^siton stool) - (remove 3) - (write (crlf) |You are on the stool.|)) - -(p name309 - (input climb stool) - --> - (remove 1) - (make input mount stool)) - -(comment ****************Additional objects********************) - -(comment ****Chest**** ) - -(p name310 - (location ^name <x>) - (object ^name chest ^place <x>) - --> - (write (crlf) |There is a chest of treasure!!!|)) - -(p name311 - (object ^name chest ^place held) - (input open chest) - --> - (remove 2) - (write (crlf) |Give up, the chest doesn't open, but is worth gigabucks the way it is.|)) - -(comment ****Conch**** ) - -(p name312 - (object ^name conch ^place held) - (input blow conch) - --> - (remove 2) - (write (crlf) |'Hoooonk!'|)) - -(p name313 - (object ^name conch ^place <x>) - (location ^name <x>) - --> - (write (crlf) |There is a large conch shell here.|)) - -(p name314 - (input <x> shell) - --> - (remove 1) - (make input <x> conch)) - -(p name315 - (object ^name conch ^place held) - (input listen conch) - --> - (remove 1) - (write (crlf) |You hear the ocean 'rumble'.|)) - -(p name316 - (location ^name <x>) - (object ^name token ^place <x>) - --> - (write (crlf) |There is a token here.|)) - -(p name317 - (location ^name <x>) - (object ^name tokens ^place <x>) - --> - (write (crlf) |There are tokens here.|)) - -(p name318 - (input bite <x>) - (object ^name <x> ^place held) - --> - (remove 1) - (write (crlf) |The| <x> |bites back, Chomp!!|)) - -(p name319 - (x 10) - (input bite) - --> - (remove 2) - (write (crlf) |You must be holding what you are trying to bite.|)) - -(p name0320 - (object ^name <x> ^treasure t ^place held ^scored nil) - (status ^score <y>) - --> - (modify 2 ^score (compute <y> + 15)) - (modify 1 ^scored t)) - -(p name0321 - (object ^name bottle ^place lawn) - (object ^name water ^inside bottle ^xscore nil) - (status ^score <y>) - --> - (modify 3 ^score (compute 5 + <y>)) - (modify 2 ^xscore t)) - -(p name0322 - (input pour) - (object ^name bottle ^place held) - (object ^name water ^xscore t) - (status ^score <z>) - --> - (remove 1) - (modify 4 ^score (compute <z> - 5))) - -(p name0323 - (object ^name <x> ^place lawn ^treasure t ^xscore nil) - (status ^score <y>) - --> - (modify 2 ^score (compute 5 + <y>)) - (modify 1 ^name <x> ^xscore t)) - -(p name0324 - (object ^name <x> ^xscore t ^place held) - (status ^score <y>) - --> - (modify 1 ^xscore nil) - (modify 2 ^score (compute <y> - 5))) - -(p name321 - (input score) - (status ^score <x>) - --> - (write (crlf) |Score =| <x>) - (remove 1)) - -(p name322 - (status ^quit t ^score <x>) - --> - (write (crlf) |Your final score is| <x>) - (write (crlf) |The total possible is 440|) - (make turnoff)) - -(p name323 - (turnoff) - (status ^score < 20) - --> - (write (crlf) |Hmm... I don't think you tried very hard.|)) - -(p name324 - (turnoff) - --> - (halt)) - -(p name325 - (turnoff) - (status ^score {< 50 > 21}) - --> - (write (crlf) |Rank Novice! Are you scared of your own shadow?|)) - -(p name326 - (turnoff) - (status ^score {> 51 < 80}) - --> - (write (crlf) |Beginning Ghost Hunter|)) - -(p name327 - (turnoff) - (status ^score {> 81 < 140}) - --> - (write (crlf) |Reasonable Spirit Fighter|)) - -(p name328 - (turnoff) - (status ^score {> 141 < 220}) - --> - (write (crlf) |Intermediate Haunt Hacker|)) - -(p name329 - (turnoff) - (status ^score {> 221 < 290}) - --> - (write (crlf) |Advanced Monster Killer|)) - -(p name330 - (turnoff) - (status ^score {> 291 < 360}) - --> - (write (crlf) |Master Haunter!!|)) - -(p name331 - (turnoff) - (status ^score > 361) - --> - (write (crlf) |Fearless Vampire Killer|)) - -(p name332 - (status ^likes <x>) - (turnoff) - (status ^score > 435) - --> - (write (crlf) |and waster of many cycles.|)) - -(p name333 - (location ^name <x>) - (object ^name pearls ^place <x>) - --> - (write (crlf) |There are huge pearls here!!|)) - -(p name334 - (location ^name <x>) - (object ^name diamonds ^place <x>) - --> - (write (crlf) |There are diamonds here!|)) - -(p name335 - (location ^name <x>) - (object ^name orchid ^place <x> ^state plant) - --> - (write (crlf) |There is a beautiful black orchid here.|)) - -(p name336 - (location ^name <x>) - (object ^name orchid ^place <x> ^state plant) - (input smell <y>) - --> - (remove 3) - (write (crlf) |Yum! The orchid smells delicious!|)) - -(p name337 - (object ^name orchid ^place held) - (input smell orchid) - --> - (remove 2) - (write (crlf) |I like the odor! Sniff. Sniff.|)) - -(p name338 - (input pick orchid) - --> - (remove 1) - (make input get orchid)) - -(p name339 - (input smell <x>) - --> - (remove 1) - (write (crlf) |Ah CHOOOO! There is alot of dust around here.|)) - -(p name340 - (input sniff <x>) - --> - (remove 1) - (make input smell <x>)) - -(p name341 - (location ^name <x>) - (object ^name rope ^place <x> ^tied noose) - --> - (write (crlf) |There is rope in a noose here.|)) - -(p name342 - (location ^name <x>) - (object ^name rope ^place <x> ^tied untied) - --> - (write (crlf) |There is some loose rope here.|)) - -(p name343 - (location ^name <x>) - (object ^name <y> ^place <x>) - (object ^name rope ^place <> <x> ^tied <y>) - --> - (write (crlf) |A rope is tied to the| <y> )) - -(p name344 - (location ^name <x>) - (object ^name <y> ^place <> <x>) - (object ^name rope ^place <x> ^tied <y>) - --> - (write (crlf) |An end of a rope is here.|)) - -(p name345 - (location ^name <x>) - (object ^name rope ^place <x> ^tied <y>) - (object ^name <y> ^place <x>) ---> - (write (crlf) |An end of the rope is here, tied to the | <y> )) - -(p name346 - (location ^name <x>) - (object ^name rope ^place <x> ^tied <y>) - (object ^name <y> ^place held) ---> - (write (crlf) |A rope tied to the| <y> |is here.|)) - -(p name347 - (object ^name rope ^place held ^tied noose) - (input untie rope) - --> - (modify 1 ^tied untied) - (remove 2) - (write (crlf) |The rope is now untied.|)) - -(p name348 - (object ^name rope ^tied noose) - (input hang <x>) - --> - (remove 2) - (write (crlf) |No hanging around here.|)) - -(p name349 - (object ^name rope ^place held ^tied noose) - (input tie rope <x>) - --> - (remove 2) - (write (crlf) |The rope is already in knots.|)) - -(p name350 - (object ^name rope ^place held) - (input tie <x>) - --> - (remove 2) - (write (crlf) |Look, don't tie| <x> |, tie rope to something you have on you.|)) - -(p name351 - (object ^name rope ^place held) - (input tieup <x>) - --> - (remove 2) - (make input tie rope to <x>)) - -(p name352 - (object ^name rope ^place held ^tied untied) - (object ^name <x> ^place held) - (input tie rope to <x>) - --> - (modify 1 ^tied <x>) - (remove 3) - (write (crlf) |The rope is tied to| <x> |.|)) - -(p name353 - (object ^name rope ^place held ^tied <z>) - (input tie rope to <x>) - --> - (remove 2) - (write (crlf) |The rope is already tied to the| <z> ) - (write (crlf) |I can tie the rope to only one object at a time.|)) - -(p name354 - (location ^name <y>) - (object ^name <x> ^place <y>) - (object ^name rope ^place <> held ^tied <x>) - (input get <x>) - --> - (modify 3 ^place held) - (write (crlf) |You get the rope first and then ...|)) - -(p name355 - (location ^name <y>) - (object ^name <x> ^place held) - (object ^name rope ^place <> held ^tied <x>) - (input get rope) - --> - (modify 3 ^place held) - (remove 4) - (write (crlf) |You just pulled in the rest of the rope.|)) - -(p name356 - (location ^name <Z>) - (object ^name rope ^place held) - (object ^name cecil ^place <Z>) - (input tie rope to cecil) - --> - (remove 4) - (write (crlf) |You can't tie cecil down!|)) - -(p name357 - (location ^name laboratory) - (object ^name rope ^place held) - (input tie rope to monster) - --> - (remove 3) - (write (crlf) |That would be very foolish.|)) - -(p name358 - (location ^name <Z>) - (object ^name rope ^place held ^tied untied) - (object ^name dracula ^place <Z>) - (input tie rope to dracula) - --> - (remove 4) - (write (crlf) |You can't get Dracula, not to mention tie him up.|)) - -(p name359 - (input tie rope to {<< candy marijuana cube orchid >> <x>} ) - (object ^name rope ^place held ^tied untied) - (object ^name <x> ^place held) - --> - (remove 1) - (write (crlf) |That is too small for the rope to be tied to.|)) - -(p name360 - (input lasso <x>) - --> - (remove 1) - (make input tie rope to <x>)) - -(p name361 - (object ^name rope ^place held ^tied untied) - (input tie rope to rope) - --> - (modify 1 ^tied noose) - (remove 2) - (write (crlf) |The rope is tied in knots.|)) - -(p name362 - (location ^name torture_chamber) - (status ^likes <x>) - (object ^name rope ^place held) - (object ^name damsel ^state free) - (input tie rope to <x>) - --> - (remove 5) - (make input torture damsel)) - -(p name363 - (location ^name <x>) - (object ^name rope ^place held) - (object ^name chest ^place <x>) - (object ^name octopus ^alive t) - (input tie rope to chest) - --> - (remove 5) - (write (crlf) |The octopus blocks your way.|)) - -(p name364 - (object ^name rope ^place held) - (input tie rope to <x>) - --> - (remove 2) - (write (crlf) |Either you aren't holding | <x> |, or I can't tie the rope to it.|)) - -(p name365 - (object ^name rope ^place <> held) - (input tie rope to <z>) - --> - (remove 2) - (write (crlf) |You don't have the rope.|)) - -(p name366 - (input untie rope) - (object ^name rope ^tied <x>) - (object ^name <x> ^place held) ---> - (remove 1) - (modify 2 ^tied untied) - (write (crlf) |The rope is no longer tied to| <x> |.|)) - -(p name367 - (input pull rope) - (object ^name rope ^place held ^tied <x>) - (object ^name <x>) ---> - (write (crlf) |Umph! You just pulled in the| <x> |.|) - (remove 1) - (modify 3 ^place held)) - -(p name368x5 - (input pull rope) - (object ^name rope ^tied <x>) - (object ^name <x> ^place held) - --> - (remove 1) - (modify 2 ^place held) - (write (crlf) |You now have all the rope.|)) - -(p name368 - (input untie rope) - (object ^name rope ^tied untied) - --> - (remove 1) - (write (crlf) |The rope isn't tied to anything.|)) - -(p name369 - (input untie rope) - (object ^name rope ^tied <x>) - (object ^name <x> ^place <y>) - --> - (remove 1) - (write (crlf) |The rope is tied to the| <x> |, which you aren't holding.|)) - -(p name370 - (location ^name bathysphere) - (input pull rope) - (object ^name rope ^tied <x>) - (object ^name <x> ^place ocean) - (portal ^name wdoor ^door closed) - --> - (remove 2) - (write (crlf) |The airlock door is closed on the rope.|)) - -(p name371 - (location ^name <x>) - (object ^name wetsuit ^place <x>) - --> - (write (crlf) |There is a wetsuit, with everything needed to survive (location ^underwater t).|)) - -(p name372 - (input << don wear >> <x>) - --> - (remove 1) - (make input put on <x>)) - -(p name373 - (location ^name <x>) - (object ^name wetsuit ^place <x>) - (input put on wetsuit) - --> - (modify 2 ^place held)) - -(p name374 - (object ^name wetsuit ^place held) - (input put on wetsuit) - --> - (modify 1 ^wears t) - (remove 2) - (write (crlf) |You are wearing a wetsuit.|)) - -(p name375 - (object ^name wetsuit ^wears t) - (input << remove doff >> wetsuit) ---> - (modify 1 ^wears nil) - (remove 2) - (write (crlf) |Your wetsuit is in your arms.|)) - -(p name376 - (location ^name <x>) - (input drop wetsuit) - (object ^name wetsuit ^place held ^wears t) - --> - (remove 2) - (modify 3 ^wears nil ^place <x>)) - -(p name377 - (location ^name <x>) - (object ^name speargun ^place <x>) - --> - (write (crlf) |There is a speargun that shoots underwater.|)) - -(p name378 - (location ^name <x>) - (object ^name speargun ^place <x> ^state loaded) ---> - (write (crlf) |The speargun is loaded, ready to fire.|)) - -(p name379 - (location ^name <x>) - (object ^name speargun ^place held ^state loaded) - (location ^underwater nil) - (input shoot) - (status) - --> - (modify 2 ^state unloaded) - (remove 4) - (write (crlf) |The gun goes off. BRRRANG!!|) - (write (crlf) |The backlash from the speargun snaps your neck!|) - (modify 5 ^quit t)) - -(p name380 - (object ^name speargun ^place held ^state unloaded) - (input shoot speargun) - --> - (remove 2) - (write (crlf) |The gun isn't loaded with a spear!|)) - -(p name381 - (object ^name speargun ^place held ^state unloaded) - (object ^name spear ^place held) - (input load) - --> - (write (crlf) |The gun is now loaded.|) - (modify 1 ^state loaded)) - -(p name382 - (location ^name <x>) - (object ^name spear ^place <x>) - --> - (write (crlf) |There is a speargun spear here.|)) - -(p name383 - (input <x> gun) - --> - (remove 1) - (make input <x> speargun)) - -(p name384 - (input << pres p depress push >> <x>) - --> - (remove 1) - (make input press <x>)) - -(p name385 - (location ^name <x>) - (object ^name coins ^place <x>) - --> - (write (crlf) |You see many coins here!|)) - -(p name386 - (location ^name <x>) - (object ^name bone ^place <x>) - --> - (write (crlf) |There is a bone here that you identify as from the MISSING LINK!|)) - -(p name387 - (location ^name <x>) - (object ^name soap ^place <x>) - --> - (write (crlf) |There is a bar of soap here.|)) - -(p name388 - (location ^name <x>) - (object ^name gem ^place <x>) - --> - (write (crlf) |There is a valuable gem here.|)) - -(p name396 - (location ^name <x>) - (object ^name jade ^place <x>) - --> - (write (crlf) |There is a piece of valuable jade here.|)) - -(p name397 - (input why <x>) - --> - (remove 1) - (write (crlf) |Hey, I don't know.|) - (write (crlf) |Send mail to Laird@cmua if you have questions.|)) - -(p name398 - (input eat orchid) - (object ^name orchid ^place held) - --> - (remove 1) - (remove 2) - (write (crlf) |Chomp! chomp. I don't think your real family had a taste for orchids.|) - (write (crlf) |It looks like you aren't one of those that knows how to digest orchids.|)) - -(p name399 - (input eat orchid) - (status ^name <x> St |.| John) - (object ^name orchid ^place held) - --> - (remove 1) - (remove 2) - (remove 3) - (write (crlf) |An orchid a day keeps the crazies away!|) - (make command ^string eat_it)) - -(p name400 - (location ^name <x>) - (object ^name orchid ^place <x>) - (input eat orchid) - --> - (make input get orchid)) - -(p name401 - (input say <x>) - --> - (remove 1) - (make input <x>) - (write (crlf) |You can just type| <x> ) - (write (crlf) |and I'll try and understand| <x> |right now.|)) - -(p name402 - (input << scream shout yell >> <x>) - --> - (write (crlf) |'| <x> |!!'|) - (remove 1) - (write (crlf) |I don't think anybody is listening.|)) - -(p name403 - (input hello) - --> - (remove 1) - (write (crlf) |Your greeting is met with silence.|)) - -(p name404 - (input fly) - --> - (remove 1) - (write (crlf) |You flap your arms, but nothing happens.|)) - -(p name405 - (input afihywn) - --> - (remove 1) - (write (crlf) |Hmm, is that Australian?|)) - -(p name1009 - (location ^name bus_stop) - --> - (write (crlf) |We are at an intersection of two streets going n-s and e-w.|) - (write (crlf) |There is a bus stop here.|) - (write (crlf) |To the west a bus is pulling away from the next bus stop.|)) - -(p name1010 - (location ^name bus_stop) - (status ^going <> nil) - (time ^realtime <x> ^btime <y>) - --> - (modify 1 ^name bus_stop) - (modify 2 ^going nil) - (modify 3 ^btime (compute <x> + 16))) - -(p name1011 - (location ^name bus_stop) - (time ^realtime <x> ^btime <x>) - (history ^bus_stopped nil) - --> - (modify 3 ^bus_stopped t)) - -(p name1012 - (location ^name bus_stop) - (history ^bus_stopped t) - --> - (write (crlf) |A bus has stopped in front of us.|)) - -(p name1013 - (input wait) - --> - (write (crlf) |La dee da.|) - (remove 1)) - -(p name1014 - (input wait) - (location ^name bus_stop) - (history ^bus_stopped nil) - --> - (remove 1) - (modify 3 ^bus_stopped t) - (write (crlf) |Yawn!|)) - -(p name1015 - (input << mount board >>) - (location ^name bus_stop) - --> - (remove 1) - (make input enter bus)) - -(p name1016 - (input enter) - (location ^name bus_stop) - (history ^bus_stopped t) - (object ^name tokens ^place held) - --> - (remove 1) - (modify 2 ^name on_bus) - (modify 3 ^bus_stopped nil) - (remove 4) - (make object ^name token ^place held)) - -(p name1017 - (input enter) - (location ^name bus_stop) - (history ^bus_stopped t) - (object ^name token ^place held) - --> - (remove 1) - (modify 2 ^name on_bus) - (modify 3 ^bus_stopped nil) - (remove 4)) - -(p name1018 - (location ^name bus_stop) - (input take ride) - --> - (remove 1) - (make input enter bus)) - -(p name1019 - (location ^name bus_stop) - (history ^bus_stopped t) --(object ^name tokens) --(object ^name token) - (status) - (input enter <x>) - --> - (remove 4) - (write (crlf) |You don't have any tokens. You sit on the corner and starve to death.|) - (modify 3 ^quit t)) - -(p name1020 - (location ^name bus_stop) - (history ^bus_stopped t) - (input enter) - (object ^name token ^place bus stop) - --> - (remove 3) - (write (crlf) |The bus doors remain closed.|)) - -(p name1021 - (location ^name bus_stop) - (history ^bus_stopped t) - (input enter) - (object ^name tokens ^place bus stop) ---> - (remove 3) - (write (crlf) |You stumble over some tokens and bang your head on the bus.|)) - -(p name1022 - (location ^name on_bus) - --> - (modify 1 ^name bus) - (make place bus ^visited t) - (write (crlf) |As you find your seat, you notice the bus is empty.|) - (write (crlf) |There isn't even a driver. But before you can change your mind,|) - (write (crlf) |the bus starts up and drives away from the intersection.|) - (write (crlf) |Va Vooooom!|) - (write (crlf) |Looking out the window you see many intersections flash by.|) - (write (crlf) | |) - (write (crlf) |After a while the intersections get farther apart.|) - (write (crlf) |The bus is now in the outskirts of town.|) - (write (crlf) |The bus comes up to an old mansion with a high gate surrounding it and stops.|) - (write (crlf) |A voice comes over the speaker: 'ALL OUT, END OF THE LINE.'|)) - -(p name1023 - (location ^name bus) - (place ^name bus ^visited nil) - --> - (write (crlf) | |) - (write (crlf) |You are in a bus. There isn't a driver and the exit doors are open.|)) - -(p name1024 - (location ^name bus) - (input get off <x>) - --> - (remove 2) - (make input exit)) - -(p name1025 - (location ^name bus) - (input << leave depart disembark >>) - --> - (remove 2) - (make input exit)) - -(p name1026 - (location ^name bus) - (input exit <x>) - --> - (remove 2) - (modify 1 ^name lawn ^side out ^east 5 ^north 2) - (write (crlf) |The bus drives off as you get off.|)) - -(p name1027 - (location ^name bus) - (input get out <x>) - --> - (remove 2) - (make input exit)) - -(p name1028 - (location ^name bus_stop) - (input << chase follow catch >> bus) - (status) - --> - (remove 2) - (write (crlf) |I'm assuming that means GO WEST.|) - (modify 3 ^going w went w)) - -(p name1029 - (location ^name bus_stop) - (time ^realtime 2226) - --> - (write (crlf) |Hint: patience is a virtue.|)) - -(p name1030 - (location ^name bus) - (input hijack bus) - --> - (remove 2) - (write (crlf) |Sorry, this bus doesn't go to Cuba, that's another line.|)) - -(p name1031 - (location ^name bus) - (input <x> driver) - --> - (remove 2) - (write (crlf) |There isn't a driver on this bus.|)) - -(p name1032 - (location ^name bus) - (input drive bus) - --> - (remove 2) - (write (crlf) |I'm sorry but you don't have a chauffeur's license.|)) - -(p name1033 - (location ^name bus) - (input <x> bus) - --> - (remove 2) - (write (crlf) |Give up and get off the bus.|)) - -(p name1034 - (location ^name bus_stop) - (input hail bus) - --> - (remove 2) - (write (crlf) |The bus does not stop for you.|)) - -(p name1035 - (location ^name lawn ^side out ^east {<< 2 3 4 5 6 7 >> <C>} - ^north << 1 2 8 >>) - (status ^going e) - --> - (modify 2 ^going nil) - (modify 1 ^east (compute 1 + <C>))) - -(p name01035 - (location ^name lawn ^side out ^east 1) - (status ^going e) - --> - (modify 2 ^going nil) - (modify 1 ^east 2)) - -(p name1036 - (location ^name lawn ^side out ^east << 1 2 8 >> - ^north {<< 2 3 4 5 6 7 >> <N>}) - (status ^going n) - --> - (modify 2 ^going nil) - (modify 1 ^north (compute 1 + <N>))) - -(p name001036 - (location ^name lawn ^side out ^north 1) - (status ^going n) - --> - (modify 2 ^going nil) - (modify 1 ^north 2)) - -(p name1037 - (location ^name lawn ^side out ^east << 1 2 8 >> - ^north {<< 3 4 5 6 7 8 >> <N>}) - (status ^going s) - --> - (modify 2 ^going nil) - (modify 1 ^north (compute <N> - 1))) - -(p name01037 - (location ^name lawn ^side out ^north 2) - (status ^going s) - --> - (modify 2 ^going nil) - (modify 1 ^north 1)) - -(p name1038 - (location ^name lawn ^side out ^east {> 2 <E>} ^north << 1 2 8 >>) - (status ^going w) - --> - (modify 2 ^going nil) - (modify 1 ^east (compute <E> - 1))) - -(p name01038 - (location ^name lawn ^side out ^east 2) - (status ^going w) - --> - (modify 2 ^going nil) - (modify 1 ^east 1)) - -(p name1039 - (location ^name lawn ^side out ^east 1 ^north <> 1) - (status ^going w) - --> - (modify 2 ^going nil) - (write (crlf) |The woods are too dense to penetrate.|)) - -(p name1041 - (location ^name lawn ^side out ^east 1 ^north 1) - (status ^going w) - --> - (modify 2 ^going nil) - (modify 1 ^name bus_stop)) - -(p name1043 - (location ^name lawn ^side out ^east 8 ^north 1) - (status ^going e) - --> - (modify 2 ^going nil) - (modify 1 ^name bus_stop)) - -(p name1044 - (location ^name lawn ^side out ^east 8 ^north <> 1) - (status ^going e) - --> - (modify 2 ^going nil) - (write (crlf) |You are unable to penetrate into the woods.|)) - -(p name1045 - (location ^name lawn ^side out ^north 1) - (status ^going s) - --> - (modify 2 ^going nil) - (write (crlf) |The forest can not be penetrated.|)) - -(p name1046 - (location ^name lawn ^side out ^north 8) - (status ^going n) - --> - (modify 2 ^going nil) - (write (crlf) |Penetration into the forest is impossible|)) - -(p name1047 - (location ^name lawn ^side out ^east << 3 4 5 6 7 >> ^north 2) - (status ^going n) - --> - (modify 2 ^going nil) - (write (crlf) |The wall prevents passage to the north.|)) - -(p name1049 - (location ^name lawn ^side out ^east << 3 4 5 6 7 >> ^north 8) - (status ^going s) - --> - (modify 2 ^going nil) - (write (crlf) |The wall is in the way.|)) - -(p name1051 - (location ^name lawn ^side out ^east << 3 4 5 6 7 >> ^north 8) - --> - (write (crlf) |You're on the north border of a wall, on the outside.|)) - -(p name1053 - (location ^name lawn ^side out ^east << 3 4 5 6 7 >> ^north 2) - --> - (write (crlf) |To the north is the wall that surrounds CHEZ MOOSE.|) - (write (crlf) |To the south is a road.|)) - -(p name1055 - (location ^name lawn ^side out ^north << 3 4 5 6 7 >> ^east 2) - --> - (write (crlf) |To the west is a thick forest, and to the east is a wall.|)) - -(p name1056 - (location ^name lawn ^side out ^east 8 ^north << 3 4 5 6 7 >>) - --> - (write (crlf) |To the east is a dark forest, and to the west is a high wall.|)) - -(p name1060 - (location ^name lawn ^side out ^east 2 ^north << 3 4 5 6 7 >>) - (status ^going e) - --> - (modify 2 ^going nil) - (write (crlf) |Ahh, there is the big wall in the way.|)) - -(p name1061 - (location ^name lawn ^side out ^east 8 ^north << 3 4 5 6 7 >>) - (status ^going w) - --> - (modify 2 ^going nil) - (write (crlf) |The wall is in the way.|)) - -(p name1074 - (location ^name lawn ^side out ^north 1) - --> - (write (crlf) |You are on the road, to the south is a forest.|)) - -(p name1075 - (location ^name lawn ^side out ^east 1 ^north > 1) - --> - (write (crlf) |You are in a forest.|)) - -(p name1098 - (location ^name lawn ^side out ^east 5 ^north 2) - --> - (write (crlf) |To the north is a gate in a wall.|) - (write (crlf) |Further north a huge mansion looms.|) - (write (crlf) | |) - (write (crlf) |Lights from inside illuminate the surrounding estate.|) - (write (crlf) |The gate is inoperable, and you won't be able to open it.|)) - -(p name1114 - (location ^name lawn ^side out ^east 2 ^north 2) - --> - (write (crlf) |This is the sw corner of the wall.|)) - -(p name1115 - (location ^name lawn ^side out ^east 8 ^north 2) - --> - (write (crlf) |This is the se corner of the wall. You can go n, s, e or w.|)) - -(p name1116 - (location ^name lawn ^side out ^east 8 ^north 8) - --> - (write (crlf) |This is the ne corner of the wall.|)) - -(p name1117 - (location ^name lawn ^side out ^east 2 ^north 8) - --> - (write (crlf) |This is the nw corner of the wall.|)) - -(comment inside) - -(p name1140 - (location ^name lawn ^side in ^east << 2 3 4 6 7 8 >> - ^north { < 8 <N>}) - (status ^going n) - --> - (modify 2 ^going nil) - (modify 1 ^north (compute 1 + <N>) ^general nil)) - -(p name1141 - (location ^name lawn ^side in ^east 5 - ^north { << 2 3 6 7 >> <N>}) - (status ^going n) - --> - (modify 2 ^going nil) - (modify 1 ^north (compute 1 + <N>) ^general nil)) - -(p name1142 - (location ^name lawn ^side in ^east << 2 3 4 6 7 8 >> - ^north { > 2 <N>}) - (status ^going s) - --> - (modify 2 ^going nil) - (modify 1 ^north (compute <N> - 1) ^general nil)) - -(p name1143 - (location ^name lawn ^side in ^east 5 - ^north { << 3 4 7 8 >> <N>}) - (status ^going s) - --> - (modify 2 ^going nil) - (modify 1 ^north (compute <N> - 1) ^general nil)) - -(p name1150 - (location ^name lawn ^side in ^north << 2 3 4 6 7 8 >> - ^east { < 8 <N>}) - (status ^going e) - --> - (modify 2 ^going nil) - (modify 1 ^east (compute 1 + <N>) ^general nil)) - -(p name1151 - (location ^name lawn ^side in ^north 5 - ^east { << 2 3 6 7 >> <N>}) - (status ^going e) - --> - (modify 2 ^going nil) - (modify 1 ^east (compute 1 + <N>) ^general nil)) - -(p name1152 - (location ^name lawn ^side in ^north << 2 3 4 6 7 8 >> - ^east { > 2 <N>}) - (status ^going w) - --> - (modify 2 ^going nil) - (modify 1 ^east (compute <N> - 1) ^general nil)) - -(p name1153 - (location ^name lawn ^side in ^north 5 - ^east { << 3 4 7 8 >> <N>}) - (status ^going w) - --> - (modify 2 ^going nil) - (modify 1 ^east (compute <N> - 1) ^general nil)) - -(p name1048 - (location ^name lawn ^side in ^north 2) - (status ^going s) - --> - (modify 2 ^going nil) - (write (crlf) |The wall won't let you go south.|)) - -(p name1050 - (location ^name lawn ^side in ^north 8) - (status ^going n) - --> - (modify 2 ^going nil) - (write (crlf) |Hey, the wall is north.|)) - -(p name1052 - (location ^name lawn ^side in ^north 8) - --> - (write (crlf) |You're on the inside of north border of a wall.|)) - -(p name1054 - (location ^name lawn ^side in ^north 2) - --> - (write (crlf) |A wall is to the south.|)) - -(p name1057 - (location ^name lawn ^side in ^east 8) - --> - (write (crlf) |To the east is a wall.|)) - -(p name1058 - (location ^name lawn ^side in ^east 2) - --> - (write (crlf) |To the west is a wall.|)) - -(p name1059 - (location ^name lawn ^side in ^east 2) - (status ^going w) - --> - (modify 2 ^going nil) - (write (crlf) |The wall blocks your way.|)) - -(p name1062 - (location ^name lawn ^side in ^east 8) - (status ^going e) - --> - (modify 2 ^going nil) - (write (crlf) |The wall is in the way.|)) - -(p name1063 - (location ^name lawn ^side in ^east 4 ^north 4) - --> - (write (crlf) |You are at the sw corner of the house.|)) - -(p name1064 - (location ^name lawn ^side in ^east 6 ^north 4) - --> - (write (crlf) |You are at the se corner of the house.|)) - -(p name1065 - (location ^name lawn ^side in ^east 4 ^north 5) - --> - (write (crlf) |You are on the west side of the house.|)) - -(p name1066 - (location ^name lawn ^side in ^east 4 ^north 6) - --> - (write (crlf) |This is the north-west corner of the house.|)) - -(p name1067 - (location ^name lawn ^side in ^east 5 ^north 6) - --> - (write (crlf) |This is the north side of the house.|)) - -(p name1068 - (location ^name lawn ^side in ^east 6 ^north 6) - --> - (write (crlf) |This is the north east corner of the mansion.|)) - -(p name1069 - (location ^name lawn ^side in ^east 6 ^north 5) - --> - (write (crlf) |This is the east side of the house.|)) - -(p name1070 - (location ^name lawn ^side in ^east 6 ^north 5) - (status ^going w) - --> - (modify 2 ^going nil) - (write (crlf) |The house is in the way.|)) - -(p name1071 - (location ^name lawn ^side in ^east 4 ^north 5) - (status ^going e) - --> - (modify 2 ^going nil) - (write (crlf) |The house is in the way.|)) - -(p name1072 - (location ^name lawn ^side in ^east 5 ^north 4) - (status ^going n) - --> - (modify 2 ^going nil) - (write (crlf) |The house is in the way.|)) - -(p name1073 - (location ^name lawn ^side in ^east 5 ^north 6) - (status ^going s) - --> - (modify 2 ^going nil) - (write (crlf) |The house is in the way.|)) - -(p name1076 - (location ^name lawn ^side in ^east 3 ^north 3 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1077 - (location ^name lawn ^side in ^east 4 ^north 3 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1078 - (location ^name lawn ^side in ^east 6 ^north 3 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1079 - (location ^name lawn ^side in ^east 7 ^north 3 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1080 - (location ^name lawn ^side in ^east 7 ^north 4 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1081 - (location ^name lawn ^side in ^east 7 ^north 7 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1082 - (location ^name lawn ^side in ^east 6 ^north 7 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1083 - (location ^name lawn ^side in ^east 5 ^north 7 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1084 - (location ^name lawn ^side in ^east 4 ^north 7 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1085 - (location ^name lawn ^side in ^east 3 ^north 6 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1086 - (location ^name lawn ^side in ^east 3 ^north 7) - --> - (write (crlf)|This looks like an old garden, but the land is all dried and hard.|)) - -(p name1087 - (object ^name bathwater ^place lawn ^side in ^east 3 ^north 7) - (object ^name orchid ^state seed) - --> - (modify 2 ^state plant) - (write (crlf) |The ground shakes...|) - (write (crlf) |An orchid sprouts from the ground.|)) - -(p name1088 - (object ^name water ^place lawn ^side in ^east 3 ^north 7) - (object ^name orchid ^place lawn ^side in ^east 3 ^north 7 ^state plant) - (object ^name bathwater ^place lawn ^side in ^east 3 ^north 7) - --> - (remove 2) - (write (crlf) |The orchid shrinks and disappears underground.|)) - -(p name1089 - (object ^name water ^place lawn ^side in ^east 3 ^north 7) - (object ^name orchid ^place lawn ^side in ^east 3 ^north 7 ^state seed) ---> - (remove 2) - (write (crlf) |Nothing happens. That must be strange water.|)) - -(p name1090 - (object ^name seawater ^place lawn ^side in ^east 3 ^north 7) - (object ^name orchid ^place lawn ^side in ^east 3 ^north 7) ---> - (remove 2) - (write (crlf) |I think you killed what ever was planted.|)) - -(p name1091 - (object ^name bathwater ^place <x>) - (object ^name water ^place <x>) ---> - (remove 1) - (remove 2) - (write (crlf) |The two types of water evaporate.|)) - -(p name1092 - (location ^name lawn ^side in ^east 3 ^north 5 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1093 - (location ^name lawn ^side in ^east 3 ^north 4 ^general nil) - --> - (modify 1 ^general lawns)) - -(p name1094 - (location ^general lawns) - --> - (write (crlf) |You're on the lawn of the mansion.|)) - -(p name1095 - (location ^name lawn ^side in ^east 5 ^north 3) - --> - (write (crlf) |You're on the front walk.|)) - -(p name1096 - (location ^name lawn ^side in ^east 5 ^north 2) - --> - (write (crlf) |You're at the front gate, which can't be opened.|)) - -(p name1097 - (location ^name lawn ^side <side> ^east 5 ^north 2) - (input climb) - --> - (remove 2) - (write (crlf) |Nice try, but the upper part of the gate is electrified!|) - (write (crlf) |I suggest you try somewhere else.|)) - -(p name1105 - (location ^name lawn ^side in ^east 7 ^north 5) - --> - (write (crlf) |You are on the drive way.|) - (write (crlf) |The drive has a gate in the wall to the east.|)) - -(p name1106 - (location ^name lawn ^side in ^east 7 ^north 6) - --> - (write (crlf) |You are on a parking space.|)) - -(p name1118 - (location ^name lawn) - (input << scale climb >>) - --> - (remove 2) - (write (crlf) |The wall is too slick to climb up. You can't get a grip.|)) - -(p name1119 - (location ^name lawn) - (input << burrow tunnel dig >>) - --> - (remove 2) - (write (crlf) |The ground is too hard to dig here.|)) - -(p name1120 - (location ^name lawn) - (object ^name <x> ^place held) - (input throw <x> at wall) - --> - (remove 3) - (write (crlf) |The| <x> |bounces off the wall.|) - (make input drop <x>)) - -(p name1121 - (input jump wall) - (location ^name lawn) - --> - (remove 1) - (write (crlf) |You aren't the HULK or Dwight Stones.|)) - -(p name1122 - (input jump wall) - (location ^name lawn) - (status ^name Dwight Stones) ---> - (remove 1) - (write (crlf) |You approach the wall. Up, up you go.|) - (write (crlf) |SPLAT!! You hit the wall right at 8". That would|) - (write (crlf) |be a new world's record. Too bad the wall is ten feet tall.|)) - -(p name1123 - (input jump wall) - (location ^name lawn) - (status ^name the Hulk) - --> - (remove 1) - (write (crlf) |Ha! You aren't the Hulk, you're just a little green|) - (write (crlf) |from the bus ride.|)) - -(p name1124 - (input jump over wall) - (location ^name lawn) - --> - (remove 1) - (write (crlf) |You watched Superman too many times!|)) - -(p name1125 - (location ^name lawn) - (input throw <y> over <Z>) - --> - (remove 2) - (write (crlf) |The wall is too high for you to throw anything over it.|)) - -(p name1126 - (input let me in) - --> - (remove 1) - (write (crlf) |I'm afraid you aren't getting anyone's attention.|)) - -(p name1127 - (input open gate) - --> - (remove 1) - (write (crlf) |The gate can't be opened by you.|)) - -(p name1128 - (status ^notreasure t) - (object ^name <x> ^place ) - --> - (remove 2)) - -(p name1129 - (location ^name lawn ^side in ^east 5 ^north 6) - --> - (write (crlf) |There is ivy on the walls of the house.|)) -(p name389 - (time ^oil_status oil ^oil_time <x> ^realtime <x>) - --> - (modify 1 ^oil_status enter ^oil_time (compute <x> + 10))) - -(p name390 - (time ^oil_status enter ^oil_time <x> ^realtime <x>) - --> - (make object ^name truck ^place lawn ^side in ^east 7 ^north 5) - (modify 1 ^oil_status walk ^oil_time (compute <x> + 10))) - -(p name391 - (time ^oil_status walk ^oil_time <x> ^realtime <x>) - (history ^grave_status undug) - --> - (modify 1 ^oil_status walk ^oil_time (compute <x> + 4)) - (modify 2 ^grave_status dug)) - -(p name392 - (time ^oil_status walk ^oil_time <x> ^realtime <x>) - (history ^grave_status dug) - --> - (modify 1 ^oil_status walk ^oil_time (compute <x> + 4)) - (modify 2 ^grave_status deep)) - -(p name393 - (time ^oil_status walk ^oil_time <x> ^realtime <x>) - (history ^grave_status deep ^grave_status2 oil) - --> - (modify 2 ^grave_status2 nil) - (modify 1 ^oil_status fixit ^oil_time (compute <x> + 8))) - -(p name394 - (time ^oil_status fixit ^oil_time <x> ^realtime <x>) - --> - (make fixed) - (modify 1 ^oil_status return ^oil_time (compute <x> + 10))) - -(p name395 - (time ^oil_status return ^oil_time <x> ^realtime <x>) - (object ^name truck ^place <y>) - --> - (modify 1 ^oil_status done) - (remove 2)) - -(p name500 - (location ^name lawn ^side in ^east 8 ^north 8) - (history ^grave_status undug) ---> - (write (crlf) |There is a fresh grave here.|)) - -(p name501 - (location ^name lawn ^side in ^east 8 ^north 8) - (history ^grave_status undug) - (input dig) - --> - (remove 3) - (modify 2 ^grave_status dug) - (write (crlf) |Luckily, the dirt is soft.|)) - -(p name502 - (location ^name lawn ^side in ^east 8 ^north 8) - (history ^grave_status dug) ---> - (write (crlf) |There is a open grave.|)) - -(p name503 - (location ^name lawn ^side in ^east 8 ^north 8) - (history ^grave_status dug) - (input dig) - --> - (remove 3) - (modify 2 ^grave_status deep)) - -(p name504 - (location ^name lawn ^side in ^east 8 ^north 8) - (history ^grave_status deep) ---> - (write (crlf) |There is a large pipe that goes through the grave.|) - (write (crlf) |There is a lever on the pipe labelled 'Emergency Release.'|)) - -(p name505 - (location ^name lawn ^side in ^east 8 ^north 8) - (input <x> dirt <y>) - --> - (remove 2) - (write (crlf) |Hmmm.. I didn't understand that. I can only dig holes and fill in holes.|)) - -(p name506 - (location ^name lawn ^side in ^east 8 ^north 8) - (input get dirt) - --> - (remove 2) - (write (crlf) |Sorry, that won't wash. I can only dig holes and fill in holes.|) - (write (crlf) |You can't get the dirt.|)) - -(p name507 - (location ^name lawn ^side in ^east 8 ^north 8) - (input pull lever) - (history ^grave_status deep ^grave_status2 <> oil) - (time ^realtime <x>) --(fixed) - --> - (remove 2) - (write (crlf) |Ummph!|) - (modify 3 ^grave_status2 oil) - (modify 4 ^oil_time (compute <x> + 30))) - -(p name508 - (location ^name lawn ^side in ^east 8 ^north 8) - (history ^grave_status2 oil) ---> - (write (crlf) |There is oil seeping out of the pipe.|)) - -(p name509 - (input << throw get push turn close >> lever) - --> - (remove 1) - (make input pull lever)) - -(p name510 - (input <x> lever) - --> - (remove 1) - (write (crlf) |I don't understand the word| <x> |as a verb for lever.|)) - -(p name511 - (history ^grave_status2 oil) - (input pull lever) - --> - (remove 2) - (write (crlf) |The lever won't close, a special tool is needed!|) - (write (crlf) |The oil continues to seep out.|)) - -(p name512 - (location ^name lawn ^side in ^east 8 ^north 8) - (input <x> oil) - --> - (remove 2) - (write (crlf) |The oil is too slippery to do anything with it.|)) - -(p name513 - (location ^name lawn ^side in ^east 8 ^north 8) - (input refill) - (walk <x>) - (history ^grave_status <y>) - --> - (remove 2) - (write (crlf) |You are unable to affect the driver's digging.|)) - -(p name514 - (location ^name lawn ^side in ^east 8 ^north 8) - (input refill) - (fixit <x>) - (history ^grave_status <y>) - --> - (remove 2) - (write (crlf) |You are unable to affect the driver's work.|)) - -(p name515 - (location ^name lawn ^side in ^east 8 ^north 8) - (input refill) - (history ^grave_status2 oil ^grave_status deep) - --> - (remove 2) - (modify 3 ^grave_status dug) - (write (crlf) |The oil still seeps out.|)) - -(p name516 - (location ^name lawn ^side in ^east 8 ^north 8) - (history ^grave_status deep) - (input refill) - --> - (remove 3) - (modify 2 ^grave_status dug)) - -(p name517 - (location ^name lawn ^side in ^east 8 ^north 8) - (history ^grave_status dug) - (input refill) - --> - (remove 3) - (modify 2 ^grave_status undug)) - -(p name518 - (input oil) - (location ^name lawn ^side in ^east 8 ^north 8) ---> - (remove 1) - (write (crlf) |The oil is too slippery to use.|)) - -(p name519 - (input fill in) - --> - (remove 1) - (make input refill)) - -(p name520 - (input fillin) - --> - (remove 1) - (make input refill)) - -(p name521 - (input cover) - --> - (remove 1) - (make input refill)) - -(p name522 - (input << scoop shovel >>) - --> - (remove 1) - (make input dig)) - -(p name523 - (input dig) - (location ^name lawn ^side in ^east 8 ^north 8) ---> - (remove 1) - (write (crlf) |The ground is too hard to dig anymore.|)) - -(p name524 - (input refill) - (location ^name lawn ^side in ^east 8 ^north 8) ---> - (remove 1) - (write (crlf) |The grave is filled.|)) - -(p name525 - (history ^grave_status dug) --(object ^name bone) ---> - (make object ^name bone ^place lawn ^side in ^east 8 ^north 8 ^treasure t)) - -(p name526 - (fixed) - (location ^name lawn ^side in ^east 8 ^north 8) - --> - (write (crlf) |The oil is not seeping out, the lever has been fixed but can not be pulled.|)) - -(p name527 - (fixed) - (location ^name lawn ^side in ^east 8 ^north 8) - (input pull) - --> - (remove 3) - (write (crlf) |The lever won't budge.|)) - - -(p name530 - (location ^name lawn ^side in ^east 8 ^north 5) - (enter) - --> - (write (crlf) |You see a truck outside at the gate.|)) - -(p name531 - (location ^name lawn ^side in ^east > 6 ^north 5) - (enter <x>) - (time ^realtime <x>) - (input <z>) - --> - (write (crlf) |The gates open and the truck enters. The gate closes before you can escape.|) - (write (crlf) |The truck says 'Oil line fixit' on the side.|) - (write (crlf) |The truck pulls in and parks on the drive.|) - (write (crlf) |The driver gets out and heads north east.|)) - -(p name532 - (enter <x>) - (time ^realtime <x>) --(location ^name lawn ^side in ^east > 6 ^north 5) - (input <z>) - --> - (write (crlf) |You hear a truck pull into the driveway and stop.|)) - -(p name533 - (walk <x>) - (location ^name lawn ^side in ^east 8 ^north 8) - --> - (write (crlf) |The driver is digging to get a better angle on the pipe.|)) - -(p name534 - (fixit <x>) - (location ^name lawn ^side in ^east 8 ^north 8) - --> - (write (crlf) |The driver is fixing the pipe.|)) - -(p name535 - (fixit <x>) - (time ^realtime <x>) - (location ^name lawn ^side in ^east 8 ^north 8) - (input <z>) - --> - (write (crlf) |The driver is finished with the work, and heads back to the truck.|)) - -(p name536 - (return <x>) - (time ^realtime <x>) - (input <z>) - (location ^name lawn ^side in ^east > 6 ^north 5) - --> - (write (crlf) |The man gets in the truck and backs out as the gate opens.|) - (write (crlf) |You are unable to escape as it leaves.|)) - -(p name537 - (input <x> driver <y>) - --> - (remove 1) - (write (crlf) |You are unable to contact or make contact with the driver.|) - (write (crlf) |It is as if he doesn't know you are there.|)) - -(p name538 - (input get truck) - --> - (remove 1) - (write (crlf) |The truck is a little heavy to get.|)) - -(p name539 - (location ^name lawn ^side in ^east 7 ^north 5) - (portal ^name truck ^place lawn ^side in ^east 7 ^north 5) - --> - (write (crlf) |There is a panel truck here.|)) - -(p name540 - (location ^name lawn ^side in ^east 7 ^north 5) - (portal ^name truck ^place lawn ^side in ^east 7 ^north 5) - (input mount truck) - --> - (remove 3) - (write (crlf) |The truck is too tall to climb up on.|)) - -(p name541 - (location ^name lawn ^side in ^east 7 ^north 5) - (object ^name truck ^place lawn ^side in ^east 7 ^north 5) - (input open <y>) - --> - (remove 3) - (write (crlf) |The front doors are locked, but you were able to open the back.|) - (modify 2 ^door open)) - -(p name542 - (portal ^name truck ^door closed) - (object ^name truck ^side in ^east 7 ^north 5) - (location ^name lawn ^side in ^east 7 ^north 5) - (input open <y>) - --> - (write (crlf) |The back doors are now open.|) - (modify 1 ^door open) - (remove 4)) - -(p name543 - (location ^name lawn ^side in ^east 7 ^north 5) - (object ^name truck ^place lawn ^side in ^east 7 ^north 5) - (input << mount enter >> <y>) - --> - (remove 3) - (write (crlf) |None of the doors are open.|)) - -(p name544 - (location ^place lawn ^side in ^east 7 ^north 5) - (object ^name truck ^place lawn ^side in ^east 7 ^north 5) - (portal ^name truck ^door open) - (input close <y>) ---> - (modify 3 ^door close) - (remove 4) - (write (crlf) |Ok.|)) - -(p name545 - (location ^name lawn ^side in ^east 7 ^north 5) - (object ^name truck ^place lawn ^side in ^east 7 ^north 5) - (portal ^name truck ^door open) - (input << mount enter >> <h>) ---> - (remove 4) - (modify 1 ^place intruck) - (write (crlf) |You are in the back of the truck.|)) - -(p name546 - (location ^name intruck) - (input look) - --> - (remove 2) - (write (crlf) |You are inside the panel truck. It is empty.|)) - -(p name547 - (object ^name truck ^place lawn ^side in ^east 7 ^north 5) - (portal ^name truck ^door open) - (location ^name intruck) - (return <y>) - (time ^realtime <y>) - (input <z>) - --> - (write (crlf) |As the truck starts up, it accelerates so fast that you fall out the back.|) - (remove 6) - (modify 3 ^place lawn ^side in ^east 7 ^north 5)) - -(p name548 - (object ^name truck ^place lawn ^side in ^east 7 ^north 5) - (portal ^name truck ^door closed) - (location ^name intruck) - (return <y>) - (time ^realtime <y>) - (input <z>) - (status) - --> - (remove 6) - (write (crlf) |VaVoom! The truck has started up.|) - (write (crlf) |Bump bump! You feel yourself being driven out of the yard.|) - (modify 7 ^going out)) - -(p name549 - (location ^name lawn ^side in ^east 7 ^north 5) - (object ^name truck ^place lawn ^side in ^east 7 ^north 5) - (portal ^name truck ^door open) - (input << mount enter >> <R>) - (object ^name <y> ^place held) - --> - (remove 4) - (write (crlf) |The| <y> |won't fit through the door!|)) - -(p name550 - (status ^going out) - --> - (modify 1 ^going nil) - (write (crlf) |As you drive by the gate you hear from the speaker:|) - (write (crlf) |'Good job son!'|) - (write (crlf) ||) - (write (crlf) |The truck drives on for a while then stops.|) - (write (crlf) |Your open the truck door and find that you are outside the walls.|) - (write (crlf) |You've escaped!|) - (write (crlf) ||) - (write (crlf) |In the distance you here the trumpeting of a bull moose.|) - (write (crlf) ||) - (write (crlf) |James Watt is here with a check for $10,000,000 to buy the land|) - (write (crlf) |for the Department of the Interior.|) - (write (crlf) |He assures you that the government will not sell the land, but admits|) - (write (crlf) |that he may allow some leasing of mineral rights. You have the option|) - (write (crlf) |of selling it and making big bucks, or you can donate, with the|) - (write (crlf) |restriction that it be perserved in its current state.|) - - (write (crlf) |What is your choice? Sell, or donate?|) - (make selldonate (accept))) - -(p name551 - (selldonate sell) - (status ^score <x>) - --> - (remove 1) - (write (crlf) |Hmm. I don't think your father would have approved.|) - (write (crlf) |Oh my god! Out of the forest a moose comes charging at you.|) - (write (crlf) |He is coming right at you. You can't escape. |) - (write (crlf) |ARGHH! He gored you, but missed James Watt.|) - (write (crlf) |You're dead, what a bummer after what you have been through.|) - (make input stop) - (modify 2 ^score (compute <x> - 20))) - -(p name552 - (selldonate) - --> - (remove 1) - (write (crlf) |Make up your mind, Sell or donate.|) - (make selldonate (accept))) - -(p name553 - (selldonate donate) - (status ^score <x>) - --> - (remove 1) - (write (crlf) |James Watt accuses you of being a reactionary idiot.|) - (write (crlf) |He stomps off, mumbling, 'Those strip miners are going|) - (write (crlf) |to be real disappointed', and walks right through a pile of moose turds.|) - (write (crlf) |I think you made the right decision.|) - (make gone) - (modify 2 ^score (compute <x> + 20))) - -(p name554 - (gone) - --> - (make input stop)) - -(p name555 - (gone) - (status ^score <x>) - (object ^name cube ^place lawn) - --> - (modify 2 ^score (compute <x> - 50)) - (make input stop) - (write (crlf) |The police bust into the yard of the house to collect|) - (write (crlf) |your treasure for you.|) - (write (crlf) |Unfortunately they find the sugar cube with the LSd in it.|) - (write (crlf) |You are arrested and thrown in jail for 50 years!!!|) - (write (crlf) |What a loser!|)) - -(p name556 - (gone) - (status ^score <x>) - (object ^name marijuana ^place lawn) ---> - (modify 2 ^score (compute <x> - 20)) - (make input stop) - (write (crlf) |The police bust into the yard of the house to collect your treasure for you.|) - (write (crlf) |They find the marijuana! Luckily you are in the state of confusion|) - (write (crlf) |and you get a $5 fine, but lose the $300 worth of pot.|) - (write (crlf) |Oh well, maybe next time you'll enjoy it first.|)) - -(p name557 - (location ^name intruck) - (input get out) - (portal ^name truck ^door open) - --> - (remove 2) - (modify 1 ^name lawn ^side in ^east 7 ^north 5)) - - -(p name1130 - (location ^name lawn ^side in ^east 5 ^north 6) - (input get ivy) - --> - (remove 2) - (write (crlf) |The ivy is stuck to the wall.|)) - - -(p name1131 - (input hi) - (location ^name lawn ^side out ^east 8 ^north 5) ---> - (remove 1) - (write (crlf) |The gate opens. You rush in and then it closes behind you.|) - (write (crlf) |Out of the speaker you hear, 'Now you are in, but will you ever get out?'|) - (modify 2 ^side in)) - -(p name1132 - (location ^name lawn ^side in ^east 8 ^north 5) - --> - (write (crlf) |You are on the driveway. The gate to the outside|) - (write (crlf) |is to the east, but is locked electronically.|)) - -(p name1133 - (location ^name lawn ^side in ^east 8 ^north 5) - (status ^going e) - --> - (modify 2 ^going nil) - (write (crlf) |The gate is locked, and you can't open it.|)) - -(p name1134 - (location ^name lawn ^side out ^east 8 ^north 5) - --> - (write (crlf) |There is a gate in the wall that spans the|) - (write (crlf) |driveway that leads into the inner grounds of the mansion.|) - (write (crlf) |By the left hand side of the gate is a 'Jack-in-the-box'|) - (write (crlf) | speaker with a button.|)) - -(p name1200 - (input << climb scale >> ) - (location ^name lawn ^side in ^east 5 ^north 6) - --> - (remove 1) - (modify 2 ^name balcony ^side nil ^east nil ^north nil) - (write (crlf) |The ivy allows you to get a grip. You climb up the wall.|) - (write (crlf) |The ivy starts to thin out and you haven't found anywhere to stop.|) - (write (crlf) |To the right you spy a balcony. Using your great skill as a|) - (write (crlf) |world class haunted house climber, you jump to the balcony.|)) - -(p name01200 - (status ^going u) - (location ^name lawn ^side in ^east 5 ^north 6) - --> - (modify 1 ^going nil) - (modify 2 ^name balcony ^side nil ^east nil ^north nil) - (write (crlf) |The ivy allows you to get a grip. You climb up the wall.|) - (write (crlf) |The ivy starts to thin out and you haven't found anywhere to stop.|) - (write (crlf) |To the right you spy a balcony. Using your great skill as a|) - (write (crlf) |world class haunted house climber, you jump to the balcony.|)) - -(p name1201 - (location ^name balcony) - (place ^name balcony ^visited nil) - --> - (write (crlf) |You are on the balcony. The doors to the inside|) - (write (crlf) |are missing leaving a large doorway to the inside.|)) - -(p name1202 - (location ^name balcony) - (status ^going u) - --> - (modify 2 ^going nil) - (write (crlf) |You can't climb any higher.|)) - -(p name1203 - (location ^name balcony) - (input climb up) - (status) - --> - (remove 2) - (modify 3 ^going u ^went u)) - -(p name1204 - (location ^name balcony) - (input climb nil) - --> - (remove 2) - (write (crlf) |Climb up or climb down?|)) - -(p name1205 - (input climb down) - (location ^name balcony) - (status) - --> - (remove 1) - (write (crlf) |I warned you that the ivy gave out up here!|) - (write (crlf) |When you tried to leap over to get a grip, you missed!!|) - (write (crlf) |Down you go|) - (write (crlf) | o|) - (write (crlf) | o|) - (write (crlf) | o|) - (write (crlf) | o.|) - (write (crlf) |Your foot gets caught in some ivy near the bottom and you land|) - (write (crlf) |on your head. |) - (modify 3 ^die t)) - -(p name1206 - (location ^name balcony) - (status ^going d) - --> - (modify 2 ^going nil) - (write (crlf) |Is that climb down or jump?|)) - -(p name1207 - (location ^name balcony) - (input jump) - (status) - --> - (write (crlf) |Paratrooper training comes in helpful sometimes.|) - (write (crlf) |Unfortunately you never had it. You break your neck when you hit.|) - (remove 2) - (modify 3 ^die t)) - -(p name1208 - (location ^name balcony) - (input jump) - (object ^name mattress ^place held) - (status) - --> - (modify 4 ^die t) - (write (crlf) |You flip over in mid-air and land on your back! 'CRUNCH'|) - (remove 2)) - -(p name1209 - (location ^name balcony) - (input jump) - (object ^name mattress ^place lawn ^side in ^east 5 ^north 6) - --> - (remove 2) - (modify 1 ^name lawn ^side in ^east 5 ^north 6) - (write (crlf) |Luckily you land on the mattress.|)) - -(p name1210 - (input drop mattress) - (location ^name balcony) - (object ^name mattress ^place held) - --> - (remove 1) - (modify 3 ^place lawn ^side in ^east 5 ^north 6) - (write (crlf) |The mattress floats to the ground.|)) - -(p name1211 - (input throw mattress) - (location ^name balcony) - --> - (remove 1) - (make input drop mattress)) - -(p name1212 - (input enter) - (location ^name balcony) - (status) - --> - (modify 3 ^going s ^went s) - (remove 1)) - -(p name1213 - (location ^name balcony) - (place ^name balcony) - (status ^going s) - --> - (modify 1 ^name bedroom) - (modify 2 ^name balcony ^visited t) - (modify 3 ^going nil)) - -(p name1214 - (location ^name bedroom) - (place ^name bedroom ^visited nil) - --> - (write (crlf) |You are in what looks like the master bedroom of the mansion.|) - (write (crlf) |A large doorway opens to the balcony to the north.|) - (write (crlf) |To the east is a opening to the bathroom.|) - (write (crlf) |The main doorway to the rest of the house is boarded up and impassable.|)) - -(p name1215 - (input enter) - (location ^name bedroom) - --> - (remove 1) - (make input e)) - -(p name1216 - (location ^name bedroom) - (make input exit) - --> - (remove 2) - (make input n)) - -(p name1217 - (location ^name bedroom) - (object ^name mattress ^place held) - (status ^going e) - --> - (modify 3 ^going nil) - (write (crlf) |The mattress won't fit through the door.|)) - -(p name1218 - (location ^name bedroom) - (object ^name mattress ^place held) - (status ^going n) - --> - (write (crlf) |The mattress just clears the door.|)) - -(p name1219 - (location ^name bedroom) - (place ^name bedroom) - (status ^going n) - --> - (modify 3 ^going nil) - (modify 2 ^name bedroom ^visited t) - (modify 1 ^name balcony)) - -(p name1220 - (location ^name bedroom) - (status ^going e) - (place ^name bedroom) - --> - (modify 2 ^going nil) - (modify 3 ^name bedroom ^visited t) - (modify 1 ^name bathroom)) - -(p name1221 - (location ^name bedroom) - (status ^sound on) - --> - (write (crlf) |Some noise can be heard through the boarded up door.|)) - -(p name1222 - (location ^name bedroom) - (object ^name mattress ^place bedroom) - --> - (write (crlf) |There is a king-size bed in the middle of the room.|)) - -(p name1223 - (location ^name bedroom) --(object ^name mattress ^place bedroom) - --> - (write (crlf) |There is the frame and springs of a king-size bed in the room.|)) - -(p name1224 - (location ^name bedroom) - (input get bed) - --> - (remove 2) - (write (crlf) |All you can get is the mattress, the rest is too heavy.|) - (make input get mattress)) - -(p name1225 - (location ^name <x>) - (object ^name mattress ^place <x>) - (input cut mattress) - --> - (remove 3) - (remove 2) - (write (crlf) |The mattress is poorly made and you rip it to shreds.|) - (write (crlf) |In fact it is in a million pieces that float away.|)) - -(p name1226 - (input cut mattress) - (object ^name mattress ^place held) - --> - (remove 1) - (remove 2) - (write (crlf) |The mattress falls to pieces in your hands and they all float away.|)) - -(p name1227 - (input << chop rip tear >>) - --> - (remove 1) - (make input cut)) - -(p name1228 - (location ^name bedroom) - (input look under bed) - --> - (remove 2) - (write (crlf) |'Ahhh Chooo!' There is dust under the bed.|)) - -(p name1229 - (location ^name bedroom) - (input <x> under bed) - --> - (remove 2) - (write (crlf) |The bed is too low to go under.|)) - -(p name1230 - (input mount bed) - (location ^name bedroom) - --> - (remove 1) - (modify 2 ^ontop bed) - (write (crlf) |You are on the bed.|)) - -(p name1231 - (location ^name bedroom ^ontop bed) - (object ^name mattress ^place bedroom) - (input jump) --(object ^name mirror ^state broke) - --> - (remove 3) - (write (crlf) |You bounce up and hit the mirror. It shatters into many small pieces.|) - (make object ^name mirror ^state broke)) - -(p name1232 - (input bounce) - --> - (remove 1) - (make input jump)) - -(p name1233 - (location ^name bedroom ^ontop bed) - (input jump) - --> - (remove 2) - (write (crlf) |Without the mattress on you don't get any cheap thrills.|)) - -(p name1234 - (location ^name bedroom ^ontop <> nil) - (input get mirror) - --> - (remove 2) - (write (crlf) |The mirror is still out of reach.|)) - -(p name1235 - (location ^name bedroom) - (input get mirror) - --> - (remove 2) - (write (crlf) |The mirror is much too high to reach.|)) - -(p name1236 - (location ^name bedroom) --(object ^name mirror ^state broke) - --> - (write (crlf) |There is a mirror on the ceiling above the bed.|)) - -(p name1237 - (location ^name bedroom) - (object ^name mirror ^state broke) - (input get mirror) - (status ^cut nil) - --> - (remove 3) - (modify 4 ^cut t) - (write (crlf) |The glass is too sharp to carry, you cut yourself. 'Ouch!'|)) - -(p name1238 - (location ^name bedroom ^ontop bed) - (object ^name mirror ^state broke) - (input get mirror <x>) - (status) - --> - (remove 3) - (modify 4 ^cut t) - (write (crlf) |The glass cuts you when you try to pick it up.|)) - -(p name1239 - (location ^name bedroom) - (object ^name mirror ^state broke) - (input get glass) - (status) - --> - (remove 3) - (modify 4 ^cut t) - (write (crlf) |'Ouch!' The glass cuts you, you can't carry it.|)) - -(p name1240 - (location ^name bedroom) - (object ^name mirror ^state broke) - --> - (write (crlf) |There is glass from a broken mirror on the floor.|)) - -(p name1241 - (input sleep) - (location ^name bedroom ^ontop bed) - --> - (write (crlf) |Snooze... - . - . - . - . - . - ... snort. Ah that was refreshing, but useless, you're still ugly.|) - (remove 1)) - -(p name1242 - (input get << on in >> bed) - (location ^name bedroom) - --> - (remove 1) - (make input mount bed)) - -(p name1243 - (location ^name bedroom) - (input sit on bed) - --> - (remove 2) - (make input mount bed)) - -(p name1244 - (x 10) - (input sleep) - --> - (remove 2) - (write (crlf) |Let's wait until we are on a bed.|)) - -(p name1245 - (location ^name {<> bedroom <x>}) - (object ^name mattress ^place <x>) - --> - (write (crlf) |There is a king-size mattress here.|)) - -(p name1246 - (location ^name bathroom) - (place ^name bathroom ^visited nil) - --> - (write (crlf) |You are in the master bathroom.|) - (write (crlf) |The exciting features around are the bathtub and the toilet.|)) - -(p name1247 - (location ^name bathroom) - (status ^going w) - (place ^name bathroom) - --> - (modify 1 ^name bedroom) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name1248 - (location ^name bathroom) - (input urinate) - --> - (remove 2) - (write (crlf) |That was a relief!|)) - -(p name1249 - (location ^name bathroom) - (input urinate) - (status ^likes prince) - --> - (modify 1 ^siton toilet)) - -(p name1250 - (input urinate into bottle) - --> - (remove 1) - (write (crlf) |The adventure has frighten you so much that your|) - (write (crlf) |urethra won't relax|) - (write (crlf) |and you are unable to even expel a drop.|)) - -(p name1251 - (input get urine) - --> - (remove 1) - (make input urinate into bottle)) - -(p name1252 - (input urinate in bottle) - --> - (remove 1) - (make input urinate into bottle)) - -(p name1253 - (input shit) - (location ^name bathroom) - --> - (remove 1) - (modify 2 ^siton toilet) - (write (crlf) |Too bad there isn't any tissue!|)) - -(p name1254 - (input piss) - --> - (remove 1) - (make input urinate)) - -(p name1255 - (input take a leak) - --> - (remove 1) - (make input urinate)) - -(p name1256 - (input take a crap) - (location ^name bathroom) - --> - (remove 1) - (make input shit)) - -(p name1257 - (input mount toilet) - (location ^name bathroom) - --> - (remove 1) - (modify 2 ^siton toilet) - (write (crlf) |Sitting on a toilet is lots of fun!|)) - -(p name1258 - (input sit on toilet) - (location ^name bathroom) - --> - (remove 1) - (modify 2 ^siton toilet) - (write (crlf) |Duly sat.|)) - -(p name1259 - (location ^name bathroom) - (input flush) - (status) - --> - (remove 2) - (modify 3 ^die t) - (write (crlf) |When you flush the toilet it spins around, knocking you off your feet!|) - (write (crlf) |You crack your head on the bathtub and die!!|)) - -(p name1260 - (location ^name bathroom ^siton <> nil) - (status ^going w) - --> - (modify 1 ^siton nil)) - -(p name1261 - (input flush) - (location ^name bathroom ^siton toilet) - (place ^name bathroom) - --> - (remove 1) - (modify 2 ^name backroom) - (modify 3 ^visited t)) - -(p name1262 - (location ^name bathroom) - (input get toilet) - --> - (remove 2) - (write (crlf) |Give me a break! The toilet stays here!|)) - -(p name1263 - (location ^name bathroom) - (input get bathtub) - --> - (write (crlf) |The bathtub doesn't move.|) - (remove 2)) - -(p name1264 - (location ^name bathroom) - (input << enter mount >> bathtub) - --> - (modify 1 ^siton bathtub) - (remove 2) - (write (crlf) |Ok.|)) - -(p name1265 - (location ^name bathroom) - (input sit in bathtub) - --> - (modify 1 ^siton bathtub) - (remove 2) - (write (crlf) |Ok.|)) - -(p name1266 - (location ^name bathroom) - (input turn on water) - (place ^name bathroom) - --> - (remove 2) - (modify 3 ^state water_running)) - -(p name1267 - (location ^name bathroom) - (place ^name bathroom ^state water_running) - --> - (write (crlf) |The water is on in the bathtub.|)) - -(p name1268 - (location ^name bathroom) - (place ^name bathroom ^state <> water_running) - (input turn off water) - --> - (remove 3) - (write (crlf) |The water is already off.|)) - -(p name1269 - (location ^name bathroom) - (place ^name bathroom ^state water_running) - (input turn off water) - --> - (modify 2 ^state nil) - (remove 3) - (write (crlf) |The water is turned off.|) - (write (crlf) |All the water drains out.|)) - -(p name1270 - (location ^name bathroom) - (input turn on shower) - --> - (remove 2) - (write (crlf) |There isn't a shower head, just a bathtub.|)) - -(p name1271 - (location ^name bathroom) - (input take shower) - --> - (remove 2) - (write (crlf) |I thought I said there was only a bathtub!|)) - -(p name1272 - (location ^name bathroom) - (input take bath) - --> - (remove 2) - (make command ^string wash)) - -(p name1273 - (location ^name bathroom) - (input wash) - --> - (remove 2) - (make command ^string wash)) - -(p name1274 - (location ^name bathroom) - (command ^string wash) - (place ^name bathroom ^state <> water_running) - --> - (write (crlf) |Well, I must turn on the water.|) - (modify 3 ^state water_running)) - -(p name1275 - (location ^name bathroom ^siton <> bathtub) - (command ^string wash) - --> - (write (crlf) |Let's get in the bathtub.|) - (modify 1 ^siton bathtub)) - -(p name1276 - (location ^name bathroom) - (command ^string wash) - (object ^name soap ^place bathroom) - --> - (write (crlf) |Hmmm... now where was that soap.|) - (make input get soap)) - -(p name1277 - (location ^name bathroom ^siton bathtub) - (command ^string wash) - (object ^name soap ^place held) - (place ^name bathroom ^state water_running) - --> - (remove 2) - (remove 3) - (write (crlf) |Luckily we don't worry about clothes in this adventure!|) - (write (crlf) |The water is nice and warm. Too bad I don't have a rubber duckie!|) - (write (crlf) |Well let's use the soap to get clean.|) - (write (crlf) |There is so much dirt here it takes alot of soap.|) - (write (crlf) |As the soap wears away, we are left with a GEM!!.|) - (make object ^name gem ^place held ^treasure t)) - -(p name1278 - (x 10) - (command ^string wash) - --> - (remove 1) - (write (crlf) |Ahh, can't wash without any soap and water.|)) - -(p name1279 - (location ^siton bathtub) - (object ^name soap ^place held) - (place ^name bathroom ^state water_running) - --> - (write (crlf) |As long as we're here, we might as well wash.|) - (make command ^string wash)) - -(p name1280 - (location ^name bathroom) - (object ^name soap ^place held) - (input drop soap in << bathtub water >>) - (place ^name bathroom ^state water_running) - --> - (remove 2) - (remove 3) - (write (crlf) |The soap dissolves and a gem remains!|) - (make object ^name gem ^place bathroom ^treasure t)) - -(p name1281 - (location ^siton bathtub) - (object ^name <x> ^wears t) - --> - (remove 1) - (write (crlf) |If we're getting in the bathtub I'm going to take off the| - <x> |.|) - (make input take off <x>)) - -(p name1282 - (location ^name bathroom) - (input lather) - --> - (remove 2) - (make input wash)) - -(p name1283 - (location ^name bathroom) - (input drop soap in water) - --> - (remove 2) - (make input wash)) - -(p name1284 - (location ^name bathroom) - (input drop soap in bathtub) - --> - (remove 2) - (make input wash) - (write (crlf) |Let's jump in after it and take a bath.|)) - -(p name1285 - (location ^name bathroom) - (input drink water) - --> - (remove 2) - (write (crlf) |Gross! I'm not that thirsty!|)) - -(p name1286 - (input urinate <x>) - (object ^name <x> ^wears <> nil) - --> - (remove 1) - (make input take off <x>) - (write (crlf) |Well, I think it is best to undress a little first.|)) - -(p name1287 - (location ^name bathroom) - (input shit) - (object ^name <x> ^wears <> nil) - --> - (remove 2) - (make input take off <x>) - (write (crlf) |I'll take off the suit first.|)) - -(p name1288 - (input pee) - --> - (remove 1) - (make input urinate)) - -(p name1289 - (location ^name bathroom) - (input <x> drain) - --> - (remove 2) - (write (crlf) |The drain is open, even shoving the bed down it won't close it|)) - -(p name1290 - (location ^name bathroom) - (input plug) - --> - (remove 2) - (write (crlf) |You can't plug it.|)) - -(p name1291 - (location ^name bathroom) - (input <x> plug <y>) - --> - (remove 2) - (write (crlf) |I see no plug here.|)) - -(p name1292 - (location ^name bathroom) - (place ^name bathroom ^state water_running) - (input splash) ---> - (remove 3) - (write (crlf) |Hey, watch it! No splashing around here.|)) - -(p name1293 - (location ^name bathroom ^siton bathtub) - (place ^name bathroom ^state water_running) - (input drown) - (status) - --> - (modify 2 ^state nil) - (remove 3) - (modify 4 ^die t) - (write (crlf) |Adventure a little to tough for you eh?|) - (write (crlf) |Well you did look a little blue, especially after you held your head under|) - (write (crlf) |for ten minutes!|)) - -(p name1294 - (location ^name backroom) - (place ^name backroom ^visited nil) - --> - (write (crlf) |The toilet and the wall have swivled around 180 degrees.|) - (write (crlf) |You are now in a backroom.|) - (write (crlf) |I assume this was for when grand-dad wanted to ... in private.|) - (write (crlf) |There are no doors or windows. Just the toilet.|)) - -(p name1295 - (location ^name backroom) - (input flush) - (place ^name backroom) - --> - (modify 1 ^name bathroom) - (remove 2) - (modify 3 ^visited t) - (write (crlf) |Around you go again.|)) - -(p name1296 - (location ^name backroom) - (input urinate) - --> - (remove 2) - (write (crlf) |Your bladder is empty.|)) - -(p name1297 - (location ^name backroom) - (input shit) - --> - (remove 2) - (write (crlf) |Plop!|)) - -(p name1298 - (location ^name backroom) - (input stand) - --> - (remove 2) - (write (crlf) |There isn't enough room to stand.|)) - -(p name1299 - (location ^name backroom) - (input get up) - --> - (remove 2) - (write (crlf) |I see no up here. Ha ha, only kidding. There isn't room to stand in here.|)) -(p name2000 - (location ^name lawn ^side in ^east 5 ^north 4) - (input ouvre) - (portal ^name large_door ^door closed) - (status ^likes <f>) - --> - (remove 2) - (modify 3 ^name large_door ^door open) - (write (crlf) |The door creaks open.|) - (write (crlf) |A voice from within says: 'Welcome,| <f> |lover.'|)) - -(p name2001 - (location ^name lawn ^side in ^east 5 ^north 4) - (input ouvre) - (portal ^name large_door ^door open) - --> - (remove 2) - (write (crlf) |The door stays open.|)) - -(p name2002 - (location ^name lawn ^side in ^east 5 ^north 4) - (status ^going n) - --> - (remove 2) - (write (crlf) |The door is closed, you bump your nose!|)) - -(p name2003 - (location ^name lawn ^side in ^east 5 ^north 4) - (status ^going n) - (portal ^name large_door ^door open) - --> - (modify 1 ^name foyer ^side nil ^east nil ^north nil) - (modify 2 ^going nil)) - -(p name2004 - (location ^name lawn ^side in ^east 5 ^north 4) - (status ^going n) - (portal ^name large_door ^door open) - (object ^name mattress ^place held) - --> - (modify 2 ^going nil) - (write (crlf) |The mattress won't fit throught the door.|)) - -(p name2005 - (location ^name lawn ^side in ^east 5 ^north 4) - (status ^going n) - (portal ^name large_door ^door open) - (object ^name cube ^place held) ---> - (modify 4 ^place lawn ^side in ^east 5 ^north 4) - (write (crlf) |You stumble over the threshold and drop the cube outside.|)) - -(p name2006 - (location ^name lawn ^side in ^east 5 ^north 4) - (status ^going n) - (portal ^name large_door ^door open) - (object ^name marijuana ^place held) - --> - (write (crlf) |The dope slips from your hand.|) - (modify 4 ^place lawn ^side in ^east 5 ^north 4)) - -(p name2007 - (location ^name lawn ^side in ^east 5 ^north 4) - (input enter) - (status) - --> - (remove 2) - (modify 3 ^going n ^went n)) - -(p name2008 - (location ^name lawn ^side in ^east 5 ^north 4) - --> - (write (crlf) |You are outside a large door in the front of an old mansion.|)) - -(p name2009 - (location ^name lawn ^side in ^east 5 ^north 4) - (input knock) - --> - (remove 2) - (write (crlf) |'Knock! Knock!'|) - (make input ouvre)) - -(p name2010 - (location ^name lawn ^side in ^east 5 ^north 4) - (input ring) - --> - (remove 2) - (write (crlf) |Ding dong!|) - (make input ouvre)) - -(p name2011 - (x 30) - (input ring) - --> - (remove 2) - (write (crlf) |I see no bell here.|)) - -(p name2012 - (location ^name lawn ^side in ^east 5 ^north 4) - (input open) - (portal ^name large_door ^door closed) - --> - (remove 2) - (write (crlf) |Didn't your mother teach you any manners?|) - (write (crlf) |You shouldn't open someones door without their permission!|)) - -(p name2013 - (location ^name lawn ^side in ^east 5 ^north 4) - (portal ^name large_door ^door open) - (input close) - --> - (modify 2 ^door closed) - (remove 3) - (write (crlf) |The door closes.|)) - -(p name2014 - (location ^name lawn ^side in ^east 5 ^north 4) - (status ^sound on) - --> - (write (crlf) |Muffled sounds can be heard from inside.|)) - -(p name2015 - (location ^name foyer) - (place ^name foyer ^visited nil) - --> - (write (crlf) |You are inside of the house in the inner foyer.|) - (write (crlf) |There is a walk-in closet to the west, an entrance to a hall to the north.|)) - -(p name2016 - (location ^name foyer) - (status ^going s) - (portal ^name large_door ^door open) - --> - (modify 2 ^going nil) - (modify 3 ^door closed) - (write (crlf) |Before you can get out the large door slams shut; BOOM!|) - (write (crlf) |Laughter can be heard in the upper floors of the house.|)) - -(p name2017 - (location ^name foyer) - (portal ^name large_door ^door closed) - (input open) - --> - (remove 3) - (write (crlf) |The large door is locked impossible to open.|)) - -(p name2018 - (location ^name foyer) - (status ^going n) - (place ^name foyer) - --> - (modify 2 ^going nil) - (modify 3 ^visited t) - (modify 1 ^name main_hall)) - -(p name2019 - (location ^name foyer) - (portal ^name large_door ^door closed) - (status ^going s) - --> - (modify 3 ^going nil) - (write (crlf) |The door is shut.|)) - -(p name2020 - (location ^name foyer) - (input enter closet) - (status) - --> - (remove 2) - (modify 3 ^going w ^went w)) - -(p name2021 - (location ^name foyer) - (input enter hall) - (status) - --> - (modify 3 ^going n ^went n) - (remove 2)) - -(p name2022 - (location ^name foyer) - (status ^going w) - (place ^name foyer) - --> - (modify 3 ^visited t) - (modify 1 ^name closet) - (modify 2 ^going nil)) - -(p name2023 - (location ^name foyer) - (portal ^name large_door ^door open) - (input close) - --> - (remove 3) - (modify 2 ^door closed) - (write (crlf) |The door closes.|)) - -(p name2024 - (location ^name foyer) - (place ^name foyer ^virgin t) - (time ^realtime <y>) - --> - (modify 2 ^virgin nil) - (modify 3 ^orc_status sweat ^orc_time (compute <y> + 160)) - (write (crlf) |You feel a chill run down your spine, and you doubt your own sanity.|) - (write (crlf) | |) - (write (crlf) |A booming voice proclaims:|) - (write (crlf) |'YOU WON'T GET OUT BY A DOOR.'|) - (write (crlf) |'... at least alive!'|) - (write (crlf) | |) - (write (crlf) |The house is very damp and musty.|)) - -(p name2025 - (location ^name foyer) - (time ^realtime <y> ^orc_time < <y>) - --> - (modify 2 ^orc_time (compute <y> + 20)) - (write (crlf) |A booming voice proclaims:|) - (write (crlf) |'You must be mad to return. If you're not, you will be soon.'|)) - -(p name2026 - (location ^name foyer) - (time ^realtime <y>) - (command ^string eat_it) - --> - (modify 2 ^orc_status nil) - (remove 3)) - -(p name2027 - (location ^name foyer) - (status ^sound on) - --> - (write (crlf) |Some noise is coming from the hall.|)) - -(p name2028 - (location ^name main_hall) - (status ^going s) - (place ^name main_hall) - --> - (modify 1 ^name foyer) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2029 - (location ^name main_hall) - (place ^name main_hall ^visited nil) - --> - (write (crlf) |You are in the main hall.|) - (write (crlf) |The foyer is south.|) - (write (crlf) |The hall extends west and darkens.|) - (write (crlf) |A large room is to the east.|)) - -(p name2030 - (location ^name main_hall) - (place ^name main_hall) - (status ^going w) - --> - (modify 1 ^name dark_hall) - (modify 2 ^visited t) - (modify 3 ^going nil)) - -(p name2031 - (location ^name main_hall) - (status ^going e) - (place ^name main_hall) - --> - (modify 1 ^name library) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2032 - (location ^name main_hall) - (status ^going << u n >>) - (object ^name stairs ^state whole) - (place ^name main_hall) - --> - (modify 1 ^name stairs) - (modify 2 ^going nil) - (modify 4 ^visited t)) - -(p name2033 - (location ^name main_hall) - (status ^going n) - (object ^name stairs ^state collapsed) - (place ^name main_hall) - --> - (modify 1 ^name stairs_debris) - (modify 2 ^going nil) - (modify 4 ^visited t)) - -(p name2034 - (location ^name main_hall) - (status ^sound on) - --> - (write (crlf) |Weird noises are coming from above.|)) - -(p name2035 - (location ^name closet) - (status ^going e) - (place ^name closet) - --> - (modify 1 ^name foyer) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2036 - (location ^name closet) - (place ^name closet ^visited nil) - --> - (write (crlf) |You are in a large closet, you can see all its contents|) - (write (crlf) | by the light from the foyer.|)) - -(p name2037 - (location ^name dark_hall) - (place ^name dark_hall ^visited nil) - --> - (write (crlf) |You are in a poorly lit hall. There is a faint scent of fresh paint.|)) -(p name2038 - (location ^name dark_hall) - (status ^going w) - (place ^name dark_hall) - --> - (modify 1 ^name smelly_room) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2039 - (location ^name dark_hall) - (status ^going e) - (place ^name dark_hall) - --> - (modify 1 ^name main_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2040 - (location ^name stairs) - (place ^name stairs ^visited nil) - --> - (write (crlf) |You are on the landing of the stair case.|) - (write (crlf) |stairs go up and down.|) - (write (crlf) | |) - (write (crlf) |The stairs are squeeky! They seem about to collapse.|)) - -(p name2041 - (location ^name stairs) - (status ^sound on) - --> - (write (crlf) |The sound is coming from above you.|)) - -(p name2042 - (location ^name stairs) - (status ^going u) - (place ^name stairs) - --> - (modify 1 ^name upper_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2043 - (location ^name stairs) - (status ^going d) - (place ^name stairs) - --> - (modify 1 ^name main_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2045 - (location ^name stairs) - (place ^name stairs ^visited t) - --> - (write (crlf) |SQUEEK! These stairs are delicate!|)) - -(p name2046 - (location ^name stairs) - (object ^name stairs ^state whole) - (input jump) - --> - (write (crlf) |CRASH! You've collapsed the stairs.|) - (modify 1 ^name stairs_debris) - (modify 2 ^state collapsed) - (remove 3)) - -(p name2047 - (location ^name smelly_room) - (place ^name smelly_room ^visited nil) - --> - (write (crlf) |You are in a room that smells of paint.|) - (write (crlf) |There are no windows or door except the one you came through.|) - (write (crlf) |The walls are wood panel.|)) - -(p name2048 - (location ^name smelly_room) - (status ^going e) - (place ^name smelly_room) - --> - (modify 1 ^name dark_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2049 - (location ^name library) - (place ^name library ^visited nil) - --> - (write (crlf) |You are in the library. All the walls are lined with books.|) - (write (crlf) |There is a bust of Homer within reach.|)) - -(p name2050 - (location ^name library) - (status ^going w) - (place ^name library) - --> - (modify 1 ^name main_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2051 - (location ^name library) - (input get bust) - --> - (remove 1) - (write (crlf) |The bust is too heavy to carry.|)) - -(p name2052 - (location ^name library) - (input turn bust) - (portal ^name library ^door closed) - --> - (remove 2) - (modify 3 ^door open)) - -(p name2053 - (location ^name library) - (input enter) - (portal ^name library ^door open) - (status) - --> - (remove 2) - (modify 4 ^going e ^went e)) - -(p name2054 - (location ^name library) - (portal ^name library ^door open) - (object ^name wetsuit ^wears t) - (status ^going e) - --> - (modify 4 ^going nil) - (write (crlf) |You can't fit into the opening.|)) - -(p name2055 - (location ^name library) - (portal ^name library ^door open) - (object ^name wetsuit ^place held) - (status ^going e) - --> - (modify 4 ^going nil) - (write (crlf) |Something you're carrying is to big to fit through the door.|)) - -(p name2056 - (location ^name library) - (portal ^name library ^door open) - (status ^going e) - (place ^name library) - --> - (modify 1 ^name secret_stairs) - (modify 3 ^going nil) - (modify 4 ^visited t)) - -(p name2057 - (location ^name library) - (input turn bust) - (portal ^name library ^door open) - --> - (remove 2) - (modify 3 ^door closed) - (write (crlf) |The shelves close.|)) - -(p name2058 - (location ^name library) - (portal ^name library ^door open) - --> - (write (crlf) |The east wall of books is open!|)) - -(p name2059 - (location ^name library) - (input bust) - --> - (remove 2) - (write (crlf) |I'll bust you if you don't watch it.|)) - -(p name2060 - (location ^name library) - (input rub bust) - --> - (remove 2) - (write (crlf) |That isn't very rewarding, nothing happens.|)) - -(p name2061 - (location ^name library) - (input kiss bust) - --> - (remove 2) - (write (crlf) |That might turn on a frog, but homer is unmoved.|)) - -(p name2062 - (location ^name library ^book nil) - (input get book) - --> - (modify 1 ^book t) - (remove 2) - (write (crlf) |You get a book but discover it has only virtual pages.|) - (write (crlf) |The book disappears.|)) - -(p name2063 - (location ^name library ^book t ^book2 nil) - (input get book) - --> - (write (crlf) |The title of the book is 'Vampires I have known'|) - (modify 1 ^book2 t) - (remove 2) - (make object ^name book ^place held)) - -(p name2064 - (location ^name library ^book t ^book2 t) - (input get book) - --> - (remove 2) - (write (crlf) |All the rest of the books are fake.|) - (write (crlf) |They seem to be wood.|)) - -(p name2065 - (location ^name secret_stairs) - (place ^name secret_stairs ^visited nil) - --> - (write (crlf) |You are in the head of a secret staircase.|) - (write (crlf) |The stairs go down. A pole in the room goes through a hole in the ceiling.|)) - -(p name2066 - (location ^name secret_stairs) - (status ^going w) - (portal ^name library ^door open) - (place ^name secret_stairs) - --> - (modify 1 ^name library) - (modify 2 ^going nil) - (modify 4 ^visited t)) - -(p name2067 - (location ^name secret_stairs) - (status ^going d) - (place ^name secret_stairs) - --> - (modify 1 ^name wine_cellar) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2068 - (location ^name secret_stairs) - (portal ^name library ^door closed) - (input open <x>) - --> - (remove 3) - (write (crlf) |The stacks can't be opened from here.|)) - -(p name2069 - (location ^name secret_stairs) - (portal ^name library ^door open) - --> - (write (crlf) |The west wall is open.|)) - -(p name2070 - (location ^name secret_stairs) - (status ^going u) - --> - (modify 2 ^going nil) - (write (crlf) |That isn't a bat pole, ROBIN. You can only come down.|)) - -(p name2071 - (location ^name stairs_debris) - (place ^name stairs_debris ^visited nil) - --> - (write (crlf) |You are on wreckage of the stairs.|) - (write (crlf) |To the south is the main_hall, north is a small opening.|)) - -(p name2072 - (location ^name stairs_debris) - (status ^going s) - (place ^name stairs_debris) - --> - (modify 1 ^name main_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2073 - (location ^name stairs_debris) - (status ^going n) - (place ^name stairs_debris) - --> - (modify 1 ^name back_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2074 - (location ^name back_hall) - (place ^name back_hall ^visited nil) - --> - (write (crlf) |This is the back hall. It connects the kitchen and|) - (write (crlf) |dining room. The kitchen is east and the dining room is west.|)) - -(p name2075 - (location ^name back_hall) - (object ^name stairs ^state collapsed) - --> - (write (crlf) |To the south is the wreckage of the stairs.|)) - -(p name2076 - (location ^name back_hall) - (status ^going e) - (place ^name back_hall) - --> - (modify 1 ^name kitchen) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2077 - (location ^name back_hall) - (status ^going w) - (place ^name back_hall) - --> - (modify 1 ^name dining_room) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2078 - (location ^name back_hall) - (status ^going s) - (place ^name back_hall) - (object ^name stairs ^state collapsed) - --> - (modify 1 ^name stairs_debris) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2079 - (location ^name kitchen) - (place ^name kitchen ^visited nil) - --> - (write (crlf) |You are in a old kitchen. All the windows are|) - (write (crlf) |boarded up. The only exit is west.|) - (write (crlf) | |) - (write (crlf) |There is a refrigerator in the corner.|) - (write (crlf) |A ventilation duct is open over the refrigerator.|)) - -(p name2080 - (location ^name kitchen) - (status ^going w) - (place ^name kitchen) - --> - (modify 1 ^name back_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2081 - (location ^name kitchen) - (input exit) - (status) - --> - (remove 2) - (modify 3 ^going w ^went w)) - -(p name2082 - (location ^name kitchen) - (portal ^name rdoor ^door closed) - --> - (write (crlf) |The refrigirator door is closed.|)) - -(p name2083 - (location ^name kitchen) - (portal ^name rdoor ^door open) - --> - (write (crlf) |The door of the ice box is open.|)) - -(p name2084 - (location ^name kitchen) - (portal ^name rdoor ^door closed) - (input open) - --> - (remove 3) - (modify 2 ^door open)) - -(p name2085 - (location ^name kitchen) - (portal ^name rdoor ^door open) - (input close) ---> - (remove 3) - (modify 2 ^door closed)) - -(p name2086 - (location ^name kitchen) - (portal ^name rdoor ^door open) - (object ^name cube ^place frig) - --> - (write (crlf) |There is a small white cube in the refrigirator.|)) - -(p name2087 - (location ^name kitchen) - (portal ^name rdoor ^door open) - (object ^name cube ^place frig) - (input get cube) - --> - (remove 4) - (write (crlf) |You have a cube.|) - (modify 3 ^place held)) - -(p name2088 - (location ^name kitchen) - (status ^going u) - --> - (modify 2 ^going nil) - (modify 1 ^ontop frig)) - -(p name2089 - (location ^name kitchen ^ontop frig) - --> - (write (crlf) |You are ontop the refrigirator.|) - (write (crlf) |Going down will put you on the floor, going south will put you in the duct.|)) - -(p name2090 - (location ^name kitchen) - (input mount) - --> - (remove 2) - (modify 1 ^ontop frig)) - -(p name2091 - (location ^name kitchen ^ontop frig) - (status ^going s) - (place ^name kitchen) - --> - (modify 2 ^going nil) - (modify 3 ^visited t) - (modify 1 ^name ductf2 ^ontop nil)) - -(p name2092 - (location ^name dining_room) - (place ^name dining room ^visited nil) - --> - (write (crlf) |You are in a large dining room. The ceiling is very high.|) - (write (crlf) |The hall is east.|)) - -(p name2093 - (location ^name dining_room) - (status ^going e) - (place ^name dining_room) - --> - (modify 1 ^name back_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2094 - (location ^name upper_hall) - (place ^name upper_hall ^visited nil) - --> - (write (crlf) |You are at the upper hall. You can see down the|) - (write (crlf) |first steps of some stairs. A circular staircase|) - (write (crlf) |continues up.|) - (write (crlf) | |) - (write (crlf) |There is a dark room to the south,|) - (write (crlf) |a hall to the west, a stone wall to the east,|) - (write (crlf) |and another room to the north.|)) - -(p name2095 - (location ^name upper_hall) - (object ^name stairs ^state collapsed) - (status ^going d) - --> - (modify 3 ^going nil) - (write (crlf) |The stairs are collapsed.|)) - -(p name2096 - (location ^name upper_hall) - (status ^going d) - (place ^name upper_hall) - (object ^name stairs ^state whole) - --> - (modify 1 ^name stairs) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2097 - (location ^name upper_hall) - (status ^going s) - (place ^name upper_hall) - --> - (modify 1 ^name dark_room) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2098 - (location ^name upper_hall) - (status ^going w) - (place ^name upper_hall) - --> - (modify 1 ^name long_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2099 - (location ^name upper_hall) - (status ^going n) - (place ^name upper_hall) - --> - (modify 1 ^name dull_room) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2100 - (location ^name upper_hall) - (status ^going e) - (place ^name upper_hall) - (portal ^name wall ^door open) - --> - (modify 1 ^name secret_room) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2101 - (location ^name upper_hall) - (portal ^name wall ^door closed) - (input << move pull get >> brick) - --> - (remove 3) - (write (crlf) |The brick moves, but can't be removed from the wall.|) - (write (crlf) |A secret panel in the wall opens!|) - (write (crlf) |There is a room ahead.|) - (modify 2 ^door open)) - -(p name2102 - (location ^name upper_hall) - (input close wall) - (portal ^name wall ^door open) - --> - (remove 2) - (modify 3 ^door closed) - (write (crlf) |The wall closes.|)) - -(p name2103 - (location ^name upper_hall) - (status ^going u) - (place ^name upper_hall) - --> - (modify 1 ^name laboratory) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2104 - (location ^name upper_hall) - (status ^sound on) - --> - (write (crlf) |You hear clanking and screams coming from the hall.|)) - -(p name2105 - (location ^name laboratory) - (location ^name laboratory) - (place ^name laboratory ^visited nil) - --> - (write (crlf) |You are in the laboratory. The most notable feature is a huge |) - (write (crlf) |slab in the middle of the room. There is a large |) - (write (crlf) |lever switch. The stairs are the only obvious exit. The ceiling|) - (write (crlf) |is a glass dome painted black, much too high to reach.|)) - -(p name2106 - (location ^name laboratory) - (status ^going d) - (place ^name laboratory) - --> - (modify 1 ^name upper_hall) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2107 - (location ^name laboratory) - (status ^going w) - (place ^name laboratory) - (wall is down) - --> - (modify 1 ^name bar) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2108 - (location ^name laboratory) - (wall is down) - --> - (write (crlf) |The west wall has the shape of a running figure in it.|)) - -(p name2109 - (location ^name laboratory) - (input <B> << lever switch >>) - --> - (remove 2) - (make monster live)) - -(p name2110 - (location ^name laboratory) - (input <x> lever) - (object ^name lever ^state thrown) - --> - (remove 2) - (write (crlf) |The lever is stuck.|)) - -(p name2111 - (location ^name laboratory) - (monster live) - (object ^name monster ^place laboratory) --(object ^name lever ^state thrown) - --> - (remove 2) - (write (crlf) |The lights dim. A massive door on the east wall|) - (write (crlf) |opens revealing a bank of computers, generators, and misc.|) - (write (crlf) |electronic gear. The generators start to scream.|) - (write (crlf) |The lights dim more. Suddenly sparks start to fly from the|) - (write (crlf) |equipment. The body on the table starts to jerk around.|) - (write (crlf) | |) - (write (crlf) |As suddenly as it started, the generators turn off, the|) - (write (crlf) |wall closes. And everything returns to normal.....|) - (write (crlf) |Then the body rises, removes its sheet and it is a monster.|) - (write (crlf) | |) - (write (crlf) |The monster approaches you and says 'Trick or Treat'|) - (make object ^name lever ^state thrown)) - -(p name2112 - (location ^name laboratory) - (object ^name monster ^place laboratory) --(object ^name lever ^state thrown) - --> - (write (crlf) |There is the shape of a body on the slab, covered with a sheet.|)) - -(p name2113 - (location ^name laboratory) - (object ^name monster ^place laboratory) - (object ^name candy ^place held) - (object ^name lever ^state thrown) - (input give candy) - --> - (remove 3) - (remove 2) - (remove 5) - (write (crlf) |The monster is pleased.| - |He eats the candy, walks through the west wall|) - (write (crlf) |and disappears.|) - (make wall is down)) - -(p name2114 - (location ^name laboratory) - (object ^name monster ^place laboratory) - (object ^name lever ^state thrown) - (input <x> monster) - --> - (remove 2) - (remove 4) - (write (crlf) |The monster is frightened and holds his breath until he turns|) - (write (crlf) |blue. He then disappears.|)) - -(p name2115 - (location ^name laboratory) - (object ^name lever ^state thrown) - --> - (write (crlf) |The lever has been thrown, and is stuck in that position.|)) - -(p name2116 - (location ^name laboratory) - (object ^name football ^place held) - (input kick football) - --> - (remove 3) - (write (crlf) |The football goes crashing through the glass dome.|) - (modify 2 ^place lawn ^side in ^east 7 ^north 4) - (make object ^name dome ^state broken)) - -(p name2117 - (location ^name laboratory) - (object ^name football ^place held) - (object ^name rope ^state tied ^tied football) - (input kick football <p>) - --> - (remove 4) - (write (crlf) |Kicking the football tears the rope off of it.|) - (write (crlf) |The football goes crashing through the glass dome.|) - (modify 3 ^state untied) - (modify 2 ^place lawn ^side in ^east 7 ^north 4) - (make object ^name dome ^state broken)) - -(p name2118 - (location ^name laboratory) - (object ^name Dracula ^place laboratory) - (object ^name dome ^state broken) - --> - (remove 2) - (write (crlf) |The bat flies through the hole in the dome and escapes.|)) - -(p name2119 - (location ^name laboratory) - (object ^name Dracula ^place laboratory) - --> - (write (crlf) |There is a bat flying around in the dome, too high to reach.|)) - -(p name2120 - (location ^name laboratory) - (object ^name Dracula ^place laboratory) - (input get Dracula) - --> - (remove 3) - (write (crlf) |I said the bat was too high to reach, even on a stool.|)) - -(p name2121 - (location ^name laboratory) - (object ^name Dracula ^place laboratory) - (input get bat) - --> - (remove 3) - (write (crlf) |The bat is much too high for you to get.|)) - -(p name2122 - (location ^name laboratory) - (object ^name Dracula ^place laboratory) - (object ^name dome ^state broken) - (time ^morning t) - --> - (remove 2) - (make object ^name ring ^place laboratory ^treasure t) - (write (crlf) |The sun's rays cause the bat to shrivel. Something falls to the floor.|)) - -(p name2123 - (object ^name Dracula ^place laboratory) - (object ^name dome ^state broken) - (time ^morning t) - --> - (remove 1) - (make object ^name ring ^place laboratory ^treasure t)) - -(p name2124 - (location ^name laboratory) - (object ^name monster ^place laboratory) - (object ^name lever ^state thrown) - (place ^name laboratory ^visited t) - --> - (write (crlf) |The monster is drooling on himself, saying 'Trick or Treat'|)) - -(p name2125 - (location ^name laboratory) - (object ^name monster ^place laboratory) - (object ^name lever ^state thrown) - (input give <x>) - --> - (remove 4) - (write (crlf) |The monster doesn't like | <x> |. |) - (write (crlf) |He is getting very angry.|)) - -(p name2126 - (location ^name laboratory) - (object ^name monster ^place laboratory) - (object ^name lever ^state thrown) - (input give monster <x>) - --> - (remove 4) - (make input give <x>)) - -(p name2127 - (location ^name laboratory) - (object ^name monster ^place laboratory) - (object ^name lever ^state thrown) - (input give <x> to monster) - --> - (remove 4) - (make input give <x>)) - -(p name2128 - (location ^name laboratory) - (object ^name monster ^place laboratory) - (object ^name lever ^state thrown) - (input throw <x>) - --> - (remove 4) - (make input give <x>)) - -(p name2129 - (location ^name laboratory) - (object ^name dome ^state broken) - (time ^morning t) - --> - (write (crlf) |Light shows throught the hole.|)) - -(p name2130 - (location ^name laboratory) - (object ^name matches ^place laboratory) - (time ^morning t) - --> - (write (crlf) |Even in the sun light the matches don't dry.|) - (write (crlf) |The laboratory is damp and musty.|)) - -(p name2131 - (location ^name laboratory) - (input dry matches) - --> - (remove 2) - (write (crlf) |The laboratory is very damp.|)) - -(p name2132 - (location ^name laboratory) - (object ^name dome ^state broken) - (time ^morning nil) - --> - (write (crlf) |You can see the moon through the dome.|)) - -(p name2133 - (location ^name laboratory) - (object ^name monster ^place laboratory) - (object ^name cube ^place held) - (object ^name lever ^state thrown) - (input give cube) - --> - (remove 2) - (remove 3) - (remove 5) - (write (crlf) |The monster eats the cube. He then starts saying 'ohhh, ahhhh'.|) - (write (crlf) |'Out of sight man.' Then he jumps straight up through the dome.|) - (make object ^name dome ^state broken)) - -(p name2134 - (location ^name bar) - (location ^name bar) - (place ^name bar ^visited nil) - --> - (write (crlf) |You are in a bar. There isn't any booze.|)) - -(p name2135 - (location ^name bar) - (status ^going e) - (place ^name bar) - --> - (modify 1 ^name laboratory) - (modify 2 ^going nil) - (modify 3 ^visited t)) - -(p name2136 - (location ^name wine_racks) - --> - (write (crlf) |You are in rows of wine racks that stretch out of sight in all directions.|)) - -(p name2137 - (location ^name wine_racks ^east <e>) - (status ^going e) - --> - (remove 1) - (modify 2 ^going nil) - (modify 1 ^name wine_racks ^east (compute 1 + <e>))) - diff --git a/contrib/ops/mab.ops b/contrib/ops/mab.ops deleted file mode 100644 index 9632ad56e7d15de8ba8134cc0ba3c8c7720bf05c..0000000000000000000000000000000000000000 --- a/contrib/ops/mab.ops +++ /dev/null @@ -1,174 +0,0 @@ -(literalize start) - -(literalize monkey - at - on - holds) - -(literalize object - name - at - weight - on) - -(literalize goal - status - type - object - to) - -(p mb1 - (goal ^status active ^type holds ^object <w>) - (object ^name <w> ^at <p> ^on ceiling) - --> - (make goal ^status active ^type move ^object ladder ^to <p>)) - - -(p mb2 - (goal ^status active ^type holds ^object <w>) - (object ^name <w> ^at <p> ^on ceiling) - (object ^name ladder ^at <p>) - --> - (make goal ^status active ^type on ^object ladder)) - -(p mb4 - (goal ^status active ^type holds ^object <w>) - (object ^name <w> ^at <p> ^on ceiling) - (object ^name ladder ^at <p>) - (monkey ^on ladder ^holds nil) - --> - (write (crlf) grab <w>) - (modify 4 ^holds <w>) - (modify 1 ^status satisfied)) - -(p mb3 - (goal ^status active ^type holds ^object <w>) - (object ^name <w> ^at <p> ^on ceiling) - (object ^name ladder ^at <p>) - (monkey ^on ladder) - --> - (make goal ^status active ^type holds ^object nil)) - -(p mb5 - (goal ^status active ^type holds ^object <w>) - (object ^name <w> ^at <p> ^on floor) - --> - (make goal ^status active ^type walk-to ^object <p>)) - -(p mb7 - (goal ^status active ^type holds ^object <w>) - (object ^name <w> ^at <p> ^on floor) - (monkey ^at <p> ^holds nil) - --> - (write (crlf) grab <w>) - (modify 3 ^holds <w>) - (modify 1 ^status satisfied)) - -(p mb6 - (goal ^status active ^type holds ^object <w>) - (object ^name <w> ^at <p> ^on floor) - (monkey ^at <p>) - --> - (make goal ^status active ^type holds ^object nil)) - -(p mb8 - (goal ^status active ^type move ^object <o> ^to <p>) - (object ^name <o> ^weight light ^at <> <p>) - --> - (make goal ^status active ^type holds ^object <o>)) - - -(p mb9 - (goal ^status active ^type move ^object <o> ^to <p>) - (object ^name <o> ^weight light ^at <> <p>) - (monkey ^holds <o>) - --> - (make goal ^status active ^type walk-to ^object <p>)) - - -(p mb10 - (goal ^status active ^type move ^object <o> ^to <p>) - (object ^name <o> ^weight light ^at <p>) - --> - (modify 1 ^status satisfied)) - - -(p mb11 - (goal ^status active ^type walk-to ^object <p>) - --> - (make goal ^status active ^type on ^object floor)) - -(p mb12 - (goal ^status active ^type walk-to ^object <p>) - (monkey ^on floor ^at {<c> <> <p>} ^holds nil) - --> - (write (crlf) walk to <p>) - (modify 2 ^at <p>) - (modify 1 ^status satisfied)) - - -(p mb13 - (goal ^status active ^type walk-to ^object <p>) - (monkey ^on floor ^at {<c> <> <p>} ^holds {<w> <> nil}) - (object ^name <w>) - --> - (write (crlf) walk to <p>) - (modify 2 ^at <p>) - (modify 3 ^at <p>) - (modify 1 ^status satisfied)) - -(p mb14 - (goal ^status active ^type on ^object floor) - (monkey ^on {<x> <> floor}) - --> - (write (crlf) jump onto the floor) - (modify 2 ^on floor) - (modify 1 ^status satisfied)) - -(p mb15 - (goal ^status active ^type on ^object <o>) - (object ^name <o> ^at <p>) - --> - (make goal ^status active ^type walk-to ^object <p>)) - - - -(p mb16 - (goal ^status active ^type on ^object <o>) - (object ^name <o> ^at <p>) - (monkey ^at <p>) - --> - (make goal ^status active ^type holds ^object nil)) - - -(p mb17 - (goal ^status active ^type on ^object <o>) - (object ^name <o> ^at <p>) - (monkey ^at <p> ^holds nil) - --> - (write (crlf) climb onto <o>) - (modify 3 ^on <o>) - (modify 1 ^status satisfied)) - -(p mb18 - (goal ^status active ^type holds ^object nil) - (monkey ^holds {<x> <> nil}) - --> - (write (crlf) drop <x>) - (modify 2 ^holds nil) - (modify 1 ^status satisfied)) - -(p mb19 - (goal ^status active) - --> - (modify 1 ^status not-processed)) - -(p t1 - (start) - --> - (make monkey ^at 5-7 ^on couch) - (make object ^name couch ^at 5-7 ^weight heavy) - (make object ^name bananas ^on ceiling ^at 2-2) - (make object ^name ladder ^on floor ^at 9-5 ^weight light) - (make goal ^status active ^type holds ^object bananas)) - diff --git a/contrib/ops/myw.ops b/contrib/ops/myw.ops deleted file mode 100644 index f78a299b33e9df44829aaea7b6d92a734a964a86..0000000000000000000000000000000000000000 --- a/contrib/ops/myw.ops +++ /dev/null @@ -1,9029 +0,0 @@ -(literalize unit unit-name file-name) - -(literalize pin net-name pin-name external-net-name external-pin-name pin-left-x pin-left-y fixed-pin pin-x pin-y pin-layer pin-layer-constraint pin-channel-side pin-is-attached) - -(literalize channel channel-bottom-left-x channel-bottom-left-y channel-top-right-x channel-top-right-y channel-width channel-length no-of-left-pins no-of-right-pins no-of-bottom-pins no-of-top-pins right-fixed left-fixed bottom-fixed top-fixed channel-type no-of-fixed-sides) - -(literalize net net-name parent-name net-no-of-pins net-left-x net-left-y net-right-x net-right-y no-of-left-pins no-of-right-pins no-of-top-pins no-of-bottom-pins net-is-routed left-most-pin-name right-most-pin-name bottom-most-pin-name top-most-pin-name fixed-net net-layer external-net-name no-of-inter max-no-of-via) - -(literalize layer-info layer-name layer-order layer-priority) - -(literalize context present previous saved) - -(literalize ff net-name pin-name grid-layer grid-x grid-y came-from can-chng-layer) - -(literalize next-net-to-be-routed net-name no-of-attached-pins criteria) - -(literalize to-be-routed net-name no-of-attached-pins) - -(literalize occupied x y m) - -(literalize constraint constraint-type constraint-relation channel-side constraint-reason net-name-1 net-name-2 pin-name-1 pin-name-2 seg-id-1 seg-id-2) - -(literalize congestion direction coordinate no-of-nets extra-nets como) - -(literalize intersection net-name direction min max) - -(literalize horizontal min max com compo commo layer status min-net max-net net-name pin-name) - -(literalize vertical min max com compo commo layer status min-net max-net net-name pin-name) - -(literalize horizontal-s net-name min max com id top-count bot-count sum difference absolute side) - -(literalize vertical-s net-name min max com id top-count bot-count sum difference absolute side) - -(literalize total net-name row-col coor level-pins total-pins cong min-xy max-xy last-pin last-xy nets) - -(literalize tree net-name orientation com min max count id) - -(vector-attribute nets) - -(p p327 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> > <min> } ^com 1 ^id <id>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side bottom) - (constraint ^constraint-type vertical ^seg-id-1 <id>) - (total ^net-name <> <nn>) - - (total-verti <nn>) - --> - (remove <t>) -) - -(p p328 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> < <max> } ^max { <hmax> >= <gx> } ^com <lr> ^id <id>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <> <id>) - (last-row <lr>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side top) - (constraint ^constraint-type vertical ^seg-id-2 <id>) - (total ^net-name <> <nn>) - - (total-verti <nn>) - --> - (remove <t>) -) - -(p p329 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> > <min> } ^com 1 ^id <id>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side left) - (constraint ^constraint-type horizontal ^seg-id-1 <id>) - (total ^net-name <> <nn>) - - (total-verti <nn>) - --> - (remove <t>) -) - -(p p330 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> < <max> } ^max { <vmax> >= <gy> } ^com <lc> ^id <id>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <> <id>) - (last-col <lc>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side right) - (constraint ^constraint-type horizontal ^seg-id-2 <id>) - (total ^net-name <> <nn>) - - (total-verti <nn>) - --> - (remove <t>) -) - -(p p331 - { <c> (context ^present modify-total) } - --> - (modify <c> ^present delete-total) -) - -(p p332 - { <c> (context ^present delete-total) } - - (total) - --> - (remove <c>) - (make context ^previous find-no-of-pins-on-a-row-col) -) - -(p p333 - { <c> (context ^present extend-total) } - (last-row <lr>) - --> - (make maximum-total 0 0 0 1 0 <lr> 0) - (make merge-direction left) - (modify <c> ^present merge) - (make eliminate-total) -) - -(p p334 - { <c> (context ^present delete-total) } - --> - (modify <c> ^present extend-total) -) - -(p p335 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> } ^com 1 ^id <id> ^absolute <a> ^sum <s>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>) - - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <hmax> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side bottom) - --> - (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <hmax>) -) - -(p p336 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> } ^com <lr> ^id <id> ^absolute <a> ^sum <s>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <> <id>) - - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <hmax> ^last-pin checked) - (last-row <lr>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side top) - --> - (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <hmax>) -) - -(p p337 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com 1 ^id <id> ^absolute <a> ^sum <s>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>) - - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <vmax> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side left) - --> - (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <vmax>) -) - -(p p338 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com <lc> ^id <id> ^absolute <a> ^sum <s>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <> <id>) - - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <vmax> ^last-pin checked) - (last-col <lc>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side right) - --> - (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <vmax>) -) - -(p p339 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min 1 ^max { <hmax> >= <gx> } ^com <com> ^id <id> ^absolute <a> ^sum <s>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>) - - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy 1 ^max-xy <hmax> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x 0 ^pin-y <com> ^pin-channel-side left) - --> - (make (substr <t> 1 inf) ^min-xy 1 ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> 1 <hmax>) -) - -(p p340 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max <lc> ^com <com> ^id <id> ^absolute <a> ^sum <s>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>) - - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <lc> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-y <com> ^pin-channel-side right) - (last-col <lc>) - --> - (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <lc> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <lc>) -) - -(p p341 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min 1 ^max { <vmax> >= <gy> } ^com <com> ^id <id> ^absolute <a> ^sum <s>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>) - - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy 1 ^max-xy <vmax> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x <com> ^pin-channel-side bottom) - --> - (make (substr <t> 1 inf) ^min-xy 1 ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> 1 <vmax>) -) - -(p p342 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max <lr> ^com <com> ^id <id> ^absolute <a> ^sum <s>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>) - - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <lr> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x <com> ^pin-channel-side top) - (last-row <lr>) - --> - (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <lr> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <lr>) -) - -(p p343 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (total ^net-name <nn> ^row-col <rc> ^coor <y> ^last-pin checked) - --> - (remove <t>) -) - -(p p344 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - --> - (remove <t>) -) - -(p p345 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (net ^net-name <nn> ^net-no-of-pins 2) - --> - (modify <t> ^last-pin checked ^nets <nn> <min> <max>) -) - -(p p346 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - - (total ^last-pin checked) - --> - (modify <t> ^last-pin checked ^nets <nn> <min> <max>) -) - -(p p347 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) } - (last-col <lc>) - (horizontal-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { >= <min> <> <lc> } ^com <y> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x 0 ^pin-y <y>) - - (pin ^net-name <nn> ^pin-y <y> ^pin-channel-side right) - --> - (remove <t>) -) - -(p p348 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <tmin> ^max-xy <max>) } - (last-col <lc>) - (horizontal-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { <maxs> <> <lc> } ^com <y> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x 0 ^pin-y <y>) - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com { <min> > 1 <= <maxs> }) - - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com < <min>) - { <h> (horizontal ^net-name <nn1> ^min 0 ^max { <hmax> < <min> } ^com <y> ^layer <lay>) } - { <ff> (ff ^net-name <nn1> ^grid-x <hmax> ^grid-y <y> ^grid-layer <lay> ^came-from west) } - { <h1> (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <y> ^layer <lay>) } - - (pin ^net-name <nn> ^pin-y <y>) - - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <y> ^max >= <y> ^com <min> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <min> ^max >= <min> ^com <y> ^layer <lay>) - --> - (remove <t>) - (modify <h> ^max <min>) - (modify <h1> ^min <min> ^min-net <nn1>) - (modify <ff> ^grid-x <min> ^can-chng-layer nil) -) - -(p p349 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) } - (last-col <lc>) - (horizontal-s ^net-name { <nn1> <> <nn> } ^min { <= <max> <> 1 } ^max <lc> ^com <y> ^id <=> 1) - (pin ^net-name <nn1> ^pin-y <y> ^pin-channel-side right) - - (pin ^net-name <nn> ^pin-y <y> ^pin-channel-side left) - --> - (remove <t>) -) - -(p p350 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <tmax>) } - (last-col <lc>) - (horizontal-s ^net-name { <nn1> <> <nn> } ^min { <mins> <> 1 } ^max <lc> ^com <y> ^id <=> 1) - (pin ^net-name <nn1> ^pin-y <y> ^pin-channel-side right) - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com { <max> >= <mins> < <lc> }) - - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com > <max>) - { <h> (horizontal ^net-name <nn1> ^min { <hmin> > <max> } ^max <garb> ^com <y> ^layer <lay>) } - { <ff> (ff ^net-name <nn1> ^grid-x <hmin> ^grid-y <y> ^grid-layer <lay> ^came-from east) } - { <h1> (horizontal ^net-name nil ^min < <max> ^max <hmin> ^com <y> ^layer <lay>) } - - (pin ^net-name <nn> ^pin-y <y>) - - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <y> ^max >= <y> ^com <max> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <max> ^max >= <max> ^com <y> ^layer <lay>) - --> - (remove <t>) - (modify <h> ^min <max>) - (modify <h1> ^max <max> ^max-net <nn1>) - (modify <ff> ^grid-x <max> ^can-chng-layer nil) -) - -(p p351 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) } - (last-row <lr>) - (vertical-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { >= <min> <> <lr> } ^com <x> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x <x> ^pin-channel-side top) - --> - (remove <t>) -) - -(p p352 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <tmin> ^max-xy <max>) } - (last-row <lr>) - (vertical-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { <maxs> <> <lr> } ^com <x> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side bottom) - (horizontal ^net-name <nn> ^min <= <x> ^max <x> ^com { <min> > 1 <= <maxs> }) - - (horizontal ^net-name <nn> ^min <= <x> ^max <x> ^com < <min>) - { <v> (vertical ^net-name <nn1> ^min 0 ^max { <vmax> < <min> } ^com <x> ^layer <lay>) } - { <ff> (ff ^net-name <nn1> ^grid-x <x> ^grid-y <vmax> ^grid-layer <lay> ^came-from south) } - { <v1> (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <x> ^layer <lay>) } - - (pin ^net-name <nn> ^pin-x <x>) - - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <min> ^max >= <min> ^com <x>) - - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <x> ^max >= <x> ^com <min>) - --> - (remove <t>) - (modify <v> ^max <min>) - (modify <v1> ^min <min> ^min-net <nn1>) - (modify <ff> ^grid-y <min> ^can-chng-layer nil) -) - -(p p353 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) } - (last-row <lr>) - (vertical-s ^net-name { <nn1> <> <nn> } ^min { <= <max> <> 1 } ^max <lr> ^com <x> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x <x> ^pin-channel-side bottom) - --> - (remove <t>) -) - -(p p354 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <tmax>) } - (last-row <lr>) - (vertical-s ^net-name { <nn1> <> <nn> } ^min { <mins> <> 1 } ^max <lr> ^com <x> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side top) - (horizontal ^net-name <nn> ^min <= <x> ^max >= <x> ^com { <max> >= <mins> < <lr> }) - - (horizontal ^net-name <nn> ^min <= <x> ^max >= <x> ^com > <max>) - { <v> (vertical ^net-name <nn1> ^min { <vmin> > <max> } ^max <garb> ^com <x> ^layer <lay>) } - { <ff> (ff ^net-name <nn1> ^grid-x <x> ^grid-y <vmin> ^grid-layer <lay> ^came-from north) } - { <v1> (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <x> ^layer <lay>) } - - (pin ^net-name <nn> ^pin-x <x>) - - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <max> ^max >= <max> ^com <x>) - - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <x> ^max >= <x> ^com <max>) - --> - (remove <t>) - (modify <v> ^min <max>) - (modify <v1> ^max <max> ^max-net <nn1>) - (modify <ff> ^grid-y <max> ^can-chng-layer nil) -) - -(p p355 - (context ^present extend-total) - - (switch-box) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>) } - (last-row > <y>) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>) - - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>) - - (horizontal ^net-name <nn> ^min <= <min> ^max >= <min> ^com <y>) - - (horizontal ^net-name <nn> ^min <= <max> ^max >= <max> ^com <y>) - - (horizontal ^net-name <nn> ^min >= <min> ^max <= <max> ^com <y>) - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com > <y>) - - (ff ^net-name <nn> ^grid-x { >= <min> <= <max> } ^grid-y <y> ^pin-name >= 1000) - --> - (modify <t> ^coor (compute <y> + 1)) -) - -(p p356 - (context ^present extend-total) - - (switch-box) - { <t> (total ^net-name <nn> ^row-col row ^coor { <y> > 0 } ^min-xy <min> ^max-xy <max> ^last-xy <id>) } - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <id>) - (last-row <lr>) - - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>) - - (horizontal ^net-name <nn> ^min <= <min> ^max >= <min> ^com <y>) - - (horizontal ^net-name <nn> ^min <= <max> ^max >= <max> ^com <y>) - - (horizontal ^net-name <nn> ^min >= <min> ^max <= <max> ^com <y>) - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com < <y>) - - (ff ^net-name <nn> ^grid-x { >= <min> <= <max> } ^grid-y <y> ^pin-name >= 1000) - --> - (modify <t> ^coor (compute <y> - 1)) -) - -(p p357 - (context ^present extend-total) - - (switch-box) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>) } - (last-col > <x>) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>) - - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>) - - (vertical ^net-name <nn> ^min <= <min> ^max >= <min> ^com <x>) - - (vertical ^net-name <nn> ^min <= <max> ^max >= <max> ^com <x>) - - (vertical ^net-name <nn> ^min >= <min> ^max <= <max> ^com <x>) - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com > <x>) - - (ff ^net-name <nn> ^grid-x <x> ^grid-y { >= <min> <= <max> } ^pin-name >= 1000) - --> - (modify <t> ^coor (compute <x> + 1)) -) - -(p p358 - (context ^present extend-total) - - (switch-box) - { <t> (total ^net-name <nn> ^row-col col ^coor { <x> > 0 } ^min-xy <min> ^max-xy <max> ^last-xy <id>) } - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <id>) - (last-col <lc>) - - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>) - - (vertical ^net-name <nn> ^min <= <min> ^max >= <min> ^com <x>) - - (vertical ^net-name <nn> ^min <= <max> ^max >= <max> ^com <x>) - - (vertical ^net-name <nn> ^min >= <min> ^max <= <max> ^com <x>) - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com < <x>) - - (ff ^net-name <nn> ^grid-x <x> ^grid-y { >= <min> <= <max> } ^pin-name >= 1000) - --> - (modify <t> ^coor (compute <x> - 1)) -) - -(p p359 - (context ^present extend-total) - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>) - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> < <y> } ^grid-layer <lay> ^pin-name <pn>) } - { <v> (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> >= <y> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <y> ^max >= <y> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <y> ^layer <lay>) - --> - (make vertical ^min <y> ^max <vmax> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>) - (modify <v> ^max <gy> ^max-net <nn>) - (make vertical ^min <gy> ^max <y> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>) - (modify <ff> ^grid-y <y> ^came-from south ^can-chng-layer nil) -) - -(p p360 - (context ^present extend-total) - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <id>) - (last-row <lr>) - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> > <y> } ^grid-layer <lay> ^pin-name <pn>) } - { <v> (vertical ^net-name nil ^min { <vmin> <= <y> } ^max { <vmax> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <y> ^max >= <y> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <y> ^layer <lay>) - --> - (make vertical ^min <gy> ^max <vmax> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>) - (modify <v> ^max <y> ^max-net <nn>) - (make vertical ^min <y> ^max <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>) - (modify <ff> ^grid-y <y> ^came-from north ^can-chng-layer nil) -) - -(p p361 - (context ^present extend-total) - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>) - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx> < <x> } ^grid-y { <gy> >= <min> <= <max> } ^grid-layer <lay> ^pin-name <pn>) } - { <v> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> >= <x> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <x> ^max >= <x> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <x> ^layer <lay>) - --> - (make horizontal ^min <x> ^max <hmax> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>) - (modify <v> ^max <gx> ^max-net <nn>) - (make horizontal ^min <gx> ^max <x> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>) - (modify <ff> ^grid-x <x> ^came-from west ^can-chng-layer nil) -) - -(p p362 - (context ^present extend-total) - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <id>) - (last-col <lc>) - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx> > <x> } ^grid-y { <gy> >= <min> <= <max> } ^grid-layer <lay> ^pin-name <pn>) } - { <v> (horizontal ^net-name nil ^min { <hmin> <= <x> } ^max { <hmax> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <x> ^max >= <x> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <x> ^layer <lay>) - --> - (make horizontal ^min <gx> ^max <hmax> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>) - (modify <v> ^max <x> ^max-net <nn>) - (make horizontal ^min <x> ^max <gx> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>) - (modify <ff> ^grid-x <x> ^came-from east ^can-chng-layer nil) -) - -(p p490 - { <c> (context ^present separate) } - --> - (modify <c> ^present reconnect) -) - -(p p491 - { <c> (context ^present reconnect) } - --> - (modify <c> ^present form-verti) -) - -(p p492 - { <c> (context ^present form-verti) } - --> - (modify <c> ^present partial-route) -) - -(p p493 - { <c> (context ^present partial-route) } - --> - (modify <c> ^present extend-pins) -) - -(p p494 - { <c1> (context ^present extend-pins) } - --> - (modify <c1> ^present nil ^previous extend-pins) -) - -(p p495 - { <c1> (context ^previous extend-pins) } - --> - (make switch-box) - (make context ^present propagate-constraint) - (remove <c1>) -) - -(p p496 - { <c1> (context ^previous extend-pins) } - (channel ^no-of-left-pins 0 ^no-of-right-pins 0) - --> - (remove <c1>) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p497 - { <c1> (context ^previous extend-pins) } - (channel ^no-of-bottom-pins 0 ^no-of-top-pins 0) - --> - (remove <c1>) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p498 - (context ^previous propagate-constraint) - (net ^net-is-routed <> yes) - --> - (remove 1) - (make context ^present lshape1) -) - -(p p499 - (context ^present lshape1) - --> - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p500 - { <c> (context ^previous find-no-of-pins-on-a-row-col) } - - (total) - - (extend-ff-tried) - --> - (remove <c>) - (make context ^present lshape4) -) - -(p p501 - { <c> (context ^present lshape4) } - --> - (remove <c>) - (make extend-ff-tried) - (make context ^present extend-ff) -) - -(p p502 - { <c> (context ^present extend-ff) } - --> - (remove <c>) - (make context ^previous extend-ff) -) - -(p p503 - { <c> (context ^previous extend-ff) } - - (extended-ff) - --> - (remove <c>) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p504 - { <c> (context ^previous extend-ff) } - { <e> (extended-ff) } - { <ex> (extend-ff-tried) } - --> - (remove <c> <e> <ex>) - (make context ^present find-no-of-pins-on-a-row-col) - (make goal cleanup extended-ff) -) - -(p p505 - (context ^previous find-no-of-pins-on-a-row-col) - - (total) - (extend-ff-tried) - - (total-verti) - --> - (remove 1) - (make context ^present find-no-of-vcg-hcg) - (make goal cleanup counted-verti) -) - -(p p506 - (context ^previous find-no-of-pins-on-a-row-col) - - (total) - (total-verti) - - (verti-has-loop) - --> - (remove 1) - (make verti-has-loop) - (make context ^present choose-between-total-verti) -) - -(p p507 - (context ^previous find-no-of-pins-on-a-row-col) - - (total) - (total-verti) - (verti-has-loop) - --> - (make context ^present extend-h-v-s) - (make goal cleanup total-verti) - (make goal cleanup counted-verti) - (make goal cleanup extend-ff-tried) - (remove 1 3) -) - -(p p508 - (context ^present choose-between-total-verti) - - (total-verti ^4 > 0) - --> - (modify 1 ^present extend-h-v-s) - (make goal cleanup counted-verti) -) - -(p p509 - (context ^previous find-no-of-vcg-hcg) - - (total-verti) - --> - (remove 1) - (make context ^present extend-h-v-s) -) - -(p p510 - (context ^present loose-constraint) - --> - (make context ^present lshape2) - (remove 1) -) - -(p p511 - (context ^present lshape2) - --> - (modify 1 ^present lshape3) -) - -(p p512 - (context ^present lshape3) - --> - (remove 1) - (make context ^present random0) -) - -(p p513 - (context ^present random0) - --> - (remove 1) - (make context ^present random1) -) - -(p p514 - (context ^present remove-routed-net-segments) - - (net ^net-is-routed <> yes) - - (horizontal ^net-name <> nil ^status nil) - - (vertical ^net-name <> nil ^status nil) - --> - (write (crlf) | Finished with the routing.|) - (halt) -) - -(p p1 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^com <min>) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top) - - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>) - (pin ^net-name <> <nn> ^pin-x <min> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { < <px> > <min> }) - (pin ^net-name <nn> ^pin-x > <px> ^pin-channel-side top) - --> - (modify <h> ^min <px>) - (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p2 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^com <min>) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom) - - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>) - (pin ^net-name <> <nn> ^pin-x <min> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { < <px> > <min> }) - (pin ^net-name <nn> ^pin-x > <px> ^pin-channel-side bottom) - --> - (modify <h> ^min <px>) - (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p3 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^com <max>) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top) - - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>) - (pin ^net-name <> <nn> ^pin-x <max> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { < <max> > <px> }) - (pin ^net-name <nn> ^pin-x < <px> ^pin-channel-side top) - --> - (modify <h> ^max <px>) - (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p4 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^com <max>) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom) - - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>) - (pin ^net-name <> <nn> ^pin-x <max> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { < <max> > <px> }) - (pin ^net-name <nn> ^pin-x < <px> ^pin-channel-side bottom) - --> - (modify <h> ^max <px>) - (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p5 - (context ^present reconnect) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top) - - (pin ^pin-x <max> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^max <max>) -) - -(p p6 - (context ^present reconnect) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom) - - (pin ^pin-x <min> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^min <min>) -) - -(p p7 - (context ^present reconnect) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top) - - (pin ^pin-x <max> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^max <max>) -) - -(p p8 - (context ^present reconnect) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom) - - (pin ^pin-x <min> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^min <min>) -) - -(p p9 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <com>) - { <v> (vertical-s ^net-name <nn> ^com { <com1> >= <min1> <= <max1> }) } - (pin ^net-name <> <nn> ^pin-x <com1>) - (congestion ^direction col ^coordinate { <px> >= <min1> <= <max1> }) - - (pin ^net-name <> <nn> ^pin-x <px>) - - (vertical-s ^com <px>) - --> - (modify <v> ^com <px>) -) - -(p p10 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <com>) - { <v> (vertical-s ^net-name <nn> ^com { <com1> >= <min1> <= <max> }) } - (pin ^net-name <> <nn> ^pin-x <com1>) - (congestion ^direction col ^coordinate { <px> >= <min1> <= <max> }) - - (pin ^net-name <> <nn> ^pin-x <px>) - - (vertical-s ^com <px>) - --> - (modify <v> ^com <px>) -) - -(p p11 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <hcom>) - - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max1> }) - { <v> (vertical-s ^net-name <nn> ^com { <vcom> < <min1> }) } - - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>) - --> - (modify <v> ^com <min1>) -) - -(p p12 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <hcom>) - - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max1> }) - { <v> (vertical-s ^net-name <nn> ^com { <vcom> > <max1> }) } - - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>) - --> - (modify <v> ^com <max1>) -) - -(p p13 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <hcom>) - - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max> }) - { <v> (vertical-s ^net-name <nn> ^com { <vcom> < <min1> }) } - - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>) - --> - (modify <v> ^com <min1>) -) - -(p p14 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <hcom>) - - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max> }) - { <v> (vertical-s ^net-name <nn> ^com { <vcom> > <max> }) } - - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>) - --> - (modify <v> ^com <max>) -) - -(p p15 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min1> ^max <max1> ^id <id1>) - { <h> (horizontal-s ^net-name <nn> ^min <max1> ^max <max2> ^com <com> ^id <id2>) } - (horizontal-s ^net-name <nn> ^min <max2> ^max <max3> ^id <id3>) - - (horizontal-s ^net-name <nn> ^id { <> <id1> <> <id2> <> <id3> }) - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max1>) - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max2>) - --> - (modify <h> ^min <min1> ^max <max3>) -) - -(p p16 - (context ^present reconnect) - (vertical-s ^net-name <nn> ^min <min1> ^max <max1> ^id <id1>) - { <h> (vertical-s ^net-name <nn> ^min <max1> ^max <max2> ^com <com> ^id <id2>) } - (vertical-s ^net-name <nn> ^min <max2> ^max <max3> ^id <id3>) - - (vertical-s ^net-name <nn> ^id { <> <id1> <> <id2> <> <id3> }) - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max1>) - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max2>) - --> - (modify <h> ^min <min1> ^max <max3>) -) - -(p p17 - (context ^present separate) - { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <max>) - (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side right) - - (pin ^net-name <nn> ^pin-x > <com> ^pin-y { > <py> <= <max> }) - - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side top) - - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <py> < <max> }) - - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <max>) - --> - (modify <v> ^max <py>) - (make vertical-s ^net-name <nn> ^min <py> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p18 - (context ^present separate) - { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <max>) - (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side left) - - (pin ^net-name <nn> ^pin-x < <com> ^pin-y { > <py> <= <max> }) - - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side top) - - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <py> < <max> }) - - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <max>) - --> - (modify <v> ^max <py>) - (make vertical-s ^net-name <nn> ^min <py> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p19 - (context ^present separate) - { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <min>) - (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side right) - - (pin ^net-name <nn> ^pin-x > <com> ^pin-y { < <py> >= <min> }) - - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side bottom) - - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <py> }) - - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <min>) - --> - (modify <v> ^min <py>) - (make vertical-s ^net-name <nn> ^min <min> ^max <py> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p20 - (context ^present separate) - { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <min>) - (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side left) - - (pin ^net-name <nn> ^pin-x < <com> ^pin-y { < <py> >= <min> }) - - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side bottom) - - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <py> }) - - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <min>) - --> - (modify <v> ^min <py>) - (make vertical-s ^net-name <nn> ^min <min> ^max <py> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p21 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <min>) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { < <px> >= <min> } ^pin-y > <com>) - - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side left) - - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <px> }) - - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <min>) - --> - (modify <h> ^min <px>) - (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p22 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <min>) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { < <px> >= <min> } ^pin-y < <com>) - - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side left) - - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <px> }) - - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <min>) - --> - (modify <h> ^min <px>) - (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p23 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <max>) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { > <px> <= <max> } ^pin-y > <com>) - - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side right) - - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <px> < <max> }) - - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <max>) - --> - (modify <h> ^max <px>) - (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p24 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <max>) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { > <px> <= <max> } ^pin-y < <com>) - - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side right) - - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <px> < <max> }) - - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <max>) - --> - (modify <h> ^max <px>) - (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p604 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side top) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>) - - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical) -) - -(p p605 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side bottom) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>) - - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top) - - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>) - --> - (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical) -) - -(p p606 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side top) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1> ^com 1) - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical) -) - -(p p607 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side bottom) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1> ^com <> 1) - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top) - - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>) - --> - (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical) -) - -(p p608 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0) - (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side top) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical) -) - -(p p609 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0) - (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side bottom) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top) - - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>) - --> - (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical) -) - -(p p610 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com 1 ^id <id>) - (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <lr> ^id <id1>) - (last-row <lr>) - (vertical-s ^net-name <bnn> ^com <vcom>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side top) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical) -) - -(p p611 - (context ^present form-verti) - (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y { <vcom> >= <min> <= <max> } ^pin-channel-side right) - (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal) -) - -(p p612 - (context ^present form-verti) - (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y { <vcom> >= <min> <= <max> } ^pin-channel-side left) - (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side right) - - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>) - --> - (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type horizontal) -) - -(p p613 - (context ^present form-verti) - (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0) - (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side right) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal) -) - -(p p614 - (context ^present form-verti) - (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0) - (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side left) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side right) - - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>) - --> - (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type horizontal) -) - -(p p615 - (context ^present form-verti) - (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com 1 ^id <id>) - (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <lc> ^id <id1>) - (last-col <lc>) - (horizontal-s ^net-name <bnn> ^com <vcom>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side right) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal) -) - -(p p616 - (context ^present form-verti) - (constraint ^constraint-type vertical ^net-name-1 <tnn> ^net-name-2 <bnn> ^seg-id-1 <tid> ^seg-id-2 <bid>) - (constraint ^constraint-type vertical ^net-name-1 <nn1> ^net-name-2 <tnn> ^seg-id-1 <id1> ^seg-id-2 <tid2>) - - (vertical-cycle <tnn> <tid> <tid2>) - --> - (make vertical-cycle <tnn> <tid> <tid2>) -) - -(p p617 - (context ^present form-verti) - (constraint ^constraint-type horizontal ^net-name-1 <tnn> ^net-name-2 <bnn> ^seg-id-1 <tid> ^seg-id-2 <bid>) - (constraint ^constraint-type horizontal ^net-name-1 <nn1> ^net-name-2 <tnn> ^seg-id-1 <id1> ^seg-id-2 <tid2>) - - (horizontal-cycle <tnn> <tid> <tid2>) - --> - (make horizontal-cycle <tnn> <tid> <tid2>) -) - -(p p618 - (context ^present remove-cycle) - { <h> (horizontal-cycle <nn>) } - - (constraint ^constraint-type horizontal ^net-name-1 <nn>) - - (constraint ^constraint-type horizontal ^net-name-2 <nn>) - --> - (remove <h>) -) - -(p p619 - (context ^present remove-cycle) - { <h> (horizontal-cycle <nn>) } - - (constraint ^constraint-type horizontal ^net-name-2 <nn>) - --> - (remove <h>) -) - -(p p620 - (context ^present remove-cycle) - { <h> (horizontal-cycle <nn>) } - - (constraint ^constraint-type horizontal ^net-name-1 <nn>) - --> - (remove <h>) -) - -(p p621 - (context ^present remove-cycle) - { <h> (vertical-cycle <nn>) } - - (constraint ^constraint-type vertical ^net-name-1 <nn>) - - (constraint ^constraint-type vertical ^net-name-2 <nn>) - --> - (remove <h>) -) - -(p p622 - (context ^present remove-cycle) - { <h> (vertical-cycle <nn>) } - - (constraint ^constraint-type vertical ^net-name-2 <nn>) - --> - (remove <h>) -) - -(p p623 - (context ^present remove-cycle) - { <h> (vertical-cycle <nn>) } - - (constraint ^constraint-type vertical ^net-name-1 <nn>) - --> - (remove <h>) -) - -(p p624 - { <c> (context ^present remove-cycle) } - --> - (remove <c>) -) - -(p p625 - (context ^present remove-cycle) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <max>) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^max <max>) -) - -(p p626 - (context ^present remove-cycle) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <min>) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^min <min>) -) - -(p p627 - (context ^present remove-cycle) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <max>) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^max <max>) -) - -(p p628 - (context ^present remove-cycle) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <min>) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^min <min>) -) - -(p p629 - (context ^present remove-cycle) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com 1) - (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from south) - - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y < <gy>) - - (vertical-s ^net-name <nn> ^min 1 ^max > <gy> ^com <gx>) - --> - (make vertical-s ^net-name <nn> ^min 1 ^max (compute <gy> + 1) ^com <gx> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) -) - -(p p630 - (context ^present remove-cycle) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com 1) - (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from south) - - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y <= <gy>) - { <v> (vertical-s ^net-name <nn> ^min 1 ^max <= <gy> ^com <gx>) } - --> - (modify <v> ^max (compute <gy> + 1)) -) - -(p p631 - (context ^present remove-cycle) - (last-row <lr>) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com <lr>) - (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from north) - - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y > <gy>) - - (vertical-s ^net-name <nn> ^min < <gy> ^max <lr> ^com <gx>) - --> - (make vertical-s ^net-name <nn> ^min (compute <gy> - 1) ^max <lr> ^com <gx> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) -) - -(p p632 - (context ^present remove-cycle) - (last-row <lr>) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com <lr>) - (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from north) - - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y >= <gy>) - { <v> (vertical-s ^net-name <nn> ^min >= <gy> ^max <lr> ^com <gx>) } - --> - (modify <v> ^min (compute <gy> - 1)) -) - -(p p633 - (context ^present remove-cycle) - (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com 1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from west) - - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y <> <gy>) - - (horizontal-s ^net-name <nn> ^min 1 ^max > <gx> ^com <gy>) - --> - (make horizontal-s ^net-name <nn> ^min 1 ^max (compute <gx> + 1) ^com <gy> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) -) - -(p p634 - (context ^present remove-cycle) - (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com 1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from west) - - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y <> <gy>) - { <h> (horizontal-s ^net-name <nn> ^min 1 ^max <= <gx> ^com <gy>) } - --> - (modify <h> ^max (compute <gx> + 1)) -) - -(p p635 - (context ^present remove-cycle) - (last-col <lc>) - (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com <lc>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from east) - - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y <> <gy>) - - (horizontal-s ^net-name <nn> ^min < <gx> ^max <lc> ^com <gy>) - --> - (make horizontal-s ^net-name <nn> ^min (compute <gx> - 1) ^max <lc> ^com <gy> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) -) - -(p p636 - (context ^present remove-cycle) - (last-col <lc>) - (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com <lc>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from east) - - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y <> <gy>) - { <h> (horizontal-s ^net-name <nn> ^min >= <gx> ^max <lc> ^com <gy>) } - --> - (modify <h> ^min (compute <gx> - 1)) -) - -(p p637 - (context ^present remove-cycle) - (last-row <lr>) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0) - { <v> (vertical-s ^net-name <nn> ^min 1 ^max { <lr> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) } - (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side top) - (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from south) - --> - (modify <v> ^min (compute <lr> - 1)) -) - -(p p638 - (context ^present remove-cycle) - (last-row <lr>) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0) - { <v> (vertical-s ^net-name <nn> ^min 1 ^max { <lr> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) } - (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side bottom) - (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from north) - --> - (modify <v> ^max 2) -) - -(p p639 - (context ^present remove-cycle) - (last-col <lc>) - (vertical-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0) - { <v> (horizontal-s ^net-name <nn> ^min 1 ^max { <lc> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) } - (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side right) - (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from west) - --> - (modify <v> ^min (compute <lc> - 1)) -) - -(p p640 - (context ^present remove-cycle) - (last-col <lc>) - (vertical-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0) - { <v> (horizontal-s ^net-name <nn> ^min 1 ^max { <lc> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) } - (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side left) - (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from east) - --> - (modify <v> ^max 2) -) - -(p p472 - (context ^present partial-route) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) } - { <vs> (vertical-s ^net-name <nn> ^min <gy1> ^max <gy> ^com <gx>) } - { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1> ^came-from south) } - { <v> (vertical ^net-name nil ^min <gy1> ^max <gy> ^com <gx> ^layer <lay>) } - --> - (modify <v> ^net-name <nn> ^pin-name <pn>) - (remove <ff1> <ff2> <vs>) -) - -(p p473 - (context ^present partial-route) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east) } - { <vs> (horizontal-s ^net-name <nn> ^min <gx1> ^max <gx> ^com <gy>) } - { <ff2> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn1> ^came-from west) } - { <v> (horizontal ^net-name nil ^min <gx1> ^max <gx> ^com <gy> ^layer <lay>) } - --> - (modify <v> ^net-name <nn> ^pin-name <pn>) - (remove <ff1> <ff2> <vs>) -) - -(p p474 - (context ^present partial-route) - { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) } - { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <min> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from east) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from north) - --> - (remove <v2>) - (modify <h> ^com <vmin>) - (modify <v1> ^min <vmin>) -) - -(p p475 - (context ^present partial-route) - { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <min> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from east) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from north) - --> - (modify <v2> ^com <vcom>) - (modify <h> ^com <vmin>) -) - -(p p476 - (context ^present partial-route) - { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) } - { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <min> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from west) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from north) - --> - (remove <v2>) - (modify <h> ^com <vmin>) - (modify <v1> ^min <vmin>) -) - -(p p477 - (context ^present partial-route) - { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <min> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from west) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from north) - --> - (modify <v2> ^com <vcom>) - (modify <h> ^com <vmin>) -) - -(p p478 - (context ^present partial-route) - { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) } - { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <max> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from east) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from south) - --> - (remove <v2>) - (modify <h> ^com <vmax>) - (modify <v1> ^max <vmax>) -) - -(p p479 - (context ^present partial-route) - { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <max> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from east) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from south) - --> - (modify <v2> ^com <vcom>) - (modify <h> ^com <vmax>) -) - -(p p480 - (context ^present partial-route) - { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) } - { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <max> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from west) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from south) - --> - (remove <v2>) - (modify <h> ^com <vmax>) - (modify <v1> ^max <vmax>) -) - -(p p481 - (context ^present partial-route) - { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <max> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from west) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from south) - --> - (modify <v2> ^com <vcom>) - (modify <h> ^com <vmax>) -) - -(p p482 - (context ^present partial-route) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) } - { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <min> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from north) - (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from east) - --> - (remove <h2>) - (modify <v> ^com <hmin>) - (modify <h1> ^min <hmin>) -) - -(p p483 - (context ^present partial-route) - { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <min> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from north) - (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from east) - --> - (modify <h2> ^com <hcom>) - (modify <v> ^com <hmin>) -) - -(p p484 - (context ^present partial-route) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) } - { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <max> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from north) - (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from west) - --> - (remove <h2>) - (modify <v> ^com <hmax>) - (modify <h1> ^max <hmax>) -) - -(p p485 - (context ^present partial-route) - { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <max> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from north) - (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from west) - --> - (modify <h2> ^com <hcom>) - (modify <v> ^com <hmax>) -) - -(p p486 - (context ^present partial-route) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) } - { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <min> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from south) - (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from east) - --> - (remove <h2>) - (modify <v> ^com <hmin>) - (modify <h1> ^min <hmin>) -) - -(p p487 - (context ^present partial-route) - { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <min> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from south) - (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from east) - --> - (modify <h2> ^com <hcom>) - (modify <v> ^com <hmin>) -) - -(p p488 - (context ^present partial-route) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) } - { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <max> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from south) - (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from west) - --> - (remove <h2>) - (modify <v> ^com <hmax>) - (modify <h1> ^max <hmax>) -) - -(p p489 - (context ^present partial-route) - { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <max> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from south) - (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from west) - --> - (modify <h2> ^com <hcom>) - (modify <v> ^com <hmax>) -) - -(p p186 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> < 0 }) - - (horizontal-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) } - - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y < <gy1>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y <gy1>) - - (horizontal ^net-name nil ^min < <gx2> ^max > <gx1> ^com <gy1>) - - (horizontal ^net-name nil ^min <gx2> ^max > <gx1> ^com <gy1> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx2> ^max <gx1> ^com <gy1> ^max-net nil) - { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> bottom) - - (vertical-cycle <nn>) - --> - (modify <v> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p187 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> < 0 }) - - (horizontal-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) } - - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y < <gy1>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y <gy1>) - - (horizontal ^net-name nil ^min < <gx1> ^max > <gx2> ^com <gy1>) - - (horizontal ^net-name nil ^min <gx1> ^max > <gx2> ^com <gy1> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx1> ^max <gx2> ^com <gy1> ^max-net nil) - { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> bottom) - - (vertical-cycle <nn>) - --> - (modify <v> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p188 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> < 0 }) - - (horizontal-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) } - (vertical-s ^net-name <nn> ^min <= <gy1> ^max > <gy1> ^com <gx1>) - - (ff ^net-name <nn> ^grid-x <> <gx1> ^grid-y <= <gy1>) - { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy1>) - - (vertical-s ^net-name <> <nn> ^min <= <gy2> ^max >= <gy2> ^com <gx1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> bottom) - - (vertical-cycle <nn>) - --> - (make extended-ff <nn> bottom) - (modify <v> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p189 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> > 0 }) - - (horizontal-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) } - - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y > <gy1>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y <gy1>) - - (horizontal ^net-name nil ^min < <gx2> ^max > <gx1> ^com <gy1>) - - (horizontal ^net-name nil ^min <gx2> ^max > <gx1> ^com <gy1> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx2> ^max <gx1> ^com <gy1> ^max-net nil) - { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy1> ^como <gy2>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> top) - - (vertical-cycle <nn>) - --> - (modify <v> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p190 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> > 0 }) - - (horizontal-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) } - - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y > <gy1>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y <gy1>) - - (horizontal ^net-name nil ^min < <gx1> ^max > <gx2> ^com <gy1>) - - (horizontal ^net-name nil ^min <gx1> ^max > <gx2> ^com <gy1> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx1> ^max <gx2> ^com <gy1> ^max-net nil) - { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy1> ^como <gy2>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> top) - - (vertical-cycle <nn>) - --> - (modify <v> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p191 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> > 0 }) - - (horizontal-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) } - (vertical-s ^net-name <nn> ^min < <gy1> ^max >= <gy1> ^com <gx1>) - - (ff ^net-name <nn> ^grid-x <> <gx1> ^grid-y >= <gy1>) - { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy1> ^como <gy2>) - - (vertical-s ^net-name <> <nn> ^min <= <gy2> ^max >= <gy2> ^com <gx1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> top) - - (vertical-cycle <nn>) - --> - (make extended-ff <nn> top) - (modify <v> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p192 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (horizontal-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <max> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) } - - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com <gy>) - { <v> (vertical ^net-name nil ^max { <vmax> > <gy> } ^min { < <vmax> <= <gy> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <max> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gy2> ^layer <lay>) - - (vertical-cycle <nn>) - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com > <gy>) - --> - (modify <v> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p193 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (horizontal-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <min> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) } - - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com <gy>) - { <v> (vertical ^net-name nil ^max { <vmax> > <gy> } ^min { < <vmax> <= <gy> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <min> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gy2> ^layer <lay>) - - (vertical-cycle <nn>) - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com > <gy>) - --> - (modify <v> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p194 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (horizontal-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <max> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) } - - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com <gy>) - { <v> (vertical ^net-name nil ^max { <vmax> >= <gy> } ^min { < <vmax> < <gy> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy> ^como <gy2>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <max> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gy2> ^layer <lay>) - - (vertical-cycle <nn>) - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com < <gy>) - --> - (modify <v> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p195 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (horizontal-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <min> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) } - - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com <gy>) - { <v> (vertical ^net-name nil ^max { <vmax> >= <gy> } ^min { < <vmax> < <gy> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy> ^como <gy2>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <min> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gy2> ^layer <lay>) - - (vertical-cycle <nn>) - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com < <gy>) - --> - (modify <v> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p196 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> < 0 }) - - (vertical-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) } - - (ff ^net-name <nn> ^grid-x < <gx1> ^grid-y <garb1>) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> < <gy1> }) - - (vertical ^net-name nil ^min < <gy2> ^max > <gy1> ^com <gx1>) - - (vertical ^net-name nil ^min <gy2> ^max > <gy1> ^com <gx1> ^min-net nil) - - (vertical ^net-name nil ^min < <gy2> ^max <gy1> ^com <gx1> ^max-net nil) - { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> left) - - (horizontal-cycle <nn>) - --> - (modify <v> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p197 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> < 0 }) - - (vertical-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) } - - (ff ^net-name <nn> ^grid-x < <gx1> ^grid-y <garb1>) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> > <gy1> }) - - (vertical ^net-name nil ^min < <gy1> ^max > <gy2> ^com <gx1>) - - (vertical ^net-name nil ^min <gy1> ^max > <gy2> ^com <gx1> ^min-net nil) - - (vertical ^net-name nil ^min < <gy1> ^max <gy2> ^com <gx1> ^max-net nil) - { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> left) - - (horizontal-cycle <nn>) - --> - (modify <v> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p198 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> < 0 }) - - (vertical-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) } - (horizontal-s ^net-name <nn> ^min <= <gx1> ^max > <gx1> ^com <gy1>) - - (ff ^net-name <nn> ^grid-x <= <gx1> ^grid-y <> <gy1>) - { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx1>) - - (horizontal-s ^net-name <> <nn> ^min <= <gx2> ^max >= <gx2> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> left) - - (horizontal-cycle <nn>) - --> - (make extended-ff <nn> left) - (modify <v> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p199 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> > 0 }) - - (vertical-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) } - - (ff ^net-name <nn> ^grid-x > <gx1> ^grid-y <garb1>) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> < <gy1> }) - - (vertical ^net-name nil ^min < <gy2> ^max > <gy1> ^com <gx1>) - - (vertical ^net-name nil ^min <gy2> ^max > <gy1> ^com <gx1> ^min-net nil) - - (vertical ^net-name nil ^min < <gy2> ^max <gy1> ^com <gx1> ^max-net nil) - { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx1> ^como <gx2>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> right) - - (horizontal-cycle <nn>) - --> - (modify <v> ^max <gx2> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p200 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> > 0 }) - - (vertical-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) } - - (ff ^net-name <nn> ^grid-x > <gx1> ^grid-y <gy1>) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> > <gy1> }) - - (vertical ^net-name nil ^min < <gy1> ^max > <gy2> ^com <gx1>) - - (vertical ^net-name nil ^min <gy1> ^max > <gy2> ^com <gx1> ^min-net nil) - - (vertical ^net-name nil ^min < <gy1> ^max <gy2> ^com <gx1> ^max-net nil) - { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx1> ^como <gx2>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> right) - - (horizontal-cycle <nn>) - --> - (modify <v> ^max <gx2> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p201 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> > 0 }) - - (vertical-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) } - (horizontal-s ^net-name <nn> ^min < <gx1> ^max >= <gx1> ^com <gy1>) - - (ff ^net-name <nn> ^grid-x >= <gx1> ^grid-y <> <gy1>) - { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx1> ^como <gx2>) - - (horizontal-s ^net-name <> <nn> ^min <= <gx2> ^max >= <gx2> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> right) - - (horizontal-cycle <nn>) - --> - (make extended-ff <nn> right) - (modify <v> ^max <gx2> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p202 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (vertical-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <max> ^grid-layer <lay> ^came-from west ^pin-name <pn>) } - - (vertical ^net-name nil ^min < <max> ^max >= <max> ^com <gx>) - { <v> (horizontal ^net-name nil ^max { <vmax> > <gx> } ^min { < <vmax> <= <gx> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <max> ^layer <lay>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gx2> ^layer <lay>) - - (horizontal-cycle <nn>) - --> - (modify <v> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^max <gx2> ^min <gx> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p203 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (vertical-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <min> ^grid-layer <lay> ^came-from west ^pin-name <pn>) } - - (vertical ^net-name nil ^min <= <min> ^max > <min> ^com <gx>) - { <v> (horizontal ^net-name nil ^max { <vmax> > <gx> } ^min { < <vmax> <= <gx> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <min> ^layer <lay>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gx2> ^layer <lay>) - - (horizontal-cycle <nn>) - --> - (modify <v> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^max <gx2> ^min <gx> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p204 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (vertical-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <max> ^grid-layer <lay> ^came-from east ^pin-name <pn>) } - - (vertical ^net-name nil ^min < <max> ^max >= <max> ^com <gx>) - { <v> (horizontal ^net-name nil ^max { <vmax> >= <gx> } ^min { < <vmax> < <gx> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx> ^como <gx2>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <max> ^layer <lay>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gx2> ^layer <lay>) - - (horizontal-cycle <nn>) - --> - (modify <v> ^max <gx2> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx> ^min <gx2> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p205 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (vertical-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <min> ^grid-layer <lay> ^came-from east ^pin-name <pn>) } - - (vertical ^net-name nil ^min <= <min> ^max > <min> ^com <gx>) - { <v> (horizontal ^net-name nil ^max { <vmax> >= <gx> } ^min { < <vmax> < <gx> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx> ^como <gx2>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <min> ^layer <lay>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gx2> ^layer <lay>) - - (horizontal-cycle <nn>) - --> - (modify <v> ^max <gx2> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx> ^min <gx2> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p206 - { <c> (context ^present extend-h-v-s) } - --> - (modify <c> ^present loose-constraint0) -) - -(p p207 - { <c> (context ^present extend-h-v-s) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from west ^pin-name <pn>) } - (horizontal-s ^net-name <nn> ^min <= <gx> ^max { <hmaxs> > <gx> } ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^com <gy>) - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <vcoms> > <gx> <= <hmaxs> }) - - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { >= <gx> < <vcoms> }) - { <h> (horizontal ^net-name nil ^min <gx> ^max { <hmax> >= <vcoms> } ^com <gy> ^layer <lay>) } - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <vcoms> ^layer <lay>) - --> - (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <vcoms>) - (modify <h> ^min <vcoms> ^min-net <nn>) - (modify <ff> ^grid-x <vcoms> ^can-chng-layer nil) - (modify <c> ^present propagate-constraint) -) - -(p p208 - { <c> (context ^present extend-h-v-s) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from east ^pin-name <pn>) } - (horizontal-s ^net-name <nn> ^min { <hmins> < <gx> } ^max >= <gx> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^com <gy>) - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <vcoms> < <gx> >= <hmins> }) - - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <= <gx> > <vcoms> }) - { <h> (horizontal ^net-name nil ^min { <hmin> <= <vcoms> } ^max <gx> ^com <gy> ^layer <lay>) } - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <vcoms> ^layer <lay>) - --> - (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcoms>) - (modify <h> ^max <vcoms> ^max-net <nn>) - (modify <ff> ^grid-x <vcoms> ^can-chng-layer nil) - (modify <c> ^present propagate-constraint) -) - -(p p209 - { <c> (context ^present extend-h-v-s) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) } - (vertical-s ^net-name <nn> ^min <= <gy> ^max { <vmaxs> > <gy> } ^com <gx>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <gx>) - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <hcoms> > <gy> <= <vmaxs> }) - - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { >= <gy> < <hcoms> }) - { <v> (vertical ^net-name nil ^min <gy> ^max { <vmax> >= <hcoms> } ^com <gx> ^layer <lay>) } - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <hcoms> ^layer <lay>) - --> - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <hcoms>) - (modify <v> ^min <hcoms> ^min-net <nn>) - (modify <ff> ^grid-y <hcoms> ^can-chng-layer nil) - (modify <c> ^present propagate-constraint) -) - -(p p210 - { <c> (context ^present extend-h-v-s) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) } - (vertical-s ^net-name <nn> ^min { <vmins> < <gy> } ^max >= <gy> ^com <gx>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <gx>) - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <hcoms> < <gy> >= <vmins> }) - - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <= <gy> > <hcoms> }) - { <v> (vertical ^net-name nil ^min { <vmin> <= <hcoms> } ^max <gy> ^com <gx> ^layer <lay>) } - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <hcoms> ^layer <lay>) - --> - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <hcoms>) - (modify <v> ^max <hcoms> ^max-net <nn>) - (modify <ff> ^grid-y <hcoms> ^can-chng-layer nil) - (modify <c> ^present propagate-constraint) -) - -(p p29 - (goal cleanup <c>) - (<c>) - --> - (remove 2) -) - -(p p30 - (goal cleanup <c>) - - (<c>) - --> - (remove 1) -) - -(p p31 - (goal cleanup) - (verti-has-loop) - --> - (remove 2) -) - -(p p83 - (context ^present propagate-constraint) - --> - (remove 1) - (make context ^previous propagate-constraint) - (make context ^present remove-cycle) -) - -(p p84 - (context ^present << propagate-constraint extend-pins move-ff >>) - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com> ^layer <lay> ^compo <cpo> ^commo <egarb1>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <min2> <= <max1> } ^max { <max2> >= <min1> } ^com <cpo> ^layer <lay> ^compo <garb1> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <cpo> > <min3> } ^com { <com2> <= <max1> >= <min1> <= <max2> >= <min2> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) } - --> - (make vertical ^min <min3> ^max <com> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn1> ^min-net <mnn>) - (make vertical ^min <cpo> ^max <max3> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn2> ^max-net <man>) - (remove <v1>) -) - -(p p85 - (context ^present << propagate-constraint extend-pins >>) - (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <com> ^layer <lay> ^compo <egarb2> ^commo <gy>) - { <v1> (vertical ^net-name nil ^min { <min3> <= <gy> } ^max { <max3> >= <com> > <min3> } ^com <gx> ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) } - --> - (make vertical ^min <min3> ^max <gy> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn1> ^min-net <mnn>) - (make vertical ^min <com> ^max <max3> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn2> ^max-net <man>) - (remove <v1>) -) - -(p p86 - (context ^present << propagate-constraint extend-pins >>) - (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <com> ^layer <lay> ^compo <gy> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <gy> > <min3> } ^com <gx> ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) } - --> - (make vertical ^min <min3> ^max <com> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn2> ^min-net <mnn>) - (make vertical ^min <gy> ^max <max3> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn1> ^max-net <man>) - (remove <v1>) -) - -(p p87 - (context ^present propagate-constraint) - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min <min2> ^max <gar2> ^com <com> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <min2> > <max1> } ^com <com> ^layer <lay> ^compo <egarb5> ^commo <egarb6>) } - - (vertical ^com { > <max1> < <min2> }) - --> - (remove <h1>) -) - -(p p88 - (context ^present << propagate-constraint extend-pins move-ff >>) - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com> ^layer <lay> ^compo <cpo> ^commo <egarb1>) - (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <min2> <= <max1> } ^max { <max2> >= <min1> } ^com <cpo> ^layer <lay> ^compo <garb1> ^compo <egarb2>) - { <h1> (horizontal ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <cpo> } ^com { <com2> <= <max1> >= <min1> <= <max2> >= <min2> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) } - --> - (make horizontal ^min <min3> ^max <com> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <mnn> ^max-net <nn1>) - (make horizontal ^min <cpo> ^max <max3> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <man> ^min-net <nn2>) - (remove <h1>) -) - -(p p89 - (context ^present propagate-constraint) - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min <min2> ^max <garb2> ^com <com> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) - - (horizontal ^com { > <max1> < <min2> }) - { <v1> (vertical ^net-name nil ^min <max1> ^max { <min2> > <max1> } ^com <com> ^layer <lay> ^compo <egarb5> ^commo <egarb6>) } - --> - (remove <v1>) -) - -(p p90 - (context ^present propagate-constraint) - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <vmin> ^max <garb1> ^com <vcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <hcom> ^layer <lay> ^compo <vmin> ^commo <garb5>) - { <v1> (vertical ^net-name nil ^min <garb4> ^max { <vmin> > <garb4> } ^com <vcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) } - --> - (modify <v1> ^max <hcom> ^max-net <nn2>) -) - -(p p91 - (context ^present propagate-constraint) - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <vmax>) - { <v1> (vertical ^net-name nil ^min <vmax> ^max { <garb5> > <vmax> } ^com <vcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) } - --> - (modify <v1> ^min <hcom> ^min-net <nn2>) -) - -(p p92 - (context ^present propagate-constraint) - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <min> ^max <garb1> ^com <hcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <vcom> ^layer <lay> ^compo <min> ^commo <egarb3>) - { <h1> (horizontal ^net-name nil ^min <garb4> ^max { <min> > <garb4> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - --> - (modify <h1> ^max <vcom> ^max-net <nn2>) -) - -(p p93 - (context ^present propagate-constraint) - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max> ^com <hcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <max>) - { <h1> (horizontal ^net-name nil ^min <max> ^max { <garb4> > <max> } ^com <hcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) } - --> - (modify <h1> ^min <vcom> ^min-net <nn2>) -) - -(p p94 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - { <h1> (horizontal ^net-name nil ^min <garb3> ^max { <gx> > <garb3> } ^com <gy> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) } - (vertical ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <vcom> ^layer <lay> ^compo <gx> ^commo <egarb2>) - --> - (modify <h1> ^max <vcom> ^max-net <nn2>) -) - -(p p95 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { <garb4> > <gx> } ^com <gy> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - (vertical ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <vcom> ^layer <lay> ^compo <garb3> ^commo <gx>) - --> - (modify <h1> ^min <vcom> ^min-net <nn2>) -) - -(p p96 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - (horizontal ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <hcom> ^layer <lay> ^compo <gy> ^commo <garb3>) - { <v1> (vertical ^net-name nil ^min <garb4> ^max { <gy> > <garb4> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - --> - (modify <v1> ^max <hcom> ^max-net <nn2>) -) - -(p p97 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - (horizontal ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <hcom> ^layer <lay> ^compo <garb3> ^commo <gy>) - { <v1> (vertical ^net-name nil ^min <gy> ^max { <garb4> > <gy> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - --> - (modify <v1> ^min <hcom> ^min-net <nn2>) -) - -(p p98 - (context ^present << propagate-constraint extend-pins random1 check-for-routed-net >>) - { <h1> (horizontal ^min <min> ^max <= <min>) } - --> - (remove <h1>) -) - -(p p99 - (context ^present << propagate-constraint extend-pins random1 check-for-routed-net >>) - { <v1> (vertical ^min <min> ^max <= <min>) } - --> - (remove <v1>) -) - -(p p100 - { <h1> (horizontal ^min <min> ^max <= <min>) } - --> - (remove <h1>) -) - -(p p101 - { <v1> (vertical ^min <min> ^max <= <min>) } - --> - (remove <v1>) -) - -(p p102 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com <min1>) - - (horizontal ^status nil ^min < <min1> ^max >= <min1> ^com <com1>) - (vertical ^status nil ^net-name <garb1> ^min { <vmin> <= <com1> } ^max { >= <com1> > <vmin> } ^com { <com2> > <min1> <= <max1> } ^layer <garb2> ^compo <egarb4> ^commo <egarb5>) - - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com { < <com2> >= <min1> }) - --> - (modify <h1> ^min <com2> ^min-net nil) -) - -(p p103 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com <min1>) - - (vertical ^status nil ^min < <min1> ^max >= <min1> ^com <com1>) - (horizontal ^status nil ^net-name <garb1> ^min { <hmin> <= <com1> } ^max { <garb2> >= <com1> > <hmin> } ^com { <com2> > <min1> <= <max1> } ^layer <garb3> ^compo <egarb4> ^commo <egarb5>) - - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com { < <com2> >= <min1> }) - --> - (modify <v1> ^min <com2> ^min-net nil) -) - -(p p104 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com <max1>) - - (horizontal ^status nil ^min <= <max1> ^max > <max1> ^com <com1>) - (vertical ^status nil ^net-name <garb1> ^min { <vmin> <= <com1> } ^max { <garb2> >= <com1> > <vmin> } ^com { <com2> >= <min1> < <max1> } ^layer <egarb1> ^compo <egarb2> ^commo <egarb3>) - - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com { > <com2> <= <max1> }) - --> - (modify <h1> ^max <com2> ^max-net nil) -) - -(p p105 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com <max1>) - - (vertical ^status nil ^min <= <max1> ^max > <max1> ^com <com1>) - (horizontal ^status nil ^net-name <garb1> ^min { <hmin> <= <com1> } ^max { <garb2> >= <com1> > <hmin> } ^com { <com2> >= <min1> < <max1> } ^layer <egarb1> ^compo <egarb4> ^commo <egarb5>) - - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com { > <com2> <= <max1> }) - --> - (modify <v1> ^max <com2> ^max-net nil) -) - -(p p106 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <hmin> ^max { <hmax> > <hmin> } ^com <hcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) } - - (vertical ^com { > <hmin> < <hmax> }) - - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <lay>) - - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <lay>) - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <> <lay> ^compo <egarb4> ^commo <egarb5>) - (vertical ^net-name { <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <hmin> ^layer <> <lay> ^compo <egarb2> ^commo <egarb3>) - --> - (remove <h1>) -) - -(p p107 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (horizontal ^com { > <vmin> < <vmax> }) - - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmax> ^layer <lay>) - - (vertical ^status nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <lay>) - (horizontal ^net-name { <nn1> <> nil } ^min { <garb1> <= <vcom> } ^max { <garb2> >= <vcom> } ^com <vmax> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - (horizontal ^net-name { <> <nn1> <> nil } ^min { <garb4> <= <vcom> } ^max { <garb5> >= <vcom> } ^com <vmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>) - --> - (remove <v1>) -) - -(p p108 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <hmin> ^max { <hmax> > <hmin> } ^com <hcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) } - - (vertical ^com { > <hmin> < <hmax> }) - - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmin> ^layer <lay>) - - (horizontal ^status nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <lay>) - - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <lay>) - (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <hmax> ^layer { <garb3> <> <lay> } ^compo <egarb2> ^commo <egarb3>) - (vertical ^net-name { <garb7> <> <nn1> <> nil } ^min { <gabr4> <= <hcom> } ^max { <garb5> >= <hcom> } ^com <hmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>) - --> - (remove <h1>) -) - -(p p109 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) } - - (horizontal ^com { > <vmin> < <vmax> }) - - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmin> ^layer <lay>) - - (vertical ^status nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <lay>) - (horizontal ^net-name { <nn1> <> nil } ^min { <garb1> <= <vcom> } ^max { <garb2> >= <vcom> } ^com <vmax> ^layer { <garb3> <> <lay> } ^compo <egarb2> ^commo <egarb3>) - (horizontal ^net-name { <garb7> <> <nn1> <> nil } ^min { <garb4> <= <vcom> } ^max { <garb5> >= <vcom> } ^com <vmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>) - --> - (remove <v1>) -) - -(p p110 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>) - - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> }) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil) - (horizontal ^net-name { <nn> <> nil } ^min <garb1> ^max <max1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) - (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <garb4> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max2> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> }) - --> - (modify <h1> ^max (compute <max2> - 1) ^max-net nil) -) - -(p p111 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max1> ^layer <lay>) - - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> }) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil) - (horizontal ^net-name { <nn> <> nil } ^min <max2> ^max <garb1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) - (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <garb4> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max1> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> }) - --> - (modify <h1> ^min (compute <max1> + 1) ^min-net nil) -) - -(p p112 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>) - - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { >= <max1> < <max2> }) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { >= <max1> < <max2> } ^max-net nil) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { >= <max1> < <max2> } ^min-net nil) - - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>) - (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max2> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { >= <max1> < <max2> }) - --> - (modify <h1> ^max (compute <max2> - 1) ^max-net nil) -) - -(p p113 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max1> ^layer <lay>) - - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> <= <max2> }) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> <= <max2> } ^max-net nil) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> <= <max2> } ^min-net nil) - - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>) - (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max1> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> <= <max2> }) - --> - (modify <h1> ^min (compute <max1> + 1) ^min-net nil) -) - -(p p114 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - (vertical ^net-name { <nn> <> nil } ^min <garb1> ^max <max1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) - - (horizontal ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>) - - (vertical ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>) - - (horizontal ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> }) - - (horizontal ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil) - - (horizontal ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil) - (horizontal ^net-name { <nn1> <> <nn> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <max2> ^layer { <garb4> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - - (horizontal ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> }) - --> - (modify <v1> ^max (compute <max2> - 1) ^max-net nil) -) - -(p p115 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^compo <gy>) - { <v1> (vertical ^net-name nil ^min <vmin> ^max { <gy> > <vmin> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { >= <vmin> < <gy> }) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { >= <vmin> < <gy> } ^max-net nil) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { >= <vmin> < <gy> } ^min-net nil) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <vmin> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <vmin> ^max >= <vmin> ^com <gx>) - --> - (modify <v1> ^max (compute <gy> - 1) ^max-net nil) -) - -(p p116 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { <max2> > <gx> } ^com <gy> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> <= <max2> } ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> <= <max2> }) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> <= <max2> } ^max-net nil) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> <= <max2> }) - --> - (modify <h1> ^min (compute <gx> + 1) ^min-net nil) -) - -(p p117 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^min-net { <nn> <> nil }) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { <hmax> >= <vcom> > <hmin> } ^com <vmax> ^layer <lay> ^commo <vmin> ^min-net { <> <nn> <> nil } ^max-net { <> <nn> <> nil }) - - (vertical ^net-name nil ^min < <vmax> ^max > <vmax> ^com { > <hmin> < <hmax> }) - - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { > <hmin> < <vcom> } ^max-net nil) - - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { > <vcom> < <hmax> } ^max-net nil) - - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com { > <hmin> < <hmax> } ^min-net nil) - - (vertical ^net-name { <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { > <hmin> < <hmax> }) - --> - (remove <v1>) -) - -(p p118 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>) - - (vertical ^net-name nil ^com <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com > <max1>) - - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com < <min1>) - { <h1> (horizontal ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) } - - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com { >= <min1> <= <max1> } ^layer <lay2>) - { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) } - - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>) - (pin ^net-name <nn2> ^pin-x < <com1>) - (pin ^net-name <nn2> ^pin-x > <com1>) - { <b1> (branch-no <pn>) } - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <b1>) - (make horizontal ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make horizontal ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (make horizontal ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cmo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from east) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cpo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west) - (remove <h1>) -) - -(p p119 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>) - - (vertical ^net-name nil ^com <com1>) - { <h1> (horizontal ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) } - - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com > <com2>) - - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com < <com2>) - { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) } - - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>) - (pin ^net-name <nn2> ^pin-x < <com1>) - (pin ^net-name <nn2> ^pin-x > <com1>) - { <b1> (branch-no <pn>) } - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <b1>) - (make horizontal ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make horizontal ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (make horizontal ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cmo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from east) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cpo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west) - (remove <h1>) -) - -(p p120 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>) - - (horizontal ^net-name nil ^com <com1>) - - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com > <max1>) - - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com < <min1>) - { <v1> (vertical ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) } - - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com { >= <min1> <= <max1> } ^layer <lay2>) - { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) } - - (vertical ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>) - (pin ^net-name <nn2> ^pin-y < <com1>) - (pin ^net-name <nn2> ^pin-y > <com1>) - { <b1> (branch-no <pn>) } - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <b1>) - (make vertical ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make vertical ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (make vertical ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cmo1> ^grid-layer <lay2> ^came-from north) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cpo1> ^grid-layer <lay2> ^came-from south) - (remove <v1>) -) - -(p p121 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>) - - (horizontal ^net-name nil ^com <com1>) - { <v1> (vertical ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) } - - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com > <com2>) - - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com < <com2>) - { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) } - - (vertical ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>) - (pin ^net-name <nn2> ^pin-y < <com1>) - (pin ^net-name <nn2> ^pin-y > <com1>) - { <b1> (branch-no <pn>) } - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <b1>) - (make vertical ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make vertical ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (make vertical ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cmo1> ^grid-layer <lay2> ^came-from north) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cpo1> ^grid-layer <lay2> ^came-from south) - (remove <v1>) -) - -(p p122 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <min2> ^max { <max2> > <min2> } ^com <com2> ^layer <lay2> ^compo <cpo2> ^commo <cmo2>) } - - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com > <com2>) - - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com < <com2>) - - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com <com2> ^layer <> <lay2>) - (congestion ^direction col ^coordinate { <x1> <= <max2> } ^como { <x2> >= <min2> }) - - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com > <com2>) - - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com < <com2>) - - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com <com2> ^layer <> <lay2>) - { <t1> (to-be-routed ^net-name <nn2> ^no-of-attached-pins <nap>) } - - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <x2> ^max >= <x1>) - (pin ^net-name <nn2> ^pin-x <= <x2>) - (pin ^net-name <nn2> ^pin-x >= <x1>) - { <b1> (branch-no <pn>) } - - (horizontal ^net-name { <> <nn2> <> nil } ^min <= <x2> ^max >= <x2> ^com <com2> ^layer <lay2>) - - (vertical ^net-name { <> <nn2> <> nil } ^min <= <com2> ^max >= <com2> ^com <x2> ^layer <lay2>) - - (horizontal ^net-name { <> <nn2> <> nil } ^min <= <x1> ^max >= <x1> ^com <com2> ^layer <lay2>) - - (vertical ^net-name { <> <nn2> <> nil } ^min <= <com2> ^max >= <com2> ^com <x1> ^layer <lay2>) - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <b1>) - (make horizontal ^min <x2> ^max <x1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make horizontal ^min <min2> ^max <x2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (make horizontal ^min <x1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <x2> ^grid-y <com2> ^grid-layer <lay2> ^came-from east) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <x1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west) - (remove <h1>) -) - -(p p123 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com { <com1> <> 1 } ^layer <lay1> ^compo <cpo1> ^commo <cmo1> ^min-net <mnn> ^max-net <xnn>) } - - (horizontal ^net-name nil ^min < <com1> ^max > <com1>) - (horizontal ^net-name nil ^min <com1> ^max { <garb3> > <com1> } ^com { <bhcom> <= <max1> >= <min1> } ^layer <garb4>) - (horizontal ^net-name nil ^min { <garb1> < <com1> } ^max <com1> ^com { <thcom> <= <max1> > <bhcom> } ^layer <garb2>) - - (horizontal ^net-name nil ^min < <com1> ^max <com1> ^com { < <thcom> > <bhcom> }) - - (horizontal ^net-name nil ^min <com1> ^max > <com1> ^com { < <thcom> > <bhcom> }) - { <t1> (to-be-routed ^net-name <nn2> ^no-of-attached-pins <nap>) } - - (vertical ^status nil ^net-name { <nn2> <> nil } ^com <com1>) - - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>) - (pin ^net-name <nn2> ^pin-x < <com1>) - (pin ^net-name <nn2> ^pin-x > <com1>) - { <b1> (branch-no <pn>) } - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <v1> <b1>) - (make vertical ^min <min1> ^max <bhcom> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^max-net <nn2> ^min-net <mnn>) - (make vertical ^min <thcom> ^max <max1> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^min-net <nn2> ^max-net <xnn>) - (make vertical ^min <bhcom> ^max <thcom> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^net-name <nn2> ^pin-name <pn>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com1> ^grid-y <bhcom> ^grid-layer <lay1> ^came-from north) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com1> ^grid-y <thcom> ^grid-layer <lay1> ^came-from south) -) - -(p p124 - (context ^present propagate-constraint) - (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <com2> ^grid-layer <lay1> ^pin-name <egarb1>) - - (vertical ^net-name nil ^min <= <com2> ^max >= <com2> ^com <gx>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com > <com2>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com < <com2>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min < <gx>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^com < <gx>) - { <h1> (horizontal ^net-name nil ^min { <min2> < <gx> } ^max { <max2> >= <gx> > <min2> } ^com <com2> ^layer <lay1> ^compo <cpo2> ^commo <cmo2> ^min-net <nn2>) } - --> - (make horizontal ^min <min2> ^max (compute <gx> - 1) ^com <com2> ^layer <lay1> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (modify <h1> ^min <gx> ^min-net <nn1>) -) - -(p p125 - (context ^present propagate-constraint) - (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <com2> ^grid-layer <lay1> ^pin-name <egarb1>) - - (vertical ^net-name nil ^min <= <com2> ^max >= <com2> ^com <gx>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com > <com2>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com < <com2>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^max > <gx>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^com > <gx>) - { <h1> (horizontal ^net-name nil ^min { <min2> <= <gx> } ^max { <max2> > <gx> > <min2> } ^com <com2> ^layer <lay1> ^compo <cpo2> ^commo <cmo2> ^max-net <nn2>) } - --> - (make horizontal ^min (compute <gx> + 1) ^max <max2> ^com <com2> ^layer <lay1> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (modify <h1> ^max <gx> ^max-net <nn1>) -) - -(p p126 - (context ^present << propagate-constraint extend-total-verti >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> east ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) } - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) } - - (horizontal ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>) - - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>) - --> - (modify <h1> ^min (compute <max1> + 1) ^min-net <nn>) - (make horizontal ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>) - (modify <ff1> ^grid-x (compute <max1> + 1) ^came-from west ^can-chng-layer nil) -) - -(p p127 - (context ^present << propagate-constraint extend-total-verti >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> west ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) } - { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) } - - (horizontal ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>) - - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>) - --> - (modify <h1> ^max (compute <max1> - 1) ^max-net <nn>) - (make horizontal ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>) - (modify <ff1> ^grid-x (compute <max1> - 1) ^came-from east ^can-chng-layer nil) -) - -(p p128 - (context ^present << propagate-constraint extend-total-verti >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> north ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) } - { <v1> (vertical ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) } - - (vertical ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>) - - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>) - --> - (modify <v1> ^min (compute <max1> + 1) ^min-net <nn>) - (make vertical ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>) - (modify <ff1> ^grid-y (compute <max1> + 1) ^came-from south ^can-chng-layer nil) -) - -(p p129 - (context ^present << propagate-constraint extend-total-verti >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> south ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) } - { <v1> (vertical ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) } - - (vertical ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>) - - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>) - --> - (modify <v1> ^max (compute <max1> - 1) ^max-net <nn>) - (make vertical ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>) - (modify <ff1> ^grid-y (compute <max1> - 1) ^came-from north ^can-chng-layer nil) -) - -(p p130 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <h1> (horizontal ^status nil ^net-name <nn> ^min <min> ^max { <max> > <min> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <gar1>) } - { <h2> (horizontal ^status nil ^net-name <nn> ^min <max> ^max { <max2> > <max> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <nn1>) } - --> - (modify <h1> ^max <max2> ^max-net <nn1>) - (remove <h2>) -) - -(p p131 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <v1> (vertical ^status nil ^net-name <nn> ^min <min> ^max { <max> > <min> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <gar1>) } - { <v2> (vertical ^status nil ^net-name <nn> ^min <max> ^max { <max2> > <max> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <nn1>) } - --> - (modify <v1> ^max <max2> ^max-net <nn1>) - (remove <v2>) -) - -(p p132 - (context ^present propagate-constraint) - { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gar1> ^max <max> ^com <com> ^layer <lay> ^pin-name <pn>) } - { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) } - (vertical ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>) - --> - (modify <h1> ^max <max2>) - (remove <h2>) -) - -(p p133 - (context ^present propagate-constraint) - { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <gar1> ^com <com> ^layer <lay> ^pin-name <pn>) } - { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min2> ^max <min> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) } - (vertical ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>) - --> - (modify <h1> ^min <min2>) - (remove <h2>) -) - -(p p134 - (context ^present propagate-constraint) - { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <gar1> ^max <max> ^com <com> ^layer <lay> ^pin-name <pn>) } - { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>) - --> - (modify <v1> ^max <max2>) - (remove <v2>) -) - -(p p135 - (context ^present propagate-constraint) - { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <gar1> ^com <com> ^layer <lay> ^pin-name <pn>) } - { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min2> ^max <min> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>) - --> - (modify <v1> ^min <min2>) - (remove <v2>) -) - -(p p136 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> east ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) } - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) } - - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>) - - (horizontal ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>) - --> - (modify <h1> ^min (compute <max1> + 1) ^min-net <nn>) - (make horizontal ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>) - (modify <ff1> ^grid-x (compute <max1> + 1) ^came-from west ^can-chng-layer nil) -) - -(p p137 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> west ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) } - { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) } - - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>) - - (horizontal ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>) - --> - (modify <h1> ^max (compute <max1> - 1) ^max-net <nn>) - (make horizontal ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>) - (modify <ff1> ^grid-x (compute <max1> - 1) ^came-from east ^can-chng-layer nil) -) - -(p p138 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> north ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) } - { <v1> (vertical ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) } - - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>) - - (vertical ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>) - --> - (modify <v1> ^min (compute <max1> + 1) ^min-net <nn>) - (make vertical ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>) - (modify <ff1> ^grid-y (compute <max1> + 1) ^came-from south ^can-chng-layer nil) -) - -(p p139 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> south ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) } - { <v1> (vertical ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) } - - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>) - - (vertical ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>) - --> - (modify <v1> ^max (compute <max1> - 1) ^max-net <nn>) - (make vertical ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>) - (modify <ff1> ^grid-y (compute <max1> - 1) ^came-from north ^can-chng-layer nil) -) - -(p p140 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com> ^max >= <com> ^com { >= <min> <= <max> } ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - - (included <nn> <pn1>) - (included <nn> <pn2>) - --> - (make included <nn> <pn1>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p141 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com> ^max >= <com> ^com { >= <min> <= <max> } ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - (included <nn> <pn1>) - - (included <nn> <pn2>) - --> - (make included <nn> <pn2>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p142 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - (included <nn> <pn1>) - - (included <nn> <pn2>) - --> - (make included <nn> <pn2>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p143 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <egarb4> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - - (included <nn> <pn1>) - (included <nn> <pn2>) - --> - (make included <nn> <pn1>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p144 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <egarb4> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - (included <nn> <pn1>) - - (included <nn> <pn2>) - --> - (make included <nn> <pn2>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p145 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - - (included <nn> <pn1>) - (included <nn> <pn2>) - --> - (make included <nn> <pn1>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p146 - { <c1> (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) } - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - { <n1> (net ^net-name <nn> ^net-no-of-pins <nap>) } - --> - (remove <c1> <t1>) - (make join-routed-net <nn>) - (modify <n1> ^net-is-routed yes) -) - -(p p147 - { <c1> (context ^present check-for-routed-net) } - --> - (remove <c1>) - (make context ^present move-ff) -) - -(p p148 - { <con> (context ^present move-ff) } - --> - (modify <con> ^present set-min-max) -) - -(p p149 - { <con> (context ^present set-min-max) } - --> - (remove <con>) - (make context ^present propagate-constraint) -) - -(p p150 - (context ^present propagate-constraint) - { <c1> (constraint ^pin-name-2 <pn>) } - - (ff ^pin-name <pn>) - --> - (remove <c1>) -) - -(p p151 - (context ^present propagate-constraint) - { <c1> (constraint ^pin-name-1 <pn>) } - - (ff ^pin-name <pn>) - --> - (remove <c1>) -) - -(p p152 - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <> <pn>) } - --> - (remove <ff1> <ff2>) -) - -(p p153 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) } - { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2> ^grid-layer <lay> ^pin-name <> <pn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy1>) - { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1> <ff2>) - (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <v1> ^min <gy2> ^min-net <nn>) - (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p154 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy2> ^layer <lay> ^compo <egarb1> ^commo <gy1> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>) - { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1>) - (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <v1> ^min <gy2> ^min-net <nn>) - (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p155 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2> ^grid-layer <lay> ^pin-name <pn>) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy1> ^layer <lay> ^compo <gy2> ^commo <egarb1> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1>) - { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1>) - (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <v1> ^min <gy2> ^min-net <nn>) - (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p156 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) } - (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> > <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^pin-name <garb1>) - { <ff2> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <max> } ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx1>) - { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1> <ff2>) - (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <h1> ^min <gx2> ^min-net <nn>) - (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p157 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) } - (vertical ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <gx2> ^layer <lay> ^compo <egarb1> ^commo <gx1> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y <gy>) - { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1>) - (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <h1> ^min <gx2> ^min-net <nn>) - (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p158 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx2> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) } - (vertical ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <gx1> ^layer <lay> ^compo <gx2> ^commo <egarb1> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy>) - { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1>) - (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <h1> ^min <gx2> ^min-net <nn>) - (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p159 - (context ^present propagate-constraint) - { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) } - - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (vertical ^net-name <> nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - - (horizontal ^net-name <> nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { >= <gy> > <vmin> } ^com <gx> ^layer { <lay2> <> <lay> }) - --> - (modify <ff1> ^grid-layer <lay2> ^can-chng-layer no) -) - -(p p160 - (context ^present propagate-constraint) - { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) } - - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (vertical ^net-name <> nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - - (horizontal ^net-name <> nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { >= <gx> > <hmin> } ^com <gy> ^layer { <lay2> <> lay> }) - --> - (modify <ff1> ^grid-layer <lay2> ^can-chng-layer no) -) - -(p p161 - (context ^present propagate-constraint) - { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) } - - (horizontal ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - - (vertical ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - --> - (modify <ff1> ^can-chng-layer no) -) - -(p p162 - (context ^present << propagate-constraint move-ff >>) - { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) } - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - --> - (modify <ff1> ^can-chng-layer no) -) - -(p p163 - (context ^present << propagate-constraint move-ff >>) - { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) } - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - --> - (modify <ff1> ^can-chng-layer no) -) - -(p p164 - (context ^present propagate-constraint) - { <ff1> (ff ^can-chng-layer no ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn>) } - { <ff2> (ff ^can-chng-layer no ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay2> ^pin-name <garb1>) } - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx2>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy1>) - { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> >= <gx1> > <hmin> } ^com <gy1> ^layer <lay1> ^compo <hcpo> ^commo <gy2> ^min-net <hnn1>) } - { <v1> (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy1> > <vmin> } ^com <gx2> ^layer <lay2> ^compo <gx1> ^commo <vcmo> ^min-net <vnn1>) } - --> - (make horizontal ^min <hmin> ^max <gx2> ^com <gy1> ^commo <gy2> ^compo <hcpo> ^layer <lay1> ^min-net <hnn1> ^max-net <nn>) - (modify <h1> ^min <gx1> ^min-net <nn>) - (make vertical ^min <vmin> ^max <gy2> ^com <gx2> ^commo <vcmo> ^compo <gx1> ^layer <lay2> ^min-net <vnn1> ^max-net <nn>) - (modify <v1> ^min <gy1> ^min-net <nn>) - (remove <ff1> <ff2>) - (make horizontal ^min <gx2> ^max <gx1> ^com <gy1> ^commo <gy2> ^compo <hcpo> ^layer <lay1> ^net-name <nn> ^pin-name <pn>) - (make vertical ^min <gy2> ^max <gy1> ^com <gx2> ^commo <vcmo> ^compo <gx1> ^layer <lay2> ^net-name <nn> ^pin-name <pn>) -) - -(p p165 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <garb1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min <garb2> ^max { <max> > <garb2> } ^com <com> ^layer <lay> ^max-net <> <nn>) } - --> - (modify <v1> ^max-net <nn>) -) - -(p p166 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <min> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min <min> ^max { <garb2> > <min> } ^com <com> ^layer <lay> ^min-net <> <nn>) } - --> - (modify <v1> ^min-net <nn>) -) - -(p p167 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <max> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min { <garb1> < <max> } ^max <max> ^com { >= <hmin> <= <hmax> } ^layer <lay> ^max-net <> <nn>) } - --> - (modify <v1> ^max-net <nn>) -) - -(p p168 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <min> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min <min> ^max { <garb1> > <min> } ^com { >= <hmin> <= <hmax> } ^layer <lay> ^min-net <> <nn>) } - --> - (modify <v1> ^min-net <nn>) -) - -(p p169 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <garb1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <h1> (horizontal ^net-name nil ^min <garb2> ^max { <max> > <garb2> } ^com <com> ^layer <lay> ^max-net <> <nn>) } - --> - (modify <h1> ^max-net <nn>) -) - -(p p170 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <min> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <h1> (horizontal ^net-name nil ^min <min> ^max { <garb2> > <min> } ^com <com> ^layer <lay> ^min-net <> <nn>) } - --> - (modify <h1> ^min-net <nn>) -) - -(p p171 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <max> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max> > <garb1> } ^com { >= <vmin> <= <vmax> } ^layer <lay> ^max-net <> <nn>) } - --> - (modify <h1> ^max-net <nn>) -) - -(p p172 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <min> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <h1> (horizontal ^net-name nil ^min <min> ^max { <garb1> > <min> } ^com { >= <vmin> <= <vmax> } ^layer <lay> ^min-net <> <nn>) } - --> - (modify <h1> ^min-net <nn>) -) - -(p p173 - (context ^present propagate-constraint) - { <ff1> (ff ^can-chng-layer no ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy2> ^layer <garb3> ^compo <garb4> ^commo <gy1> ^pin-name <> <pn>) - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy2>) - - (vertical ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx>) - { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1>) - (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <v1> ^min <gy2> ^min-net <nn>) - (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p174 - (join-routed-net <nn>) - { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <lay> ^compo <garb1> ^commo <garb2>) } - { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>) } - --> - (modify <h1> ^max <max2>) - (remove <h2>) -) - -(p p175 - (join-routed-net <nn>) - { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <max> ^com <com> ^layer <lay> ^compo <garb2> ^commo <garb3>) } - { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - --> - (modify <v1> ^max <max2>) - (remove <v2>) -) - -(p p176 - { <j1> (join-routed-net <nn>) } - --> - (remove <j1>) - (make move-via <nn>) -) - -(p p177 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <vlayer> ^pin-name <egarb1>) - (horizontal ^net-name nil ^min <hmin2> ^max { <gx> > <hmin2> } ^com <vmax> ^layer <vlayer> ^compo <egarb8> ^commo <egarb9>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { < <vmax> > <gy> }) - { <v1> (vertical ^net-name nil ^min { <garb1> <= <gy> } ^max { <vmax> > <garb1> > <gy> } ^com <gx> ^layer <vlayer> ^commo <cmo> ^compo <cpo> ^max-net <maxn>) } - (horizontal ^net-name { <> <nn> <> nil } ^min { <hmin1> <= <gx> } ^max >= <gx> ^com <vmax> ^layer <> <vlayer>) - (vertical ^net-name { <> <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { <vcom> < <gx> >= <hmin1> >= <hmin2> } ^layer <vlayer>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com <vmax>) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { < <vmax> > <gy> } ^max-net nil) - - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <gx>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmax> ^max > <vmax> ^com <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gx> ^max > <gx> ^com <vmax>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { < <vmax> > <gy> } ^min-net nil) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { < <vmax> > <gy> }) - - (vertical ^net-name nil ^min < <vmax> ^max > <vmax> ^com { < <gx> > <vcom> }) - - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { < <gx> > <vcom> } ^max-net nil) - - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com { < <gx> > <vcom> } ^min-net nil) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { < <gx> > <vcom> }) - --> - (make vertical ^min (compute <gy> + 1) ^max <vmax> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <vlayer> ^max-net <maxn>) - (modify <v1> ^max <gy> ^max-net <nn>) -) - -(p p178 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <layer> ^pin-name <pn>) - { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <gx> > <hmin> } ^com <gy> ^layer <layer> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (vertical ^net-name { <> <nn> <> nil } ^min <cpo> ^max { <garb2> >= <cpo> } ^com <vcom> ^layer <layer1> ^compo <vcpo> ^commo <gx>) - (horizontal ^net-name { <> <nn> <> nil } ^min { <garb3> <= <vcom> } ^max { <garb4> >= <vcom> } ^com <cpo> ^layer <> <layer1> ^compo <garb5> ^commo <gy>) - (vertical ^net-name { <> <nn> <> nil } ^min { <garb6> <= <cmo> } ^max <cmo> ^com <vcom> ^layer <layer2> ^compo <vcpo> ^commo <gx>) - (horizontal ^net-name { <> <nn> <> nil } ^min { <garb7> <= <vcom> } ^max { <garb8> >= <vcom> } ^com <cmo> ^layer <> <layer2> ^compo <gy> ^commo <garb9>) - (vertical ^net-name { <> <nn> <> nil } ^min { <garb13> <= <gy> } ^max { <garb14> >= <gy> } ^com <vcpo> ^layer <layer3> ^compo <garb10> ^commo <vcom>) - (horizontal ^net-name { <> <nn> <> nil } ^min { <garb11> <= <vcpo> } ^max { <garb12> >= <vcpo> } ^com <gy> ^layer <> <layer3> ^compo <cpo> ^commo <cmo>) - --> - (make horizontal ^min (compute <gx> + 1) ^max <hmax> ^com <gy> ^compo <cpo> ^commo <cmo> ^layer <layer> ^max-net <mn>) - (modify <h1> ^max <gx> ^max-net <nn>) -) - -(p p179 - (context ^present propagate-constraint) - { <ff1> (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <pn>) } - (vertical ^net-name { <> <nn> <> nil } ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com <vcom> ^layer <lay2> ^compo <garb1> ^commo <gx>) - (vertical ^net-name { <> <nn> <> nil } ^min { <vmax2> > <gy> <= <vmax> } ^max <garb4> ^com <gx> ^layer <lay4>) - (vertical ^net-name { <> <nn> <> nil } ^min <garb2> ^max { <vmin2> < <gy> >= <vmin> } ^com <gx> ^layer <lay3>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmin2> < <gy> }) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmin2> < <gy> } ^layer <> <lay2> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmin2> < <gy> } ^max-net nil) - - (horizontal ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { > <vmin2> < <gy> }) - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <vmin2> ^layer <> <lay3>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmax2> }) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmax2> } ^layer <> <lay2> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmax2> } ^max-net nil) - - (horizontal ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmax2> }) - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <vmax2> ^layer <> <lay4>) - { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> >= <vcom> > <hmin> } ^com <gy> ^layer { <lay5> <> <lay2> } ^compo <hcpo> ^commo <hcmo> ^max-net <mn>) } - --> - (make horizontal ^layer <lay5> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <nn> ^max-net <mn> ^min <vcom> ^max <hmax>) - (modify <h1> ^max <gx> ^max-net <nn>) - (make horizontal ^layer <lay5> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom>) - (modify <ff1> ^grid-x <vcom> ^grid-layer <lay5> ^can-chng-layer no) -) - -(p p180 - (context ^present propagate-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <vmax> ^com <vcom> ^layer <lay1> ^compo <cpo> ^commo <cmo>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <vmax> ^layer { <garb4> <> <lay1> }) - (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <vmin> > <vmax> } ^max <garb5> ^com <vcom> ^layer <lay2>) - (horizontal ^net-name { <nn1> <> nil } ^min { <garb6> <= <vcom> } ^max { <garb7> >= <vcom> } ^com <vmin> ^layer { <garb8> <> <lay2> }) - (vertical ^net-name { <> <nn> <> nil } ^min { <vmin2> <= <vmax> } ^max { <vmax2> >= <vmin> } ^com <cpo> ^layer <lay3>) - { <v1> (vertical ^net-name nil ^min <vmax> ^max { <vmax3> > <vmax> } ^com <vcom> ^layer <lay3>) } - - (vertical ^net-name nil ^min <vmax3> ^com <vcom>) - - (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com { > <vmax> <= <vmax3> }) - - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com { > <vmax> <= <vmax3> } ^layer <> <lay3> ^min-net nil) - - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com { > <vmax> <= <vmax3> } ^max-net nil) - - (horizontal ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com { > <vmax> <= <vmax3> }) - --> - (modify <v1> ^min (compute <vmax> + 1) ^min-net nil) -) - -(p p181 - (context ^present propagate-constraint) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) } - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <garb1> ^grid-layer <lay> ^pin-name <> <pn>) - - (vertical ^com { > <gx> < <gx2> }) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { <egarb1> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2>) - --> - (modify <h1> ^min (compute <gx> + 1) ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^com <gy> ^max (compute <gx> + 1) ^commo <hcmo> ^compo <hcpo> ^layer <lay>) - (modify <ff1> ^grid-x (compute <gx> + 1) ^came-from west) -) - -(p p182 - (context ^present propagate-constraint) - { <v3> (vertical ^net-name nil ^min <vmin2> ^max { <vmax2> > <vmin2> } ^com <vcom> ^layer <garb1> ^compo <vcpo> ^commo <egarb1>) } - (congestion ^direction row ^coordinate <vmax2> ^como <vmin2>) - - (horizontal ^status nil ^min < <vcom> ^max >= <vcom> ^com { <= <vmax2> >= <vmin2> }) - - (vertical ^status nil ^min <vmax2> ^max > <vmax2> ^com <vcom>) - - (vertical ^status nil ^max <vmin2> ^min < <vmin2> ^com <vcom>) - (vertical ^net-name nil ^min { <vmin> <= <vmin2> } ^max { > <vmin> >= <vmax2> } ^com <vcpo> ^layer <lay>) - (horizontal ^net-name nil ^min <vcom> ^max { <egarb2> > <vcom> } ^com <vmax2> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) - (horizontal ^net-name nil ^min <vcom> ^max { <egarb5> > <vcom> } ^com <vmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) - --> - (remove <v3>) -) - -(p p183 - (context ^present propagate-constraint) - { <v3> (vertical ^net-name nil ^min <vmin2> ^max { <vmax2> > <vmin2> } ^com <vcom> ^layer <garb1> ^compo <garb2> ^commo <vcmo>) } - (congestion ^direction row ^coordinate <vmax2> ^como <vmin2>) - - (horizontal ^status nil ^min <= <vcom> ^max > <vcom> ^com { <= <vmax2> >= <vmin2> }) - - (vertical ^status nil ^min <vmax2> ^max > <vmax2> ^com <vcom>) - - (vertical ^status nil ^max <vmin2> ^min < <vmin2> ^com <vcom>) - (vertical ^net-name nil ^min { <vmin> <= <vmin2> } ^max { > <vmin> >= <vmax2> } ^com <vcmo> ^layer <lay>) - (horizontal ^net-name nil ^min <egarb1> ^max { <vcom> > <egarb1> } ^com <vmax2> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) - (horizontal ^net-name nil ^min <egarb6> ^max { <vcom> > <egarb6> } ^com <vmin2> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) - --> - (remove <v3>) -) - -(p p184 - (context ^present propagate-constraint) - { <h3> (horizontal ^net-name nil ^min <hmin2> ^max { <hmax2> > <hmin2> } ^com <hcom> ^layer <garb1> ^compo <hcpo> ^commo <egarb1>) } - (congestion ^direction col ^coordinate <hmax2> ^como <hmin2>) - - (vertical ^status nil ^min < <hcom> ^max >= <hcom> ^com { <= <hmax2> >= <hmin2> }) - - (horizontal ^status nil ^min <hmax2> ^max > <hmax2> ^com <hcom>) - - (horizontal ^status nil ^max <hmin2> ^min < <hmin2> ^com <hcom>) - (horizontal ^net-name nil ^min { <hmin> <= <hmin2> } ^max { > <hmin> >= <hmax2> } ^com <hcpo> ^layer <lay>) - (vertical ^net-name nil ^min <hcom> ^max { <egarb2> > <hcom> } ^com <hmax2> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) - (vertical ^net-name nil ^min <hcom> ^max { <egarb5> > <hcom> } ^com <hmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) - --> - (remove <h3>) -) - -(p p185 - (context ^present propagate-constraint) - { <h3> (horizontal ^net-name nil ^min <hmin2> ^max { <hmax2> > <hmin2> } ^com <hcom> ^layer <garb1> ^compo <garb2> ^commo <hcmo>) } - (congestion ^direction col ^coordinate <hmax2> ^como <hmin2>) - - (vertical ^status nil ^min <= <hcom> ^max > <hcom> ^com { <= <hmax2> >= <hmin2> }) - - (horizontal ^status nil ^min <hmax2> ^max > <hmax2> ^com <hcom>) - - (horizontal ^status nil ^max <hmin2> ^min < <hmin2> ^com <hcom>) - (horizontal ^net-name nil ^min { <hmin> <= <hmin2> } ^max { > <hmin> >= <hmax2> } ^com <hcmo> ^layer <lay>) - (vertical ^net-name nil ^min <egarb1> ^max { <hcom> > <egarb1> } ^com <hmax2> ^layer <lay> ^compo <egarb3> ^compo <egarb4>) - (vertical ^net-name nil ^min <egarb5> ^max { <hcom> > <egarb5> } ^com <hmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) - --> - (remove <h3>) -) - -(p p538 - (finally-routed <nn>) - { <i1> (included <nn>) } - --> - (remove <i1>) -) - -(p p539 - (finally-routed <nn>) - { <ff1> (ff ^net-name <nn>) } - --> - (remove <ff1>) -) - -(p p540 - (finally-routed <nn>) - { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-1 <nn>) } - --> - (remove <c1>) -) - -(p p541 - (finally-routed <nn>) - { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-2 <nn>) } - --> - (remove <c1>) -) - -(p p542 - (finally-routed <nn>) - { <c> (<< horizontal-cycle vertical-cycle >> <nn>) } - --> - (remove <c>) -) - -(p p543 - (finally-routed <nn>) - { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-2 <nn>) } - --> - (remove <c1>) -) - -(p p544 - (finally-routed <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) - { <h1> (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { <hmax> > <hmin> >= <vcom> } ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <nn1>) } - --> - (make horizontal ^min <hmin> ^max (compute <vcom> - 1) ^com <hcom> ^compo <hcpo> ^commo <hcmo> ^layer <lay> ^min-net <nn1>) - (modify <h1> ^min (compute <vcom> + 1) ^min-net nil) -) - -(p p545 - (finally-routed <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) - { <v1> (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { <vmax> > <vmin> >= <hcom> } ^com { <vcom> >= <hmin> <= <hmax> } ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <nn1>) } - --> - (make vertical ^min <vmin> ^max (compute <hcom> - 1) ^com <vcom> ^compo <vcpo> ^commo <vcmo> ^layer <lay> ^min-net <nn1>) - (modify <v1> ^min (compute <hcom> + 1) ^min-net nil) -) - -(p p546 - (finally-routed <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <rmax> ^com <com> ^layer <lay> ^compo <garb4> ^commo <garb3>) - { <v1> (vertical ^net-name nil ^min <rmax> ^max { <garb2> > <rmax> } ^com <com> ^layer <lay> ^compo <garb6> ^commo <garb5>) } - --> - (modify <v1> ^min (compute <rmax> + 1) ^min-net nil) -) - -(p p547 - (finally-routed <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <rmin> ^max <garb1> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>) - { <v1> (vertical ^net-name nil ^min <garb2> ^max { <rmin> > <garb2> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) } - --> - (modify <v1> ^max (compute <rmin> - 1) ^max-net nil) -) - -(p p548 - (finally-routed <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <rmax> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>) - { <h1> (horizontal ^net-name nil ^min <rmax> ^max { <garb2> > <rmax> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) } - --> - (modify <h1> ^min (compute <rmax> + 1) ^min-net nil) -) - -(p p549 - (finally-routed <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <rmin> ^max <garb1> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>) - { <h1> (horizontal ^net-name nil ^min <garb2> ^max { <rmin> > <garb2> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) } - --> - (modify <h1> ^max (compute <rmin> - 1) ^max-net nil) -) - -(p p550 - { <f1> (finally-routed <nn>) } - --> - (remove <f1>) - (make context ^present remove-routed-net-segments <nn>) -) - -(p p551 - (context ^present remove-routed-net-segments <nn>) - { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <c> ^layer <lay> ^compo <garb1> ^commo <garb2>) } - --> - (modify <h1> ^status routed) - (write (crlf) |hor | <nn> <min> <max> <c> <lay>) -) - -(p p552 - (context ^present remove-routed-net-segments <nn>) - { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <c> ^layer <lay> ^compo <garb1> ^commo <garb2>) } - --> - (modify <v1> ^status routed) - (write (crlf) |ver | <nn> <min> <max> <c> <lay>) -) - -(p p553 - (context ^present remove-routed-net-segments <nn>) - { <h> (horizontal-s ^net-name <nn>) } - --> - (remove <h>) -) - -(p p554 - (context ^present remove-routed-net-segments <nn>) - { <v> (vertical-s ^net-name <nn>) } - --> - (remove <v>) -) - -(p p555 - (context ^present remove-routed-net-segments <nn>) - { <p> (pin ^net-name <nn>) } - --> - (remove <p>) -) - -(p p556 - (context ^present remove-routed-net-segments <nn>) - { <n> (net ^net-name <nn>) } - --> - (remove <n>) -) - -(p p557 - { <c1> (context ^present remove-routed-net-segments) } - --> - (remove <c1>) - (make context ^present check-for-routed-net) -) - -(p p32 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - { <v> (vertical ^net-name nil ^min <gy2> ^max > <gy2> ^com <gx2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^min-net <garb2>) } - - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com <gy2> ^layer <lay>) - (congestion ^direction row ^coordinate <gy3> ^como <gy2>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx2> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy3> ^layer <lay>) - --> - (modify <v> ^min <gy3> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn2> ^min <gy2> ^max <gy3> ^com <gx2> ^compo <gx1> ^commo <cmo> ^layer <lay>) - (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from south) -) - -(p p33 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - { <v> (vertical ^net-name nil ^min < <gy1> ^max <gy1> ^com <gx1> ^layer <lay> ^commo <gx2> ^compo <cpo> ^min-net <garb2>) } - - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com <gy1> ^layer <lay>) - (congestion ^direction row ^coordinate <gy1> ^como <gy3>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx1> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy3> ^layer <lay>) - --> - (modify <v> ^max <gy3> ^max-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn1> ^min <gy3> ^max <gy1> ^com <gx1> ^compo <cpo> ^commo <gx2> ^layer <lay>) - (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from north) -) - -(p p34 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - { <v> (vertical ^net-name nil ^min <gy2> ^max > <gy2> ^com <gx2> ^layer <lay> ^commo <gx1> ^compo <cpo> ^min-net <garb2>) } - - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy2> ^layer <lay>) - (congestion ^direction row ^coordinate <gy3> ^como <gy2>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx2> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy3> ^layer <lay>) - --> - (modify <v> ^min <gy3> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn2> ^min <gy2> ^max <gy3> ^com <gx2> ^compo <cpo> ^commo <gx1> ^layer <lay>) - (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from south) -) - -(p p35 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - { <v> (vertical ^net-name nil ^min < <gy1> ^max <gy1> ^com <gx1> ^layer <lay> ^commo <cmo> ^compo <gx2> ^min-net <garb2>) } - - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy1> ^layer <lay>) - (congestion ^direction row ^coordinate <gy1> ^como <gy3>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx1> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy3> ^layer <lay>) - --> - (modify <v> ^max <gy3> ^max-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn1> ^min <gy3> ^max <gy1> ^com <gx1> ^compo <gx2> ^commo <cmo> ^layer <lay>) - (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from north) -) - -(p p36 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - { <v> (horizontal ^net-name nil ^min <gx2> ^max > <gx2> ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^min-net <garb2>) } - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx2> ^layer <lay>) - (congestion ^direction col ^coordinate <gx3> ^como <gx2>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy2> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx3> ^layer <lay>) - --> - (modify <v> ^min <gx3> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn2> ^min <gx2> ^max <gx3> ^com <gy2> ^compo <gy1> ^commo <cmo> ^layer <lay>) - (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from west) -) - -(p p37 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - { <v> (horizontal ^net-name nil ^min < <gx1> ^max <gx1> ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <garb2>) } - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx1> ^layer <lay>) - (congestion ^direction col ^coordinate <gx1> ^como <gx3>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy1> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx3> ^layer <lay>) - --> - (modify <v> ^max <gx3> ^max-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn1> ^min <gx3> ^max <gx1> ^com <gy1> ^compo <cpo> ^commo <gy2> ^layer <lay>) - (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from east) -) - -(p p38 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - { <v> (horizontal ^net-name nil ^min < <gx2> ^max <gx2> ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^min-net <garb2>) } - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx2> ^layer <lay>) - (congestion ^direction col ^coordinate <gx2> ^como <gx3>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy2> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx3> ^layer <lay>) - --> - (modify <v> ^max <gx3> ^max-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn2> ^min <gx3> ^max <gx2> ^com <gy2> ^compo <gy1> ^commo <cmo> ^layer <lay>) - (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from east) -) - -(p p39 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - { <v> (horizontal ^net-name nil ^min <gx1> ^max > <gx1> ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <garb2>) } - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx1> ^layer <lay>) - (congestion ^direction col ^coordinate <gx3> ^como <gx1>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy1> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx3> ^layer <lay>) - --> - (modify <v> ^min <gx3> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn1> ^min <gx1> ^max <gx3> ^com <gy1> ^compo <cpo> ^commo <gy2> ^layer <lay>) - (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from west) -) - -(p p40 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p41 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p42 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>) - (last-row <gy>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p43 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>) - (last-row <gy>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p44 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay> ^commo 0) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p45 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay> ^commo 0) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p46 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <h1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <vmax2> ^max-net nil) -) - -(p p47 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p48 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>) - (last-col <gx>) - --> - (modify <v1> ^max <vmax2> ^max-net nil) -) - -(p p49 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>) - (last-col <gx>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p50 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay> ^commo 0) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^max <vmax2> ^max-net nil) -) - -(p p51 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay> ^commo 0) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p52 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p53 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p54 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>) - (last-row <gy>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p55 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>) - (last-row <gy>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p56 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay> ^commo 0) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p57 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay> ^commo 0) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p58 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <h1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <vmax2> ^max-net nil) -) - -(p p59 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p60 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>) - (last-col <gx>) - --> - (modify <v1> ^max <vmax2> ^max-net nil) -) - -(p p61 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>) - (last-col <gx>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p62 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay> ^commo 0) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^max <vmax2> ^max-net nil) -) - -(p p63 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay> ^commo 0) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p64 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max { <hmax> > <vcom> } ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>) - (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcpo> ^layer <lay> ^compo <garb2> ^commo <vcom>) - (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com <hcmo> ^layer <lay>) - - (vertical ^status nil ^min <vmax> ^max > <vmax> ^com <vcom>) - - (horizontal ^status nil ^min { <temp> <= <vcom> } ^max { > <temp> >= <vcom> } ^com <vmax> ^layer <> <lay>) - --> - (modify <v> ^max <hcmo> ^max-net nil) - (make (substr <h> 1 inf) ^max <vcmo> ^max-net <nn1>) - (modify <h> ^min <vcpo> ^min-net <nn2>) -) - -(p p65 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max { <hmax> > <vcom> } ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>) - (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcpo> ^layer <lay> ^compo <garb2> ^commo <vcom>) - (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com <hcpo> ^layer <lay>) - - (vertical ^status nil ^min < <vmin> ^max <vmin> ^com <vcom>) - - (horizontal ^status nil ^min { <temp> <= <vcom> } ^max { > <temp> >= <vcom> } ^com <vmin> ^layer <> <lay>) - --> - (modify <v> ^min <hcpo> ^min-net nil) - (make (substr <h> 1 inf) ^max <vcmo> ^max-net <nn1>) - (modify <h> ^min <vcpo> ^min-net <nn2>) -) - -(p p66 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max { <vmax> > <hcom> } ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>) - (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcpo> ^layer <lay> ^compo <garb2> ^commo <hcom>) - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com <vcmo> ^layer <lay>) - - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom>) - - (vertical ^status nil ^min { <temp> <= <hcom> } ^max { > <temp> >= <hcom> } ^com <hmax> ^layer <> <lay>) - --> - (modify <h> ^max <vcmo> ^max-net nil) - (make (substr <v> 1 inf) ^max <hcmo> ^max-net <nn1>) - (modify <v> ^min <hcpo> ^min-net <nn2>) -) - -(p p67 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max { <vmax> > <hcom> } ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>) - (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcpo> ^layer <lay> ^compo <garb2> ^commo <hcom>) - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com <vcpo> ^layer <lay>) - - (horizontal ^status nil ^min < <hmin> ^max <hmin> ^com <hcom>) - - (vertical ^status nil ^min { <temp> <= <hcom> } ^max { > <temp> >= <hcom> } ^com <hmin> ^layer <> <lay>) - --> - (modify <h> ^min <vcpo> ^min-net nil) - (make (substr <v> 1 inf) ^max <hcmo> ^max-net <nn1>) - (modify <v> ^min <hcpo> ^min-net <nn2>) -) - -(p p68 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>) - (horizontal ^net-name nil ^min < <vcom> ^max >= <vcom> ^com <hcmo> ^layer <lay>) - - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com <vmax> ^layer <> <lay>) - --> - (modify <h> ^max <vcmo> ^max-net <nn1>) -) - -(p p69 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min <vcom> ^max { <hmax> > <vcom> } ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcpo> ^layer <lay> ^compo <garb1> ^commo <vcom>) - (horizontal ^net-name nil ^min <= <vcom> ^max > <vcom> ^com <hcmo> ^layer <lay>) - - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com <vmax> ^layer <> <lay>) - --> - (modify <h> ^min <vcpo> ^min-net <nn1>) -) - -(p p70 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>) - (horizontal ^net-name nil ^min < <vcom> ^max >= <vcom> ^com <hcpo> ^layer <lay>) - - (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com <vmin> ^layer <> <lay>) - --> - (modify <h> ^max <vcmo> ^max-net <nn1>) -) - -(p p71 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min <vcom> ^max { <hmax> > <vcom> } ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcpo> ^layer <lay> ^compo <garb1> ^commo <vcom>) - (horizontal ^net-name nil ^min <= <vcom> ^max > <vcom> ^com <hcpo> ^layer <lay>) - - (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com <vmin> ^layer <> <lay>) - --> - (modify <h> ^min <vcpo> ^min-net <nn1>) -) - -(p p72 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min <hcom> ^max { <vmax> > <hcom> } ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcpo> ^layer <lay> ^compo <garb1> ^commo <hcom>) - (vertical ^net-name nil ^min <= <hcom> ^max > <hcom> ^com <vcmo> ^layer <lay>) - - (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com <hmax> ^layer <> <lay>) - --> - (modify <v> ^min <hcpo> ^min-net <nn1>) -) - -(p p73 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>) - (vertical ^net-name nil ^min < <hcom> ^max >= <hcom> ^com <vcmo> ^layer <lay>) - - (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com <hmax> ^layer <> <lay>) - --> - (modify <v> ^max <hcmo> ^max-net <nn1>) -) - -(p p74 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min <hcom> ^max { <vmax> > <hcom> } ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcpo> ^layer <lay> ^compo <garb1> ^commo <hcom>) - (vertical ^net-name nil ^min <= <hcom> ^max > <hcom> ^com <vcpo> ^layer <lay>) - - (horizontal ^net-name nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com <hmin> ^layer <> <lay>) - --> - (modify <v> ^min <hcpo> ^min-net <nn1>) -) - -(p p75 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>) - (vertical ^net-name nil ^min < <hcom> ^max >= <hcom> ^com <vcpo> ^layer <lay>) - - (horizontal ^net-name nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com <hmin> ^layer <> <lay>) - --> - (modify <v> ^max <hcmo> ^max-net <nn1>) -) - -(p p76 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay>) - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <vlay>) - (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer { <hlay> <> <vlay> } ^compo <hcpo> ^commo <vmax>) - - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmax>) - { <v> (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <hlay>) } - --> - (modify <v> ^min <hcom> ^min-net <nn2>) -) - -(p p77 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay>) - (vertical ^net-name nil ^min <garb1> ^max { <vmin> > <garb1> } ^com <vcom> ^layer <vlay>) - (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer { <hlay> <> <vlay> } ^compo <vmin> ^commo <hcmo>) - - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmin>) - { <v> (vertical ^net-name nil ^min <garb2> ^max { <vmin> > <garb2> } ^com <vcom> ^layer <hlay>) } - --> - (modify <v> ^max <hcom> ^max-net <nn2>) -) - -(p p78 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay>) - (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <hlay>) - (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer { <vlay> <> <hlay> } ^compo <vcpo> ^commo <hmax>) - - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax>) - { <h> (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <vlay>) } - --> - (modify <h> ^min <vcom> ^min-net <nn2>) -) - -(p p79 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay>) - (horizontal ^net-name nil ^min <garb1> ^max { <hmin> > <garb1> } ^com <hcom> ^layer <hlay>) - (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer { <vlay> <> <hlay> } ^compo <hmin> ^commo <vcmo>) - - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmin>) - { <h> (horizontal ^net-name nil ^min <garb2> ^max { <hmin> > <garb2> } ^com <hcom> ^layer <vlay>) } - --> - (modify <h> ^max <vcom> ^max-net <nn2>) -) - -(p p80 - (context ^present propagate-constraint) - (last-col <lc>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> <= 1 } ^max <vmax> ^com <vcom> ^layer <vlay> ^pin-name <pn> ^commo <vcmo>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max { <hmax> >= <lc> } ^com <vmax> ^layer <hlay>) - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay>) } - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> }) - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> }) - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name <nn> ^min <= <vmax> ^max >= <vmax> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com <vcom>) - - (vertical ^net-name <nn> ^min <vmax> ^max > <vmax> ^com <vcom>) - - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com <vcom>) - - (vertical ^net-name <nn> ^min < <vmin> ^max <vmin> ^com <vcom>) - --> - (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcmo>) - (modify <h> ^max <vcmo> ^max-net <nn>) - (make ff ^grid-x <vcmo> ^grid-y <hcom> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from east) -) - -(p p81 - (context ^present propagate-constraint) - (last-row <lr>) - (last-col <lc>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max { <vmax> >= <lr> } ^com <vcom> ^layer <vlay> ^pin-name <pn> ^commo <vcmo>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max { <hmax> >= <lc> } ^com <vmin> ^layer <hlay>) - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay>) } - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> }) - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> }) - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name <nn> ^min <= <vmin> ^max >= <vmin> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com <vcom>) - - (vertical ^net-name <nn> ^min < <vmin> ^max <vmin> ^com <vcom>) - - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com <vcom>) - - (vertical ^net-name <nn> ^min <vmax> ^max > <vmax> ^com <vcom>) - --> - (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcmo>) - (modify <h> ^max <vcmo> ^max-net <nn>) - (make ff ^grid-x <vcmo> ^grid-y <hcom> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from east) -) - -(p p82 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^pin-name <pn> ^commo <hcmo>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max <vmax1> ^com <hmin> ^layer <vlay1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max <vmax2> ^com <hmax> ^layer <vlay2>) - { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer <lay>) } - - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com { < <vcom> >= <hmin> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com { < <vcom> >= <hmin> }) - - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com <vcom> ^layer <> <lay>) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <> <lay>) - - (horizontal ^net-name <nn> ^min <= <hmax> ^max >= <hmax> ^com { > <hcom> <= <vmax2> }) - - (horizontal ^net-name <nn> ^min <= <hmin> ^max >= <hmin> ^com { > <hcom> <= <vmax1> }) - - (horizontal ^net-name nil ^min <= <hmax> ^max >= <hmax> ^com { > <hcom> <= <vmax2> }) - - (horizontal ^net-name nil ^min <= <hmin> ^max >= <hmin> ^com { > <hcom> <= <vmax1> }) - - (horizontal ^net-name nil ^min <= <hmax> ^max >= <hmax> ^com <hcom>) - - (horizontal ^net-name <nn> ^min <hmax> ^max > <hmax> ^com <hcom>) - - (horizontal ^net-name nil ^min <= <hmin> ^max >= <hmin> ^com <hcom>) - - (horizontal ^net-name <nn> ^min < <hmin> ^max <hmin> ^com <hcom>) - --> - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <hcmo>) - (modify <v> ^max <hcmo> ^max-net <nn>) - (make ff ^grid-x <vcom> ^grid-y <hcmo> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from north) -) - -(p p377 - (context ^present find-no-of-pins-on-a-row-col) - (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay> ^compo <egarb1> ^commo <egabr2>) - (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>) - (ff ^net-name <nn> ^grid-y <gy> ^pin-name { <pn2> <> <pn1> } ^grid-x { <gx> > <fx> <= <max> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <fx> ^max >= <gx> ^com <gy>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <fx> <= <gx> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col row ^coor <gy>) - --> - (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <fx> ^max-xy <gx> ^last-pin <pn1> ^last-xy <fx>) -) - -(p p378 - (context ^present find-no-of-pins-on-a-row-col) - (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx> > <fx> <= <max> } ^pin-name { <pn2> <> <pn1> }) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <fx> ^max >= <gx> ^com <gy>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <fx> <= <gx> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col row ^coor <gy>) - --> - (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <fx> ^max-xy <gx> ^last-pin <pn1> ^last-xy <fx>) -) - -(p p379 - (context ^present find-no-of-pins-on-a-row-col) - (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay>) - (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx> < <fx> >= <min> } ^pin-name { <pn2> <> <pn1> }) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <fx> >= <gx> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col row ^coor <gy>) - --> - (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <gx> ^max-xy <fx> ^last-pin <pn2> ^last-xy <gx>) -) - -(p p380 - (context ^present find-no-of-pins-on-a-row-col) - (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>) - (ff ^net-name <nn> ^grid-x <gx> ^pin-name { <pn2> <> <pn1> } ^grid-y { <gy> > <fy> <= <max> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <fy> ^max >= <gy> ^com <gx>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <fy> <= <gy> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col col ^coor <gx>) - --> - (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <fy> ^max-xy <gy> ^last-pin <pn1> ^last-xy <fy>) -) - -(p p381 - (context ^present find-no-of-pins-on-a-row-col) - (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy> > <fy> <= <max> } ^pin-name { <pn2> <> <pn1> }) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <fy> ^max >= <gy> ^com <gx>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <fy> <= <gy> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col col ^coor <gx>) - --> - (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <fy> ^max-xy <gy> ^last-pin <pn1> ^last-xy <fy>) -) - -(p p382 - (context ^present find-no-of-pins-on-a-row-col) - (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy> < <fy> >= <min> } ^pin-name { <pn2> <> <pn1> }) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <fy> ^com <gx>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <fy> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col col ^coor <gx>) - --> - (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <gy> ^max-xy <fy> ^last-pin <pn2> ^last-xy <gy>) -) - -(p p383 - (context ^present find-no-of-pins-on-a-row-col) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <pn>) - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb3>) - - (ff ^net-name <nn> ^grid-y <= <gy> ^pin-name <> <pn>) - - (total ^net-name <nn>) - --> - (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins <np> ^total-pins <np>) -) - -(p p384 - (context ^present find-no-of-pins-on-a-row-col) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <pn>) - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb3> ^no-of-bottom-pins <np>) - - (ff ^net-name <nn> ^grid-y >= <gy> ^pin-name <> <pn>) - - (total ^net-name <nn>) - --> - (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins <np> ^total-pins <np>) -) - -(p p385 - (context ^present find-no-of-pins-on-a-row-col) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb2>) - - (total ^net-name <nn>) - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn> ^grid-x { <fx> > <gx> }) - - (ff ^net-name <nn> ^grid-y < <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <fx> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>) - { <v1> (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <mn>) } - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <gy> ^como <hcmo>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify <v1> ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff1> ^grid-y <hcmo> ^can-chng-layer nil) - (make total ^net-name <nn> ^row-col row ^coor <hcmo> ^level-pins <np> ^total-pins <np>) -) - -(p p386 - (context ^present find-no-of-pins-on-a-row-col) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb2> ^no-of-bottom-pins <np>) - - (total ^net-name <nn>) - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn> ^grid-x { <fx> > <gx> }) - - (ff ^net-name <nn> ^grid-y > <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <fx> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>) - { <v1> (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <mn>) } - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <hcmo> ^como <gy>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <nn> ^max-net <mn>) - (modify <v1> ^max <gy> ^max-net <nn>) - (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff1> ^grid-y <hcmo> ^can-chng-layer nil) - (make total ^net-name <nn> ^row-col row ^coor <hcmo> ^level-pins <np> ^total-pins <np>) -) - -(p p387 - { <t1> (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <np> ^total-pins <np> ^min-xy nil ^max-xy nil) } - (pin ^net-name <nn> ^pin-x <px1>) - - (pin ^net-name <nn> ^pin-x < <px1>) - (pin ^net-name <nn> ^pin-x { <px2> > <px1> }) - - (pin ^net-name <nn> ^pin-x > <px2>) - --> - (modify <t1> ^min-xy <px1> ^max-xy <px2>) -) - -(p p388 - (context ^present find-no-of-pins-on-a-row-col) - --> - (make context ^previous find-no-of-pins-on-a-row-col) - (remove 1) -) - -(p p389 - (context ^previous find-no-of-pins-on-a-row-col) - (total) - --> - (remove 1) - (make context ^present modify-total) -) - -(p p390 - (context ^present delete-totals) - --> - (modify 1 ^present choose-between-nets-on-the-same-row-col) -) - -(p p391 - { <c1> (context ^present << choose-between-nets-on-the-same-row-col choose-between-nets-on-the-same-row-col-con >>) } - { <t1> (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <garb1>) } - - (total ^net-name <> <nn> ^level-pins >= <cou>) - - (total ^net-name <nn> ^row-col <> <rc> ^level-pins >= <cou>) - --> - (remove <c1> <t1>) - (make change-priority) - (make tran-total <rc> <xy> (substr <t1> nets inf)) -) - -(p p392 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <garb1> ^row-col { << row col >> <garb2> } ^coor <garb3> ^level-pins <cou> ^total-pins <cou>) - { <t1> (total ^level-pins < <cou>) } - --> - (remove <t1>) -) - -(p p393 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <garb1> ^row-col { << row col >> <garb2> } ^coor <garb3> ^level-pins <cou> ^total-pins <garb4>) - { <t1> (total ^level-pins <cou1> ^total-pins { < <cou> <> <cou1> }) } - --> - (remove <t1>) -) - -(p p394 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <garb1> ^level-pins <cou>) - { <t1> (total ^net-name <nn> ^row-col <> <rc> ^level-pins <cou>) } - --> - (remove <t1>) -) - -(p p395 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <garb1>) - { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <> <xy> ^level-pins <cou>) } - --> - (remove <t1>) -) - -(p p396 - { <c1> (context ^present << choose-between-nets-on-the-same-row-col choose-between-nets-on-the-same-row-col-con >>) } - { <t1> (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <cou>) } - - (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou>) - --> - (remove <c1> <t1>) - (make change-priority) - (make tran-total <rc> <xy> (substr <t1> nets inf)) -) - -(p p397 - { <t1> (tran-total <rc> <xy> { <nn> <> nil <> end } <min> <max>) } - --> - (write (crlf) |***** next net to be routed is| <nn> *****) - (make next-segment <nn> <rc> <xy> useless <min> <max>) - (remove <t1>) - (make tran-total <rc> <xy> (substr <t1> 7 inf)) -) - -(p p398 - { <t1> (tran-total <rc> <xy> nil) } - --> - (make dominant-layer) - (remove <t1>) - (make goal cleanup total-verti) - (make goal cleanup counted-verti) - (make goal cleanup total) - (make goal cleanup extend-ff-tried) -) - -(p p399 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn> ^row-col { << row col >> <garb1> } ^coor <garb2> ^level-pins <cou> ^total-pins <cou>) - { <t1> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins > <cou>) } - --> - (remove <t1>) -) - -(p p400 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn> ^row-col { << row col >> <garb1> } ^coor <garb2> ^level-pins <cou> ^total-pins <cou1>) - { <t1> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins > <cou1>) } - - (total ^net-name <garb3> ^row-col <garb4> ^coor <garb5> ^level-pins <cou2> ^total-pins <cou2>) - --> - (remove <t1>) -) - -(p p401 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <garb1> ^row-col <garb2> ^coor <garb3> ^level-pins <cou1> ^total-pins <cou2>) - { <t1> (total ^net-name <garb4> ^row-col <garb5> ^coor <garb6> ^level-pins < <cou1> ^total-pins < <cou2>) } - --> - (remove <t1>) -) - -(p p402 - (context ^present choose-between-nets-on-the-same-row-col) - --> - (modify 1 ^present choose-between-nets-on-the-same-row-col-con) -) - -(p p403 - (context ^present choose-between-nets-on-the-same-row-col-con) - { <t1> (total ^net-name <nn> ^row-col row ^level-pins <cou> ^total-pins <cou2> ^cong nil) } - (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2>) - (pin ^net-name <nn> ^pin-x <px1>) - - (pin ^net-name <nn> ^pin-x < <px1>) - (pin ^net-name <nn> ^pin-x { <px2> > <px1> }) - - (pin ^net-name <nn> ^pin-x > <px2>) - (congestion ^direction col ^coordinate { >= <px1> <= <px2> } ^no-of-nets <non>) - - (congestion ^direction col ^coordinate { >= <px1> <= <px2> } ^no-of-nets > <non>) - --> - (modify <t1> ^cong <non>) -) - -(p p404 - (context ^present choose-between-nets-on-the-same-row-col-con) - { <t1> (total ^net-name <nn> ^row-col col ^level-pins <cou> ^total-pins <cou2> ^cong nil) } - (total <> <nn> { } { } <cou> <cou2>) - (pin ^net-name <nn> ^pin-y <py1>) - - (pin ^net-name <nn> ^pin-y < <py1>) - (pin ^net-name <nn> ^pin-y { <py2> > <py1> }) - - (pin ^net-name <nn> ^pin-y > <py2>) - (congestion ^direction row ^coordinate { >= <py1> <= <py2> } ^no-of-nets <non>) - - (congestion ^direction row ^coordinate { >= <py1> <= <py2> } ^no-of-nets > <non>) - --> - (modify <t1> ^cong <non>) -) - -(p p405 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <min1> ^max-xy <max1>) - (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy { <min2> > <max1> } ^max-xy <max2>) - { <t> (total ^net-name <nn1> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <= <max1> ^max-xy >= <min2>) } - --> - (remove <t>) -) - -(p p406 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <min1> ^max-xy <max1>) - { <t> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy >= <min1> ^max-xy <= <max1>) } - --> - (remove <t>) -) - -(p p407 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) - { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) } - (<< vertical-cycle horizontal-cycle >> <nn1>) - --> - (remove <t>) -) - -(p p408 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) - { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) } - (pin ^net-name <nn1> ^pin-y { <py> < <y> } ^pin-channel-side << left right >>) - - (pin ^net-name <nn> ^pin-y { > <py> < <y> } ^pin-channel-side << left right >>) - --> - (remove <t>) -) - -(p p409 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) - { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) } - (pin ^net-name <nn1> ^pin-y { <py> > <y> } ^pin-channel-side << left right >>) - - (pin ^net-name <nn> ^pin-y { > <y> < <py> } ^pin-channel-side << left right >>) - --> - (remove <t>) -) - -(p p410 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong <non>) - - (total ^cong nil) - { <t> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong <= <non>) } - --> - (remove <t>) -) - -(p p411 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn1> ^row-col <rc1> ^coor <xy1> ^level-pins <cou> ^total-pins > <cou>) - { <t1> (total ^net-name <nn2> ^row-col { <rc2> <> <rc1> } ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) } - { <t2> (total ^net-name <> <nn2> ^row-col <rc2> ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) } - --> - (remove <t1> <t2>) -) - -(p p412 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn1> ^row-col <rc1> ^coor <xy1> ^level-pins <cou> ^total-pins > <cou>) - { <t1> (total ^net-name <nn2> ^row-col <rc2> ^coor { <xy2> <> <xy1> } ^level-pins <cou> ^total-pins > <cou>) } - { <t2> (total ^net-name <> <nn2> ^row-col <rc2> ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) } - --> - (remove <t1> <t2>) -) - -(p p413 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-bottom-pins { <np> > 1 } ^net-is-routed <> yes) - - (total-verti <nn> bottom) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom) - --> - (make total-verti <nn> bottom 0 <np>) -) - -(p p414 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> bottom) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom) - (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>) - --> - (make total-verti <nn> bottom 0 <np>) -) - -(p p415 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> bottom) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom) - (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>) - --> - (make total-verti <nn> bottom 0 <np>) -) - -(p p416 - (context ^present find-no-of-vcg-hcg) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <garb1>) - (pin ^net-name <nn> ^pin-x <gx> ^pin-channel-side top ^pin-name <pn1>) - (net ^net-name { <nn1> <> <nn> } ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes) - (pin ^net-name <nn1> ^pin-x <gx> ^pin-channel-side bottom ^pin-name <pn2>) - - (total-verti <nn1> bottom) - - (constraint ^constraint-type vertical ^net-name-1 <nn> ^net-name-2 <nn1> ^pin-name-1 <pn1> ^pin-name-2 <pn2>) - --> - (make counted-verti <nn1> bottom <nn> <pn1> <pn2>) - (make total-verti <nn1> bottom 1 <np>) -) - -(p p417 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-left-pins { <np> > 1 } ^net-is-routed <> yes) - - (total-verti <nn> left) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left) - --> - (make total-verti <nn> left 0 <np>) -) - -(p p418 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> left) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left) - (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>) - --> - (make total-verti <nn> left 0 <np>) -) - -(p p419 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> left) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left) - (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>) - --> - (make total-verti <nn> left 0 <np>) -) - -(p p420 - (context ^present find-no-of-vcg-hcg) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb3> ^pin-name <garb2>) - (pin ^net-name <nn> ^pin-y <gy> ^pin-channel-side right ^pin-name <pn1>) - (net ^net-name { <nn1> <> <nn> } ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes) - (pin ^net-name <nn1> ^pin-y <gy> ^pin-channel-side left ^pin-name <pn2>) - - (total-verti <nn1> left) - - (constraint ^constraint-type horizontal ^net-name-1 <nn> ^net-name-2 <nn1> ^pin-name-1 <pn1> ^pin-name-2 <pn2>) - --> - (make counted-verti <nn1> left <nn> <pn1> <pn2>) - (make total-verti <nn1> left 1 <np>) -) - -(p p421 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-top-pins { <np> > 1 } ^net-is-routed <> yes) - - (total-verti <nn> top) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top) - --> - (make total-verti <nn> top 0 <np>) -) - -(p p422 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-top-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> top) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top) - (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>) - --> - (make total-verti <nn> top 0 <np>) -) - -(p p423 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-top-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> top) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top) - (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>) - --> - (make total-verti <nn> top 0 <np>) -) - -(p p424 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-right-pins { <np> > 1 } ^net-is-routed <> yes) - - (total-verti <nn> right) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right) - --> - (make total-verti <nn> right 0 <np>) -) - -(p p425 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-right-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> right) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right) - (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>) - --> - (make total-verti <nn> right 0 <np>) -) - -(p p426 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-right-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> right) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right) - (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>) - --> - (make total-verti <nn> right 0 <np>) -) - -(p p427 - (context ^present find-no-of-vcg-hcg) - (total-verti <nn> bottom <ntc>) - (constraint ^constraint-type vertical ^net-name-1 <tn> ^net-name-2 <nn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - - (counted-verti <nn> bottom <tn> <tpn> <bpn>) - --> - (make counted-verti <nn> bottom <tn> <tpn> <bpn>) - (modify 2 ^4 (compute <ntc> + 1)) -) - -(p p428 - (context ^present find-no-of-vcg-hcg) - (total-verti <nn> left <ntc>) - (constraint ^constraint-type horizontal ^net-name-1 <tn> ^net-name-2 <nn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - - (counted-verti <nn> left <tn> <tpn> <bpn>) - --> - (make counted-verti <nn> left <tn> <tpn> <bpn>) - (modify 2 ^4 (compute <ntc> + 1)) -) - -(p p429 - (context ^present find-no-of-vcg-hcg) - (total-verti <nn> top <ntc>) - (constraint ^constraint-type vertical ^net-name-1 <nn> ^net-name-2 <bn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - - (counted-verti <nn> top <bn> <tpn> <bpn>) - --> - (make counted-verti <nn> top <bn> <tpn> <bpn>) - (modify 2 ^4 (compute <ntc> + 1)) -) - -(p p430 - (context ^present find-no-of-vcg-hcg) - (total-verti <nn> right <ntc>) - (constraint ^constraint-type horizontal ^net-name-1 <nn> ^net-name-2 <bn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - - (counted-verti <nn> right <bn> <tpn> <bpn>) - --> - (make counted-verti <nn> right <bn> <tpn> <bpn>) - (modify 2 ^4 (compute <ntc> + 1)) -) - -(p p431 - (context ^present find-no-of-vcg-hcg) - --> - (remove 1) - (make context ^previous find-no-of-vcg-hcg) -) - -(p p432 - (context ^previous find-no-of-vcg-hcg) - (total-verti) - --> - (remove 1) - (make context ^present choose-between-total-verti) - (make context ^present choose-between-total-verti-0) -) - -(p p433 - (context ^present choose-between-total-verti) - - (total-verti ^4 0) - { <t> (total-verti <nn> bottom <garb> > 1) } - - (ff ^net-name <nn> ^came-from south) - --> - (remove <t>) -) - -(p p434 - (context ^present choose-between-total-verti) - - (total-verti ^4 0) - { <t> (total-verti <nn> top <garb> > 1) } - - (ff ^net-name <nn> ^came-from north) - --> - (remove <t>) -) - -(p p435 - (context ^present choose-between-total-verti) - - (total-verti ^4 0) - { <t> (total-verti <nn> left <garb> > 1) } - - (ff ^net-name <nn> ^came-from west) - --> - (remove <t>) -) - -(p p436 - (context ^present choose-between-total-verti) - - (total-verti ^4 0) - { <t> (total-verti <nn> right <garb> > 1) } - - (ff ^net-name <nn> ^came-from east) - --> - (remove <t>) -) - -(p p437 - (context ^present choose-between-total-verti) - --> - (modify 1 ^present extend-total-verti) -) - -(p p438 - (context ^present choose-between-total-verti) - (total-verti ^4 > 0) - (total-verti ^4 0) - --> - (remove 3) -) - -(p p439 - (context ^present choose-between-total-verti) - (total-verti <nn> { << top bottom >> <tb> } > 0) - (total-verti <nn> { << top bottom >> <> <tb> } 0) - --> - (remove 3) -) - -(p p440 - (context ^present choose-between-total-verti) - (total-verti <nn> { << left right >> <tb> } > 0) - (total-verti <nn> { << left right >> <> <tb> } 0) - --> - (remove 3) -) - -(p p441 - (context ^present choose-between-total-verti-0) - (total-verti <nn> { << top bottom >> <tb> } > 0) - (total-verti <nn> { << top bottom >> <> <tb> } > 0) - --> - (remove 2 3) -) - -(p p442 - (context ^present choose-between-total-verti-0) - (total-verti <nn> { << left right >> <tb> } > 0) - (total-verti <nn> { << left right >> <> <tb> } > 0) - --> - (remove 2 3) -) - -(p p443 - (context ^present choose-between-total-verti-0) - --> - (remove 1) -) - -(p p444 - (context ^present extend-total-verti) - (total-verti <nn> bottom ^5 > 1) - - (total-verti ^5 1) - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) - - (ff ^net-name <nn> ^grid-y < <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com <gx>) - (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> > <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - (congestion ^direction row ^coordinate <como> ^como <gy>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <como> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^min <min> ^max <gy> ^min-net <mn> ^max-net <nn> ^commo <vcmo> ^compo <vcpo> ^com <gx> ^layer <lay>) - (modify 4 ^min <como> ^min-net <nn>) - (make vertical ^net-name <nn> ^min <gy> ^max <como> ^layer <lay> ^commo <vcmo> ^compo <vcpo> ^pin-name <pn> ^com <gx>) - (modify 3 ^grid-y <como> ^can-chng-layer nil) - (remove 2) -) - -(p p445 - (context ^present extend-total-verti) - (total-verti <nn> left ^5 > 1) - - (total-verti ^5 1) - (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) - - (ff ^net-name <nn> ^grid-x < <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx> ^com <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { > <min> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - (congestion ^direction col ^coordinate <como> ^como <gx>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gy> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <como> ^layer <lay>) - --> - (make horizontal ^net-name nil ^min <min> ^max <gx> ^min-net <mn> ^max-net <nn> ^commo <hcmo> ^compo <hcpo> ^com <gy> ^layer <lay>) - (modify 4 ^min <como> ^min-net <nn>) - (make horizontal ^net-name <nn> ^min <gx> ^max <como> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^pin-name <pn> ^com <gy>) - (modify 3 ^grid-x <como> ^can-chng-layer nil) - (remove 2) -) - -(p p446 - (context ^present extend-total-verti) - (total-verti <nn> top ^5 > 1) - - (total-verti ^5 1) - (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) - - (ff ^net-name <nn> ^grid-y > <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com <gx>) - (vertical ^net-name nil ^max { <max> >= <gy> } ^min { < <max> < <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^max-net <mn>) - (congestion ^direction row ^coordinate <gy> ^como <como>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <como> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^min <gy> ^max <max> ^max-net <mn> ^min-net <nn> ^commo <vcmo> ^compo <vcpo> ^com <gx> ^layer <lay>) - (modify 4 ^max <como> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <como> ^layer <lay> ^commo <vcmo> ^compo <vcpo> ^pin-name <pn> ^com <gx>) - (modify 3 ^grid-y <como> ^can-chng-layer nil) - (remove 2) -) - -(p p447 - (context ^present extend-total-verti) - (total-verti <nn> right ^5 > 1) - - (total-verti ^5 1) - (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) - - (ff ^net-name <nn> ^grid-x > <gx>) - - (horizontal ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx> ^status nil ^com <gy>) - (horizontal ^net-name nil ^max { <max> >= <gx> } ^min { < <max> < <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^max-net <mn>) - (congestion ^direction col ^coordinate <gx> ^como <como>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gy> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <como> ^layer <lay>) - --> - (make horizontal ^net-name nil ^min <gx> ^max <max> ^max-net <mn> ^min-net <nn> ^commo <hcmo> ^compo <hcpo> ^com <gy> ^layer <lay>) - (modify 4 ^max <como> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx> ^min <como> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^pin-name <pn> ^com <gy>) - (modify 3 ^grid-x <como> ^can-chng-layer nil) - (remove 2) -) - -(p p448 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> bottom ^5 1) } - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin>) - { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c6> ^max <hcom> ^max-net <nn>) - (modify <c4> ^min <hcom>) - (make pull-ff north <nn> <gx> <gy> <gx> <hcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from north) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p449 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> bottom ^5 1) } - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin> ^grid-layer <garb1> ^pin-name <garb2>) } - { <c7> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb3> ^commo <garb4>) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c7> ^max <hcom> ^max-net <nn>) - (modify <c4> ^min <hcom>) - (make pull-ff north <nn> <gx> <gy> <gx> <hcom>) - (modify <c5> ^grid-y <hcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p450 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> bottom ^5 1) } - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> }) - { <c41> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin1> > <gy> } ^com { <vcom1> > <gx> } ^layer <lay> ^pin-name <pn1>) } - - (vertical-s ^net-name <> <nn> ^com <vcom1>) - { <c61> (vertical ^net-name nil ^min <vvmin1> ^max { <vmin1> > <vvmin1> } ^com <vcom1> ^layer <lay>) } - (horizontal ^net-name nil ^min { <hmin1> <= <gx> } ^max { > <hmin1> >= <vcom1> } ^com { <hcom1> >= <vvmin1> < <vmin1> <= <hcom> }) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom1> ^com { >= <vvmin1> < <hcom1> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom1> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin1> > <hcom1> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <hcom1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <vcom> ^layer <lay>) - --> - (modify <c61> ^max <hcom1> ^max-net <nn>) - (modify <c41> ^min <hcom1>) - (make pull-ff north <nn> <gx> <gy> <gx> <hcom1>) - (make ff ^net-name <nn> ^pin-name <pn1> ^grid-layer <lay> ^grid-x <vcom1> ^grid-y <hcom1> ^came-from north) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p451 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> bottom ^5 1) } - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin>) - { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay>) } - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> >= <vvmin> < <vmin> }) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { >= <vvmin> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c6> ^max <hcom> ^max-net <nn>) - (modify <c4> ^min <hcom>) - (make pull-ff north <nn> <gx> <gy> <gx> <hcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from north) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p452 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> bottom ^5 1) } - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin> ^grid-layer <garb1> ^pin-name <garb2>) } - { <c7> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay>) } - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> >= <vvmin> < <vmin> }) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { >= <vvmin> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c7> ^max <hcom> ^max-net <nn>) - (modify <c4> ^min <hcom>) - (make pull-ff north <nn> <gx> <gy> <gx> <hcom>) - (modify <c5> ^grid-y <hcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p453 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> top ^5 1) } - (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax>) - { <c6> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> <= <vvmax> > <vmax> }) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { <= <vvmax> > <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c6> ^min <hcom> ^min-net <nn>) - (modify <c4> ^max <hcom>) - (make pull-ff south <nn> <gx> <gy> <gx> <hcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from south) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p454 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> top ^5 1) } - (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax> ^grid-layer <garb2> ^pin-name <garb3>) } - { <c7> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> <= <vvmax> > <vmax> }) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { <= <vvmax> > <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c7> ^min <hcom> ^min-net <nn>) - (modify <c4> ^max <hcom>) - (make pull-ff south <nn> <gx> <gy> <gx> <hcom>) - (modify <c5> ^grid-y <hcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p455 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> top ^5 1) } - (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax>) - { <c6> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> <= <vvmax> > <vmax> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { <= <vvmax> > <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c6> ^min <hcom> ^min-net <nn>) - (modify <c4> ^max <hcom>) - (make pull-ff south <nn> <gx> <gy> <gx> <hcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from south) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p456 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> top ^5 1) } - (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax> ^grid-layer <garb4> ^pin-name <garb5>) } - { <c7> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> <= <vvmax> > <vmax> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { <= <vvmax> > <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c7> ^min <hcom> ^min-net <nn>) - (modify <c4> ^max <hcom>) - (make pull-ff south <nn> <gx> <gy> <gx> <hcom>) - (modify <c5> ^grid-y <hcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p457 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> left ^5 1) } - (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom>) - { <c6> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> >= <hhmin> < <hmin> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { >= <hhmin> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c6> ^max <vcom> ^max-net <nn>) - (modify <c4> ^min <vcom>) - (make pull-ff east <nn> <gx> <gy> <gy> <vcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from east) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p458 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> left ^5 1) } - (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - { <c5> (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) } - { <c7> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) } - (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> >= <hhmin> < <hmin> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { >= <hhmin> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c7> ^max <vcom> ^max-net <nn>) - (modify <c4> ^min <vcom>) - (make pull-ff east <nn> <gx> <gy> <gy> <vcom>) - (modify <c5> ^grid-x <vcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p459 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> left ^5 1) } - (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom>) - { <c6> (horizontal ^net-name nil ^max <hmin> ^min { <hhmin> < <hmin> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> >= <hhmin> < <hmin> }) - - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { >= <hhmin> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c6> ^max <vcom> ^max-net <nn>) - (modify <c4> ^min <vcom>) - (make pull-ff east <nn> <gx> <gy> <gy> <vcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from east) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p460 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> left ^5 1) } - (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - { <c5> (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) } - { <c7> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) } - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> >= <hhmin> < <hmin> }) - - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { >= <hhmin> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c7> ^max <vcom> ^max-net <nn>) - (modify <c4> ^min <vcom>) - (make pull-ff east <nn> <gx> <gy> <gy> <vcom>) - (modify <c5> ^grid-x <vcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p461 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> right ^5 1) } - (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom>) - { <c6> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> <= <hhmax> > <hmax> }) - - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { <= <hhmax> > <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c6> ^min <vcom> ^min-net <nn>) - (modify <c4> ^max <vcom>) - (make pull-ff west <nn> <gx> <gy> <gy> <vcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from west) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p462 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> right ^5 1) } - (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - { <c5> (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) } - { <c7> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <gabr6> ^commo <garb7>) } - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> <= <hhmax> > <hmax> }) - - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { <= <hhmax> > <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c7> ^min <vcom> ^min-net <nn>) - (modify <c4> ^max <vcom>) - (make pull-ff west <nn> <gx> <gy> <gy> <vcom>) - (modify <c5> ^grid-x <vcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p463 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> right ^5 1) } - (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom>) - { <c6> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <gabr5>) } - (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> <= <hhmax> > <hmax> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { <= <hhmax> > <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c6> ^min <vcom> ^min-net <nn>) - (modify <c4> ^max <vcom>) - (make pull-ff west <nn> <gx> <gy> <gy> <vcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from west) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p464 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> right ^5 1) } - (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - { <c5> (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) } - { <c7> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) } - (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> <= <hhmax> > <hmax> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { <= <hhmax> > <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c7> ^min <vcom> ^min-net <nn>) - (modify <c4> ^max <vcom>) - (make pull-ff west <nn> <gx> <gy> <gy> <vcom>) - (modify <c5> ^grid-x <vcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p465 - { <c1> (context ^present remove-total-verti-gt1) } - --> - (modify <c1> ^present find-no-of-pins-on-a-row-col) -) - -(p p466 - { <c1> (context ^present extend-total-verti) } - --> - (modify <c1> ^present remove-total-verti-gt1) -) - -(p p467 - (context ^present remove-total-verti-gt1) - (total-verti ^5 > 1) - { <t> (total-verti ^5 1) } - --> - (remove <t>) -) - -(p p468 - { <c1> (context ^present remove-total-verti-gt1) } - (total-verti ^5 > 1) - - (total-verti ^5 1) - --> - (make remove-all-total-vertis) - (modify <c1> ^present extend-total-verti) -) - -(p p469 - { <c1> (context ^present remove-total-verti-gt1) } - { <c> (remove-all-total-vertis) } - - (total-verti) - --> - (remove <c>) - (modify <c1> ^present propagate-constraint) -) - -(p p470 - { <c1> (context ^present remove-total-verti-gt1) } - { <c> (remove-all-total-vertis) } - --> - (remove <c>) - (modify <c1> ^present find-no-of-pins-on-a-row-col) -) - -(p p471 - { <c1> (context ^present << extend-total-verti remove-total-verti-gt1 >>) } - - (total-verti) - --> - (modify <c1> ^present propagate-constraint) -) - -(p p515 - { <c> (context ^previous find-no-of-pins-on-a-row-col) } - - (total) - { <p> (pull-ff north <nn> <gx> <gy1> <gx> <gy2>) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from south ^pin-name <pn>) } - { <v> (vertical ^net-name nil ^min <gy1> ^max >= <gy2> ^com <gx> ^layer <lay>) } - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - --> - (remove <p> <c>) - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <gy2>) - (modify <v> ^min <gy2> ^min-net <nn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p516 - { <c> (context ^previous find-no-of-pins-on-a-row-col) } - - (total) - { <p> (pull-ff south <nn> <gx> <gy1> <gx> <gy2>) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from north ^pin-name <pn>) } - { <v> (vertical ^net-name nil ^min <= <gy2> ^max <gy1> ^com <gx> ^layer <lay>) } - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - --> - (remove <p> <c>) - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <gy2>) - (modify <v> ^max <gy2> ^max-net <nn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p517 - { <c> (context ^previous find-no-of-pins-on-a-row-col) } - - (total) - { <p> (pull-ff east <nn> <gx1> <gy> <gx2> <gy>) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from west ^pin-name <pn>) } - { <v> (horizontal ^net-name nil ^min <gx1> ^max >= <gx2> ^com <gy> ^layer <lay>) } - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove <p> <c>) - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <gx2>) - (modify <v> ^min <gx2> ^min-net <nn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p518 - { <c> (context ^previous find-no-of-pins-on-a-row-col) } - - (total) - { <p> (pull-ff west <nn> <gx1> <gy> <gx2> <gy>) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from east ^pin-name <pn>) } - { <v> (horizontal ^net-name nil ^min <= <gx2> ^max <gx1> ^com <gy> ^layer <lay>) } - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove <p> <c>) - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <gx2>) - (modify <v> ^max <gx2> ^max-net <nn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p293 - (eliminate-total) - (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>) - { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy <min2> ^max-xy { <max2> > <max1> } ^level-pins < <p1>) } - - (total ^row-col <rc> ^coor <xy> ^max-xy < <min2>) - - (total ^row-col <rc> ^coor <xy> ^min-xy { > <max1> < <max2> }) - --> - (remove <t1>) -) - -(p p294 - (eliminate-total) - (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>) - { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy <min2> ^max-xy { <max2> < <max1> } ^level-pins < <p1>) } - - (total ^row-col <rc> ^coor <xy> ^max-xy < <min2>) - - (total ^row-col <rc> ^coor <xy> ^min-xy { > <max2> < <max1> }) - --> - (remove <t1>) -) - -(p p295 - (eliminate-total) - (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>) - { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy { <min2> < <min1> } ^max-xy <max2> ^level-pins < <p1>) } - - (total ^row-col <rc> ^coor <xy> ^min-xy > <max2>) - - (total ^row-col <rc> ^coor <xy> ^max-xy { > <min2> < <min1> }) - --> - (remove <t1>) -) - -(p p296 - (eliminate-total) - (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>) - { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy { <min2> > <min1> } ^max-xy <max2> ^level-pins < <p1>) } - - (total ^row-col <rc> ^coor <xy> ^min-xy > <max2>) - - (total ^row-col <rc> ^coor <xy> ^max-xy { > <min1> < <min2> }) - --> - (remove <t1>) -) - -(p p297 - (context ^present merge) - { <m> (merge-direction left) } - { <t1> (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins <lcou> ^total-pins <tcou> ^min-xy <min> ^max-xy <max>) } - - (rmerge) - - (total ^net-name <> <nn1> ^row-col <rc> ^coor <xy> ^max-xy < <max>) - (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy > <max>) - --> - (remove <m>) - (make merge-direction right) - (make lmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou> (substr <t1> nets inf)) -) - -(p p298 - (context ^present merge) - { <m> (merge-direction right) } - { <t1> (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins <lcou> ^total-pins <tcou> ^min-xy <min> ^max-xy <max>) } - - (lmerge) - - (total ^net-name <> <nn1> ^row-col <rc> ^coor <xy> ^min-xy > <min>) - (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^max-xy < <min>) - --> - (remove <m>) - (make merge-direction left) - (make rmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou> (substr <t1> nets inf)) -) - -(p p299 - { <c> (lmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou>) } - { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy { <min1> > <max> } ^max-xy <max1>) } - - (total ^row-col <rc> ^coor <xy> ^min-xy > <max> ^max-xy < <min1>) - - (place-holder <rc> <xy> > <max> < <min1>) - --> - (make total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins (compute <lcou> + <cou3>) ^total-pins (compute <tcou> + <cou4>) ^min-xy <min> ^max-xy <max1> ^nets (substr <c> 9 inf) (substr <t2> nets inf)) - (make delete-merged <nn2> <rc> <xy> <min1> <max1> (genatom)) -) - -(p p300 - { <c> (rmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou>) } - { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy <min1> ^max-xy { <max1> < <min> }) } - - (total ^row-col <rc> ^coor <xy> ^min-xy > <max1> ^max-xy < <min>) - - (place-holder <rc> <xy> > <max1> < <min>) - --> - (make total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins (compute <lcou> + <cou3>) ^total-pins (compute <tcou> + <cou4>) ^min-xy <min1> ^max-xy <max> ^nets (substr <c> 9 inf) (substr <t2> nets inf)) - (make rdelete-merged <nn2> <rc> <xy> <min1> <max1> (genatom)) -) - -(p p301 - { <d> (delete-merged <nn> <rc> <xy> <min> <max> <id>) } - (delete-merged <nn> <rc> <xy> <min> <max> <> <id>) - --> - (remove <d>) -) - -(p p302 - { <d> (rdelete-merged <nn> <rc> <xy> <min> <max> <id>) } - (rdelete-merged <nn> <rc> <xy> <min> <max> <> <id>) - --> - (remove <d>) -) - -(p p303 - (delete-merged <nn> <rc> <xy> <min> <max>) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) } - - (lmerge) - --> - (remove <t>) -) - -(p p304 - (rdelete-merged <nn> <rc> <xy> <min> <max>) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) } - - (rmerge) - --> - (remove <t>) -) - -(p p305 - { <d> (<< delete-merged rdelete-merged >>) } - - (<< lmerge rmerge >>) - --> - (remove <d>) -) - -(p p306 - (delete-merged <nn> <rc> <xy> <min> <max>) - { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max> ^level-pins <cou1> ^total-pins <cou2>) } - { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy <min1> ^max-xy { <max1> < <min> }) } - - (lmerge) - --> - (make place-holder <rc> <xy> <min> <max> (genatom)) - (make total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins (compute <cou1> + <cou3>) ^total-pins (compute <cou2> + <cou4>) ^min-xy <min1> ^max-xy <max> ^nets (substr <t1> nets inf) (substr <t2> nets inf)) -) - -(p p307 - (rdelete-merged <nn> <rc> <xy> <min> <max>) - { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max> ^level-pins <cou1> ^total-pins <cou2>) } - { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy { <min1> > <max> } ^max-xy <max1>) } - - (rmerge) - --> - (make place-holder <rc> <xy> <min> <max> (genatom)) - (make total ^net-name <nn> ^row-col <rc> ^coor <xy> ^level-pins (compute <cou1> + <cou3>) ^total-pins (compute <cou2> + <cou4>) ^min-xy <min> ^max-xy <max1> ^nets (substr <t1> nets inf) (substr <t2> nets inf)) -) - -(p p308 - { <p> (place-holder <rc> <xy> <min> <max> <id>) } - (place-holder <rc> <xy> <min> <max> <> <id>) - --> - (remove <p>) -) - -(p p309 - (<< lmerge rmerge >>) - { <p> (place-holder <rc> <xy> <min> <max> <id>) } - - (total ^row-col <rc> ^coor <xy> ^max-xy < <min>) - --> - (remove <p>) -) - -(p p310 - (<< lmerge rmerge >>) - { <p> (place-holder <rc> <xy> <min> <max> <id>) } - - (total ^row-col <rc> ^coor <xy> ^min-xy > <max>) - --> - (remove <p>) -) - -(p p311 - (context ^present merge) - { <l> (lmerge <nn> <rc> <xy> <min> <max>) } - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) } - --> - (remove <l> <t>) -) - -(p p312 - (context ^present merge) - { <l> (rmerge <nn> <rc> <xy> <min> <max>) } - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) } - --> - (remove <l> <t>) -) - -(p p313 - (context ^present merge) - (total ^level-pins <cou> ^total-pins <cou>) - - (total ^level-pins { <cou1> > <cou> } ^total-pins <cou1>) - { <m> (maximum-total < <cou>) } - --> - (modify <m> ^2 <cou>) -) - -(p p314 - (context ^present merge) - (total ^row-col row ^coor 1 ^level-pins <cou> ^total-pins <cou>) - - (total ^row-col row ^coor 1 ^level-pins { <cou1> > <cou> } ^total-pins <cou1>) - { <m> (maximum-total ^5 1 < <cou>) } - --> - (modify <m> ^6 <cou>) -) - -(p p315 - (context ^present merge) - (last-row <lr>) - (total ^row-col row ^coor <lr> ^level-pins <cou> ^total-pins <cou>) - - (total ^row-col row ^coor <lr> ^level-pins { <cou1> > <cou> } ^total-pins <cou1>) - { <m> (maximum-total ^7 <lr> < <cou>) } - --> - (modify <m> ^8 <cou>) -) - -(p p316 - (context ^present merge) - (total ^level-pins <cou1> ^total-pins <cou2>) - - (total ^level-pins > <cou1> ^total-pins > <cou2>) - { <m> (maximum-total <garb4> { <min1> < <cou1> }) } - --> - (modify <m> ^3 <cou1> ^4 <cou2>) -) - -(p p317 - { <con> (context ^present merge) } - --> - (modify <con> ^present delete-totals) - (make goal cleanup eliminate-total) - (make goal cleanup merge-direction) -) - -(p p318 - (context ^present delete-totals) - (maximum-total <max> <garb1> <garb2>) - { <t> (total ^level-pins { <cou> < <max> } ^total-pins <> <cou>) } - --> - (remove <t>) -) - -(p p319 - (context ^present delete-totals) - (maximum-total ^5 1 ^6 <cou>) - { <t> (total ^row-col row ^coor 1 ^level-pins { <cou1> < <cou> } ^total-pins <cou1>) } - --> - (remove <t>) -) - -(p p320 - (context ^present delete-totals) - (maximum-total ^7 <lr> ^8 <cou>) - { <t> (total ^row-col row ^coor <lr> ^level-pins { <cou1> < <cou> } ^total-pins <cou1>) } - --> - (remove <t>) -) - -(p p321 - (context ^present delete-totals) - (maximum-total <garb1> <min> <max>) - { <t> (total ^level-pins { <cou> < <min> }) } - (last-row <lr>) - (total ^row-col row ^coor { <> 1 <> <lr> }) - --> - (remove <t>) -) - -(p p322 - (context ^present delete-totals) - (total ^row-col <rc> ^coor <xy> ^level-pins <min> ^total-pins <max>) - { <t1> (total ^row-col <rc> ^coor <xy> ^level-pins { <cou> <= <min> } ^total-pins > <max>) } - --> - (remove <t1>) -) - -(p p323 - (context ^present delete-totals) - { <m> (maximum-total <garb1> <garb2> <garb3>) } - --> - (remove <m>) -) - -(p p324 - { <c1> (context ^present delete-totals) } - - (maximum-total) - { <t1> (total ^net-name <nn1> ^row-col row ^coor 1) } - { <t2> (total ^net-name <nn2> ^row-col row ^coor <lr>) } - - (total ^row-col row ^coor { <> 1 <> <lr> }) - (last-row <lr>) - --> - (remove <c1> <t1> <t2>) - (make change-priority) - (make tran-total row 1 (substr <t1> nets inf) end) - (make tran-total row <lr> (substr <t2> nets inf) end) - (make goal cleanup total) -) - -(p p325 - (context ^present delete-totals) - - (maximum-total) - (total ^net-name <nn1> ^row-col row ^coor 1) - (total ^net-name <nn2> ^row-col row ^coor <lr>) - { <t1> (total ^net-name <> <nn1> ^row-col row ^coor 1) } - (last-row <lr>) - --> - (remove <t1>) -) - -(p p326 - { <t1> (tran-total <rc> <xy1> end) } - { <t2> (tran-total <rc> <> <xy1> end) } - --> - (remove <t2>) - (modify <t1> ^4 nil) -) - -(p p519 - (context ^present random1) - (net ^net-name <nn> ^net-no-of-pins 2) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) - (vertical-layer <lay>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> <= <gy1> } ^grid-layer <lay>) - (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^compo <gx2> ^commo <cmo> ^min-net <vnn1>) - (vertical ^net-name nil ^min { <vmin2> <= <gy2> } ^max { <vmax2> > <vmin2> >= <gy2> >= <vmin1> } ^com <gx2> ^layer <lay> ^compo <cpo> ^commo <garb1> ^max-net <vnn2>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> >= <gx2> > <hmin> } ^com { <hcom> <= <vmax1> >= <vmin1> <= <vmax2> >= <vmin2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - - (horizontal ^net-name <> nil ^com <hcom>) - --> - (remove 1 3 5) - (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gx2> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>) - (modify 6 ^min <gy1> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax2> ^compo <cpo> ^commo <gx1> ^min-net <nn> ^max-net <vnn2>) - (modify 7 ^max <gy2> ^max-net <nn>) - (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 8 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <cmo> ^compo <gx2> ^net-name <nn> ^pin-name <pn>) - (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <gx1> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p520 - (context ^present random1) - (net ^net-name <nn> ^net-no-of-pins 2) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) - (horizontal-layer <lay>) - (ff ^net-name <nn> ^grid-x { <gx2> >= <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <lay>) - (horizontal ^net-name nil ^min { <hmin1> <= <gx1> } ^max { <hmax1> > <hmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^compo <gy2> ^commo <cmo> ^max-net <hnn1>) - (horizontal ^net-name nil ^min { <hmin2> <= <gx2> } ^max { <hmax2> > <hmin2> >= <gx2> >= <hmax1> } ^com <gy2> ^layer <lay> ^compo <cpo> ^commo <garb1> ^min-net <hnn2>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> >= <gy2> > <vmin> } ^com { <vcom> <= <hmax1> >= <hmin1> <= <hmax2> >= <hmin2> } ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - - (vertical ^net-name <> nil ^com <vcom>) - --> - (remove 1 3 5) - (make horizontal ^com <gy1> ^layer <lay> ^min <vcom> ^max <hmax1> ^compo <gy2> ^commo <cmo> ^min-net <nn> ^max-net <hnn1>) - (modify 6 ^max <gx1> ^max-net <nn>) - (make horizontal ^com <gy2> ^layer <lay> ^min <hmin2> ^max <vcom> ^compo <cpo> ^commo <gy1> ^min-net <hnn2> ^max-net <nn>) - (modify 7 ^min <gx2> ^min-net <nn>) - (make vertical ^min <vmin> ^max <gy1> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 8 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <lay> ^min <gx1> ^max <vcom> ^commo <cmo> ^compo <gy2> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <lay> ^min <vcom> ^max <gx2> ^commo <gy1> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (make vertical ^com <vcom> ^layer <lay> ^min <gy1> ^max <gy2> ^commo <vcmo> ^compo <vcpo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p521 - (context ^present random1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> > <gx> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { >= <gx> < <vcom1> }) - (vertical ^com { <vcom2> <= <vcom1> > <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom2>) - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom2> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <vcom2> >= <gx> } ^layer <lay>) - - (ff ^net-name <nn> ^grid-x < <gx>) - - (ff ^grid-x <vcom2> ^grid-y <gy>) - --> - (make made-random-move) - (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <vcom2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from west) -) - -(p p522 - (context ^present random1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> < <gx> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> }) - (vertical ^com { <vcom2> >= <vcom1> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom2> ^max >= <gx>) - (horizontal ^net-name nil ^min { <hmin> <= <vcom2> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <gx> >= <vcom2> } ^layer <lay>) - - (ff ^net-name <nn> ^grid-x > <gx>) - - (ff ^grid-x <vcom2> ^grid-y <gy>) - --> - (make made-random-move) - (make horizontal ^min <hmin> ^layer <lay> ^max <vcom2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east) -) - -(p p523 - (context ^present random1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <vcom1> < <gx> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> }) - (vertical ^com { <vcom2> >= <vcom1> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom2> ^max >= <gx>) - (horizontal ^net-name nil ^min { <hmin> <= <vcom2> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <gx> >= <vcom2> } ^layer <lay>) - - (ff ^net-name <nn> ^grid-x > <gx>) - - (ff ^grid-x <vcom2> ^grid-y <gy>) - --> - (make made-random-move) - (make horizontal ^min <hmin> ^layer <lay> ^max <vcom2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east) -) - -(p p524 - (context ^present random1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> < <gy> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom1> <= <gy> }) - (horizontal ^com { <hcom2> >= <hcom1> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcom2> ^max >= <gy>) - (vertical ^net-name nil ^min { <vmin> <= <hcom2> } ^max { > <vmin> >= <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <hcom2> <= <gy> } ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom2> ^max >= <hcom2> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y > <gy>) - - (ff ^grid-x <gx> ^grid-y <hcom2>) - --> - (make made-random-move) - (make vertical ^min <vmin> ^layer <lay> ^max <hcom2> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <hcom2> ^max <gy> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>) - (modify 2 ^grid-y <hcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from north) -) - -(p p525 - (context ^present random1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> > <gy> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <hcom1> >= <gy> }) - (horizontal ^com { <hcom2> <= <hcom1> > <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <hcom2>) - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom2> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <hcom2> } ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom2> ^max >= <hcom2> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y < <gy>) - - (ff ^grid-x <gx> ^grid-y <hcom2>) - --> - (make made-random-move) - (make vertical ^min <vmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <hcom2> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <hcom2> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>) - (modify 2 ^grid-y <hcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from south) -) - -(p p526 - (context ^present random1) - --> - (remove 1) - (make context ^present check-random-move) -) - -(p p527 - { <c> (context ^present check-random-move) } - { <m> (made-random-move) } - --> - (remove <c> <m>) - (make context ^present check-for-routed-net) - (make goal cleanup made-random-move) -) - -(p p528 - { <c> (context ^present check-random-move) } - - (made-random-move) - --> - (remove <c>) - (make context ^present random2) -) - -(p p529 - (context ^present random2) - --> - (write (crlf) |Sorry, I can not proceed anymore because of my ignorance.|) - (halt) -) - -(p p530 - (context ^present random0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - - (ff ^net-name <nn> ^pin-name <> <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> < <gy> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom1> <= <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcom1> ^max >= <gy>) - (vertical ^net-name nil ^min { <vmin> <= <hcom1> } ^max { > <vmin> >= <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - (vertical-layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <hcom1> <= <gy> } ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y > <gy>) - --> - (remove 1) - (make vertical ^min <vmin> ^layer <lay> ^max <hcom1> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>) - (modify 4 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <hcom1> ^max <gy> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>) - (modify 2 ^grid-y <hcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from north) - (make context ^present propagate-constraint) -) - -(p p531 - (context ^present random0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - - (ff ^net-name <nn> ^pin-name <> <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> > <gy> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <hcom1> >= <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <hcom1>) - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom1> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - (vertical-layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <hcom1> } ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y < <gy>) - --> - (remove 1) - (make vertical ^min <vmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>) - (modify 4 ^min <hcom1> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <hcom1> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>) - (modify 2 ^grid-y <hcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from south) - (make context ^present propagate-constraint) -) - -(p p532 - (context ^present random0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - - (ff ^net-name <nn> ^pin-name <> <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> < <gx> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom1> ^max >= <gx>) - (horizontal ^net-name nil ^min { <hmin> <= <vcom1> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - (horizontal-layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <vcom1> <= <gx> } ^layer <lay>) - - (ff ^net-name <nn> ^grid-x > <gx>) - --> - (remove 1) - (make horizontal ^min <hmin> ^layer <lay> ^max <vcom1> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify 4 ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom1> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify 2 ^grid-x <vcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from east) - (make context ^present propagate-constraint) -) - -(p p533 - (context ^present random0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - - (ff ^net-name <nn> ^pin-name <> <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> > <gx> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { >= <gx> < <vcom1> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom1>) - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom1> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - (horizontal-layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <gx> <= <vcom1> } ^layer <lay>) - - (ff ^net-name <nn> ^grid-x < <gx>) - --> - (remove 1) - (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify 4 ^min <vcom1> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom1> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify 2 ^grid-x <vcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from west) - (make context ^present propagate-constraint) -) - -(p p534 - { <c> (context ^present random2) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (vertical ^status nil ^net-name { <nn> <> nil } ^com > <gx>) - { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - --> - (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify <h> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify <ff> ^grid-x <gx2> ^grid-layer <lay> ^can-chng-layer nil ^came-from west) - (remove <c>) - (make context ^present check-for-routed-net) -) - -(p p535 - { <c> (context ^present random2) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (vertical ^status nil ^net-name { <nn> <> nil } ^com < <gx>) - { <h> (horizontal ^net-name nil ^min { <hmin> < <gx> } ^max { <hmax> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) } - (congestion ^direction col ^coordinate <gx> ^como <gx2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - --> - (make horizontal ^min <hmin> ^layer <lay> ^max <gx2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify <h> ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify <ff> ^grid-x <gx2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east) - (remove <c>) - (make context ^present check-for-routed-net) -) - -(p p536 - { <c> (context ^present random2) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^com > <gy>) - { <h> (vertical ^net-name nil ^min { <hmin> <= <gy> } ^max { <hmax> > <gy> } ^com <gx> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - --> - (make vertical ^min <hmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify <h> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <gy2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gx>) - (modify <ff> ^grid-y <gy2> ^grid-layer <lay> ^can-chng-layer nil ^came-from south) - (remove <c>) - (make context ^present check-for-routed-net) -) - -(p p537 - { <c> (context ^present random2) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^com < <gy>) - { <h> (vertical ^net-name nil ^min { <hmin> < <gy> } ^max { <hmax> >= <gy> } ^com <gx> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) } - (congestion ^direction row ^coordinate <gy> ^como <gy2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - --> - (make vertical ^min <hmin> ^layer <lay> ^max <gy2> ^com <gx> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify <h> ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy2> ^max <gy> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gx>) - (modify <ff> ^grid-y <gy2> ^grid-layer <lay> ^can-chng-layer nil ^came-from north) - (remove <c>) - (make context ^present check-for-routed-net) -) - -(p p558 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <nmax> } ^grid-y <gy>) - - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy> ^layer <> <lay>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2 3) - (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>) -) - -(p p559 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> > <gx1> <= <nmax> }) - - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx1> < <gx2> }) - (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2) - (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>) -) - -(p p560 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> < <gx1> >= <nmin> }) - - (ff ^net-name <nn> ^grid-x { < <gx1> > <gx2> } ^grid-y <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { < <gx1> > <gx2> }) - (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx2> ^max >= <gx1> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2) - (make horizontal ^com <gy> ^min <min> ^max <gx2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx2> ^max <gx1> ^net-name <nn> ^pin-name <pn>) -) - -(p p561 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> > <gx1> <= <nmax> }) - - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx1> < <gx2> }) - (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (horizontal-layer <lay>) - (dominant-layer) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2) - (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>) -) - -(p p562 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> < <gx1> >= <nmin> }) - - (ff ^net-name <nn> ^grid-x { < <gx1> > <gx2> } ^grid-y <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { < <gx1> > <gx2> }) - (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (horizontal-layer <lay>) - (dominant-layer) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx2> ^max >= <gx1> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2) - (make horizontal ^com <gy> ^min <min> ^max <gx2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx2> ^max <gx1> ^net-name <nn> ^pin-name <pn>) -) - -(p p563 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <nmax> } ^grid-y <gy>) - - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (horizontal-layer <lay>) - (dominant-layer) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2 3) - (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>) -) - -(p p564 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy1> <= <nmax> } ^grid-x <gx>) - - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>) - (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (vertical ^net-name nil ^min <= <gy1> ^max >= <gy2> ^com <gx> ^layer <> <lay>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2 3) - (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>) -) - -(p p565 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> > <gy1> <= <nmax> }) - - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy1> < <gy2> }) - (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2) - (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>) -) - -(p p566 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> < <gy1> >= <nmin> }) - - (ff ^net-name <nn> ^grid-y { > <gy2> < <gy1> } ^grid-x <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy2> < <gy1> }) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> >= <gy1> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy1> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2) - (make vertical ^com <gx> ^min <min> ^max <gy2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy2> ^max <gy1> ^net-name <nn> ^pin-name <pn>) -) - -(p p567 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> > <gy1> <= <nmax> }) - - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy1> < <gy2> }) - (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (vertical-layer <lay>) - (dominant-layer) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2) - (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>) -) - -(p p568 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> < <gy1> >= <nmin> }) - - (ff ^net-name <nn> ^grid-y { > <gy2> < <gy1> } ^grid-x <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy2> < <gy1> }) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> >= <gy1> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (vertical-layer <lay>) - (dominant-layer) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy1> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2) - (make vertical ^com <gx> ^min <min> ^max <gy2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy2> ^max <gy1> ^net-name <nn> ^pin-name <pn>) -) - -(p p569 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy1> <= <nmax> } ^grid-x <gx>) - - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>) - (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (vertical-layer <lay>) - (dominant-layer) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2 3) - (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>) -) - -(p p570 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <max> >= <nmin> <= <nmax> } ^com <gy> ^layer <garb2> ^compo <garb3> ^commo <garb4> ^pin-name <pn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <max> ^max > <max> ^com <gy>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <min> > <max> <= <nmax> } ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <min> ^max >= <min> ^com <gy>) - (horizontal ^net-name nil ^min <max> ^max { <min> > <max> } ^com <gy> ^layer <garb5> ^compo <garb6> ^commo <garb7>) - --> - (modify 4 ^net-name <nn> ^pin-name <pn> ^max-net nil ^min-net nil) -) - -(p p571 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <max> >= <nmin> <= <nmax> } ^com <gx> ^layer <garb2> ^compo <garb3> ^commo <garb4> ^pin-name <pn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <max> ^max > <max> ^com <gx>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min { <min> > <max> <= <nmax> } ^com <gx>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <min> ^max >= <min> ^com <gx>) - (vertical ^net-name nil ^min <max> ^max { <min> > <max> } ^com <gx> ^layer <garb5> ^compo <garb6> ^commo <garb7>) - --> - (modify 4 ^net-name <nn> ^pin-name <pn> ^max-net nil ^min-net nil) -) - -(p p572 - { <next> (next-segment <nn> row <gy>) } - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <pn> ^came-from north) - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb1>) - - (ff ^net-name <nn> ^grid-y < <gy>) - { <ff> (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^pin-name <pn2> ^grid-x <gx> ^grid-layer <lay> ^came-from north) } - { <v1> (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) } - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com { < <gy2> >= <gy> } ^layer <lay>) - --> - (make vertical ^net-name nil ^max <gy> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify <v1> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn2>) - (modify <ff> ^grid-y <gy> ^can-chng-layer nil) - (modify <next> ^5 useless) -) - -(p p573 - { <next> (next-segment <nn> row <gy>) } - (ff ^came-from south ^net-name <nn> ^grid-y <gy> ^pin-name <pn>) - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb1> ^no-of-bottom-pins <np>) - - (ff ^net-name <nn> ^grid-y > <gy>) - { <ff> (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^pin-name <pn2> ^grid-x <gx> ^grid-layer <lay> ^came-from south) } - { <v1> (vertical ^net-name nil ^max { <max> >= <gy> } ^min { < <max> <= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com { > <gy2> <= <gy> } ^layer <lay>) - --> - (make vertical ^net-name nil ^max <max> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <nn> ^max-net <mn>) - (modify <v1> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn2>) - (modify <ff> ^grid-y <gy> ^can-chng-layer nil) - (modify <v1> ^5 useless) -) - -(p p574 - (next-segment <nn> row <gy> <gg1> <nmin> <nmax>) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x { <gx> >= <nmin> <= <nmax> } ^grid-layer <lay> ^pin-name <pn>) - (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy2> ^com <gx>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <gy> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify 3 ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <gy> ^can-chng-layer nil) - (modify 1 ^2 <nn>) -) - -(p p575 - (next-segment <nn> row <gy> <gg1> <nmin> <nmax>) - (vertical ^net-name { <nn> <> nil } ^min { <gy2> > <gy> } ^com { <gx> >= <nmin> <= <nmax> } ^layer <lay> ^pin-name <pn>) - (vertical ^net-name nil ^min { < <gy2> <= <gy> } ^max <gy2> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy2> ^com <gx>) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>) - - (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy2> ^com <gx>) - - (ff ^net-name <> <nn> ^grid-x <gx>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - --> - (modify 3 ^max <gy> ^max-net <nn>) - (modify 2 ^min <gy>) - (make ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) - (modify 1 ^2 <nn>) -) - -(p p576 - (next-segment <nn> row <gy> <gg1> <nmin> <nmax>) - (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x { <gx> >= <nmin> <= <nmax> } ^grid-layer <lay> ^pin-name <pn>) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) - (vertical-s ^net-name <nn> ^min <= <gy2> ^max >= <gy> ^com <gx>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <gy2> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify 3 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <gy> ^can-chng-layer nil) - (modify 1 ^2 <nn>) -) - -(p p577 - (next-segment <nn> row <gy> <gg1> <nmin> <nmax>) - (vertical ^net-name { <nn> <> nil } ^min { <gy2> < <gy> } ^com { <gx> >= <nmin> <= <nmax> } ^layer <lay> ^pin-name <pn>) - (vertical ^net-name nil ^min <gy2> ^max { > <gy2> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - (vertical-s ^net-name <nn> ^min <= <gy2> ^max >= <gy> ^com <gx>) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>) - - (vertical ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy> ^com <gx>) - - (ff ^net-name <> <nn> ^grid-x <gx>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - --> - (modify 3 ^min <gy> ^min-net <nn>) - (modify 2 ^max <gy>) - (make ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south) - (modify 1 ^2 <nn>) -) - -(p p578 - (next-segment <nn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <garb2>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <garb3> ^compo <garb4> ^commo <garb5>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <garb6> ^compo <garb7> ^commo <garb8>) - --> - (remove 2) -) - -(p p579 - (next-segment <nn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <garb2>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max <gx> ^com <gy>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gx> ^max > <gx> ^com <gy>) - --> - (remove 2) -) - -(p p580 - (change-priority) - { <n> (next-segment ^5 useless) } - --> - (modify <n> ^5 nil) -) - -(p p581 - (change-priority) - { <n> (next-segment <nn> col <x> useless <min> <max>) } - (vertical-s ^net-name <nn> ^com <x> ^sum 2 ^difference 0) - (last-row <lr>) - --> - (modify <n> ^5 nil 1 <lr>) -) - -(p p582 - (change-priority) - { <n> (next-segment <nn> row <y> useless <min> <max>) } - (horizontal-s ^net-name <nn> ^com <x> ^sum 2 ^difference 0) - (last-col <lc>) - --> - (modify <n> ^5 nil 1 <lc>) -) - -(p p583 - { <n> (next-segment <nn> <rc> <xy> nil) } - - (next-segment ^5 <> nil) - --> - (remove <n>) - (make move-ff <nn> <rc> <xy>) -) - -(p p584 - { <c> (change-priority) } - --> - (remove <c>) - (make end-of-specialized-move-ff) -) - -(p p585 - (move-ff <nn> row <xy>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <xy> ^layer <lay> ^compo <cpo> ^commo <garb1>) - { <ff> (ff ^came-from south ^net-name { <nn1> <> <nn> } ^grid-x { <gx> >= <min> <= <max> } ^grid-y <xy> ^grid-layer { <flay> <> <lay> }) } - { <v1> (vertical ^status nil ^net-name <nn1> ^min < <xy> ^max <xy> ^com <gx> ^layer <flay>) } - - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <xy> ^layer <flay>) - { <v2> (vertical ^net-name nil ^min <xy> ^max { <garb4> > <xy> } ^com <gx> ^layer <flay> ^compo <garb2> ^commo <garb3>) } - --> - (modify <v2> ^min <cpo> ^min-net <nn1>) - (modify <v1> ^max <cpo>) - (modify <ff> ^grid-y <cpo> ^can-chng-layer nil) -) - -(p p586 - (move-ff <nn> row <xy>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <xy> ^layer <lay> ^compo <garb1> ^commo <cmo>) - { <ff> (ff ^came-from north ^net-name { <nn1> <> <nn> } ^grid-x { <gx> >= <min> <= <max> } ^grid-y <xy> ^grid-layer { <flay> <> <lay> }) } - { <v1> (vertical ^status nil ^net-name <nn1> ^min <xy> ^max > <xy> ^com <gx> ^layer <flay>) } - - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <xy> ^layer <flay>) - { <v2> (vertical ^net-name nil ^min <vmin> ^max { <xy> > <vmin> } ^com <gx> ^layer <flay> ^compo <garb2> ^commo <garb3>) } - --> - (modify <v2> ^max <cmo> ^max-net <nn1>) - (modify <v1> ^min <cmo>) - (modify <ff> ^grid-y <cmo> ^can-chng-layer nil) -) - -(p p587 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <min> ^max <max>) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max>) } - --> - (remove <h>) -) - -(p p588 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <min> ^max <max>) - { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max>) } - --> - (remove <v>) -) - -(p p589 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> < <com> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <com> } ^com <gx> ^id <id>) } - (vertical ^net-name nil ^min <= <gy> ^max >= <com> ^com <gx>) - - (vertical-s ^net-name <> <nn> ^com <gx>) - --> - (remove <v>) - (make next-segment <nn> col <gx> nil <vmin> <vmax>) -) - -(p p590 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> > <com> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <com> } ^max { <vmax> >= <gy> } ^com <gx> ^id <id>) } - (vertical ^net-name nil ^min <= <com> ^max >= <gy> ^com <gx>) - - (vertical-s ^net-name <> <nn> ^com <gx>) - --> - (remove <v>) - (make next-segment <nn> col <gx> nil <vmin> <vmax>) -) - -(p p591 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> < <hcom1> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) } - (vertical ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax2> }) - - (vertical-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> col <vcom2> nil <vmin> <vmax>) -) - -(p p592 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> > <hcom1> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) } - (vertical ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax2> }) - - (vertical-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> col <vcom2> nil <vmin> <vmax>) -) - -(p p593 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> < <hcom1> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) } - (vertical ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax1> }) - - (vertical-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> col <vcom2> nil <vmin> <vmax>) -) - -(p p594 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> > <hcom1> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) } - (vertical ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax1> }) - - (vertical-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> col <vcom2> nil <vmin> <vmax>) -) - -(p p595 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (ff ^net-name <nn> ^grid-x { <gx> < <com> } ^grid-y { <gy> >= <min> <= <max> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <gx> } ^max { <vmax> >= <com> } ^com <gy> ^id <id>) } - (horizontal ^net-name nil ^min <= <gx> ^max >= <com> ^com <gy>) - - (horizontal-s ^net-name <> <nn> ^com <gy>) - --> - (remove <v>) - (make next-segment <nn> row <gy> nil <vmin> <vmax>) -) - -(p p596 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (ff ^net-name <nn> ^grid-x { <gx> > <com> } ^grid-y { <gy> >= <min> <= <max> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <com> } ^max { <vmax> >= <gx> } ^com <gy> ^id <id>) } - (horizontal ^net-name nil ^min <= <com> ^max >= <gx> ^com <gy>) - - (horizontal-s ^net-name <> <nn> ^com <gy>) - --> - (remove <v>) - (make next-segment <nn> row <gy> nil <vmin> <vmax>) -) - -(p p597 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> < <hcom1> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) } - (horizontal ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax2> }) - - (horizontal-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> row <vcom2> nil <vmin> <vmax>) -) - -(p p598 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> > <hcom1> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) } - (horizontal ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax2> }) - - (horizontal-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> row <vcom2> nil <vmin> <vmax>) -) - -(p p599 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> < <hcom1> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) } - (horizontal ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax1> }) - - (horizontal-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> row <vcom2> nil <vmin> <vmax>) -) - -(p p600 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> > <hcom1> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) } - (horizontal ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax1> }) - - (horizontal-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> row <vcom2> nil <vmin> <vmax>) -) - -(p p601 - { <m> (move-ff) } - --> - (remove <m>) -) - -(p p602 - { <e> (end-of-specialized-move-ff) } - - (next-segment) - --> - (remove <e>) - (make context ^present check-for-routed-net) -) - -(p p603 - (context ^present << check-for-routed-net propagate-constraint >>) - (<< dominant-layer change-priority next-segment >>) - --> - (remove 2) -) - -(p p244 - (context ^present lshape1) - (<< total-verti counted-verti total counted >>) - --> - (remove 2) -) - -(p p245 - (context ^present lshape1) - (last-row <gy>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) - - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <gy2>) - - (vertical ^com { > <gx> < <gx2> }) - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^min-net <mn>) - - (pin ^pin-x <gx2> ^pin-y <hcpo>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - --> - (make horizontal ^layer <lay> ^min <hmin> ^max <gx> ^min-net <mn> ^max-net <nn> ^com <gy> ^commo <hcmo> ^compo <hcpo>) - (modify 5 ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx> ^max <gx2> ^com <gy> ^commo <hcmo> ^compo <hcpo>) - (modify 3 ^grid-x <gx2> ^came-from west) -) - -(p p246 - (context ^present lshape1) - (last-row <gy>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) - - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <gy2>) - - (vertical ^com { > <gx2> < <gx> }) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (pin ^pin-x <gx2> ^pin-y <hcpo>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - --> - (make horizontal ^layer <lay> ^min <hmin> ^max <gx2> ^min-net <mn> ^max-net <nn> ^com <gy> ^commo <hcmo> ^compo <hcpo>) - (modify 5 ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx2> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo>) - (modify 3 ^grid-x <gx2> ^came-from east) -) - -(p p247 - (context ^present lshape1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y 1 ^grid-layer <lay> ^pin-name <pn> ^came-from south) - - (ff ^net-name <nn> ^grid-y 1 ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <gy2>) - - (vertical ^com { > <gx> < <gx2> }) - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <hmin> >= <gx2> } ^com 1 ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (pin ^pin-x <gx2> ^pin-y 0) - - (vertical ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gx2> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com 1 ^layer <lay>) - --> - (make horizontal ^layer <lay> ^min <hmin> ^max <gx> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <hcmo> ^compo <hcpo>) - (modify 4 ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx> ^max <gx2> ^com 1 ^commo <hcmo> ^compo <hcpo>) - (modify 2 ^grid-x <gx2> ^came-from west) -) - -(p p248 - (context ^present lshape1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y 1 ^grid-layer <lay> ^pin-name <pn> ^came-from south) - - (ff ^net-name <nn> ^grid-y 1 ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <gy2>) - - (vertical ^com { > <gx2> < <gx> }) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx> } ^com 1 ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (pin ^pin-x <gx2> ^pin-y 0) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gx2> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com 1 ^layer <lay>) - --> - (make horizontal ^layer <lay> ^min <hmin> ^max <gx2> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <hcmo> ^compo <hcpo>) - (modify 4 ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx2> ^max <gx> ^com 1 ^commo <hcmo> ^compo <hcpo>) - (modify 2 ^grid-x <gx2> ^came-from east) -) - -(p p249 - (context ^present lshape1) - (last-col <gx>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east) - - (ff ^net-name <nn> ^grid-x <gx> ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> > <gy> }) - - (horizontal ^com { > <gy> < <gy2> }) - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy2> > <vmin> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (pin ^pin-x <vcpo> ^pin-y <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (make vertical ^layer <lay> ^min <vmin> ^max <gy> ^min-net <mn> ^max-net <nn> ^com <gx> ^commo <vcmo> ^compo <vcpo>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy> ^max <gy2> ^com <gx> ^commo <vcmo> ^compo <vcpo>) - (modify 3 ^grid-y <gy2> ^came-from south) -) - -(p p250 - (context ^present lshape1) - (last-col <gx>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east) - - (ff ^net-name <nn> ^grid-x <gx> ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> < <gy> }) - - (horizontal ^com { > <gy2> < <gy> }) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy> > <vmin> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (pin ^pin-x <vcpo> ^pin-y <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (make vertical ^layer <lay> ^min <vmin> ^max <gy2> ^min-net <mn> ^max-net <nn> ^com <gx> ^commo <vcmo> ^compo <vcpo>) - (modify 5 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy2> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo>) - (modify 3 ^grid-y <gy2> ^came-from north) -) - -(p p251 - (context ^present lshape1) - (ff ^net-name <nn> ^grid-x 1 ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from west) - - (ff ^net-name <nn> ^grid-x 1 ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> > <gy> }) - - (horizontal ^com { > <gy> < <gy2> }) - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> > <vmin> >= <gy2> } ^com 1 ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (pin ^pin-x 0 ^pin-y <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com 1 ^layer <lay>) - --> - (make vertical ^layer <lay> ^min <vmin> ^max <gy> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <vcmo> ^compo <vcpo>) - (modify 4 ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy> ^max <gy2> ^com 1 ^commo <vcmo> ^compo <vcpo>) - (modify 2 ^grid-y <gy2> ^came-from south) -) - -(p p252 - (context ^present lshape1) - (ff ^net-name <nn> ^grid-x 1 ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from west) - - (ff ^net-name <nn> ^grid-x 1 ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> < <gy> }) - - (horizontal ^com { > <gy2> < <gy> }) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy> } ^com 1 ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (pin ^pin-x 0 ^pin-y <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com 1 ^layer <lay>) - --> - (make vertical ^layer <lay> ^min <vmin> ^max <gy2> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <vcmo> ^compo <vcpo>) - (modify 4 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy2> ^max <gy> ^com 1 ^commo <vcmo> ^compo <vcpo>) - (modify 2 ^grid-y <gy2> ^came-from north) -) - -(p p253 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy1> > <vmin> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> >= <gx2> > <hmin> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p254 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p255 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p256 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p257 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>) - - (pin ^net-name <nn1> ^pin-x >= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p258 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x > <gx1>) - - (pin ^net-name <nn1> ^pin-x <= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p259 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>) - - (pin ^net-name <nn1> ^pin-x >= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p260 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>) - (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy1> ^grid-x > <gx2>) - - (pin ^net-name <nn1> ^pin-x <= <gx2>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p261 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>) - - (pin ^net-name <nn1> ^pin-y >= <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p262 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>) - - (pin ^net-name <nn1> ^pin-y >= <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p263 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y > <gy2>) - - (pin ^net-name <nn1> ^pin-y <= <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p264 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx2> ^grid-y > <gy1>) - - (pin ^net-name <nn1> ^pin-y <= <gy1>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p265 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>) - - (pin ^net-name <nn1> ^pin-y >= <gy2>) - (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>) - - (pin ^net-name <nn2> ^pin-x >= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p266 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>) - - (pin ^net-name <nn1> ^pin-y >= <gy2>) - (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x > <gx1>) - - (pin ^net-name <nn2> ^pin-x <= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p267 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y > <gy2>) - - (pin ^net-name <nn1> ^pin-y <= <gy2>) - (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>) - - (pin ^net-name <nn2> ^pin-x >= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p268 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx2> ^grid-y > <gy1>) - - (pin ^net-name <nn1> ^pin-y <= <gy1>) - (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy1> ^grid-x > <gx2>) - - (pin ^net-name <nn2> ^pin-x <= <gx2>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p269 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p270 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p271 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p272 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p273 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p274 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p275 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p276 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p277 - (context ^present lshape3) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p278 - (context ^present lshape3) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p279 - (context ^present lshape3) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p280 - (context ^present lshape3) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p281 - (context ^present lshape4) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p282 - (context ^present lshape4) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p283 - (context ^present lshape4) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <garb2>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p284 - (context ^present lshape4) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p285 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - - (ff ^grid-x <gx1> ^net-name <> <nn>) - { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^commo <gx2> ^compo <cpo> ^min-net <vnn1>) } - { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com { <hcom> >= <vmin1> < <gy1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (vertical-layer <lay>) - (ff ^grid-x <gx2> ^net-name <> <nn>) - - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com { >= <vmin1> < <hcom> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>) - --> - (remove <c>) - (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <cpo> ^commo <gx2> ^min-net <vnn1> ^max-net <nn>) - (modify <v> ^min <gy1> ^min-net <nn>) - (make horizontal ^min <hmin> ^max <gx2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <gx2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>) - (make horizontal ^com <hcom> ^layer <lay> ^min <gx2> ^max <gx1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>) - (modify <ff> ^grid-x <gx2> ^grid-y <hcom> ^can-chng-layer nil ^came-from east) - (make context ^present check-for-routed-net) -) - -(p p286 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - - (ff ^grid-x <gx2> ^net-name <> <nn>) - { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy2> } ^max { <vmax1> > <vmin1> >= <gy2> } ^com <gx2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^max-net <vnn1>) } - { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com { <hcom> <= <vmax1> > <gy2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (vertical-layer <lay>) - (ff ^grid-x <gx1> ^net-name <> <nn>) - - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com { <= <vmax1> > <hcom> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>) - --> - (remove <c>) - (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <gx1> ^commo <cmo> ^max-net <vnn1> ^min-net <nn>) - (modify <v> ^max <gy2> ^max-net <nn>) - (make horizontal ^min <hmin> ^max <gx2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <cmo> ^compo <gx1> ^net-name <nn> ^pin-name <pn2>) - (make horizontal ^com <hcom> ^layer <lay> ^min <gx2> ^max <gx1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>) - (modify <ff> ^grid-x <gx1> ^grid-y <hcom> ^can-chng-layer nil ^came-from west) - (make context ^present check-for-routed-net) -) - -(p p287 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - - (ff ^grid-x <gx1> ^net-name <> <nn>) - { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^commo <cmo> ^compo <gx2> ^min-net <vnn1>) } - { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com { <hcom> >= <vmin1> < <gy1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (vertical-layer <lay>) - (ff ^grid-x <gx2> ^net-name <> <nn>) - - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com { >= <vmin1> < <hcom> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>) - --> - (remove <c>) - (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gx2> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>) - (modify <v> ^min <gy1> ^min-net <nn>) - (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <cmo> ^compo <gx2> ^net-name <nn> ^pin-name <pn1>) - (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>) - (modify <ff> ^grid-x <gx2> ^grid-y <hcom> ^can-chng-layer nil ^came-from west) - (make context ^present check-for-routed-net) -) - -(p p288 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - - (ff ^grid-x <gx2> ^net-name <> <nn>) - { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy2> } ^max { <vmax1> > <vmin1> >= <gy2> } ^com <gx2> ^layer <lay> ^commo <gx1> ^compo <cpo> ^max-net <vnn1>) } - { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com { <hcom> <= <vmax1> > <gy2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (vertical-layer <lay>) - (ff ^grid-x <gx1> ^net-name <> <nn>) - - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com { <= <vmax1> > <hcom> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>) - --> - (remove <c>) - (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <cpo> ^commo <gx1> ^max-net <vnn1> ^min-net <nn>) - (modify <v> ^max <gy2> ^max-net <nn>) - (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <gx1> ^compo <cpo> ^net-name <nn> ^pin-name <pn2>) - (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>) - (modify <ff> ^grid-x <gx1> ^grid-y <hcom> ^can-chng-layer nil ^came-from east) - (make context ^present check-for-routed-net) -) - -(p p289 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - - (ff ^grid-y <gy1> ^net-name <> <nn>) - { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx1> } ^max { <vmax1> > <vmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <vnn1>) } - { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> >= <vmin1> < <gx1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (horizontal-layer <lay>) - (ff ^grid-y <gy2> ^net-name <> <nn>) - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { >= <vmin1> < <hcom> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>) - --> - (remove <c>) - (make horizontal ^com <gy1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <cpo> ^commo <gy2> ^min-net <vnn1> ^max-net <nn>) - (modify <v> ^min <gx1> ^min-net <nn>) - (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <lay> ^min <hcom> ^max <gx1> ^commo <gy2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>) - (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>) - (modify <ff> ^grid-y <gy2> ^grid-x <hcom> ^can-chng-layer nil ^came-from north) - (make context ^present check-for-routed-net) -) - -(p p290 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - - (ff ^grid-y <gy2> ^net-name <> <nn>) - { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx2> } ^max { <vmax1> > <vmin1> >= <gx2> } ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^max-net <vnn1>) } - { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> <= <vmax1> > <gx2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (horizontal-layer <lay>) - (ff ^grid-y <gy1> ^net-name <> <nn>) - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { <= <vmax1> > <hcom> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>) - --> - (remove <c>) - (make horizontal ^com <gy2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <gy1> ^commo <cmo> ^max-net <vnn1> ^min-net <nn>) - (modify <v> ^max <gx2> ^max-net <nn>) - (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <lay> ^max <hcom> ^min <gx2> ^commo <cmo> ^compo <gy1> ^net-name <nn> ^pin-name <pn2>) - (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>) - (modify <ff> ^grid-y <gy1> ^grid-x <hcom> ^can-chng-layer nil ^came-from south) - (make context ^present check-for-routed-net) -) - -(p p291 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - - (ff ^grid-y <gy1> ^net-name <> <nn>) - { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx1> } ^max { <vmax1> > <vmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^max-net <vnn1>) } - { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> <= <vmax1> > <gx1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (horizontal-layer <lay>) - (ff ^grid-y <gy2> ^net-name <> <nn>) - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { <= <vmax1> > <hcom> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>) - --> - (remove <c>) - (make horizontal ^com <gy1> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <cpo> ^commo <gy2> ^max-net <vnn1> ^min-net <nn>) - (modify <v> ^max <gx1> ^max-net <nn>) - (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <lay> ^min <gx1> ^max <hcom> ^commo <gy2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>) - (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>) - (modify <ff> ^grid-y <gy2> ^grid-x <hcom> ^can-chng-layer nil ^came-from north) - (make context ^present check-for-routed-net) -) - -(p p292 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - - (ff ^grid-y <gy2> ^net-name <> <nn>) - { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx2> } ^max { <vmax1> > <vmin1> >= <gx2> } ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^min-net <vnn1>) } - { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> >= <vmin1> < <gx2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (horizontal-layer <lay>) - (ff ^grid-y <gy1> ^net-name <> <nn>) - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { >= <vmin1> < <hcom> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>) - --> - (remove <c>) - (make horizontal ^com <gy2> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gy1> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>) - (modify <v> ^min <gx2> ^min-net <nn>) - (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <lay> ^max <gx2> ^min <hcom> ^commo <cmo> ^compo <gy1> ^net-name <nn> ^pin-name <pn2>) - (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>) - (modify <ff> ^grid-y <gy1> ^grid-x <hcom> ^can-chng-layer nil ^came-from south) - (make context ^present check-for-routed-net) -) - -(p p211 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx> }) - (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y < <gy>) - - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y > <gy>) - --> - (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min <gx> ^min-net <nn>) - (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p212 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> south ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> < <gy> }) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y >= <gy>) - - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y >= <gy>) - --> - (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min <gy> ^min-net <nn>) - (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p213 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> }) - (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y < <gy>) - - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y > <gy>) - --> - (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max <gx> ^max-net <nn>) - (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p214 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy> }) - (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y <= <gy>) - - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y <= <gy>) - --> - (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max <gy> ^max-net <nn>) - (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p215 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <= <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> > <min> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y > <gy>) - --> - (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min <gx> ^min-net <nn>) - (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p216 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y >= <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> > <min> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y < <gy>) - --> - (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min <gx> ^min-net <nn>) - (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p217 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <= <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y > <gy>) - --> - (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max <gx> ^max-net <nn>) - (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p218 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y >= <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y < <gy>) - --> - (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max <gx> ^max-net <nn>) - (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p219 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x >= <gx>) - (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <lay>) - - (ff ^net-name <nn> ^grid-x < <gx>) - --> - (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>) - (modify 4 ^max <gy> ^max-net <nn>) - (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p220 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x <= <gx>) - (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (ff ^net-name <nn> ^grid-x > <gx>) - --> - (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>) - (modify 4 ^max <gy> ^max-net <nn>) - (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p221 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> south ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x <= <gx>) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (ff ^net-name <nn> ^grid-x > <gx>) - --> - (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>) - (modify 4 ^min <gy> ^min-net <nn>) - (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p222 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x >= <gx>) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <lay>) - - (ff ^net-name <nn> ^grid-x < <gx>) - --> - (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>) - (modify 4 ^min <gy> ^min-net <nn>) - (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p223 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - --> - (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p224 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-y { <gy2> > <com1> } ^grid-x <gx>) - (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - --> - (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p225 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - --> - (make horizontal ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p226 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-y { <gy2> < <com1> } ^grid-x <gx>) - (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - --> - (make vertical ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p227 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - --> - (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p228 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-y { <gy2> > <com1> } ^grid-x <gx>) - (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - --> - (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p229 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^layer <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - --> - (make horizontal ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p230 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> }) - (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - --> - (make vertical ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p231 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (vertical ^net-name nil ^max <min1> ^com <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p232 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (vertical ^net-name nil ^max <min1> ^com <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p233 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (vertical ^net-name nil ^max <min1> ^com <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make horizontal ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p234 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (vertical ^net-name nil ^max <min1> ^com <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make horizontal ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p235 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> > <com1> }) - (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (horizontal ^net-name nil ^max <min1> ^com <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p236 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> > <com1> }) - (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (horizontal ^net-name nil ^max <min1> ^com <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p237 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> }) - (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (horizontal ^net-name nil ^max <min1> ^com <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make vertical ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p238 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> }) - (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^commo <cmo2> ^compo <cpo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (horizontal ^net-name nil ^max <min1> ^com <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make vertical ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p239 - (context ^present loose-constraint0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top) - (vertical ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com { <vcom> > <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-y > <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom> ^com <gy>) - (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <gy> ^como <hcmo>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <hcmo> ^can-chng-layer nil) - (modify 1 ^present propagate-constraint) -) - -(p p240 - (context ^present loose-constraint0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top) - (vertical ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com { <vcom> < <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-y > <gy>) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <gx> ^com <gy>) - (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <gy> ^como <hcmo>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <hcmo> ^can-chng-layer nil) - (modify 1 ^present propagate-constraint) -) - -(p p241 - (context ^present loose-constraint0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom) - (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com { <vcom> > <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-y < <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom> ^com <gy>) - (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <hcmo> ^como <gy>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^max-net <mn> ^min-net <nn>) - (modify 5 ^max <gy> ^max-net <nn>) - (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <hcmo> ^can-chng-layer nil) - (modify 1 ^present propagate-constraint) -) - -(p p242 - (context ^present loose-constraint0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom) - (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com { <vcom> < <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-y < <gy>) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <gx> ^com <gy>) - (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <hcmo> ^como <gy>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^max-net <mn> ^min-net <nn>) - (modify 5 ^max <gy> ^max-net <nn>) - (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <hcmo> ^can-chng-layer nil) - (modify 1 ^present propagate-constraint) -) - -(p p243 - (context ^present loose-constraint0) - --> - (modify 1 ^present loose-constraint) -) - -(p p363 - (move-via <nn>) - --> - (remove 1) - (make finally-routed <nn>) -) - -(p p364 - (move-via <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <garb1> ^commo <hcmo> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcmo> ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> }) - (vertical ^net-name nil ^min { <vmin2> <= <hcmo> } ^max { <vmax2> > <vmin2> >= <hcom> } ^com <vcom> ^layer <hlay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (horizontal ^net-name <> <nn> ^min < <vcom> ^max >= <vcom> ^com <hcmo>) - - (vertical ^net-name <> <nn> ^min < <hcmo> ^max <hcmo> ^com <vcom>) - --> - (modify 3 ^max <hcmo>) - (make vertical ^layer <vlay> ^max <hcom> ^min <hcmo> ^com <vcom> ^min-net <nn> ^commo <vcmo> ^compo <vcpo>) - (make vertical ^layer <hlay> ^min <vmin2> ^max <hcmo> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>) - (modify 4 ^min <hcom> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcmo> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^com <vcom>) - (remove 1) - (make move-via <nn> <vlay> <vcom> <hcom>) -) - -(p p365 - (move-via <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <garb1> ^commo <hcmo> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcmo> ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> }) - (vertical ^net-name nil ^min { <vmin2> <= <hcmo> } ^max { <vmax2> > <vmin2> >= <hcom> } ^com <vcom> ^layer <hlay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (horizontal ^net-name <> <nn> ^min <= <vcom> ^max > <vcom> ^com <hcmo>) - - (vertical ^net-name <> <nn> ^min < <hcmo> ^max <hcmo> ^com <vcom>) - --> - (modify 3 ^max <hcmo>) - (make vertical ^layer <vlay> ^max <hcom> ^min <hcmo> ^com <vcom> ^min-net <nn> ^commo <vcmo> ^compo <vcpo>) - (make vertical ^layer <hlay> ^min <vmin2> ^max <hcmo> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>) - (modify 4 ^min <hcom> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcmo> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^com <vcom>) - (remove 1) - (make move-via <nn> <vlay> <vcom> <hcom>) -) - -(p p366 - (move-via <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <garb1> ^commo <vcmo> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcmo> ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> }) - (horizontal ^net-name nil ^min { <hmin2> <= <vcmo> } ^max { <hmax2> > <hmin2> >= <vcom> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (vertical ^net-name <> <nn> ^min < <hcom> ^max >= <hcom> ^com <vcmo>) - - (horizontal ^net-name <> <nn> ^min < <vcmo> ^max <vcmo> ^com <hcom>) - --> - (modify 3 ^max <vcmo>) - (make horizontal ^layer <hlay> ^max <vcom> ^min <vcmo> ^com <hcom> ^min-net <nn> ^commo <hcmo> ^compo <hcpo>) - (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcmo> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>) - (modify 4 ^min <vcom> ^min-net <nn>) - (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcmo> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^com <hcom>) - (remove 1) - (make move-via <nn> <hlay> <hcom> <vcom>) -) - -(p p367 - (move-via <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <garb1> ^commo <vcmo> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcmo> ^com { <hcom> >= <vmin> <= <vmax> } ^max <vcom> ^layer { <hlay> <> <vlay> }) - (horizontal ^net-name nil ^min { <hmin2> <= <vcmo> } ^max { <hmax2> > <hmin2> >= <vcom> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (vertical ^net-name <> <nn> ^min <= <hcom> ^max > <hcom> ^com <vcmo>) - - (horizontal ^net-name <> <nn> ^min < <vcmo> ^max <vcmo> ^com <hcom>) - --> - (modify 3 ^max <vcmo>) - (make horizontal ^layer <hlay> ^max <vcom> ^min <vcmo> ^com <hcom> ^min-net <nn> ^commo <hcmo> ^compo <hcpo>) - (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcmo> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>) - (modify 4 ^min <vcom> ^min-net <nn>) - (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcmo> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^com <hcom>) - (remove 1) - (make move-via <nn> <hlay> <hcom> <vcom>) -) - -(p p368 - (move-via <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <hcpo> ^commo <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max >= <hcpo> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> }) - (vertical ^net-name nil ^min { <vmin2> <= <hcom> } ^max { <vmax2> > <vmin2> >= <hcpo> } ^com <vcom> ^layer <hlay> ^commo <vcmo> ^compo <vcpo> ^min-net <mn>) - - (horizontal ^net-name <> <nn> ^min < <vcom> ^max >= <vcom> ^com <hcpo>) - - (vertical ^net-name <> <nn> ^min <hcpo> ^max > <hcpo> ^com <vcom>) - --> - (modify 3 ^min <hcpo>) - (make vertical ^layer <vlay> ^min <hcom> ^max <hcpo> ^com <vcom> ^max-net <nn> ^commo <vcmo> ^compo <vcpo>) - (make vertical ^layer <hlay> ^min <vmin2> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>) - (modify 4 ^min <hcpo> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcom> ^max <hcpo> ^commo <vcmo> ^compo <vcpo> ^com <vcom>) - (remove 1) - (make move-via <nn> <vlay> <vcom> <hcom>) -) - -(p p369 - (move-via <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <hcpo> ^commo <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max >= <hcpo> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> }) - (vertical ^net-name nil ^min { <vmin2> <= <hcom> } ^max { <vmax2> > <vmin2> >= <hcpo> } ^com <vcom> ^layer <hlay> ^commo <vcmo> ^compo <vcpo> ^min-net <mn>) - - (horizontal ^net-name <> <nn> ^min <= <vcom> ^max > <vcom> ^com <hcpo>) - - (vertical ^net-name <> <nn> ^min <hcpo> ^max > <hcpo> ^com <vcom>) - --> - (modify 3 ^min <hcpo>) - (make vertical ^layer <vlay> ^min <hcom> ^max <hcpo> ^com <vcom> ^max-net <nn> ^commo <vcmo> ^compo <vcpo>) - (make vertical ^layer <hlay> ^min <vmin2> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>) - (modify 4 ^min <hcpo> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcom> ^max <hcpo> ^commo <vcmo> ^compo <vcpo> ^com <vcom>) - (remove 1) - (make move-via <nn> <vlay> <vcom> <hcom>) -) - -(p p370 - (move-via <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <vcpo> ^commo <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max >= <vcpo> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> }) - (horizontal ^net-name nil ^min { <hmin2> <= <vcom> } ^max { <hmax2> > <hmin2> >= <vcpo> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (vertical ^net-name <> <nn> ^min < <hcom> ^max >= <hcom> ^com <vcpo>) - - (horizontal ^net-name <> <nn> ^min <vcpo> ^max > <vcpo> ^com <hcom>) - --> - (modify 3 ^min <vcpo>) - (make horizontal ^layer <hlay> ^max <vcpo> ^min <vcom> ^com <hcom> ^max-net <nn> ^commo <hcmo> ^compo <hcpo>) - (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>) - (modify 4 ^min <vcpo> ^min-net <nn>) - (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcom> ^max <vcpo> ^commo <hcmo> ^compo <hcpo> ^com <hcom>) - (remove 1) - (make move-via <nn> <hlay> <hcom> <vcom>) -) - -(p p371 - (move-via <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <vcpo> ^commo <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max >= <vcpo> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> }) - (horizontal ^net-name nil ^min { <hmin2> <= <vcom> } ^max { <hmax2> > <hmin2> >= <vcpo> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (vertical ^net-name <> <nn> ^min <= <hcom> ^max > <hcom> ^com <vcmo>) - - (horizontal ^net-name <> <nn> ^min <vcpo> ^max > <vcpo> ^com <hcom>) - --> - (modify 3 ^min <vcpo>) - (make horizontal ^layer <hlay> ^max <vcpo> ^min <vcom> ^com <hcom> ^max-net <nn> ^commo <hcmo> ^compo <hcpo>) - (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>) - (modify 4 ^min <vcpo> ^min-net <nn>) - (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcom> ^max <vcpo> ^commo <hcmo> ^compo <hcpo> ^com <hcom>) - (remove 1) - (make move-via <nn> <hlay> <hcom> <vcom>) -) - -(p p372 - (move-via <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin1> ^max <vmax1> ^com <vcom1> ^layer <vlay> ^compo <vcpo1> ^commo <vcmo1> ^pin-name <pn1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmax1> ^max <vmax2> ^com { <vcom2> > <vcom1> } ^layer <vlay> ^compo <vcpo2> ^commo <vcmo2> ^pin-name <pn2>) - { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom1> ^max <vcom2> ^com <vmax1> ^layer { <hlay> <> <vlay> }) } - { <h2> (horizontal ^status nil ^net-name nil ^min { <fmin> <= <vcom1> } ^max { <fmax> >= <vcom2> } ^com <vmax1> ^layer <vlay>) } - - (vertical ^min < <vmax1> ^max >= <vmax1> ^com { > <vcom1> < <vcom2> }) - --> - (remove <h2>) - (modify <h1> ^net-name nil ^pin-name nil ^min-net nil ^max-net nil) - (make (substr <h2> 1 inf) ^max <vcmo1> ^max-net nil) - (make (substr <h2> 1 inf) ^min <vcpo2> ^min-net nil) - (make (substr <h1> 1 inf) ^layer <vlay>) -) - -(p p373 - (move-via <nn> <lay> <x> <y>) - (horizontal ^min <x> ^max <garb1> ^com <y> ^layer <lay> ^min-net <nn> ^max-net <garb2>) - --> - (modify 2 ^min-net nil) -) - -(p p374 - (move-via <nn> <lay> <x> <y>) - (vertical ^min <y> ^max <garb1> ^com <x> ^layer <lay> ^min-net <nn> ^max-net <garb2>) - --> - (modify 2 ^min-net nil) -) - -(p p375 - (move-via <nn> <lay> <x> <y>) - (horizontal ^min <garb1> ^max <x> ^com <y> ^layer <lay> ^min-net <garb2> ^max-net <nn>) - --> - (modify 2 ^max-net nil) -) - -(p p376 - (move-via <nn> <lay> <x> <y>) - (vertical ^min <garb1> ^max <y> ^com <x> ^layer <lay> ^min-net <garb2> ^max-net <nn>) - --> - (modify 2 ^max-net nil) -) - -(p start-dummy - (start) - --> - (write (crlf) | Dummy START, do "loadwm" from "kuh.tmp".| (crlf)) - - - -(make layer-info ^layer-name metal ^layer-order 2) -(make layer-info ^layer-name poly ^layer-order 1) -(make channel ^channel-bottom-left-x 0 ^channel-bottom-left-y 0 ^channel-top-right-x 13 ^channel-top-right-y 5 ^channel-width 5 ^channel-length 13 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 12 ^no-of-bottom-pins 12) -(make last-row 4 3) -(make last-col 12 11) -(make pin ^net-name 3 ^external-pin-name 1 ^pin-x 1 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 35 ^external-net-name 3) -(make pin ^net-name 1 ^external-pin-name 2 ^pin-x 2 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 34 ^external-net-name 1) -(make pin ^net-name 5 ^external-pin-name 3 ^pin-x 3 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 33 ^external-net-name 5) -(make pin ^net-name 3 ^external-pin-name 4 ^pin-x 4 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 32 ^external-net-name 3) -(make pin ^net-name 5 ^external-pin-name 5 ^pin-x 5 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 31 ^external-net-name 5) -(make pin ^net-name 2 ^external-pin-name 6 ^pin-x 6 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 30 ^external-net-name 2) -(make pin ^net-name 6 ^external-pin-name 7 ^pin-x 7 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 29 ^external-net-name 6) -(make pin ^net-name 8 ^external-pin-name 8 ^pin-x 8 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 28 ^external-net-name 8) -(make pin ^net-name 9 ^external-pin-name 9 ^pin-x 9 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 27 ^external-net-name 9) -(make pin ^net-name 8 ^external-pin-name 10 ^pin-x 10 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 26 ^external-net-name 8) -(make pin ^net-name 7 ^external-pin-name 11 ^pin-x 11 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 25 ^external-net-name 7) -(make pin ^net-name 9 ^external-pin-name 12 ^pin-x 12 ^pin-y 0 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side bottom ^pin-name 24 ^external-net-name 9) -(make pin ^net-name 2 ^external-pin-name 13 ^pin-x 1 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 6 ^external-net-name 2) -(make pin ^net-name 1 ^external-pin-name 14 ^pin-x 2 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 7 ^external-net-name 1) -(make pin ^net-name 4 ^external-pin-name 15 ^pin-x 3 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 8 ^external-net-name 4) -(make pin ^net-name 5 ^external-pin-name 16 ^pin-x 4 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 9 ^external-net-name 5) -(make pin ^net-name 1 ^external-pin-name 17 ^pin-x 5 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 10 ^external-net-name 1) -(make pin ^net-name 6 ^external-pin-name 18 ^pin-x 6 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 11 ^external-net-name 6) -(make pin ^net-name 7 ^external-pin-name 19 ^pin-x 7 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 12 ^external-net-name 7) -(make pin ^net-name 10 ^external-pin-name 20 ^pin-x 8 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 13 ^external-net-name 10) -(make pin ^net-name 4 ^external-pin-name 21 ^pin-x 9 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 14 ^external-net-name 4) -(make pin ^net-name 9 ^external-pin-name 22 ^pin-x 10 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 15 ^external-net-name 9) -(make pin ^net-name 10 ^external-pin-name 23 ^pin-x 11 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 16 ^external-net-name 10) -(make pin ^net-name 10 ^external-pin-name 24 ^pin-x 12 ^pin-y 5 ^pin-layer poly ^pin-layer-constraint fixed ^pin-channel-side top ^pin-name 17 ^external-net-name 10) -(make net ^net-name 3 ^parent-name 3 ^net-no-of-pins 2 ^net-left-x 1 ^net-left-y 0 ^net-right-x 4 ^net-right-y 0 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 0 ^no-of-bottom-pins 2 ^left-most-pin-name 35 ^right-most-pin-name 32 ^bottom-most-pin-name 35 ^top-most-pin-name 35 ^external-net-name 3) -(make to-be-routed ^net-name 3 ^no-of-attached-pins 1) -(make included 3 35) -(make net ^net-name 1 ^parent-name 1 ^net-no-of-pins 3 ^net-left-x 2 ^net-left-y 0 ^net-right-x 5 ^net-right-y 5 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 2 ^no-of-bottom-pins 1 ^left-most-pin-name 34 ^right-most-pin-name 10 ^bottom-most-pin-name 34 ^top-most-pin-name 7 ^external-net-name 1) -(make to-be-routed ^net-name 1 ^no-of-attached-pins 1) -(make included 1 34) -(make net ^net-name 5 ^parent-name 5 ^net-no-of-pins 3 ^net-left-x 3 ^net-left-y 0 ^net-right-x 5 ^net-right-y 5 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 1 ^no-of-bottom-pins 2 ^left-most-pin-name 33 ^right-most-pin-name 31 ^bottom-most-pin-name 33 ^top-most-pin-name 9 ^external-net-name 5) -(make to-be-routed ^net-name 5 ^no-of-attached-pins 1) -(make included 5 33) -(make net ^net-name 2 ^parent-name 2 ^net-no-of-pins 2 ^net-left-x 1 ^net-left-y 0 ^net-right-x 6 ^net-right-y 5 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 1 ^no-of-bottom-pins 1 ^left-most-pin-name 6 ^right-most-pin-name 30 ^bottom-most-pin-name 30 ^top-most-pin-name 6 ^external-net-name 2) -(make to-be-routed ^net-name 2 ^no-of-attached-pins 1) -(make included 2 30) -(make net ^net-name 6 ^parent-name 6 ^net-no-of-pins 2 ^net-left-x 6 ^net-left-y 0 ^net-right-x 7 ^net-right-y 5 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 1 ^no-of-bottom-pins 1 ^left-most-pin-name 11 ^right-most-pin-name 29 ^bottom-most-pin-name 29 ^top-most-pin-name 11 ^external-net-name 6) -(make to-be-routed ^net-name 6 ^no-of-attached-pins 1) -(make included 6 29) -(make net ^net-name 8 ^parent-name 8 ^net-no-of-pins 2 ^net-left-x 8 ^net-left-y 0 ^net-right-x 10 ^net-right-y 0 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 0 ^no-of-bottom-pins 2 ^left-most-pin-name 28 ^right-most-pin-name 26 ^bottom-most-pin-name 28 ^top-most-pin-name 28 ^external-net-name 8) -(make to-be-routed ^net-name 8 ^no-of-attached-pins 1) -(make included 8 28) -(make net ^net-name 9 ^parent-name 9 ^net-no-of-pins 3 ^net-left-x 9 ^net-left-y 0 ^net-right-x 12 ^net-right-y 5 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 1 ^no-of-bottom-pins 2 ^left-most-pin-name 27 ^right-most-pin-name 24 ^bottom-most-pin-name 27 ^top-most-pin-name 15 ^external-net-name 9) -(make to-be-routed ^net-name 9 ^no-of-attached-pins 1) -(make included 9 27) -(make net ^net-name 7 ^parent-name 7 ^net-no-of-pins 2 ^net-left-x 7 ^net-left-y 0 ^net-right-x 11 ^net-right-y 5 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 1 ^no-of-bottom-pins 1 ^left-most-pin-name 12 ^right-most-pin-name 25 ^bottom-most-pin-name 25 ^top-most-pin-name 12 ^external-net-name 7) -(make to-be-routed ^net-name 7 ^no-of-attached-pins 1) -(make included 7 25) -(make net ^net-name 4 ^parent-name 4 ^net-no-of-pins 2 ^net-left-x 3 ^net-left-y 5 ^net-right-x 9 ^net-right-y 5 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 2 ^no-of-bottom-pins 0 ^left-most-pin-name 8 ^right-most-pin-name 14 ^bottom-most-pin-name 8 ^top-most-pin-name 8 ^external-net-name 4) -(make to-be-routed ^net-name 4 ^no-of-attached-pins 1) -(make included 4 8) -(make net ^net-name 10 ^parent-name 10 ^net-no-of-pins 3 ^net-left-x 8 ^net-left-y 5 ^net-right-x 12 ^net-right-y 5 ^no-of-left-pins 0 ^no-of-right-pins 0 ^no-of-top-pins 3 ^no-of-bottom-pins 0 ^left-most-pin-name 13 ^right-most-pin-name 17 ^bottom-most-pin-name 13 ^top-most-pin-name 13 ^external-net-name 10) -(make to-be-routed ^net-name 10 ^no-of-attached-pins 1) -(make included 10 13) -(make vertical-layer poly 24) -(make horizontal-layer metal 0) -(make congestion ^coordinate 0 ^direction row ^no-of-nets 12 ^como -1) -(make congestion ^coordinate 1 ^direction row ^no-of-nets 12 ^como 0) -(make congestion ^coordinate 2 ^direction row ^no-of-nets 6 ^como 1) -(make congestion ^coordinate 3 ^direction row ^no-of-nets 6 ^como 2) -(make congestion ^coordinate 4 ^direction row ^no-of-nets 12 ^como 3) -(make congestion ^coordinate 5 ^direction row ^no-of-nets 12 ^como 4) -(make congestion ^coordinate 0 ^direction col ^no-of-nets 0 ^como -1) -(make congestion ^coordinate 1 ^direction col ^no-of-nets 2 ^como 0) -(make congestion ^coordinate 2 ^direction col ^no-of-nets 3 ^como 1) -(make congestion ^coordinate 3 ^direction col ^no-of-nets 5 ^como 2) -(make congestion ^coordinate 4 ^direction col ^no-of-nets 5 ^como 3) -(make congestion ^coordinate 5 ^direction col ^no-of-nets 4 ^como 4) -(make congestion ^coordinate 6 ^direction col ^no-of-nets 3 ^como 5) -(make congestion ^coordinate 7 ^direction col ^no-of-nets 3 ^como 6) -(make congestion ^coordinate 8 ^direction col ^no-of-nets 4 ^como 7) -(make congestion ^coordinate 9 ^direction col ^no-of-nets 5 ^como 8) -(make congestion ^coordinate 10 ^direction col ^no-of-nets 4 ^como 9) -(make congestion ^coordinate 11 ^direction col ^no-of-nets 3 ^como 10) -(make congestion ^coordinate 12 ^direction col ^no-of-nets 2 ^como 11) -(make congestion ^coordinate 13 ^direction col ^no-of-nets 0 ^como 12) -(make horizontal ^compo 3 ^com 2 ^min 1 ^max 12 ^commo 1 ^layer metal) -(make horizontal ^compo 3 ^com 2 ^min 1 ^max 12 ^commo 1 ^layer poly) -(make horizontal ^compo 4 ^com 3 ^min 1 ^max 12 ^commo 2 ^layer metal) -(make horizontal ^compo 4 ^com 3 ^min 1 ^max 12 ^commo 2 ^layer poly) -(make vertical ^compo 3 ^com 2 ^min 1 ^max 4 ^commo 1 ^layer metal) -(make vertical ^compo 3 ^com 2 ^min 1 ^max 4 ^commo 1 ^layer poly ^min-net 1 ^max-net 1) -(make vertical ^compo 4 ^com 3 ^min 1 ^max 4 ^commo 2 ^layer metal) -(make vertical ^compo 4 ^com 3 ^min 1 ^max 4 ^commo 2 ^layer poly ^min-net 5 ^max-net 4) -(make vertical ^compo 5 ^com 4 ^min 1 ^max 4 ^commo 3 ^layer metal) -(make vertical ^compo 5 ^com 4 ^min 1 ^max 4 ^commo 3 ^layer poly ^min-net 3 ^max-net 5) -(make vertical ^compo 6 ^com 5 ^min 1 ^max 4 ^commo 4 ^layer metal) -(make vertical ^compo 6 ^com 5 ^min 1 ^max 4 ^commo 4 ^layer poly ^min-net 5 ^max-net 1) -(make vertical ^compo 7 ^com 6 ^min 1 ^max 4 ^commo 5 ^layer metal) -(make vertical ^compo 7 ^com 6 ^min 1 ^max 4 ^commo 5 ^layer poly ^min-net 2 ^max-net 6) -(make vertical ^compo 8 ^com 7 ^min 1 ^max 4 ^commo 6 ^layer metal) -(make vertical ^compo 8 ^com 7 ^min 1 ^max 4 ^commo 6 ^layer poly ^min-net 6 ^max-net 7) -(make vertical ^compo 9 ^com 8 ^min 1 ^max 4 ^commo 7 ^layer metal) -(make vertical ^compo 9 ^com 8 ^min 1 ^max 4 ^commo 7 ^layer poly ^min-net 8 ^max-net 10) -(make vertical ^compo 10 ^com 9 ^min 1 ^max 4 ^commo 8 ^layer metal) -(make vertical ^compo 10 ^com 9 ^min 1 ^max 4 ^commo 8 ^layer poly ^min-net 9 ^max-net 4) -(make vertical ^compo 11 ^com 10 ^min 1 ^max 4 ^commo 9 ^layer metal) -(make vertical ^compo 11 ^com 10 ^min 1 ^max 4 ^commo 9 ^layer poly ^min-net 8 ^max-net 9) -(make vertical ^compo 12 ^com 11 ^min 1 ^max 4 ^commo 10 ^layer metal) -(make vertical ^compo 12 ^com 11 ^min 1 ^max 4 ^commo 10 ^layer poly ^min-net 7 ^max-net 10) -(make horizontal ^compo 2 ^com 1 ^min 1 ^max 12 ^commo 0 ^layer metal) -(make horizontal ^compo 5 ^com 4 ^min 11 ^max 12 ^commo 3 ^layer poly ^min-net 10 ^max-net 10) -(make horizontal ^compo 5 ^com 4 ^min 1 ^max 12 ^commo 3 ^layer metal) -(make vertical ^compo 2 ^com 1 ^min 1 ^max 4 ^commo 0 ^layer poly ^min-net 3 ^max-net 2) -(make vertical ^compo 2 ^com 1 ^min 1 ^max 4 ^commo 0 ^layer metal) -(make vertical ^compo 13 ^com 12 ^min 1 ^max 4 ^commo 11 ^layer poly ^min-net 9 ^max-net 10) -(make vertical ^compo 13 ^com 12 ^min 1 ^max 4 ^commo 11 ^layer metal) -(make vertical ^net-name 3 ^compo 2 ^com 1 ^min 0 ^max 1 ^commo 0 ^layer poly ^pin-name 35) -(make ff ^net-name 3 ^grid-layer poly ^grid-x 1 ^grid-y 1 ^came-from south ^pin-name 35) -(make vertical ^net-name 1 ^compo 3 ^com 2 ^min 0 ^max 1 ^commo 1 ^layer poly ^pin-name 34) -(make ff ^net-name 1 ^grid-layer poly ^grid-x 2 ^grid-y 1 ^came-from south ^pin-name 34) -(make vertical ^net-name 5 ^compo 4 ^com 3 ^min 0 ^max 1 ^commo 2 ^layer poly ^pin-name 33) -(make ff ^net-name 5 ^grid-layer poly ^grid-x 3 ^grid-y 1 ^came-from south ^pin-name 33) -(make vertical ^net-name 3 ^compo 5 ^com 4 ^min 0 ^max 1 ^commo 3 ^layer poly ^pin-name 32) -(make ff ^net-name 3 ^grid-layer poly ^grid-x 4 ^grid-y 1 ^came-from south ^pin-name 32) -(make vertical ^net-name 5 ^compo 6 ^com 5 ^min 0 ^max 1 ^commo 4 ^layer poly ^pin-name 31) -(make ff ^net-name 5 ^grid-layer poly ^grid-x 5 ^grid-y 1 ^came-from south ^pin-name 31) -(make vertical ^net-name 2 ^compo 7 ^com 6 ^min 0 ^max 1 ^commo 5 ^layer poly ^pin-name 30) -(make ff ^net-name 2 ^grid-layer poly ^grid-x 6 ^grid-y 1 ^came-from south ^pin-name 30) -(make vertical ^net-name 6 ^compo 8 ^com 7 ^min 0 ^max 1 ^commo 6 ^layer poly ^pin-name 29) -(make ff ^net-name 6 ^grid-layer poly ^grid-x 7 ^grid-y 1 ^came-from south ^pin-name 29) -(make vertical ^net-name 8 ^compo 9 ^com 8 ^min 0 ^max 1 ^commo 7 ^layer poly ^pin-name 28) -(make ff ^net-name 8 ^grid-layer poly ^grid-x 8 ^grid-y 1 ^came-from south ^pin-name 28) -(make vertical ^net-name 9 ^compo 10 ^com 9 ^min 0 ^max 1 ^commo 8 ^layer poly ^pin-name 27) -(make ff ^net-name 9 ^grid-layer poly ^grid-x 9 ^grid-y 1 ^came-from south ^pin-name 27) -(make vertical ^net-name 8 ^compo 11 ^com 10 ^min 0 ^max 1 ^commo 9 ^layer poly ^pin-name 26) -(make ff ^net-name 8 ^grid-layer poly ^grid-x 10 ^grid-y 1 ^came-from south ^pin-name 26) -(make vertical ^net-name 7 ^compo 12 ^com 11 ^min 0 ^max 1 ^commo 10 ^layer poly ^pin-name 25) -(make ff ^net-name 7 ^grid-layer poly ^grid-x 11 ^grid-y 1 ^came-from south ^pin-name 25) -(make vertical ^net-name 9 ^compo 13 ^com 12 ^min 0 ^max 1 ^commo 11 ^layer poly ^pin-name 24) -(make ff ^net-name 9 ^grid-layer poly ^grid-x 12 ^grid-y 1 ^came-from south ^pin-name 24) -(make vertical ^net-name 2 ^compo 2 ^com 1 ^min 4 ^max 5 ^commo 0 ^layer poly ^pin-name 6) -(make ff ^net-name 2 ^grid-layer poly ^grid-x 1 ^grid-y 4 ^came-from north ^pin-name 6) -(make vertical ^net-name 1 ^compo 3 ^com 2 ^min 4 ^max 5 ^commo 1 ^layer poly ^pin-name 7) -(make ff ^net-name 1 ^grid-layer poly ^grid-x 2 ^grid-y 4 ^came-from north ^pin-name 7) -(make vertical ^net-name 4 ^compo 4 ^com 3 ^min 4 ^max 5 ^commo 2 ^layer poly ^pin-name 8) -(make ff ^net-name 4 ^grid-layer poly ^grid-x 3 ^grid-y 4 ^came-from north ^pin-name 8) -(make vertical ^net-name 5 ^compo 5 ^com 4 ^min 4 ^max 5 ^commo 3 ^layer poly ^pin-name 9) -(make ff ^net-name 5 ^grid-layer poly ^grid-x 4 ^grid-y 4 ^came-from north ^pin-name 9) -(make vertical ^net-name 1 ^compo 6 ^com 5 ^min 4 ^max 5 ^commo 4 ^layer poly ^pin-name 10) -(make ff ^net-name 1 ^grid-layer poly ^grid-x 5 ^grid-y 4 ^came-from north ^pin-name 10) -(make vertical ^net-name 6 ^compo 7 ^com 6 ^min 4 ^max 5 ^commo 5 ^layer poly ^pin-name 11) -(make ff ^net-name 6 ^grid-layer poly ^grid-x 6 ^grid-y 4 ^came-from north ^pin-name 11) -(make vertical ^net-name 7 ^compo 8 ^com 7 ^min 4 ^max 5 ^commo 6 ^layer poly ^pin-name 12) -(make ff ^net-name 7 ^grid-layer poly ^grid-x 7 ^grid-y 4 ^came-from north ^pin-name 12) -(make vertical ^net-name 10 ^compo 9 ^com 8 ^min 4 ^max 5 ^commo 7 ^layer poly ^pin-name 13) -(make ff ^net-name 10 ^grid-layer poly ^grid-x 8 ^grid-y 4 ^came-from north ^pin-name 13) -(make vertical ^net-name 4 ^compo 10 ^com 9 ^min 4 ^max 5 ^commo 8 ^layer poly ^pin-name 14) -(make ff ^net-name 4 ^grid-layer poly ^grid-x 9 ^grid-y 4 ^came-from north ^pin-name 14) -(make vertical ^net-name 9 ^compo 11 ^com 10 ^min 4 ^max 5 ^commo 9 ^layer poly ^pin-name 15) -(make ff ^net-name 9 ^grid-layer poly ^grid-x 10 ^grid-y 4 ^came-from north ^pin-name 15) -(make vertical ^net-name 10 ^compo 12 ^com 11 ^min 4 ^max 5 ^commo 10 ^layer poly ^pin-name 16) -(make ff ^net-name 10 ^grid-layer poly ^grid-x 11 ^grid-y 4 ^came-from north ^pin-name 16) -(make vertical ^net-name 10 ^compo 13 ^com 12 ^min 4 ^max 5 ^commo 11 ^layer poly ^pin-name 17) -(make ff ^net-name 10 ^grid-layer poly ^grid-x 12 ^grid-y 4 ^came-from north ^pin-name 17) -(make horizontal-s ^net-name 3 ^top-count 0 ^com 1 ^min 1 ^max 4 ^bot-count 2 ^id 0 ^sum 2 ^difference -2 ^absolute 2) -(make vertical-s ^net-name 1 ^top-count 1 ^com 2 ^min 1 ^max 4 ^bot-count 0 ^id 1 ^sum 1 ^difference 1 ^absolute 1) -(make horizontal-s ^net-name 1 ^top-count 2 ^com 4 ^min 2 ^max 5 ^bot-count 1 ^id 2 ^sum 3 ^difference 1 ^absolute 1) -(make horizontal-s ^net-name 5 ^top-count 1 ^com 1 ^min 3 ^max 5 ^bot-count 2 ^id 3 ^sum 3 ^difference -1 ^absolute 1) -(make vertical-s ^net-name 5 ^top-count 1 ^com 4 ^min 1 ^max 4 ^bot-count 1 ^id 4 ^sum 2 ^difference 0 ^absolute 0) -(make vertical-s ^net-name 2 ^top-count 1 ^com 1 ^min 1 ^max 4 ^bot-count 1 ^id 5 ^sum 2 ^difference 0 ^absolute 0) -(make horizontal-s ^net-name 2 ^top-count 1 ^com 1 ^min 1 ^max 6 ^bot-count 1 ^id 6 ^sum 2 ^difference 0 ^absolute 0) -(make vertical-s ^net-name 6 ^top-count 1 ^com 6 ^min 1 ^max 4 ^bot-count 0 ^id 7 ^sum 1 ^difference 1 ^absolute 1) -(make horizontal-s ^net-name 6 ^top-count 1 ^com 1 ^min 6 ^max 7 ^bot-count 1 ^id 8 ^sum 2 ^difference 0 ^absolute 0) -(make horizontal-s ^net-name 8 ^top-count 0 ^com 1 ^min 8 ^max 10 ^bot-count 2 ^id 9 ^sum 2 ^difference -2 ^absolute 2) -(make horizontal-s ^net-name 9 ^top-count 1 ^com 1 ^min 9 ^max 12 ^bot-count 2 ^id 10 ^sum 3 ^difference -1 ^absolute 1) -(make vertical-s ^net-name 9 ^top-count 1 ^com 10 ^min 1 ^max 4 ^bot-count 1 ^id 11 ^sum 2 ^difference 0 ^absolute 0) -(make vertical-s ^net-name 7 ^top-count 1 ^com 7 ^min 1 ^max 4 ^bot-count 0 ^id 12 ^sum 1 ^difference 1 ^absolute 1) -(make horizontal-s ^net-name 7 ^top-count 1 ^com 1 ^min 7 ^max 11 ^bot-count 1 ^id 13 ^sum 2 ^difference 0 ^absolute 0) -(make horizontal-s ^net-name 4 ^top-count 2 ^com 4 ^min 3 ^max 9 ^bot-count 0 ^id 14 ^sum 2 ^difference 2 ^absolute 2) -(make horizontal-s ^net-name 10 ^top-count 3 ^com 4 ^min 8 ^max 12 ^bot-count 0 ^id 15 ^sum 3 ^difference 3 ^absolute 3) -(make branch-no 1000) -(make context ^present separate) -) diff --git a/contrib/ops/ops-backup.lisp b/contrib/ops/ops-backup.lisp deleted file mode 100644 index a940546f2c8eef3ea307c3aeeafebf77b79cf2e9..0000000000000000000000000000000000000000 --- a/contrib/ops/ops-backup.lisp +++ /dev/null @@ -1,196 +0,0 @@ -; -;************************************************************************ -; -; VPS2 -- Interpreter for OPS5 -; -; -; -; This Common Lisp version of OPS5 is in the public domain. It is based -; in part on based on a Franz Lisp implementation done by Charles L. Forgy -; at Carnegie-Mellon University, which was placed in the public domain by -; the author in accordance with CMU policies. This version has been -; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen, -; and Dan Kuokka. -; -; This code is made available is, and without warranty of any kind by the -; authors or by Carnegie-Mellon University. -; - -;;;; Definitions and functions for backing up. - -(in-package "OPS") - - -;;; Internal Global Variables - -(defvar *refracts*) -(defvar *record*) -(defvar *record-array*) -(defvar *recording*) -(defvar *max-record-index*) -(defvar *record-index*) - - - -(defun backup-init () - (setq *recording* nil) - (setq *refracts* nil) - (setq *record-array* (make-array 256 :initial-element ())) ;jgk - (initialize-record)) - - -(defun back (k) - (prog (r) - loop (and (< k 1.) (return nil)) - (setq r (getvector *record-array* *record-index*)) ; ((')) - (and (null r) (return '|nothing more stored|)) - (putvector *record-array* *record-index* nil) - (record-index-plus -1.) - (undo-record r) - (setq k (1- k)) - (go loop))) - - -; *max-record-index* holds the maximum legal index for record-array -; so it and the following must be changed at the same time - -(defun begin-record (p data) - (setq *recording* t) - (setq *record* (list '=>refract p data))) - -(defun end-record nil - (cond (*recording* - (setq *record* - (cons *cycle-count* (cons *p-name* *record*))) - (record-index-plus 1.) - (putvector *record-array* *record-index* *record*) - (setq *record* nil) - (setq *recording* nil)))) - -(defun record-change (direct time elm) - (cond (*recording* - (setq *record* - (cons direct (cons time (cons elm *record*))))))) - -; to maintain refraction information, need keep only one piece of information: -; need to record all unsuccessful attempts to delete things from the conflict -; set. unsuccessful deletes are caused by attempting to delete refracted -; instantiations. when backing up, have to avoid putting things back into the -; conflict set if they were not deleted when running forward - -(defun record-refract (rule data) - (and *recording* - (setq *record* (cons '<=refract (cons rule (cons data *record*)))))) - -(defun refracted (rule data) - (prog (z) - (and (null *refracts*) (return nil)) - (setq z (cons rule data)) - (return (member z *refracts* :test #'equal)))) - - -(defun record-index-plus (k) - (setq *record-index* (+ k *record-index*)) ;"plus" changed to "+" by gdw - (cond ((< *record-index* 0.) - (setq *record-index* *max-record-index*)) - ((> *record-index* *max-record-index*) - (setq *record-index* 0.)))) - -; the following routine initializes the record. putting nil in the -; first slot indicates that that the record does not go back further -; than that. (when the system backs up, it writes nil over the used -; records so that it will recognize which records it has used. thus -; the system is set up anyway never to back over a nil.) - -(defun initialize-record nil - (setq *record-index* 0.) - (setq *recording* nil) - (setq *max-record-index* 31.) - (putvector *record-array* 0. nil)) - - -;; replaced per jcp -;;; Commented out -#| -(defun undo-record (r) - (prog (save act a b rate) - ;### (comment *recording* must be off during back up) - (setq save *recording*) - (setq *refracts* nil) - (setq *recording* nil) - (and *ptrace* (back-print (list '|undo:| (car r) (cadr r)))) - (setq r (cddr r)) - top (and (atom r) (go fin)) - (setq act (car r)) - (setq a (cadr r)) - (setq b (caddr r)) - (setq r (cdddr r)) - (and *wtrace* (back-print (list '|undo:| act a))) - (cond ((eq act '<=wm) (add-to-wm b a)) - ((eq act '=>wm) (remove-from-wm b)) - ((eq act '<=refract) - (setq *refracts* (cons (cons a b) *refracts*))) - ((and (eq act '=>refract) (still-present b)) - (setq *refracts* (delete (cons a b) *refracts*)) - (setq rate (rating-part (get a 'topnode))) - (removecs a b) - (insertcs a b rate)) - (t (%warn '|back: cannot undo action| (list act a)))) - (go top) - fin (setq *recording* save) - (setq *refracts* nil) - (return nil))) -;;; End commented out -|# - - -(defun undo-record (r) - (prog (save act a b rate) - ;### (comment *recording* must be off during back up) - (setq save *recording*) - (setq *refracts* nil) - (setq *recording* nil) - (and *ptrace* (back-print (list '|undo:| (car r) (cadr r)))) - (setq r (cddr r)) - top (and (atom r) (go fin)) - (setq act (car r)) - (setq a (cadr r)) - (setq b (caddr r)) - (setq r (cdddr r)) - (and *wtrace* (back-print (list '|undo:| act a))) - (cond ((eq act '<=wm) (add-to-wm b a)) - ((eq act '=>wm) (remove-from-wm b)) - ((eq act '<=refract) - (setq *refracts* (cons (cons a b) *refracts*))) - ((and (eq act '=>refract) (still-present b)) - (setq *refracts* (spdelete (cons a b) *refracts*)) - (setq rate (rating-part (get a 'topnode))) - (removecs a b) - (insertcs a b rate)) - (t (%warn '|back: cannot undo action| (list act a)))) - (go top) - fin (setq *recording* save) - (setq *refracts* nil) - (return nil))) - - - -; still-present makes sure that the user has not deleted something -; from wm which occurs in the instantiation about to be restored; it -; makes the check by determining whether each wme still has a time tag. - -(defun still-present (data) - (prog nil - loop - (cond ((atom data) (return t)) - ((creation-time (car data)) - (setq data (cdr data)) - (go loop)) - (t (return nil))))) - - -(defun back-print (x) - (prog (port) - (setq port (trace-file)) - (terpri port) - (print x port))) diff --git a/contrib/ops/ops-compile.lisp b/contrib/ops/ops-compile.lisp deleted file mode 100644 index bdf7960ffd3e602e70396770d3a7249e51b2d6ac..0000000000000000000000000000000000000000 --- a/contrib/ops/ops-compile.lisp +++ /dev/null @@ -1,805 +0,0 @@ -; -;************************************************************************ -; -; VPS2 -- Interpreter for OPS5 -; -; -; -; This Common Lisp version of OPS5 is in the public domain. It is based -; in part on based on a Franz Lisp implementation done by Charles L. Forgy -; at Carnegie-Mellon University, which was placed in the public domain by -; the author in accordance with CMU policies. This version has been -; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen, -; and Dan Kuokka. -; -; This code is made available is, and without warranty of any kind by the -; authors or by Carnegie-Mellon University. -; - -;;;; This file contains functions compile productions. - -(in-package "OPS") -(shadow '(remove write)) ; Should get this by requiring ops-rhs -(export '--> ) - - -;;; External global variables - -(defvar *real-cnt*) -(defvar *virtual-cnt*) -(defvar *last-node*) -(defvar *first-node*) -(defvar *pcount*) - - -;;; Internal global variables - -(defvar *matrix*) -(defvar *curcond*) -(defvar *feature-count*) -(defvar *ce-count*) -(defvar *vars*) -(defvar *ce-vars*) -(defvar *rhs-bound-vars*) -(defvar *rhs-bound-ce-vars*) -(defvar *last-branch*) -(defvar *subnum*) -(defvar *cur-vars*) -(defvar *action-type*) - - - -(defun compile-init () - (setq *real-cnt* (setq *virtual-cnt* 0.)) - (setq *pcount* 0.) - (make-bottom-node)) - - -;;; LHS Compiler - -(defun ops-p (z) - (finish-literalize) - (princ '*) - ;(drain) commented out temporarily - (force-output) ;@@@ clisp drain? - (compile-production (car z) (cdr z))) - - -(defun compile-production (name matrix) ;jgk inverted args to catch and quoted tag - (setq *p-name* name) - (catch '!error! (cmp-p name matrix)) - (setq *p-name* nil)) -#| -(defun compile-production (name matrix) ;jgk inverted args to catch - (prog (erm) ;and quoted tag - (setq *p-name* name) - (setq erm (catch '!error! (cmp-p name matrix))) - (setq *p-name* nil))) -|# - -(defun peek-lex nil (car *matrix*)) - -(defun lex nil - (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*)))) - -(defun end-of-p nil (atom *matrix*)) - -(defun rest-of-p nil *matrix*) - -(defun prepare-lex (prod) (setq *matrix* prod)) - - -(defun peek-sublex nil (car *curcond*)) - -(defun sublex nil - (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*)))) - -(defun end-of-ce nil (atom *curcond*)) - -(defun rest-of-ce nil *curcond*) - -(defun prepare-sublex (ce) (setq *curcond* ce)) - -(defun make-bottom-node nil (setq *first-node* (list '&bus nil))) - -(defun cmp-p (name matrix) - (prog (m bakptrs) - (cond ((or (null name) (consp name)) ;dtpr\consp gdw - (%error '|illegal production name| name)) - ((equal (get name 'production) matrix) - (return nil))) - (prepare-lex matrix) - (excise-p name) - (setq bakptrs nil) - (setq *pcount* (1+ *pcount*)) ;"plus" changed to "+" by gdw - (setq *feature-count* 0.) - (setq *ce-count* 0) - (setq *vars* nil) - (setq *ce-vars* nil) - (setq *rhs-bound-vars* nil) - (setq *rhs-bound-ce-vars* nil) - (setq *last-branch* nil) - (setq m (rest-of-p)) - l1 (and (end-of-p) (%error '|no '-->' in production| m)) - (cmp-prin) - (setq bakptrs (cons *last-branch* bakptrs)) - (or (eq '--> (peek-lex)) (go l1)) - (lex) - (check-rhs (rest-of-p)) - (link-new-node (list '&p - *feature-count* - name - (encode-dope) - (encode-ce-dope) - (cons 'progn (rest-of-p)))) - (putprop name (cdr (nreverse bakptrs)) 'backpointers) - (putprop name matrix 'production) - (putprop name *last-node* 'topnode))) - -(defun rating-part (pnode) (cadr pnode)) - -(defun var-part (pnode) (car (cdddr pnode))) - -(defun ce-var-part (pnode) (cadr (cdddr pnode))) - -(defun rhs-part (pnode) (caddr (cdddr pnode))) - -(defun cmp-prin nil - (prog nil - (setq *last-node* *first-node*) - (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta)) - ((eq (peek-lex) '-) (cmp-negce) (cmp-not)) - (t (cmp-posce) (cmp-and))))) - -(defun cmp-negce nil (lex) (cmp-ce)) - -(defun cmp-posce nil - (setq *ce-count* (1+ *ce-count*)) ;"plus" changed to "+" by gdw - (cond ((eq (peek-lex) '\{) (cmp-ce+cevar)) ;"plus" changed to "+" by gdw - (t (cmp-ce)))) - -(defun cmp-ce+cevar nil - (prog (z) - (lex) - (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce)) - (t (cmp-ce) (cmp-cevar))) - (setq z (lex)) - (or (eq z '\}) (%error '|missing '}'| z)))) - -(defun new-subnum (k) - (or (numberp k) (%error '|tab must be a number| k)) - (setq *subnum* (fix k))) - -(defun incr-subnum nil (setq *subnum* (1+ *subnum*))) - -(defun cmp-ce nil - (prog (z) - (new-subnum 0.) - (setq *cur-vars* nil) - (setq z (lex)) - (and (atom z) - (%error '|atomic conditions are not allowed| z)) - (prepare-sublex z) - la (and (end-of-ce) (return nil)) - (incr-subnum) - (cmp-element) - (go la))) - -(defun cmp-element nil - (and (eq (peek-sublex) '^) (cmp-tab)) - (cond ((eq (peek-sublex) '\{) (cmp-product)) - (t (cmp-atomic-or-any)))) - -(defun cmp-atomic-or-any nil - (cond ((eq (peek-sublex) '<<) (cmp-any)) - (t (cmp-atomic)))) - -(defun cmp-any nil - (prog (a z) - (sublex) - (setq z nil) - la (cond ((end-of-ce) (%error '|missing '>>'| a))) - (setq a (sublex)) - (cond ((not (eq '>> a)) (setq z (cons a z)) (go la))) - (link-new-node (list '&any nil (current-field) z)))) - - -(defun cmp-tab nil - (prog (r) - (sublex) - (setq r (sublex)) - (setq r ($litbind r)) - (new-subnum r))) - -(defun get-bind (x) - (prog (r) - (cond ((and (symbolp x) (setq r (literal-binding-of x))) - (return r)) - (t (return nil))))) - -(defun cmp-atomic nil - (prog (test x) - (setq x (peek-sublex)) - (cond ((eq x '= ) (setq test 'eq) (sublex)) - ((eq x '<>) (setq test 'ne) (sublex)) - ((eq x '<) (setq test 'lt) (sublex)) - ((eq x '<=) (setq test 'le) (sublex)) - ((eq x '>) (setq test 'gt) (sublex)) - ((eq x '>=) (setq test 'ge) (sublex)) - ((eq x '<=>) (setq test 'xx) (sublex)) - (t (setq test 'eq))) - (cmp-symbol test))) - -(defun cmp-product nil - (prog (save) - (setq save (rest-of-ce)) - (sublex) - la (cond ((end-of-ce) - (cond ((member '\} save :test #'equal) - (%error '|wrong contex for '}'| save)) - (t (%error '|missing '}'| save)))) - ((eq (peek-sublex) '\}) (sublex) (return nil))) - (cmp-atomic-or-any) - (go la))) - -(defun cmp-symbol (test) - (prog (flag) - (setq flag t) - (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil))) - (cond ((and flag (variablep (peek-sublex))) - (cmp-var test)) - ((numberp (peek-sublex)) (cmp-number test)) - ((symbolp (peek-sublex)) (cmp-constant test)) - (t (%error '|unrecognized symbol| (sublex)))))) - -(defun cmp-constant (test) ;jgk inserted concatenate form - (or (member test '(eq ne xx)) - (%error '|non-numeric constant after numeric predicate| (sublex))) - (link-new-node (list (intern (concatenate 'string - "T" - (symbol-name test) - "A")) - nil - (current-field) - (sublex)))) - -(defun cmp-number (test) ;jgk inserted concatenate form - (link-new-node (list (intern (concatenate 'string - "T" - (symbol-name test) -;@@@ error? reported by laird fix\ "A")) - "N")) - nil - (current-field) - (sublex)))) - -(defun current-field nil (field-name *subnum*)) - -(defun field-name (num) - (if (< 0 num 127) - (svref '#(nil *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* *c10* *c11* - *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* *c20* *c21* - *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* *c30* *c31* - *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* *c40* *c41* - *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* *c50* *c51* - *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* *c60* *c61* - *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* *c70* *c71* - *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* *c80* *c81* - *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* *c90* *c91* - *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* *c100* - *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108* - *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116* - *c117* *c118* *c119* *c120* *c121* *c122* *c123* *c124* - *c125* *c126* *c127*) - num) - (%error '|condition is too long| (rest-of-ce)))) - -;;; Compiling variables -; -; -; -; *cur-vars* are the variables in the condition element currently -; being compiled. *vars* are the variables in the earlier condition -; elements. *ce-vars* are the condition element variables. note -; that the interpreter will not confuse condition element and regular -; variables even if they have the same name. -; -; *cur-vars* is a list of triples: (name predicate subelement-number) -; eg: ( (<x> eq 3) -; (<y> ne 1) -; . . . ) -; -; *vars* is a list of triples: (name ce-number subelement-number) -; eg: ( (<x> 3 3) -; (<y> 1 1) -; . . . ) -; -; *ce-vars* is a list of pairs: (name ce-number) -; eg: ( (ce1 1) -; (<c3> 3) -; . . . ) - -(defmacro var-dope (var) `(assq ,var *vars*)) - -(defmacro ce-var-dope (var) `(assq ,var *ce-vars*)) - -(defun cmp-var (test) - (prog (old name) - (setq name (sublex)) - (setq old (assq name *cur-vars*)) - (cond ((and old (eq (cadr old) 'eq)) - (cmp-old-eq-var test old)) - ((and old (eq test 'eq)) (cmp-new-eq-var name old)) - (t (cmp-new-var name test))))) - -(defun cmp-new-var (name test) - (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*))) - -(defun cmp-old-eq-var (test old) ; jgk inserted concatenate form - (link-new-node (list (intern (concatenate 'string - "T" - (symbol-name test) - "S")) - nil - (current-field) - (field-name (caddr old))))) - - - -(defun cmp-new-eq-var (name old) ;jgk inserted concatenate form - (prog (pred next) - (setq *cur-vars* (delq old *cur-vars*)) - (setq next (assq name *cur-vars*)) - (cond (next (cmp-new-eq-var name next)) - (t (cmp-new-var name 'eq))) - (setq pred (cadr old)) - (link-new-node (list (intern (concatenate 'string - "T" - (symbol-name pred) - "S")) - nil - (field-name (caddr old)) - (current-field))))) - -(defun cmp-cevar nil - (prog (name old) - (setq name (lex)) - (setq old (assq name *ce-vars*)) - (and old - (%error '|condition element variable used twice| name)) - (setq *ce-vars* (cons (list name 0.) *ce-vars*)))) - -(defun cmp-not nil (cmp-beta '¬)) - -(defun cmp-nobeta nil (cmp-beta nil)) - -(defun cmp-and nil (cmp-beta '&and)) - -(defun cmp-beta (kind) - (prog (tlist vdope vname #|vpred vpos|# old) - (setq tlist nil) - la (and (atom *cur-vars*) (go lb)) - (setq vdope (car *cur-vars*)) - (setq *cur-vars* (cdr *cur-vars*)) - (setq vname (car vdope)) - ;; (setq vpred (cadr vdope)) Dario - commented out (unused) - ;; (setq vpos (caddr vdope)) - (setq old (assq vname *vars*)) - (cond (old (setq tlist (add-test tlist vdope old))) - ((not (eq kind '¬)) (promote-var vdope))) - (go la) - lb (and kind (build-beta kind tlist)) - (or (eq kind '¬) (fudge)) - (setq *last-branch* *last-node*))) - -(defun add-test (list new old) ; jgk inserted concatenate form - (prog (ttype lloc rloc) - (setq *feature-count* (1+ *feature-count*)) - (setq ttype (intern (concatenate 'string "T" - (symbol-name (cadr new)) - "B"))) - (setq rloc (encode-singleton (caddr new))) - (setq lloc (encode-pair (cadr old) (caddr old))) - (return (cons ttype (cons lloc (cons rloc list)))))) - -; the following two functions encode indices so that gelm can -; decode them as fast as possible - -(defun encode-pair (a b) - (logior (ash (1- a) encode-pair-shift) (1- b))) - -(defun encode-singleton (a) (1- a)) - -(defun promote-var (dope) - (prog (vname vpred vpos new) - (setq vname (car dope)) - (setq vpred (cadr dope)) - (setq vpos (caddr dope)) - (or (eq 'eq vpred) - (%error '|illegal predicate for first occurrence| - (list vname vpred))) - (setq new (list vname 0. vpos)) - (setq *vars* (cons new *vars*)))) - -(defun fudge nil - (mapc (function fudge*) *vars*) - (mapc (function fudge*) *ce-vars*)) - -(defun fudge* (z) - (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a))))) - -(defun build-beta (type tests) - (prog (rpred lpred lnode lef) - (link-new-node (list '&mem nil nil (protomem))) - (setq rpred *last-node*) - (cond ((eq type '&and) - (setq lnode (list '&mem nil nil (protomem)))) - (t (setq lnode (list '&two nil nil)))) - (setq lpred (link-to-branch lnode)) - (cond ((eq type '&and) (setq lef lpred)) - (t (setq lef (protomem)))) - (link-new-beta-node (list type nil lef rpred tests)))) - -(defun protomem nil (list nil)) - -(defun memory-part (mem-node) (car (cadddr mem-node))) - -(defun encode-dope nil - (prog (r all z k) - (setq r nil) - (setq all *vars*) - la (and (atom all) (return r)) - (setq z (car all)) - (setq all (cdr all)) - (setq k (encode-pair (cadr z) (caddr z))) - (setq r (cons (car z) (cons k r))) - (go la))) - -(defun encode-ce-dope nil - (prog (r all z k) - (setq r nil) - (setq all *ce-vars*) - la (and (atom all) (return r)) - (setq z (car all)) - (setq all (cdr all)) - (setq k (cadr z)) - (setq r (cons (car z) (cons k r))) - (go la))) - - - -;;; Linking the nodes - -(defun link-new-node (r) - (cond ((not (member (car r) '(&p &mem &two &and ¬) :test #'equal)) - (setq *feature-count* (1+ *feature-count*)))) - (setq *virtual-cnt* (1+ *virtual-cnt*)) - (setq *last-node* (link-left *last-node* r))) - -(defun link-to-branch (r) - (setq *virtual-cnt* (1+ *virtual-cnt*)) - (setq *last-branch* (link-left *last-branch* r))) - -(defun link-new-beta-node (r) - (setq *virtual-cnt* (1+ *virtual-cnt*)) - (setq *last-node* (link-both *last-branch* *last-node* r)) - (setq *last-branch* *last-node*)) - -(defun link-left (pred succ) - (prog (a r) - (setq a (left-outs pred)) - (setq r (find-equiv-node succ a)) - (and r (return r)) - (setq *real-cnt* (1+ *real-cnt*)) - (attach-left pred succ) - (return succ))) - -(defun link-both (left right succ) - (prog (a r) - (setq a (interq (left-outs left) (right-outs right))) - (setq r (find-equiv-beta-node succ a)) - (and r (return r)) - (setq *real-cnt* (1+ *real-cnt*)) - (attach-left left succ) - (attach-right right succ) - (return succ))) - -(defun attach-right (old new) - (rplaca (cddr old) (cons new (caddr old)))) - -(defun attach-left (old new) - (rplaca (cdr old) (cons new (cadr old)))) - -(defun right-outs (node) (caddr node)) - -(defun left-outs (node) (cadr node)) - -(defun find-equiv-node (node list) - (prog (a) - (setq a list) - l1 (cond ((atom a) (return nil)) - ((equiv node (car a)) (return (car a)))) - (setq a (cdr a)) - (go l1))) - -(defun find-equiv-beta-node (node list) - (prog (a) - (setq a list) - l1 (cond ((atom a) (return nil)) - ((beta-equiv node (car a)) (return (car a)))) - (setq a (cdr a)) - (go l1))) - -; do not look at the predecessor fields of beta nodes; they have to be -; identical because of the way the candidate nodes were found - -(defun equiv (a b) - (and (eq (car a) (car b)) - (or (eq (car a) '&mem) - (eq (car a) '&two) - (equal (caddr a) (caddr b))) - (equal (cdddr a) (cdddr b)))) - -(defun beta-equiv (a b) - (and (eq (car a) (car b)) - (equal (cddddr a) (cddddr b)) - (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) - -; the equivalence tests are set up to consider the contents of -; node memories, so they are ready for the build action - - - -;;; Check the RHSs of productions - - -(defun check-rhs (rhs) (mapc (function check-action) rhs)) - -(defun check-action (x) - (prog (a) - (cond ((atom x) - (%warn '|atomic action| x) - (return nil))) - (setq a (setq *action-type* (car x))) - (case a - (bind (check-bind x)) - (cbind (check-cbind x)) - (make (check-make x)) - (modify (check-modify x)) - (remove (check-remove x)) - (write (check-write x)) - (call (check-call x)) - (halt (check-halt x)) - (openfile (check-openfile x)) - (closefile (check-closefile x)) - (default (check-default x)) - (build (check-build x)) - (t (%warn '|undefined rhs action| a))))) - - -;(defun chg-to-write (x) -; (setq x (cons 'write (cdr x)))) - -(defun check-build (z) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-build-collect (cdr z))) - -(defun check-build-collect (args) - (prog (r) - top (and (null args) (return nil)) - (setq r (car args)) - (setq args (cdr args)) - (cond ((consp r) (check-build-collect r)) ;dtpr\consp gdw - ((eq r '\\) - (and (null args) (%warn '|nothing to evaluate| r)) - (check-rhs-value (car args)) - (setq args (cdr args)))) - (go top))) - -(defun check-remove (z) ;@@@ kluge by gdw - (and (null (cdr z)) (%warn '|needs arguments| z)) - (mapc (function check-rhs-ce-var) (cdr z))) - -;(defun check-remove (z) ;original - ; (and (null (cdr z)) (%warn '|needs arguments| z)) - ;(mapc (function check-rhs-ce-var) (cdr z))) - -(defun check-make (z) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-change& (cdr z))) - -(defun check-openfile (z) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-change& (cdr z))) - -(defun check-closefile (z) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-change& (cdr z))) - -(defun check-default (z) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-change& (cdr z))) - -(defun check-modify (z) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-rhs-ce-var (cadr z)) - (and (null (cddr z)) (%warn '|no changes to make| z)) - (check-change& (cddr z))) - -(defun check-write (z) ;note this works w/write - (and (null (cdr z)) (%warn '|needs arguments| z)) - (check-change& (cdr z))) - -(defun check-call (z) - (prog (f) - (and (null (cdr z)) (%warn '|needs arguments| z)) - (setq f (cadr z)) - (and (variablep f) - (%warn '|function name must be a constant| z)) - (or (symbolp f) - (%warn '|function name must be a symbolic atom| f)) - (or (externalp f) - (%warn '|function name not declared external| f)) - (check-change& (cddr z)))) - -(defun check-halt (z) - (or (null (cdr z)) (%warn '|does not take arguments| z))) - -(defun check-cbind (z) - (prog (v) - (or (= (length z) 2.) (%warn '|takes only one argument| z)) - (setq v (cadr z)) - (or (variablep v) (%warn '|takes variable as argument| z)) - (note-ce-variable v))) - -(defun check-bind (z) - (prog (v) - (or (> (length z) 1.) (%warn '|needs arguments| z)) - (setq v (cadr z)) - (or (variablep v) (%warn '|takes variable as argument| z)) - (note-variable v) - (check-change& (cddr z)))) - - -(defun check-change& (z) - (prog (r tab-flag) - (setq tab-flag nil) - la (and (atom z) (return nil)) - (setq r (car z)) - (setq z (cdr z)) - (cond ((eq r '^) - (and tab-flag - (%warn '|no value before this tab| (car z))) - (setq tab-flag t) - (check-tab-index (car z)) - (setq z (cdr z))) - ((eq r '//) (setq tab-flag nil) (setq z (cdr z))) - (t (setq tab-flag nil) (check-rhs-value r))) - (go la))) - -(defun check-rhs-ce-var (v) - (cond ((and (not (numberp v)) (not (ce-bound? v))) - (%warn '|unbound element variable| v)) - ((and (numberp v) (or (< v 1.) (> v *ce-count*))) - (%warn '|numeric element designator out of bounds| v)))) - -(defun check-rhs-value (x) - (cond ((consp x) (check-rhs-function x)) ;dtpr\consp gdw - (t (check-rhs-atomic x)))) - -(defun check-rhs-atomic (x) - (and (variablep x) - (not (bound? x)) - (%warn '|unbound variable| x))) - -(defun check-rhs-function (x) - (prog (a) - (setq a (car x)) - (cond ((eq a 'compute) (check-compute x)) - ((eq a 'arith) (check-compute x)) - ((eq a 'substr) (check-substr x)) - ((eq a 'accept) (check-accept x)) - ((eq a 'acceptline) (check-acceptline x)) - ((eq a 'crlf) (check-crlf x)) - ((eq a 'genatom) (check-genatom x)) - ((eq a 'litval) (check-litval x)) - ((eq a 'tabto) (check-tabto x)) - ((eq a 'rjust) (check-rjust x)) - ((not (externalp a)) - (%warn '"rhs function not declared external" a))))) - -(defun externalp (x) - ; (cond ((symbolp x) (get x 'external-routine)) ;) @@@ - ;ok, I'm eliminating this temporarily @@@@ - (cond ((symbolp x) t) - (t (%warn '|not a legal function name| x) nil))) - - -(defun check-litval (x) - (or (= (length x) 2) (%warn '|wrong number of arguments| x)) - (check-rhs-atomic (cadr x))) - -(defun check-accept (x) - (cond ((= (length x) 1) nil) - ((= (length x) 2) (check-rhs-atomic (cadr x))) - (t (%warn '|too many arguments| x)))) - -(defun check-acceptline (x) - (mapc (function check-rhs-atomic) (cdr x))) - -(defun check-crlf (x) - (check-0-args x)) - -(defun check-genatom (x) (check-0-args x)) - -(defun check-tabto (x) - (or (= (length x) 2) (%warn '|wrong number of arguments| x)) - (check-print-control (cadr x))) - -(defun check-rjust (x) - (or (= (length x) 2) (%warn '|wrong number of arguments| x)) - (check-print-control (cadr x))) - -(defun check-0-args (x) - (or (= (length x) 1.) (%warn '|should not have arguments| x))) - -(defun check-substr (x) - (or (= (length x) 4.) (%warn '|wrong number of arguments| x)) - (check-rhs-ce-var (cadr x)) - (check-substr-index (caddr x)) - (check-last-substr-index (cadddr x))) - -(defun check-compute (x) (check-arithmetic (cdr x))) - -(defun check-arithmetic (l) - (cond ((atom l) - (%warn '|syntax error in arithmetic expression| l)) - ((atom (cdr l)) (check-term (car l))) - ((not (member (cadr l) '(+ - * // \\))) ;"plus" changed to "+" by gdw - (%warn '|unknown operator| l)) - (t (check-term (car l)) (check-arithmetic (cddr l))))) - -(defun check-term (x) - (cond ((consp x) (check-arithmetic x)) ;dtpr\consp gdw - (t (check-rhs-atomic x)))) - -(defun check-last-substr-index (x) - (or (eq x 'inf) (check-substr-index x))) - -(defun check-substr-index (x) - (prog (v) - (cond ((bound? x) (return x))) - (setq v ($litbind x)) - (cond ((not (numberp v)) - (%warn '|unbound symbol used as index in substr| x)) - ((or (< v 1.) (> v 127.)) - (%warn '|index out of bounds in tab| x))))) - -(defun check-print-control (x) - (prog () - (cond ((bound? x) (return x))) - (cond ((or (not (numberp x)) (< x 1.) (> x 127.)) - (%warn '|illegal value for printer control| x))))) - -(defun check-tab-index (x) - (prog (v) - (cond ((bound? x) (return x))) - (setq v ($litbind x)) - (cond ((not (numberp v)) - (%warn '|unbound symbol occurs after ^| x)) - ((or (< v 1.) (> v 127.)) - (%warn '|index out of bounds after ^| x))))) - -(defun note-variable (var) - (setq *rhs-bound-vars* (cons var *rhs-bound-vars*))) - -(defun bound? (var) - (or (member var *rhs-bound-vars*) - (var-dope var))) - -(defun note-ce-variable (ce-var) - (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*))) - -(defun ce-bound? (ce-var) - (or (member ce-var *rhs-bound-ce-vars*) - (ce-var-dope ce-var))) diff --git a/contrib/ops/ops-io.lisp b/contrib/ops/ops-io.lisp deleted file mode 100644 index 216c3c416a6ee22009ea3b4bf71540f4d0f19636..0000000000000000000000000000000000000000 --- a/contrib/ops/ops-io.lisp +++ /dev/null @@ -1,541 +0,0 @@ -; -;************************************************************************ -; -; VPS2 -- Interpreter for OPS5 -; -; -; -; This Common Lisp version of OPS5 is in the public domain. It is based -; in part on based on a Franz Lisp implementation done by Charles L. Forgy -; at Carnegie-Mellon University, which was placed in the public domain by -; the author in accordance with CMU policies. This version has been -; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen, -; and Dan Kuokka. -; -; This code is made available is, and without warranty of any kind by the -; authors or by Carnegie-Mellon University. -; - -;;;; This file contains all the functions pertaining to I/O. - -(in-package "OPS") -(shadow '(write)) ; Should get this by requiring ops-rhs - - -;;; Internal global variables. - -(defvar *write-file*) -(defvar *trace-file*) -(defvar *accept-file*) -(defvar *ppline*) -(defvar *filters*) - - - -;;; Initialization - -(defun io-init () - (setq *write-file* nil) - (setq *trace-file* nil) - (setq *accept-file* nil)) - - - -;;; User I/O commands -;;; Dario Giuse - rewrote the (write) function to follow OPS-5 specifications. -;;; Michael Huhns fixed a few bugs in this rewrttien functions some years later. - - -(defmacro append-string (x) - `(setq wrstring (concatenate 'simple-string wrstring ,x))) - - -(defun ops-write (z) - (prog (port max k x) - (cond ((not *in-rhs*) - (%warn '|cannot be called at top level| 'write) - (return nil))) - ($reset) - (eval-args z) - (setq max ($parametercount)) - (cond ((< max 1) - (%warn '|write: nothing to print| z) - (return nil))) - (setq x ($parameter 1)) - (cond ((and (symbolp x) ($ofile x)) - (setq port ($ofile x)) - (setq k 2)) - (t - (setq port (default-write-file)) - (setq k 1))) - ;; Analyze and output all the parameters (write) was passed. - (do* ((wrstring "") - (x ($parameter k) ($parameter k)) - (field-width)) - ((> k max) - (format port wrstring) - (force-output)) ; Dario Giuse - added to force output - (incf k) - (case x - (|=== C R L F ===| - (format port "~A~%" wrstring) ; Flush the previous line - (setq wrstring "")) - (|=== R J U S T ===| - (setq field-width ($parameter k)) ; Number following (tabto) - (incf k) - (setq x (format nil "~A" ($parameter k))) ; Next field to print - (when (<= (length x) field-width) - ;; Right-justify field - (append-string (format nil "~V@A" field-width x)) - (incf k))) ; Skip next field, since we printed it already - (|=== T A B T O ===| - (setq x ($parameter k)) ; Position to tab to - (incf k) - (when (< x (length wrstring)) - ;; Flush line, start a new one - (format port "~A~%" wrstring) - (setq wrstring "")) - (append-string (format nil "~V,1@T" (- x (length wrstring) 1)))) - (t - (append-string (format nil "~A " x))))))) - - -(defun ops-openfile (z) - (prog (file mode id) - ($reset) - (eval-args z) - (cond ((not (equal ($parametercount) 3.)) - (%warn '|openfile: wrong number of arguments| z) - (return nil))) - (setq id ($parameter 1)) - (setq file ($parameter 2)) - (setq mode ($parameter 3)) - (cond ((not (symbolp id)) - (%warn '|openfile: file id must be a symbolic atom| id) - (return nil)) - ((null id) - (%warn '|openfile: 'nil' is reserved for the terminal| nil) - (return nil)) - ((or ($ifile id)($ofile id)) - (%warn '|openfile: name already in use| id) - (return nil))) -;@@@ (cond ((eq mode 'in) (putprop id (infile file) 'inputfile)) -;@@@ ((eq mode 'out) (putprop id (outfile file) 'outputfile)) -; dec 7 83 gdw added setq : is putprop needed ? ) - (cond ((eq mode 'in) (putprop id (setq id (infile file)) 'inputfile)) - ((eq mode 'out) (putprop id (setq id (outfile file)) 'outputfile)) - (t (%warn '|openfile: illegal mode| mode) - (return nil))) - (return nil))) - - -(defun infile (f_name) - (open f_name :direction :input)) - -(defun outfile (f_name) - (open f_name :direction :output :if-exists :new-version)) - -(defun ops-closefile (z) - ($reset) - (eval-args z) - (mapc (function closefile2) (use-result-array))) - -(defun closefile2 (file) - (prog (port) - (cond ((not (symbolp file)) - (%warn '|closefile: illegal file identifier| file)) - ((setq port ($ifile file)) - (close port) - (remprop file 'inputfile)) - ((setq port ($ofile file)) - (close port) - (remprop file 'outputfile))) - (return nil))) - - -(defun ops-default (z) - (prog (file use) - ($reset) - (eval-args z) - (cond ((not (equal ($parametercount) 2.)) - (%warn '|default: wrong number of arguments| z) - (return nil))) - (setq file ($parameter 1)) - (setq use ($parameter 2)) - (cond ((not (symbolp file)) - (%warn '|default: illegal file identifier| file) - (return nil)) - ((not (member use '(write accept trace) :test #'equal)) - (%warn '|default: illegal use for a file| use) - (return nil)) - ((and (member use '(write trace) :test #'equal) - (not (null file)) - (not ($ofile file))) - (%warn '|default: file has not been opened for output| file) - (return nil)) - ((and (equal use 'accept) - (not (null file)) - (not ($ifile file))) - (%warn '|default: file has not been opened for input| file) - (return nil)) - ((equal use 'write) (setq *write-file* file)) - ((equal use 'accept) (setq *accept-file* file)) - ((equal use 'trace) (setq *trace-file* file))) - (return nil))) - - -(defun ops-accept (z) - (prog (port arg) - (cond ((> (length z) 1.) - (%warn '|accept: wrong number of arguments| z) - (return nil))) - (setq port *standard-input*) - (cond (*accept-file* - (setq port ($ifile *accept-file*)) - (cond ((null port) - (%warn '|accept: file has been closed| *accept-file*) - (return nil))))) - (cond ((= (length z) 1) - (setq arg ($varbind (car z))) - (cond ((not (symbolp arg)) - (%warn '|accept: illegal file name| arg) - (return nil))) - (setq port ($ifile arg)) - (cond ((null port) - (%warn '|accept: file not open for input| arg) - (return nil))))) - (cond ((equal (peek-char t port nil "eof" ) "eof" ) - ($value 'end-of-file) - (return nil))) - (flat-value (read port)))) - - - -;;; Dario Giuse - completely changed the algorithm. It now uses one read-line -;;; and the read-from-string. -;;; -(defun ops-acceptline (z) - (let ((port *standard-input*) - (def z)) - (cond (*accept-file* - (setq port ($ifile *accept-file*)) - (cond ((null port) - (%warn '|acceptline: file has been closed| - *accept-file*) - (return-from ops-acceptline nil))))) - (cond ((> (length def) 0) - (let ((arg ($varbind (car def)))) - (cond ((and (symbolp arg) ($ifile arg)) - (setq port ($ifile arg)) - (setq def (cdr def))))))) - (let ((line (read-line port nil 'eof))) - (declare (simple-string line)) - ;; Strip meaningless characters from start and end of string. - (setq line (string-trim '(#\( #\) #\, #\tab #\space) line)) - (when (equal line "") - (mapc (function $change) def) - (return-from ops-acceptline nil)) - (setq line (concatenate 'simple-string "(" line ")")) - ;; Read all items from the line - (flat-value (read-from-string line))))) - - - - -(defun ops-rjust (z) - (prog (val) - (cond ((not (= (length z) 1.)) - (%warn '|rjust: wrong number of arguments| z) - (return nil))) - (setq val ($varbind (car z))) - (cond ((or (not (numberp val)) (< val 1.) (> val 127.)) - (%warn '|rjust: illegal value for field width| val) - (return nil))) - ($value '|=== R J U S T ===|) - ($value val))) - - -(defun ops-crlf (z) - (cond (z (%warn '|crlf: does not take arguments| z)) - (t ($value '|=== C R L F ===|)))) - - -(defun ops-tabto (z) - (prog (val) - (cond ((not (= (length z) 1.)) - (%warn '|tabto: wrong number of arguments| z) - (return nil))) - (setq val ($varbind (car z))) - (cond ((or (not (numberp val)) (< val 1.) (> val 127.)) - (%warn '|tabto: illegal column number| z) - (return nil))) - ($value '|=== T A B T O ===|) - ($value val))) - - - -(defun do-rjust (width value port) - (prog (size) - (cond ((eq value '|=== T A B T O ===|) - (%warn '|rjust cannot precede this function| 'tabto) - (return nil)) - ((eq value '|=== C R L F ===|) - (%warn '|rjust cannot precede this function| 'crlf) - (return nil)) - ((eq value '|=== R J U S T ===|) - (%warn '|rjust cannot precede this function| 'rjust) - (return nil))) - ;original-> (setq size (flatc value (1+ width))) - (setq size (min value (1+ width))) ;### KLUGE - (cond ((> size width) - (princ '| | port) - (princ value port) - (return nil))) - ;### (do k (- width size) (1- k) (not (> k 0)) (princ '| | port)) - ;^^^KLUGE @@@do - (princ value port))) - -(defun do-tabto (col port) - (prog (pos) - ;### KLUGE: FLUSHES STREAM & SETS POS TO 0 - ;OIRGINAL-> (setq pos (1+ (nwritn port))) ;hmm-takes 1 arg @@@ port - (finish-output port);kluge - (setq pos 0);kluge - (cond ((> pos col) - (terpri port) - (setq pos 1))) - ;###(do k (- col pos) (1- k) (not (> k 0)) (princ '| | port)) - ;^^^KLUGE @@@do - (return nil))) - - -(defun flat-value (x) - (cond ((atom x) ($value x)) - (t (mapc (function flat-value) x)))) - - - -;;; Printing WM - -(defun ops-ppwm (avlist) - (prog (next a) - (setq *filters* nil) - (setq next 1.) - loop (and (atom avlist) (go print)) - (setq a (car avlist)) - (setq avlist (cdr avlist)) - ;this must be expecting (ppwm class ^ attr ^ attr2 ...) not ^attr - (cond ((eq a '^) - (setq next (car avlist)) - (setq avlist (cdr avlist)) - (setq next ($litbind next)) - (and (floatp next) (setq next (fix next))) - (cond ((or (not (numberp next)) - (> next *size-result-array*) - (> 1. next)) - (%warn '|illegal index after ^| next) - (return nil)))) - ((variablep a) - (%warn '|ppwm does not take variables| a) - (return nil)) - (t (setq *filters* (cons next (cons a *filters*))) - (setq next (1+ next)))) - (go loop) - print (mapwm (function ppwm2)) - (terpri) - (return nil))) - - -(defun default-write-file () - (prog (port) - (setq port *standard-output*) - (cond (*write-file* - (setq port ($ofile *write-file*)) - (cond ((null port) - (%warn '|write: file has been closed| *write-file*) - (setq port *standard-output*))))) - (return port))) - - -(defun trace-file () - (prog (port) - (setq port *standard-output*) - (cond (*trace-file* - (setq port ($ofile *trace-file*)) - (cond ((null port) - (%warn '|trace: file has been closed| *trace-file*) - (setq port *standard-output*))))) - (return port))) - - -(defun ppwm2 (elm-tag) - (cond ((filter (car elm-tag)) - (terpri) (ppelm (car elm-tag) (default-write-file))))) - -(defun filter (elm) - (prog (fl indx val) - (setq fl *filters*) - top (and (atom fl) (return t)) - (setq indx (car fl)) - (setq val (cadr fl)) - (setq fl (cddr fl)) - (and (ident (nth (1- indx) elm) val) (go top)) - (return nil))) - -(defun ident (x y) - (cond ((eq x y) t) - ((not (numberp x)) nil) - ((not (numberp y)) nil) - ((=alg x y) t) - (t nil))) - -; the new ppelm is designed especially to handle literalize format -; however, it will do as well as the old ppelm on other formats - -(defun ppelm (elm port) - (prog (ppdat sep val att mode lastpos) - (princ (creation-time elm) port) - (princ '|: | port) - (setq mode 'vector) - (setq ppdat (get (car elm) 'ppdat)) - (and ppdat (setq mode 'a-v)) - (setq sep "(") ; ")" - (setq lastpos 0) - (do ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist))) - ((atom vlist) nil) ; terminate - (setq val (car vlist)) ; tagbody begin - (setq att (assoc curpos ppdat)) ;should ret (curpos attr-name) - (cond (att (setq att (cdr att))) ; att = (attr-name) ?? - (t (setq att curpos))) - (and (symbolp att) (is-vector-attribute att) (setq mode 'vector)) - (cond ((or (not (null val)) (eq mode 'vector)) - (princ sep port) - (ppval val att lastpos port) - (setq sep '| |) - (setq lastpos curpos)))) - (princ '|)| port))) - -(defun ppval (val att lastpos port) - ; (break "in ppval") - (cond ((not (equal att (1+ lastpos))) ; ok, if we got an att - (princ '^ port) - (princ att port) - (princ '| | port))) - (princ val port)) - - - -;;; Printing production memory - -(defun ops-pm (z) (mapc (function pprule) z) (terpri) nil) - -(defun pprule (name) - (prog (matrix next lab) - (and (not (symbolp name)) (return nil)) - (setq matrix (get name 'production)) - (and (null matrix) (return nil)) - (terpri) - (princ '|(p |) ;) - (princ name) - top (and (atom matrix) (go fin)) - (setq next (car matrix)) - (setq matrix (cdr matrix)) - (setq lab nil) - (terpri) - (cond ((eq next '-) - (princ '| - |) - (setq next (car matrix)) - (setq matrix (cdr matrix))) - ((eq next '-->) - (princ '| |)) - ((and (eq next '{) (atom (car matrix))) - (princ '| {|) - (setq lab (car matrix)) - (setq next (cadr matrix)) - (setq matrix (cdddr matrix))) - ((eq next '{) - (princ '| {|) - (setq lab (cadr matrix)) - (setq next (car matrix)) - (setq matrix (cdddr matrix))) - (t (princ '| |))) - (ppline next) - (cond (lab (princ '| |) (princ lab) (princ '}))) - (go top) - fin (princ '|)|))) - -(defun ppline (line) - (prog () - (cond ((atom line) (princ line)) - (t - (princ '|(|) ;) - (setq *ppline* line) - (ppline2) - ;( - (princ '|)|))) - (return nil))) - -(defun ppline2 () - (prog (needspace) - (setq needspace nil) - top (and (atom *ppline*) (return nil)) - (and needspace (princ '| |)) - (cond ((eq (car *ppline*) '^) (ppattval)) - (t (pponlyval))) - (setq needspace t) - (go top))) - -(defun ppattval () - (prog (att val) - (setq att (cadr *ppline*)) - (setq *ppline* (cddr *ppline*)) - (setq val (getval)) - ;### (cond ((> (+ (nwritn) (flatc att) (flatc val)) 76.))) - ;@@@ nwritn no arg - ; ;"plus" changed to "+" by gdw - ; (terpri) - ; (princ '| |) - (princ '^) - (princ att) - (mapc (function (lambda (z) (princ '| |) (princ z))) val))) - -(defun pponlyval () - (prog (val needspace) - (setq val (getval)) - (setq needspace nil) - ;### (cond ((> (+ (nwritn) (flatc val)) 76.))) - ;"plus" changed to "+" by gdw - ; (setq needspace nil) ;^nwritn no arg @@@ - ; (terpri) - ; (princ '| |) - top (and (atom val) (return nil)) - (and needspace (princ '| |)) - (setq needspace t) - (princ (car val)) - (setq val (cdr val)) - (go top))) - -(defun getval () - (prog (res v1) - (setq v1 (car *ppline*)) - (setq *ppline* (cdr *ppline*)) - (cond ((member v1 '(= <> < <= => > <=>)) - (setq res (cons v1 (getval)))) - ((eq v1 '{) - (setq res (cons v1 (getupto '})))) - ((eq v1 '<<) - (setq res (cons v1 (getupto '>>)))) - ((eq v1 '//) - (setq res (list v1 (car *ppline*))) - (setq *ppline* (cdr *ppline*))) - (t (setq res (list v1)))) - (return res))) - -(defun getupto (end) - (prog (v) - (and (atom *ppline*) (return nil)) - (setq v (car *ppline*)) - (setq *ppline* (cdr *ppline*)) - (cond ((eq v end) (return (list v))) - (t (return (cons v (getupto end))))))) - diff --git a/contrib/ops/ops-main.lisp b/contrib/ops/ops-main.lisp deleted file mode 100644 index 7397abff24d89aa8a0ab57c84c01316a48192cb2..0000000000000000000000000000000000000000 --- a/contrib/ops/ops-main.lisp +++ /dev/null @@ -1,726 +0,0 @@ -; -;************************************************************************ -; -; VPS2 -- Interpreter for OPS5 -; -; -; -; This Common Lisp version of OPS5 is in the public domain. It is based -; in part on based on a Franz Lisp implementation done by Charles L. Forgy -; at Carnegie-Mellon University, which was placed in the public domain by -; the author in accordance with CMU policies. This version has been -; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen, -; and Dan Kuokka. -; -; This code is made available is, and without warranty of any kind by the -; authors or by Carnegie-Mellon University. -; - -;;;; This file contains the top-level functions, function to literalize -;;;; and access attributes, and functions to manage the conflict set. - - -(in-package "OPS") - -(export '(literalize p vector-attribute strategy watch)) - - -;;; Global variables also used by other modules. - -(defvar *halt-flag*) -(defvar *cycle-count*) -(defvar *p-name*) -(defvar *ptrace*) -(defvar *wtrace*) - - -;;; Global variables used in this module only. - -(defvar *limit-token*) -(defvar *total-wm*) -(defvar *max-token*) -(defvar *total-token*) -(defvar *brkpts*) -(defvar *phase*) -(defvar *break-flag*) -(defvar *remaining-cycles*) -(defvar *conflict-set*) -(defvar *max-cs*) -(defvar *total-cs*) -(defvar *limit-cs*) -(defvar *strategy*) -(defvar *class-list*) -(defvar *buckets*) - - - -(defun main-init () - (setq *cycle-count* 0.) - (setq *p-name* nil) - (setq *ptrace* t) - (setq *wtrace* nil) - (setq *limit-token* 1000000.) - (setq *limit-cs* 1000000.) - (setq *total-wm* 0.) - (setq *total-token* (setq *max-token* 0.)) - (setq *max-cs* (setq *total-cs* 0.)) - (setq *conflict-set* nil) - (setq *strategy* 'lex) - (setq *buckets* 127.) ; regular OPS5 allows 64 named slots - (setq *class-list* nil) - (setq *brkpts* nil) - (setq *remaining-cycles* 1000000)) - - - -;;;; Top level commands. - - -(defmacro run (&body z) - `(ops-run ',z)) - -(defmacro ppwm (&body avlist) - `(ops-ppwm ',avlist)) - -(defmacro wm (&body a) - `(ops-wm ',a)) - -(defmacro pm (&body z) - `(ops-pm ',z)) - -(defmacro cs (&body z) - `(ops-cs ',z)) - -(defmacro matches (&body rule-list) - `(ops-matches ',rule-list)) - -(defmacro strategy (&body z) - `(ops-strategy ',z)) - -(defmacro watch (&body z) - `(ops-watch ',z)) - -(defmacro pbreak (&body z) - `(ops-pbreak ',z)) - -(defmacro excise (&body z) - `(ops-excise ',z)) - -(defmacro p (&body z) - `(ops-p ',z)) - -(defmacro external (&body z) - `(ops-external ',z)) - -(defmacro literal (&body z) - `(ops-literal ',z)) - -(defmacro literalize (&body z) - `(ops-literalize ',z)) - -(defmacro vector-attribute (&body l) - `(ops-vector-attribute ',l)) - -(defun top-level-remove (z) - (cond ((equal z '(*)) (process-changes nil (get-wm nil))) - (t (process-changes nil (get-wm z))))) - - - -;;; Functions for run command - -(defun ops-run (z) - (cond ((atom z) (setq *remaining-cycles* 1000000.) (do-continue nil)) - ((and (atom (cdr z)) (numberp (car z)) (> (car z) 0.)) - (setq *remaining-cycles* (car z)) - (do-continue nil)) - (t 'what?))) - - -(defun do-continue (wmi) - (cond (*critical* - (terpri) - (princ '|warning: network may be inconsistent|))) - (process-changes wmi nil) - (print-times (main))) - - -(defun process-changes (adds dels) - (prog (x) - process-deletes (and (atom dels) (go process-adds)) - (setq x (car dels)) - (setq dels (cdr dels)) - (remove-from-wm x) - (go process-deletes) - process-adds (and (atom adds) (return nil)) - (setq x (car adds)) - (setq adds (cdr adds)) - (add-to-wm x nil) - (go process-adds))) - - -(defun main nil - (prog (instance r) - (setq *halt-flag* nil) - (setq *break-flag* nil) - (setq instance nil) - dil (setq *phase* 'conflict-resolution) - (cond (*halt-flag* - (setq r '|end -- explicit halt|) - (go finis)) - ((zerop *remaining-cycles*) - (setq r '***break***) - (setq *break-flag* t) - (go finis)) - (*break-flag* (setq r '***break***) (go finis))) - (setq *remaining-cycles* (1- *remaining-cycles*)) - (setq instance (conflict-resolution)) - (cond ((not instance) - (setq r '|end -- no production true|) - (go finis))) - (setq *phase* (car instance)) - (accum-stats) - (eval-rhs (car instance) (cdr instance)) - (check-limits) - (and (broken (car instance)) (setq *break-flag* t)) - (go dil) - finis (setq *p-name* nil) - (return r))) - - -(defun broken (rule) (member rule *brkpts*)) - - -(defun accum-stats nil - (setq *cycle-count* (1+ *cycle-count*)) - (setq *total-token* (+ *total-token* *current-token*)) - ;"plus" changed to "+" by gdw - (cond ((> *current-token* *max-token*) - (setq *max-token* *current-token*))) - (setq *total-wm* (+ *total-wm* *current-wm*)) ;"plus" changed to "+" by gdw - (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*)))) - - -(defun check-limits nil - (cond ((> (length *conflict-set*) *limit-cs*) - (format t "~%~%conflict set size exceeded the limit of ~D after ~D~%" - *limit-cs* *p-name*) - (setq *halt-flag* t))) - (cond ((> *current-token* *limit-token*) - (format t "~%~%token memory size exceeded the limit of ~D after ~D~%" - *limit-token* *p-name*) - (setq *halt-flag* t)))) - - -(defun print-times (mess) - (prog (cc) - (cond (*break-flag* (terpri) (return mess))) - (setq cc (+ (float *cycle-count*) 1.0e-20)) - (terpri) - (princ mess) - (terpri) - (format t "~3D productions (~D // ~D nodes)~%" - *pcount* *real-cnt* *virtual-cnt*) - (format t "~3D firings (~D rhs actions)~%" - *cycle-count* *action-count*) - (format t "~3D mean working memory size (~D maximum)~%" - (round (float *total-wm*) cc) *max-wm*) - (format t "~3D mean conflict set size (~D maximum)~%" - (round (float *total-cs*) cc) *max-cs*) - (format t "~3D mean token memory size (~D maximum)~%" - (round (float *total-token*) cc) - *max-token*))) - - -;;; Functions for strategy command - -(defun ops-strategy (z) - (cond ((atom z) *strategy*) - ((equal z '(lex)) (setq *strategy* 'lex)) - ((equal z '(mea)) (setq *strategy* 'mea)) - (t 'what?))) - - -;;; Functions for watch command - -(defun ops-watch (z) - (cond ((equal z '(0.)) - (setq *wtrace* nil) - (setq *ptrace* nil) - 0.) - ((equal z '(1.)) (setq *wtrace* nil) (setq *ptrace* t) 1.) - ((equal z '(2.)) (setq *wtrace* t) (setq *ptrace* t) 2.) - ((equal z '(3.)) - (setq *wtrace* t) - (setq *ptrace* t) - '(2. -- conflict set trace not supported)) - ((and (atom z) (null *ptrace*)) 0.) - ((and (atom z) (null *wtrace*)) 1.) - ((atom z) 2.) - (t 'what?))) - - -;;; Functions for excise command - -(defun ops-excise (z) (mapc (function excise-p) z)) - -(defun excise-p (name) - (cond ((and (symbolp name) (get name 'topnode)) - (format t "~S is excised~%" name) - (setq *pcount* (1- *pcount*)) - (remove-from-conflict-set name) - (kill-node (get name 'topnode)) - (remprop name 'production) - (remprop name 'backpointers) - (remprop name 'topnode)))) - -(defun kill-node (node) - (prog nil - top (and (atom node) (return nil)) - (rplaca node '&old) - (setq node (cdr node)) - (go top))) - - -;;; Functions for external command - -(defun ops-external (z) (catch '!error! (external2 z))) ;jgk inverted args -;& quoted tag -(defun external2 (z) (mapc (function external3) z)) - -(defun external3 (x) - (cond ((symbolp x) (putprop x t 'external-routine)) - (t (%error '|not a legal function name| x)))) - -;;; Functions for pbreak command - -(defun ops-pbreak (z) - (cond ((atom z) (terpri) *brkpts*) - (t (mapc (function pbreak2) z) nil))) - -(defun pbreak2 (rule) - (cond ((not (symbolp rule)) (%warn '|illegal name| rule)) - ((not (get rule 'topnode)) (%warn '|not a production| rule)) - ((member rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*))) - (t (setq *brkpts* (cons rule *brkpts*))))) - -(defun rematm (atm list) - (cond ((atom list) list) - ((eq atm (car list)) (rematm atm (cdr list))) - (t (cons (car list) (rematm atm (cdr list)))))) - - -;;; Functions for matches command - -(defun ops-matches (rule-list) - (mapc (function matches2) rule-list) - (terpri)) - - -(defun matches2 (p) - (cond ((atom p) - (terpri) - (terpri) - (princ p) - (matches3 (get p 'backpointers) 2. (ncons 1.))))) - - -(defun matches3 (nodes ce part) - (cond ((not (null nodes)) - (terpri) - (princ '| ** matches for |) - (princ part) - (princ '| ** |) - (mapc (function write-elms) (find-left-mem (car nodes))) - (terpri) - (princ '| ** matches for |) - (princ (ncons ce)) - (princ '| ** |) - (mapc (function write-elms) (find-right-mem (car nodes))) - (matches3 (cdr nodes) (1+ ce) (cons ce part))))) - - -(defun write-elms (wme-or-count) - (cond ((consp wme-or-count) ;dtpr\consp gdw - (terpri) - (mapc (function write-elms2) wme-or-count)))) - - -(defun write-elms2 (x) - (princ '| |) - (princ (creation-time x))) - - -(defun find-left-mem (node) - (cond ((eq (car node) '&and) (memory-part (caddr node))) - (t (car (caddr node))))) - - -(defun find-right-mem (node) (memory-part (cadddr node))) - - -;;; Function for cs command. - -(defun ops-cs (z) - (cond ((atom z) (conflict-set)) - (t 'what?))) - - - -;;;; Functions for literalize and related operations. - -(defun ops-literal (z) - (prog (atm val old) - top (and (atom z) (return 'bound)) - (or (eq (cadr z) '=) (return (%warn '|wrong format| z))) - (setq atm (car z)) - (setq val (caddr z)) - (setq z (cdddr z)) - (cond ((not (numberp val)) - (%warn '|can bind only to numbers| val)) - ((or (not (symbolp atm)) (variablep atm)) - (%warn '|can bind only constant atoms| atm)) - ((and (setq old (literal-binding-of atm)) (not (equal old val))) - (%warn '|attempt to rebind attribute| atm)) - (t (putprop atm val 'ops-bind))) - (go top))) - - -(defun ops-literalize (l) - (prog (class-name atts) - (setq class-name (car l)) - (cond ((have-compiled-production) - (%warn '|literalize called after p| class-name) - (return nil)) - ((get class-name 'att-list) - (%warn '|attempt to redefine class| class-name) - (return nil))) - (setq *class-list* (cons class-name *class-list*)) - (setq atts (remove-duplicates (cdr l))) ; ??? should this - ; warn of dup atts? - (test-attribute-names atts) - (mark-conflicts atts atts) - (putprop class-name atts 'att-list))) - -(defun ops-vector-attribute (l) - (cond ((have-compiled-production) - (%warn '|vector-attribute called after p| l)) - (t - (test-attribute-names l) - (mapc (function vector-attribute2) l)))) - -(defun vector-attribute2 (att) (putprop att t 'vector-attribute)) - -(defun is-vector-attribute (att) (get att 'vector-attribute)) - -(defun test-attribute-names (l) - (mapc (function test-attribute-names2) l)) - -(defun test-attribute-names2 (atm) - (cond ((or (not (symbolp atm)) (variablep atm)) - (%warn '|can bind only constant atoms| atm)))) - -(defun finish-literalize nil - (cond ((not (null *class-list*)) - (mapc (function note-user-assigns) *class-list*) - (mapc (function assign-scalars) *class-list*) - (mapc (function assign-vectors) *class-list*) - (mapc (function put-ppdat) *class-list*) - (mapc (function erase-literal-info) *class-list*) - (setq *class-list* nil) - (setq *buckets* nil)))) - -(defun have-compiled-production nil (not (zerop *pcount*))) - -(defun put-ppdat (class) - (prog (al att ppdat) - (setq ppdat nil) - (setq al (get class 'att-list)) - top (cond ((not (atom al)) - (setq att (car al)) - (setq al (cdr al)) - (setq ppdat - (cons (cons (literal-binding-of att) att) - ppdat)) - (go top))) - (putprop class ppdat 'ppdat))) - -; note-user-assigns and note-user-vector-assigns are needed only when -; literal and literalize are both used in a program. They make sure that -; the assignments that are made explicitly with literal do not cause problems -; for the literalized classes. - -(defun note-user-assigns (class) - (mapc (function note-user-assigns2) (get class 'att-list))) - -(defun note-user-assigns2 (att) - (prog (num conf buck clash) - (setq num (literal-binding-of att)) - (and (null num) (return nil)) - (setq conf (get att 'conflicts)) - (setq buck (store-binding att num)) - (setq clash (find-common-atom buck conf)) - (and clash - (%warn '|attributes in a class assigned the same number| - (cons att clash))) - (return nil))) - -(defun note-user-vector-assigns (att given needed) - (and (> needed given) - (%warn '|vector attribute assigned too small a value in literal| att))) - -(defun assign-scalars (class) - (mapc (function assign-scalars2) (get class 'att-list))) - -(defun assign-scalars2 (att) - (prog (tlist num bucket conf) - (and (literal-binding-of att) (return nil)) - (and (is-vector-attribute att) (return nil)) - (setq tlist (buckets)) - (setq conf (get att 'conflicts)) - top (cond ((atom tlist) - (%warn '|could not generate a binding| att) - (store-binding att -1.) - (return nil))) - (setq num (caar tlist)) - (setq bucket (cdar tlist)) - (setq tlist (cdr tlist)) - (cond ((disjoint bucket conf) (store-binding att num)) - (t (go top))))) - -(defun assign-vectors (class) - (mapc (function assign-vectors2) (get class 'att-list))) - -(defun assign-vectors2 (att) - (prog (big conf new old need) - (and (not (is-vector-attribute att)) (return nil)) - (setq big 1.) - (setq conf (get att 'conflicts)) - top (cond ((not (atom conf)) - (setq new (car conf)) - (setq conf (cdr conf)) - (cond ((is-vector-attribute new) - (%warn '|class has two vector attributes| - (list att new))) - (t (setq big (max (literal-binding-of new) big)))) - (go top))) - (setq need (1+ big)) ;"plus" changed to "+" by gdw - (setq old (literal-binding-of att)) - (cond (old (note-user-vector-assigns att old need)) - (t (store-binding att need))) - (return nil))) - -(defun disjoint (la lb) (not (find-common-atom la lb))) - -(defun find-common-atom (la lb) - (prog nil - top (cond ((null la) (return nil)) - ((member (car la) lb) (return (car la))) - (t (setq la (cdr la)) (go top))))) - -(defun mark-conflicts (rem all) - (cond ((not (null rem)) - (mark-conflicts2 (car rem) all) - (mark-conflicts (cdr rem) all)))) - -(defun mark-conflicts2 (atm lst) - (prog (l) - (setq l lst) - top (and (atom l) (return nil)) - (conflict atm (car l)) - (setq l (cdr l)) - (go top))) - -(defun conflict (a b) - (prog (old) - (setq old (get a 'conflicts)) - (and (not (eq a b)) - (not (member b old)) - (putprop a (cons b old) 'conflicts)))) - -;@@@ use intrinsic -;(defun remove-duplicates (lst) - ; (cond ((atom lst) nil) - ; ((member (car lst) (cdr lst)) (remove-duplicates (cdr lst))) - ; (t (cons (car lst) (remove-duplicates (cdr lst)))))) - -(defun literal-binding-of (name) (get name 'ops-bind)) - -(defun store-binding (name lit) - (putprop name lit 'ops-bind) - (add-bucket name lit)) - -(defun add-bucket (name num) - (prog (buc) - (setq buc (assoc num (buckets))) - (and (not (member name buc)) - (rplacd buc (cons name (cdr buc)))) - (return buc))) - -(defun buckets nil - (and (atom *buckets*) (setq *buckets* (make-nums *buckets*))) - *buckets*) - -(defun make-nums (k) - (prog (nums) - (setq nums nil) - l (and (< k 2.) (return nums)) - (setq nums (cons (ncons k) nums)) - (setq k (1- k)) - (go l))) - -(defun erase-literal-info (class) - (mapc (function erase-literal-info2) (get class 'att-list)) - (remprop class 'att-list)) - -(defun erase-literal-info2 (att) (remprop att 'conflicts)) - - - - -;;;; Functions for conflict set management and resolution. - - -;;; Each conflict set element is a list of the following form: -;;; ((p-name . data-part) (sorted wm-recency) special-case-number) - -(defun conflict-resolution nil - (prog (best len) - (setq len (length *conflict-set*)) - (cond ((> len *max-cs*) (setq *max-cs* len))) - (setq *total-cs* (+ *total-cs* len)) ;"plus" changed to "+" by gdw - (cond (*conflict-set* - (setq best (best-of *conflict-set*)) - (setq *conflict-set* (delq best *conflict-set*)) - (return (pname-instantiation best))) - (t (return nil))))) - -(defun removecs (name data) - (prog (cr-data inst cs) - (setq cr-data (cons name data)) - (setq cs *conflict-set*) - loop (cond ((null cs) - (record-refract name data) - (return nil))) - (setq inst (car cs)) - (setq cs (cdr cs)) - (and (not (top-levels-eq (car inst) cr-data)) (go loop)) - (setq *conflict-set* (delq inst *conflict-set*)))) - -(defun insertcs (name data rating) - (prog (instan) - (and (refracted name data) (return nil)) - (setq instan (list (cons name data) (order-tags data) rating)) - (and (atom *conflict-set*) (setq *conflict-set* nil)) - (return (setq *conflict-set* (cons instan *conflict-set*))))) - - -(defun remove-from-conflict-set (name) - (prog (cs entry) - l1 (setq cs *conflict-set*) - l2 (cond ((atom cs) (return nil))) - (setq entry (car cs)) - (setq cs (cdr cs)) - (cond ((eq name (caar entry)) - (setq *conflict-set* (delq entry *conflict-set*)) - (go l1)) - (t (go l2))))) - -(defun order-tags (dat) - (prog (tags) - (setq tags nil) - l1p (and (atom dat) (go l2p)) - (setq tags (cons (creation-time (car dat)) tags)) - (setq dat (cdr dat)) - (go l1p) - l2p (cond ((eq *strategy* 'mea) - (return (cons (car tags) (dsort (cdr tags))))) - (t (return (dsort tags)))))) - -; destructively sort x into descending order - -(defun dsort (x) - (prog (sorted cur next cval nval) - (and (atom (cdr x)) (return x)) - loop (setq sorted t) - (setq cur x) - (setq next (cdr x)) - chek (setq cval (car cur)) - (setq nval (car next)) - (cond ((> nval cval) - (setq sorted nil) - (rplaca cur nval) - (rplaca next cval))) - (setq cur next) - (setq next (cdr cur)) - (cond ((not (null next)) (go chek)) - (sorted (return x)) - (t (go loop))))) - -(defun best-of (set) (best-of* (car set) (cdr set))) - -(defun best-of* (best rem) - (cond ((not rem) best) - ((conflict-set-compare best (car rem)) - (best-of* best (cdr rem))) - (t (best-of* (car rem) (cdr rem))))) - -(defun pname-instantiation (conflict-elem) (car conflict-elem)) - -(defun order-part (conflict-elem) (cdr conflict-elem)) - -(defun instantiation (conflict-elem) - (cdr (pname-instantiation conflict-elem))) - - -(defun conflict-set-compare (x y) - (prog (x-order y-order xl yl xv yv) - (setq x-order (order-part x)) - (setq y-order (order-part y)) - (setq xl (car x-order)) - (setq yl (car y-order)) - data (cond ((and (null xl) (null yl)) (go ps)) - ((null yl) (return t)) - ((null xl) (return nil))) - (setq xv (car xl)) - (setq yv (car yl)) - (cond ((> xv yv) (return t)) - ((> yv xv) (return nil))) - (setq xl (cdr xl)) - (setq yl (cdr yl)) - (go data) - ps (setq xl (cdr x-order)) - (setq yl (cdr y-order)) - psl (cond ((null xl) (return t))) - (setq xv (car xl)) - (setq yv (car yl)) - (cond ((> xv yv) (return t)) - ((> yv xv) (return nil))) - (setq xl (cdr xl)) - (setq yl (cdr yl)) - (go psl))) - - -(defun conflict-set nil - (prog (cnts cs p z best) - (setq cnts nil) - (setq cs *conflict-set*) - l1p (and (atom cs) (go l2p)) - (setq p (caaar cs)) - (setq cs (cdr cs)) - (setq z (assq p cnts)) - (cond ((null z) (setq cnts (cons (cons p 1.) cnts))) - (t (rplacd z (1+ (cdr z))))) - (go l1p) - l2p (cond ((atom cnts) - (setq best (best-of *conflict-set*)) - (terpri) - (return (list (caar best) 'dominates)))) - (terpri) - (princ (caar cnts)) - (cond ((> (cdar cnts) 1.) - (princ '| (|) - (princ (cdar cnts)) - (princ '| occurrences)|))) - (setq cnts (cdr cnts)) - (go l2p))) diff --git a/contrib/ops/ops-match.lisp b/contrib/ops/ops-match.lisp deleted file mode 100644 index 1ae230697a2429d5de22f4b3d88c5d54d7e99ba6..0000000000000000000000000000000000000000 --- a/contrib/ops/ops-match.lisp +++ /dev/null @@ -1,749 +0,0 @@ -; -;************************************************************************ -; -; VPS2 -- Interpreter for OPS5 -; -; -; -; This Common Lisp version of OPS5 is in the public domain. It is based -; in part on based on a Franz Lisp implementation done by Charles L. Forgy -; at Carnegie-Mellon University, which was placed in the public domain by -; the author in accordance with CMU policies. This version has been -; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen, -; and Dan Kuokka. -; -; This code is made available is, and without warranty of any kind by the -; authors or by Carnegie-Mellon University. -; - -;;;; This file contains the functions that match working memory -;;;; elements against productions LHS. - -(in-package "OPS") - - - -;;; External global variables - -(defvar *current-token*) - - -;;; Internal global variables - -(defvar *alpha-data-part*) -(defvar *alpha-flag-part*) -(defvar *flag-part*) -(defvar *data-part*) -(defvar *sendtocall*) -(defvar *side*) -(proclaim '(special *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* - *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* - *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* - *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* - *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* - *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* - *c60* *c61* *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* - *c70* *c71* *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* - *c80* *c81* *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* - *c90* *c91* *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* - *c100* *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108* *c109* - *c110* *c111* *c112* *c113* *c114* *c115* *c116* *c117* *c118* *c119* - *c120* *c121* *c122* *c123* *c124* *c125* *c126* *c127*)) - - - -;;; Network interpreter - - -(defun match-init () - (setq *current-token* 0.)) - - -(defun match (flag wme) - (sendto flag (list wme) 'left (list *first-node*))) - -; note that eval-nodelist is not set up to handle building -; productions. would have to add something like ops4's build-flag - -(defun eval-nodelist (nl) - (prog nil - top (and (not nl) (return nil)) - (setq *sendtocall* nil) - (setq *last-node* (car nl)) - (apply (caar nl) (cdar nl)) - (setq nl (cdr nl)) - (go top))) - -(defun sendto (flag data side nl) - (prog nil - top (and (not nl) (return nil)) - (setq *side* side) - (setq *flag-part* flag) - (setq *data-part* data) - (setq *sendtocall* t) - (setq *last-node* (car nl)) - (apply (caar nl) (cdar nl)) - (setq nl (cdr nl)) - (go top))) - -; &bus sets up the registers for the one-input nodes. note that this -(defun &bus (outs) - (prog (dp) - (setq *alpha-flag-part* *flag-part*) - (setq *alpha-data-part* *data-part*) - (setq dp (car *data-part*)) - (setq *c1* (car dp)) - (setq dp (cdr dp)) - (setq *c2* (car dp)) - (setq dp (cdr dp)) - (setq *c3* (car dp)) - (setq dp (cdr dp)) - (setq *c4* (car dp)) - (setq dp (cdr dp)) - (setq *c5* (car dp)) - (setq dp (cdr dp)) - (setq *c6* (car dp)) - (setq dp (cdr dp)) - (setq *c7* (car dp)) - (setq dp (cdr dp)) - (setq *c8* (car dp)) - (setq dp (cdr dp)) - (setq *c9* (car dp)) - (setq dp (cdr dp)) - (setq *c10* (car dp)) - (setq dp (cdr dp)) - (setq *c11* (car dp)) - (setq dp (cdr dp)) - (setq *c12* (car dp)) - (setq dp (cdr dp)) - (setq *c13* (car dp)) - (setq dp (cdr dp)) - (setq *c14* (car dp)) - (setq dp (cdr dp)) - (setq *c15* (car dp)) - (setq dp (cdr dp)) - (setq *c16* (car dp)) - (setq dp (cdr dp)) - (setq *c17* (car dp)) - (setq dp (cdr dp)) - (setq *c18* (car dp)) - (setq dp (cdr dp)) - (setq *c19* (car dp)) - (setq dp (cdr dp)) - (setq *c20* (car dp)) - (setq dp (cdr dp)) - (setq *c21* (car dp)) - (setq dp (cdr dp)) - (setq *c22* (car dp)) - (setq dp (cdr dp)) - (setq *c23* (car dp)) - (setq dp (cdr dp)) - (setq *c24* (car dp)) - (setq dp (cdr dp)) - (setq *c25* (car dp)) - (setq dp (cdr dp)) - (setq *c26* (car dp)) - (setq dp (cdr dp)) - (setq *c27* (car dp)) - (setq dp (cdr dp)) - (setq *c28* (car dp)) - (setq dp (cdr dp)) - (setq *c29* (car dp)) - (setq dp (cdr dp)) - (setq *c30* (car dp)) - (setq dp (cdr dp)) - (setq *c31* (car dp)) - (setq dp (cdr dp)) - (setq *c32* (car dp)) - (setq dp (cdr dp)) - (setq *c33* (car dp)) - (setq dp (cdr dp)) - (setq *c34* (car dp)) - (setq dp (cdr dp)) - (setq *c35* (car dp)) - (setq dp (cdr dp)) - (setq *c36* (car dp)) - (setq dp (cdr dp)) - (setq *c37* (car dp)) - (setq dp (cdr dp)) - (setq *c38* (car dp)) - (setq dp (cdr dp)) - (setq *c39* (car dp)) - (setq dp (cdr dp)) - (setq *c40* (car dp)) - (setq dp (cdr dp)) - (setq *c41* (car dp)) - (setq dp (cdr dp)) - (setq *c42* (car dp)) - (setq dp (cdr dp)) - (setq *c43* (car dp)) - (setq dp (cdr dp)) - (setq *c44* (car dp)) - (setq dp (cdr dp)) - (setq *c45* (car dp)) - (setq dp (cdr dp)) - (setq *c46* (car dp)) - (setq dp (cdr dp)) - (setq *c47* (car dp)) - (setq dp (cdr dp)) - (setq *c48* (car dp)) - (setq dp (cdr dp)) - (setq *c49* (car dp)) - (setq dp (cdr dp)) - (setq *c50* (car dp)) - (setq dp (cdr dp)) - (setq *c51* (car dp)) - (setq dp (cdr dp)) - (setq *c52* (car dp)) - (setq dp (cdr dp)) - (setq *c53* (car dp)) - (setq dp (cdr dp)) - (setq *c54* (car dp)) - (setq dp (cdr dp)) - (setq *c55* (car dp)) - (setq dp (cdr dp)) - (setq *c56* (car dp)) - (setq dp (cdr dp)) - (setq *c57* (car dp)) - (setq dp (cdr dp)) - (setq *c58* (car dp)) - (setq dp (cdr dp)) - (setq *c59* (car dp)) - (setq dp (cdr dp)) - (setq *c60* (car dp)) - (setq dp (cdr dp)) - (setq *c61* (car dp)) - (setq dp (cdr dp)) - (setq *c62* (car dp)) - (setq dp (cdr dp)) - (setq *c63* (car dp)) - (setq dp (cdr dp)) - (setq *c64* (car dp)) - ;-------- added for 127 atr - (setq dp (cdr dp)) - (setq *c65* (car dp)) - (setq dp (cdr dp)) - (setq *c66* (car dp)) - (setq dp (cdr dp)) - (setq *c67* (car dp)) - (setq dp (cdr dp)) - (setq *c68* (car dp)) - (setq dp (cdr dp)) - (setq *c69*(car dp)) - (setq dp (cdr dp)) - (setq *c70* (car dp)) - (setq dp (cdr dp)) - (setq *c71* (car dp)) - (setq dp (cdr dp)) - (setq *c72* (car dp)) - (setq dp (cdr dp)) - (setq *c73* (car dp)) - (setq dp (cdr dp)) - (setq *c74* (car dp)) - (setq dp (cdr dp)) - (setq *c75* (car dp)) - (setq dp (cdr dp)) - (setq *c76* (car dp)) - (setq dp (cdr dp)) - (setq *c77* (car dp)) - (setq dp (cdr dp)) - (setq *c78* (car dp)) - (setq dp (cdr dp)) - (setq *c79*(car dp)) - (setq dp (cdr dp)) - (setq *c80* (car dp)) - (setq dp (cdr dp)) - (setq *c81* (car dp)) - (setq dp (cdr dp)) - (setq *c82* (car dp)) - (setq dp (cdr dp)) - (setq *c83* (car dp)) - (setq dp (cdr dp)) - (setq *c84* (car dp)) - (setq dp (cdr dp)) - (setq *c85* (car dp)) - (setq dp (cdr dp)) - (setq *c86* (car dp)) - (setq dp (cdr dp)) - (setq *c87* (car dp)) - (setq dp (cdr dp)) - (setq *c88* (car dp)) - (setq dp (cdr dp)) - (setq *c89*(car dp)) - (setq dp (cdr dp)) - (setq *c90* (car dp)) - (setq dp (cdr dp)) - (setq *c91* (car dp)) - (setq dp (cdr dp)) - (setq *c92* (car dp)) - (setq dp (cdr dp)) - (setq *c93* (car dp)) - (setq dp (cdr dp)) - (setq *c94* (car dp)) - (setq dp (cdr dp)) - (setq *c95* (car dp)) - (setq dp (cdr dp)) - (setq *c96* (car dp)) - (setq dp (cdr dp)) - (setq *c97* (car dp)) - (setq dp (cdr dp)) - (setq *c98* (car dp)) - (setq dp (cdr dp)) - (setq *c99*(car dp)) - (setq dp (cdr dp)) - (setq *c100* (car dp)) - (setq dp (cdr dp)) - (setq *c101* (car dp)) - (setq dp (cdr dp)) - (setq *c102* (car dp)) - (setq dp (cdr dp)) - (setq *c103* (car dp)) - (setq dp (cdr dp)) - (setq *c104* (car dp)) - (setq dp (cdr dp)) - (setq *c105* (car dp)) - (setq dp (cdr dp)) - (setq *c106* (car dp)) - (setq dp (cdr dp)) - (setq *c107* (car dp)) - (setq dp (cdr dp)) - (setq *c108* (car dp)) - (setq dp (cdr dp)) - (setq *c109*(car dp)) - (setq dp (cdr dp)) - (setq *c110* (car dp)) - (setq dp (cdr dp)) - (setq *c111* (car dp)) - (setq dp (cdr dp)) - (setq *c112* (car dp)) - (setq dp (cdr dp)) - (setq *c113* (car dp)) - (setq dp (cdr dp)) - (setq *c114* (car dp)) - (setq dp (cdr dp)) - (setq *c115* (car dp)) - (setq dp (cdr dp)) - (setq *c116* (car dp)) - (setq dp (cdr dp)) - (setq *c117* (car dp)) - (setq dp (cdr dp)) - (setq *c118* (car dp)) - (setq dp (cdr dp)) - (setq *c119*(car dp)) - (setq dp (cdr dp)) - (setq *c120* (car dp)) - (setq dp (cdr dp)) - (setq *c121* (car dp)) - (setq dp (cdr dp)) - (setq *c122* (car dp)) - (setq dp (cdr dp)) - (setq *c123* (car dp)) - (setq dp (cdr dp)) - (setq *c124* (car dp)) - (setq dp (cdr dp)) - (setq *c125* (car dp)) - (setq dp (cdr dp)) - (setq *c126* (car dp)) - (setq dp (cdr dp)) - (setq *c127* (car dp)) - ;(setq dp (cdr dp)) - ;(setq *c128* (car dp)) - ;-------- - (eval-nodelist outs))) - -(defun &any (outs register const-list) - (prog (z c) - (setq z (fast-symeval register)) - (cond ((numberp z) (go number))) - symbol (cond ((null const-list) (return nil)) - ((eq (car const-list) z) (go ok)) - (t (setq const-list (cdr const-list)) (go symbol))) - number (cond ((null const-list) (return nil)) - ((and (numberp (setq c (car const-list))) - (=alg c z)) - (go ok)) - (t (setq const-list (cdr const-list)) (go number))) - ok (eval-nodelist outs))) - -(defun teqa (outs register constant) - (and (eq (fast-symeval register) constant) (eval-nodelist outs))) - -(defun tnea (outs register constant) - (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs))) - -(defun txxa (outs register constant) - (declare (ignore constant)) - (and (symbolp (fast-symeval register)) (eval-nodelist outs))) - -(defun teqn (outs register constant) - (prog (z) - (setq z (fast-symeval register)) - (and (numberp z) - (=alg z constant) - (eval-nodelist outs)))) - -(defun tnen (outs register constant) - (prog (z) - (setq z (fast-symeval register)) - (and (or (not (numberp z)) - (not (=alg z constant))) - (eval-nodelist outs)))) - -(defun txxn (outs register constant) - (declare (ignore constant)) - (prog (z) - (setq z (fast-symeval register)) - (and (numberp z) (eval-nodelist outs)))) - -(defun tltn (outs register constant) - (prog (z) - (setq z (fast-symeval register)) - (and (numberp z) - (> constant z) - (eval-nodelist outs)))) - -(defun tgtn (outs register constant) - (prog (z) - (setq z (fast-symeval register)) - (and (numberp z) - (> z constant) - (eval-nodelist outs)))) - -(defun tgen (outs register constant) - (prog (z) - (setq z (fast-symeval register)) - (and (numberp z) - (not (> constant z)) - (eval-nodelist outs)))) - -(defun tlen (outs register constant) - (prog (z) - (setq z (fast-symeval register)) - (and (numberp z) - (not (> z constant)) - (eval-nodelist outs)))) - -(defun teqs (outs vara varb) - (prog (a b) - (setq a (fast-symeval vara)) - (setq b (fast-symeval varb)) - (cond ((eq a b) (eval-nodelist outs)) - ((and (numberp a) - (numberp b) - (=alg a b)) - (eval-nodelist outs))))) - -(defun tnes (outs vara varb) - (prog (a b) - (setq a (fast-symeval vara)) - (setq b (fast-symeval varb)) - (cond ((eq a b) (return nil)) - ((and (numberp a) - (numberp b) - (=alg a b)) - (return nil)) - (t (eval-nodelist outs))))) - -(defun txxs (outs vara varb) - (prog (a b) - (setq a (fast-symeval vara)) - (setq b (fast-symeval varb)) - (cond ((and (numberp a) (numberp b)) (eval-nodelist outs)) - ((and (not (numberp a)) (not (numberp b))) - (eval-nodelist outs))))) - -(defun tlts (outs vara varb) - (prog (a b) - (setq a (fast-symeval vara)) - (setq b (fast-symeval varb)) - (and (numberp a) - (numberp b) - (> b a) - (eval-nodelist outs)))) - -(defun tgts (outs vara varb) - (prog (a b) - (setq a (fast-symeval vara)) - (setq b (fast-symeval varb)) - (and (numberp a) - (numberp b) - (> a b) - (eval-nodelist outs)))) - -(defun tges (outs vara varb) - (prog (a b) - (setq a (fast-symeval vara)) - (setq b (fast-symeval varb)) - (and (numberp a) - (numberp b) - (not (> b a)) - (eval-nodelist outs)))) - -(defun tles (outs vara varb) - (prog (a b) - (setq a (fast-symeval vara)) - (setq b (fast-symeval varb)) - (and (numberp a) - (numberp b) - (not (> a b)) - (eval-nodelist outs)))) - -(defun &two (left-outs right-outs) - (prog (fp dp) - (cond (*sendtocall* - (setq fp *flag-part*) - (setq dp *data-part*)) - (t - (setq fp *alpha-flag-part*) - (setq dp *alpha-data-part*))) - (sendto fp dp 'left left-outs) - (sendto fp dp 'right right-outs))) - -(defun &mem (left-outs right-outs memory-list) - (prog (fp dp) - (cond (*sendtocall* - (setq fp *flag-part*) - (setq dp *data-part*)) - (t - (setq fp *alpha-flag-part*) - (setq dp *alpha-data-part*))) - (sendto fp dp 'left left-outs) - (add-token memory-list fp dp nil) - (sendto fp dp 'right right-outs))) - -(defun &and (outs lpred rpred tests) - (prog (mem) - (cond ((eq *side* 'right) (setq mem (memory-part lpred))) - (t (setq mem (memory-part rpred)))) - (cond ((not mem) (return nil)) - ((eq *side* 'right) (and-right outs mem tests)) - (t (and-left outs mem tests))))) - -(defun and-left (outs mem tests) - (prog (fp dp memdp tlist tst lind rind res) - (setq fp *flag-part*) - (setq dp *data-part*) - fail (and (null mem) (return nil)) - (setq memdp (car mem)) - (setq mem (cdr mem)) - (setq tlist tests) - tloop (and (null tlist) (go succ)) - (setq tst (car tlist)) - (setq tlist (cdr tlist)) - (setq lind (car tlist)) - (setq tlist (cdr tlist)) - (setq rind (car tlist)) - (setq tlist (cdr tlist)) - ;### (comment the next line differs in and-left & -right) - (setq res (funcall tst (gelm memdp rind) (gelm dp lind))) - (cond (res (go tloop)) - (t (go fail))) - succ - ;### (comment the next line differs in and-left & -right) - (sendto fp (cons (car memdp) dp) 'left outs) - (go fail))) - -(defun and-right (outs mem tests) - (prog (fp dp memdp tlist tst lind rind res) - (setq fp *flag-part*) - (setq dp *data-part*) - fail (and (null mem) (return nil)) - (setq memdp (car mem)) - (setq mem (cdr mem)) - (setq tlist tests) - tloop (and (null tlist) (go succ)) - (setq tst (car tlist)) - (setq tlist (cdr tlist)) - (setq lind (car tlist)) - (setq tlist (cdr tlist)) - (setq rind (car tlist)) - (setq tlist (cdr tlist)) - ;### (comment the next line differs in and-left & -right) - (setq res (funcall tst (gelm dp rind) (gelm memdp lind))) - (cond (res (go tloop)) - (t (go fail))) - succ - ;### (comment the next line differs in and-left & -right) - (sendto fp (cons (car dp) memdp) 'right outs) - (go fail))) - - -(defun teqb (new eqvar) - (cond ((eq new eqvar) t) - ((not (numberp new)) nil) - ((not (numberp eqvar)) nil) - ((=alg new eqvar) t) - (t nil))) - -(defun tneb (new eqvar) - (cond ((eq new eqvar) nil) - ((not (numberp new)) t) - ((not (numberp eqvar)) t) - ((=alg new eqvar) nil) - (t t))) - -(defun tltb (new eqvar) - (cond ((not (numberp new)) nil) - ((not (numberp eqvar)) nil) - ((> eqvar new) t) - (t nil))) - -(defun tgtb (new eqvar) - (cond ((not (numberp new)) nil) - ((not (numberp eqvar)) nil) - ((> new eqvar) t) - (t nil))) - -(defun tgeb (new eqvar) - (cond ((not (numberp new)) nil) - ((not (numberp eqvar)) nil) - ((not (> eqvar new)) t) - (t nil))) - -(defun tleb (new eqvar) - (cond ((not (numberp new)) nil) - ((not (numberp eqvar)) nil) - ((not (> new eqvar)) t) - (t nil))) - -(defun txxb (new eqvar) - (cond ((numberp new) - (cond ((numberp eqvar) t) - (t nil))) - (t - (cond ((numberp eqvar) nil) - (t t))))) - - -(defun &p (rating name var-dope ce-var-dope rhs) - (declare (ignore var-dope ce-var-dope rhs)) - (prog (fp dp) - (cond (*sendtocall* - (setq fp *flag-part*) - (setq dp *data-part*)) - (t - (setq fp *alpha-flag-part*) - (setq dp *alpha-data-part*))) - (and (member fp '(nil old)) (removecs name dp)) - (and fp (insertcs name dp rating)))) - -(defun &old (a b c d e) - (declare (ignore a b c d e)) - nil) - -(defun ¬ (outs lmem rpred tests) - (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil) - ((eq *side* 'right) (not-right outs (car lmem) tests)) - (t (not-left outs (memory-part rpred) tests lmem)))) - -(defun not-left (outs mem tests own-mem) - (prog (fp dp memdp tlist tst lind rind res c) - (setq fp *flag-part*) - (setq dp *data-part*) - (setq c 0.) - fail (and (null mem) (go fin)) - (setq memdp (car mem)) - (setq mem (cdr mem)) - (setq tlist tests) - tloop (and (null tlist) (setq c (1+ c)) (go fail)) - (setq tst (car tlist)) - (setq tlist (cdr tlist)) - (setq lind (car tlist)) - (setq tlist (cdr tlist)) - (setq rind (car tlist)) - (setq tlist (cdr tlist)) - ;### (comment the next line differs in not-left & -right) - (setq res (funcall tst (gelm memdp rind) (gelm dp lind))) - (cond (res (go tloop)) - (t (go fail))) - fin (add-token own-mem fp dp c) - (and (== c 0.) (sendto fp dp 'left outs)))) - -(defun not-right (outs mem tests) - (prog (fp dp memdp tlist tst lind rind res newfp inc newc) - (setq fp *flag-part*) - (setq dp *data-part*) - (cond ((not fp) (setq inc -1.) (setq newfp 'new)) - ((eq fp 'new) (setq inc 1.) (setq newfp nil)) - (t (return nil))) - fail (and (null mem) (return nil)) - (setq memdp (car mem)) - (setq newc (cadr mem)) - (setq tlist tests) - tloop (and (null tlist) (go succ)) - (setq tst (car tlist)) - (setq tlist (cdr tlist)) - (setq lind (car tlist)) - (setq tlist (cdr tlist)) - (setq rind (car tlist)) - (setq tlist (cdr tlist)) - ;### (comment the next line differs in not-left & -right) - (setq res (funcall tst (gelm dp rind) (gelm memdp lind))) - (cond (res (go tloop)) - (t (setq mem (cddr mem)) (go fail))) - succ (setq newc (+ inc newc)) ;"plus" changed to "+" by gdw - (rplaca (cdr mem) newc) - (cond ((or (and (== inc -1.) (== newc 0.)) - (and (== inc 1.) (== newc 1.))) - (sendto newfp memdp 'right outs))) - (setq mem (cddr mem)) - (go fail))) - - -;;; Node memories - - -(defun add-token (memlis flag data-part num) - (prog (was-present) - (cond ((eq flag 'new) - (setq was-present nil) - (real-add-token memlis data-part num)) - ((not flag) - (setq was-present (remove-old memlis data-part num))) - ((eq flag 'old) (setq was-present t))) - (return was-present))) - -(defun real-add-token (lis data-part num) - (setq *current-token* (1+ *current-token*)) - (cond (num (rplaca lis (cons num (car lis))))) - (rplaca lis (cons data-part (car lis)))) - -(defun remove-old (lis data num) - (cond (num (remove-old-num lis data)) - (t (remove-old-no-num lis data)))) - -(defun remove-old-num (lis data) - (prog (m next last) - (setq m (car lis)) - (cond ((atom m) (return nil)) - ((top-levels-eq data (car m)) - (setq *current-token* (1- *current-token*)) - (rplaca lis (cddr m)) - (return (car m)))) - (setq next m) - loop (setq last next) - (setq next (cddr next)) - (cond ((atom next) (return nil)) - ((top-levels-eq data (car next)) - (rplacd (cdr last) (cddr next)) - (setq *current-token* (1- *current-token*)) - (return (car next))) - (t (go loop))))) - -(defun remove-old-no-num (lis data) - (prog (m next last) - (setq m (car lis)) - (cond ((atom m) (return nil)) - ((top-levels-eq data (car m)) - (setq *current-token* (1- *current-token*)) - (rplaca lis (cdr m)) - (return (car m)))) - (setq next m) - loop (setq last next) - (setq next (cdr next)) - (cond ((atom next) (return nil)) - ((top-levels-eq data (car next)) - (rplacd last (cdr next)) - (setq *current-token* (1- *current-token*)) - (return (car next))) - (t (go loop))))) diff --git a/contrib/ops/ops-rhs.lisp b/contrib/ops/ops-rhs.lisp deleted file mode 100644 index 7b8de9bd75d23bc8e1009ee60734ec0922f0fcf9..0000000000000000000000000000000000000000 --- a/contrib/ops/ops-rhs.lisp +++ /dev/null @@ -1,646 +0,0 @@ -; -;************************************************************************ -; -; VPS2 -- Interpreter for OPS5 -; -; -; -; This Common Lisp version of OPS5 is in the public domain. It is based -; in part on based on a Franz Lisp implementation done by Charles L. Forgy -; at Carnegie-Mellon University, which was placed in the public domain by -; the author in accordance with CMU policies. This version has been -; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen, -; and Dan Kuokka. -; -; This code is made available is, and without warranty of any kind by the -; authors or by Carnegie-Mellon University. -; - -;;;; This file contains all the functions necessary for RHS actions -;;;; including $actions. - -(in-package "OPS") -(shadow '(remove write)) -(export '(remove write make modify crlf)) - - -(proclaim '(special *ptrace* *cycle-count* *halt-flag* *wtrace*)) - - -;;; External global variables - -(defvar *size-result-array*) -(defvar *in-rhs*) -(defvar *current-wm*) -(defvar *max-wm*) -(defvar *action-count*) -(defvar *critical*) - - -;;; Internal global variables - -(defvar *wmpart-list*) -(defvar *wm-filter*) -(defvar *wm*) -(defvar *old-wm*) -(defvar *result-array*) -(defvar *variable-memory*) -(defvar *last*) -(defvar *max-index*) -(defvar *next-index*) -(defvar *data-matched*) -(defvar *ce-variable-memory*) -(defvar *rest*) -(defvar *build-trace*) - - -;;;; Functions for RHS evaluation - -(defun rhs-init () - ; if the size of result-array changes, change the line in i-g-v which - ; sets the value of *size-result-array* - (setq *size-result-array* 255.) ;255 /256 set by gdw - (setq *result-array* (make-array 256 :initial-element nil)) ;jgk - (setq *in-rhs* nil) - (setq *build-trace* nil) - (setq *max-wm* (setq *current-wm* 0.)) - (setq *action-count* 0.) - (setq *critical* nil) - (setq *wmpart-list* nil)) - - -(defun eval-rhs (pname data) - (prog (node port) - (cond (*ptrace* - (setq port (trace-file)) - (terpri port) - (princ *cycle-count* port) - (princ '|. | port) - (princ pname port) - (time-tag-print data port))) - (setq *data-matched* data) - (setq *p-name* pname) - (setq *last* nil) - (setq node (get pname 'topnode)) - (init-var-mem (var-part node)) - (init-ce-var-mem (ce-var-part node)) - (begin-record pname data) - (setq *in-rhs* t) - (eval (rhs-part node)) - (setq *in-rhs* nil) - (end-record))) - - -(defun eval-args (z) - (prog (r) - (rhs-tab 1.) - la (and (atom z) (return nil)) - (setq r (car z)) - (setq z (cdr z)) - (cond ((EQ R '^) - (RHS-tab (car z)) - (setq r (cadr z)) - (setq z (cddr z)))) - (cond ((eq r '//) ($value (car z)) (setq z (cdr z))) - (t ($change r))) - (go la))) - - - -;;;; RHS actions -;;;; Some of these can be called at the top level. - -(defmacro make (&body z) - `(ops-make ',z)) - -(defmacro remove (&body z) - `(ops-remove ',z)) - -(defmacro modify (&body z) - `(ops-modify ',z)) - -(defmacro openfile (&body z) - `(ops-openfile ',z)) - -(defmacro closefile (&body z) - `(ops-closefile ',z)) - -(defmacro default (&body z) - `(ops-default ',z)) - -(defmacro write (&body z) - `(ops-write ',z)) - -(defmacro crlf (&body z) - `(ops-crlf ',z)) - -(defmacro tabto (&body z) - `(ops-tabto ',z)) - -(defmacro rjust (&body z) - `(ops-rjust ',z)) - -(defmacro call (&body z) - `(ops-call ',z)) - -(defmacro bind (&body z) - `(ops-bind ',z)) - -(defmacro cbind (&body z) - `(ops-cbind ',z)) - -(defmacro build (&body z) - `(ops-build ',z)) - -(defmacro substr (&body l) - `(ops-substr ',l)) - -(defmacro compute (&body z) - `(ops-compute ',z)) - -(defmacro litval (&body z) - `(ops-litval ',z)) - -(defmacro accept (&body z) - `(ops-accept ',z)) - -(defmacro acceptline (&body z) - `(ops-acceptline ',z)) - -(defmacro arith (&body z) - `(ops-arith ',z)) - - -(defun ops-make (z) - (prog nil - ($reset) - (eval-args z) - ($assert))) - -(defun ops-remove (z) - (prog (old) - (and (not *in-rhs*)(return (top-level-remove z))) - top (and (atom z) (return nil)) - (setq old (get-ce-var-bind (car z))) - (cond ((null old) - (%warn '|remove: argument not an element variable| (car z)) - (return nil))) - (remove-from-wm old) - (setq z (cdr z)) - (go top))) - -(defun ops-modify (z) - (prog (old) - (cond ((not *in-rhs*) - (%warn '|cannot be called at top level| 'modify) - (return nil))) - (setq old (get-ce-var-bind (car z))) - (cond ((null old) - (%warn '|modify: first argument must be an element variable| - (car z)) - (return nil))) - (remove-from-wm old) - (setq z (cdr z)) - ($reset) - copy (and (atom old) (go fin)) - ($change (car old)) - (setq old (cdr old)) - (go copy) - fin (eval-args z) - ($assert))) - -(defun ops-bind (z) - (prog (val) - (cond ((not *in-rhs*) - (%warn '|cannot be called at top level| 'bind) - (return nil))) - (cond ((< (length z) 1.) - (%warn '|bind: wrong number of arguments to| z) - (return nil)) - ((not (symbolp (car z))) - (%warn '|bind: illegal argument| (car z)) - (return nil)) - ((= (length z) 1.) (setq val (gensym))) - (t ($reset) - (eval-args (cdr z)) - (setq val ($parameter 1.)))) - (make-var-bind (car z) val))) - -(defun ops-cbind (z) - (cond ((not *in-rhs*) - (%warn '|cannot be called at top level| 'cbind)) - ((not (= (length z) 1.)) - (%warn '|cbind: wrong number of arguments| z)) - ((not (symbolp (car z))) - (%warn '|cbind: illegal argument| (car z))) - ((null *last*) - (%warn '|cbind: nothing added yet| (car z))) - (t (make-ce-var-bind (car z) *last*)))) - - -(defun ops-call (z) - (prog (f) - (setq f (car z)) - ($reset) - (eval-args (cdr z)) - (funcall f))) - - -(defun halt nil - (cond ((not *in-rhs*) - (%warn '|cannot be called at top level| 'halt)) - (t (setq *halt-flag* t)))) - -(defun ops-build (z) - (prog (r) - (cond ((not *in-rhs*) - (%warn '|cannot be called at top level| 'build) - (return nil))) - ($reset) - (build-collect z) - (setq r (unflat (use-result-array))) - (and *build-trace* (funcall *build-trace* r)) - (compile-production (car r) (cdr r)))) - -(defun ops-compute (z) ($value (ari z))) - -; arith is the obsolete form of compute -(defun ops-arith (z) ($value (ari z))) - -(defun ari (x) - (cond ((atom x) - (%warn '|bad syntax in arithmetic expression | x) - 0.) - ((atom (cdr x)) (ari-unit (car x))) - ((eq (cadr x) '+) - (+ (ari-unit (car x)) (ari (cddr x)))) - ;"plus" changed to "+" by gdw - ((eq (cadr x) '-) - (- (ari-unit (car x)) (ari (cddr x)))) - ((eq (cadr x) '*) - (* (ari-unit (car x)) (ari (cddr x)))) - ((eq (cadr x) '//) - (floor (ari-unit (car x)) (ari (cddr x)))) ;@@@ quotient? / - ;@@@ kluge only works for integers - ;@@@ changed to floor by jcp (from round) - ((eq (cadr x) '\\) - (mod (fix (ari-unit (car x))) (fix (ari (cddr x))))) - (t (%warn '|bad syntax in arithmetic expression | x) 0.))) - -(defun ari-unit (a) - (prog (r) - (cond ((consp a) (setq r (ari a))) ;dtpr\consp gdw - (t (setq r ($varbind a)))) - (cond ((not (numberp r)) - (%warn '|bad value in arithmetic expression| a) - (return 0.)) - (t (return r))))) - -(defun ops-substr (l) - (prog (k elm start end) - (cond ((not (= (length l) 3.)) - (%warn '|substr: wrong number of arguments| l) - (return nil))) - (setq elm (get-ce-var-bind (car l))) - (cond ((null elm) - (%warn '|first argument to substr must be a ce var| - l) - (return nil))) - (setq start ($varbind (cadr l))) - (setq start ($litbind start)) - (cond ((not (numberp start)) - (%warn '|second argument to substr must be a number| - l) - (return nil))) -;### (comment |if a variable is bound to INF, the following| -; |will get the binding and treat it as INF is| -; |always treated. that may not be good|) - (setq end ($varbind (caddr l))) - (cond ((eq end 'inf) (setq end (length elm)))) - (setq end ($litbind end)) - (cond ((not (numberp end)) - (%warn '|third argument to substr must be a number| - l) - (return nil))) -;### (comment |this loop does not check for the end of elm| -; |instead it relies on cdr of nil being nil| -; |this may not work in all versions of lisp|) - (setq k 1.) - la (cond ((> k end) (return nil)) - ((not (< k start)) ($value (car elm)))) - (setq elm (cdr elm)) - (setq k (1+ k)) - (go la))) - -(defun genatom nil ($value (gensym))) - -(defun ops-litval (z) - (prog (r) - (cond ((not (= (length z) 1.)) - (%warn '|litval: wrong number of arguments| z) - ($value 0) - (return nil)) - ((numberp (car z)) ($value (car z)) (return nil))) - (setq r ($litbind ($varbind (car z)))) - (cond ((numberp r) ($value r) (return nil))) - (%warn '|litval: argument has no literal binding| (car z)) - ($value 0))) - - - -; rhs-tab implements the tab ('^') function in the rhs. it has -; four responsibilities: -; - to move the array pointers -; - to watch for tabbing off the left end of the array -; (ie, to watch for pointers less than 1) -; - to watch for tabbing off the right end of the array -; - to write nil in all the slots that are skipped -; the last is necessary if the result array is not to be cleared -; after each use; if rhs-tab did not do this, $reset -; would be much slower. - -(defun rhs-tab (z) ($tab ($varbind z))) - - -(defun time-tag-print (data port) - (cond ((not (null data)) - (time-tag-print (cdr data) port) - (princ '| | port) - (princ (creation-time (car data)) port)))) - -(defun init-var-mem (vlist) - (prog (v ind r) - (setq *variable-memory* nil) - top (and (atom vlist) (return nil)) - (setq v (car vlist)) - (setq ind (cadr vlist)) - (setq vlist (cddr vlist)) - (setq r (gelm *data-matched* ind)) - (setq *variable-memory* (cons (cons v r) *variable-memory*)) - (go top))) - -(defun init-ce-var-mem (vlist) - (prog (v ind r) - (setq *ce-variable-memory* nil) - top (and (atom vlist) (return nil)) - (setq v (car vlist)) - (setq ind (cadr vlist)) - (setq vlist (cddr vlist)) - (setq r (ce-gelm *data-matched* ind)) - (setq *ce-variable-memory* - (cons (cons v r) *ce-variable-memory*)) - (go top))) - -(defun make-ce-var-bind (var elem) - (setq *ce-variable-memory* - (cons (cons var elem) *ce-variable-memory*))) - -(defun make-var-bind (var elem) - (setq *variable-memory* (cons (cons var elem) *variable-memory*))) - -(defun get-ce-var-bind (x) - (prog (r) - (cond ((numberp x) (return (get-num-ce x)))) - (setq r (assq x *ce-variable-memory*)) - (cond (r (return (cdr r))) - (t (return nil))))) - -(defun get-num-ce (x) - (prog (r l d) - (setq r *data-matched*) - (setq l (length r)) - (setq d (- l x)) - (and (> 0. d) (return nil)) - la (cond ((null r) (return nil)) - ((> 1. d) (return (car r)))) - (setq d (1- d)) - (setq r (cdr r)) - (go la))) - - -(defun build-collect (z) - (prog (r) - la (and (atom z) (return nil)) - (setq r (car z)) - (setq z (cdr z)) - (cond ((consp r) ;dtpr\consp gdw - ($value '\() - (build-collect r) - ($value '\))) - ((eq r '\\) ($change (car z)) (setq z (cdr z))) - (t ($value r))) - (go la))) - -(defun unflat (x) (setq *rest* x) (unflat*)) - -(defun unflat* nil - (prog (c) - (cond ((atom *rest*) (return nil))) - (setq c (car *rest*)) - (setq *rest* (cdr *rest*)) - (cond ((eq c '\() (return (cons (unflat*) (unflat*)))) - ((eq c '\)) (return nil)) - (t (return (cons c (unflat*))))))) - - - -;;;; $Functions. -;;;; These functions provide an interface to the result array. -;;;; The result array is used to organize attribute values into their -;;;; correct slot. - -(defun $litbind (x) - (prog (r) - (cond ((and (symbolp x) (setq r (literal-binding-of x))) - (return r)) - (t (return x))))) - -(defun $varbind (x) - (prog (r) - (and (not *in-rhs*) (return x)) - (setq r (assq x *variable-memory*)) - (cond (r (return (cdr r))) - (t (return x))))) - -(defun $change (x) - (prog nil - (cond ((consp x) (eval-function x)) ;dtpr\consp gdw - (t ($value ($varbind x)))))) - -(defun $reset nil - (setq *max-index* 0.) - (setq *next-index* 1.)) - -(defun $tab (z) - (prog (edge next) - (setq next ($litbind z)) - (and (floatp next) (setq next (fix next))) - (cond ((or (not (numberp next)) - (> next *size-result-array*) - (> 1. next)) ; ( '| |) - (%warn '|illegal index after ^| next) - (return *next-index*))) - (setq edge (- next 1.)) - (cond ((> *max-index* edge) (go ok))) - clear (cond ((== *max-index* edge) (go ok))) - (putvector *result-array* edge nil) - (setq edge (1- edge)) - (go clear) - ok (setq *next-index* next) - (return next))) - -(defun $value (v) - (cond ((> *next-index* *size-result-array*) - (%warn '|index too large| *next-index*)) - (t - (and (> *next-index* *max-index*) - (setq *max-index* *next-index*)) - (putvector *result-array* *next-index* v) - (setq *next-index* (1+ *next-index*))))) - -(defun $assert nil - (setq *last* (use-result-array)) - (add-to-wm *last* nil)) - -(defun $parametercount nil *max-index*) - -(defun $parameter (k) - (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.)) - (%warn '|illegal parameter number | k) - nil) - ((> k *max-index*) nil) - (t (getvector *result-array* k)))) - -(defun $ifile (x) - (cond ((symbolp x) (get x 'inputfile)) - (t nil))) - -(defun $ofile (x) - (cond ((symbolp x) (get x 'outputfile)) - (t nil))) - - -;;; Use-result-array returns the contents of the result array as a list. - -(defun use-result-array nil - (prog (k r) - (setq k *max-index*) - (setq r nil) - top (and (== k 0.) (return r)) - (setq r (cons (getvector *result-array* k) r)) - (setq k (1- k)) - (go top))) - - -(defun eval-function (form) - (cond ((not *in-rhs*) - (%warn '|functions cannot be used at top level| (car form))) - (t (eval form)))) - - - -;;;; WM maintaining functions - -;;; The order of operations in the following two functions is critical. -;;; add-to-wm order: (1) change wm (2) record change (3) match -;;; remove-from-wm order: (1) record change (2) match (3) change wm -;;; (back will not restore state properly unless wm changes are recorded -;;; before the cs changes that they cause) (match will give errors if -;;; the thing matched is not in wm at the time) - -(defun add-to-wm (wme override) - (prog (fa z part timetag port) - (setq *critical* t) - (setq *current-wm* (1+ *current-wm*)) - (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*)) - (setq *action-count* (1+ *action-count*)) - (setq fa (wm-hash wme)) - (or (member fa *wmpart-list*) - (setq *wmpart-list* (cons fa *wmpart-list*))) - (setq part (get fa 'wmpart*)) - (cond (override (setq timetag override)) - (t (setq timetag *action-count*))) - (setq z (cons wme timetag)) - (putprop fa (cons z part) 'wmpart*) - (record-change '=>wm *action-count* wme) - (match 'new wme) - (setq *critical* nil) - (cond ((and *in-rhs* *wtrace*) - (setq port (trace-file)) - (terpri port) - (princ '|=>wm: | port) - (ppelm wme port))))) - -;;; remove-from-wm uses eq, not equal to determine if wme is present - -(defun remove-from-wm (wme) - (prog (fa z part timetag port) - (setq fa (wm-hash wme)) - (setq part (get fa 'wmpart*)) - (setq z (assq wme part)) - (or z (return nil)) - (setq timetag (cdr z)) - (cond ((and *wtrace* *in-rhs*) - (setq port (trace-file)) - (terpri port) - (princ '|<=wm: | port) - (ppelm wme port))) - (setq *action-count* (1+ *action-count*)) - (setq *critical* t) - (setq *current-wm* (1- *current-wm*)) - (record-change '<=wm timetag wme) - (match nil wme) - (putprop fa (delq z part) 'wmpart*) - (setq *critical* nil))) - -;;; mapwm maps down the elements of wm, applying fn to each element -;;; each element is of form (datum . creation-time) - -(defun mapwm (fn) - (prog (wmpl part) - (setq wmpl *wmpart-list*) - lab1 (cond ((atom wmpl) (return nil))) - (setq part (get (car wmpl) 'wmpart*)) - (setq wmpl (cdr wmpl)) - (mapc fn part) - (go lab1))) - -(defun ops-wm (a) - (mapc (function (lambda (z) (terpri) (ppelm z *standard-output*))) - (get-wm a)) - nil) - -(defun creation-time (wme) - (cdr (assq wme (get (wm-hash wme) 'wmpart*)))) - - -(defun get-wm (z) - (setq *wm-filter* z) - (setq *wm* nil) - (mapwm (function get-wm2)) - (prog2 nil *wm* (setq *wm* nil))) - -(defun get-wm2 (elem) - ; (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*) :test #'equal))) - (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*)) ;test #'equal) - (setq *wm* (cons (car elem) *wm*))))) - -(defun wm-hash (x) - (cond ((not x) '<default>) - ((not (car x)) (wm-hash (cdr x))) - ((symbolp (car x)) (car x)) - (t (wm-hash (cdr x))))) - -(defun refresh nil - (prog nil - (setq *old-wm* nil) - (mapwm (function refresh-collect)) - (mapc (function refresh-del) *old-wm*) - (mapc (function refresh-add) *old-wm*) - (setq *old-wm* nil))) - -(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*))) - -(defun refresh-del (x) (remove-from-wm (car x))) - -(defun refresh-add (x) (add-to-wm (car x) (cdr x))) diff --git a/contrib/ops/ops-util.lisp b/contrib/ops/ops-util.lisp deleted file mode 100644 index 58eabfba1b52990662801ccdfd8e713b8cd971c6..0000000000000000000000000000000000000000 --- a/contrib/ops/ops-util.lisp +++ /dev/null @@ -1,242 +0,0 @@ -; -;************************************************************************ -; -; VPS2 -- Interpreter for OPS5 -; -; -; -; This Common Lisp version of OPS5 is in the public domain. It is based -; in part on based on a Franz Lisp implementation done by Charles L. Forgy -; at Carnegie-Mellon University, which was placed in the public domain by -; the author in accordance with CMU policies. This version has been -; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen, -; and Dan Kuokka. -; -; This code is made available is, and without warranty of any kind by the -; authors or by Carnegie-Mellon University. -; - -;;;; This file contains utility definitions that are needed by other ops -;;;; modules. This must be loaded first so commonlisp systems that -;;;; expand macros early have them available. - -(unless (find-package "OPS") (make-package "OPS")) - -(in-package "OPS") - -;;; Assq is included in some Common Lisp implementations (like Spice Lisp and -;;; the Zetalisp CLCP) as an extension. We'll use ASSOC if it's not there. -;;; DK- turned assq into a function so it can be 'applied' - -(eval-when (compile load eval) - (unless (fboundp 'assq) - (defmacro assq (i l) - `(assoc ,i ,l)))) - -;;; Ditto for DELQ. - -(eval-when (compile load eval) - (unless (fboundp 'delq) - (defmacro delq (i l) - `(delete ,i ,l :test #'eq)))) - -; -; Spdelete "special delete" is a function which deletes every occurence -; of element from list. This function was defined because common lisp's -; delete function only deletes top level elements from a list, not lists -; from lists. -; -(defun spdelete (element list) - - (cond ((null list) nil) - ((equal element (car list)) (spdelete element (cdr list))) - (t (cons (car list) (spdelete element (cdr list)))))) - - -;;; Functions that were revised so that they would compile efficiently - -(eval-when (compile eval load) - -;* The function == is machine dependent! -;* This function compares small integers for equality. It uses EQ -;* so that it will be fast, and it will consequently not work on all -;* Lisps. It works in Franz Lisp for integers in [-128, 127] -;(system::macro == (z) `(eq ,(cadr z) ,(caddr z))) -;;; -;;; Dario Giuse - made a macro. This is going to be faster than anything else. -;;; -;;; Skef Wholey - The = function in Common Lisp will compile into good code -;;; (in all implementations that I know of) when given the right declarations. -;;; In this case, we know both numbers are fixnums, so we use that information. - -(defmacro == (x y) - `(= (the fixnum ,x) (the fixnum ,y))) - -;;; =ALG returns T if A and B are algebraically equal. -;;; This corresponds to equalp - Dario Giuse -;;; But equalp uses eql for comparison if the things are numbers - Skef Wholey -;;; -(defmacro =alg (a b) - `(eql ,a ,b)) - - -(defmacro fast-symeval (&body z) - `(symbol-value ,(car z))) - -; getvector and putvector are fast routines for using ONE-DIMENSIONAL -; arrays. these routines do no checking; they assume -; 1. the array is a vector with 0 being the index of the first -; element -; 2. the vector holds arbitrary list values - -; Example call: (putvector array index value) -;;; Dario Giuse - 6/20/84 - -(defmacro putvector (array index value) - `(setf (aref ,array ,index) ,value)) - -;;; Example call: (getvector name index) -;;; -(defmacro getvector (array index) - `(aref ,array ,index)) - - -;;; Dario Giuse 6/21/84 -(defmacro putprop (atom value property) - `(setf (get ,atom ,property) ,value)) - -) ;eval-when - - -(defun ce-gelm (x k) - (declare (fixnum k)) - (declare (optimize (speed 3) (safety 0))) - (prog nil - loop (and (== k 1.) (return (car x))) - (setq k (1- k)) - (setq x (cdr x)) - (go loop))) - -(defconstant encode-pair-shift 14) - -; The loops in gelm were unwound so that fewer calls on DIFFERENCE -; would be needed - -(defun gelm (x k) - (declare (optimize speed (safety 0)) (fixnum k)) - (prog ((ce (ash k (- encode-pair-shift))) - (sub (ldb (byte 14 0) k))) - (declare (fixnum ce sub)) - celoop (and (eql ce 0.) (go ph2)) - (setq x (cdr x)) - (and (eql ce 1.) (go ph2)) - (setq x (cdr x)) - (and (eql ce 2.) (go ph2)) - (setq x (cdr x)) - (and (eql ce 3.) (go ph2)) - (setq x (cdr x)) - (and (eql ce 4.) (go ph2)) - (setq ce (- ce 4.)) - (go celoop) - ph2 (setq x (car x)) - subloop (and (eql sub 0.) (go finis)) - (setq x (cdr x)) - (and (eql sub 1.) (go finis)) - (setq x (cdr x)) - (and (eql sub 2.) (go finis)) - (setq x (cdr x)) - (and (eql sub 3.) (go finis)) - (setq x (cdr x)) - (and (eql sub 4.) (go finis)) - (setq x (cdr x)) - (and (eql sub 5.) (go finis)) - (setq x (cdr x)) - (and (eql sub 6.) (go finis)) - (setq x (cdr x)) - (and (eql sub 7.) (go finis)) - (setq x (cdr x)) - (and (eql sub 8.) (go finis)) - (setq sub (- sub 8.)) - (go subloop) - finis (return (car x))) ) ; ) ;end prog,< locally >, defun - - - -;;; intersect two lists using eq for the equality test -(defun interq (x y) - (cond ((atom x) nil) - ((member (car x) y) (cons (car x) (interq (cdr x) y))) - (t (interq (cdr x) y)))) - - -(proclaim '(special *p-name*)) - -(defun %warn (what where) - (prog nil - (terpri) - (princ '?) - (and *p-name* (princ *p-name*)) - (princ '|..|) - (princ where) - (princ '|..|) - (princ what) - (return where))) - -(defun %error (what where) - (%warn what where) - (throw '!error! '!error!)) ;jgk quoted arguments - -;@@@(defun round (x) (fix (+ 0.5 x))) ;"plus" changed to "+" by gdw -;@@@ removed; calls converted to native clisp (round) - -(defun top-levels-eq (la lb) - (prog nil - lx (cond ((eq la lb) (return t)) - ((null la) (return nil)) - ((null lb) (return nil)) - ((not (eq (car la) (car lb))) (return nil))) - (setq la (cdr la)) - (setq lb (cdr lb)) - (go lx))) - - -;(defun dtpr (x) (consp x)) ;dtpr\consp gdw - - -(defun fix (x)(floor x)) - - -(eval-when (compile load eval) -(defmacro ncons (x) `(cons ,x nil)) -);eval-when - - -;@@@ revision suggested by sf/inc. by gdw -(defun variablep (x) - (and (symbolp x) - (let ((name (symbol-name x))) - (and (>= (length name) 1) - (char= (char name 0) #\<))))) - - - -;@@@ this is a mistake: it must either go before = is called for -;non-numeric args, or such calls replaced with eq, equal, etc. -;(defun = -;(x y) (equal x y)) - - - -#| -Commented out - Dario Giuse. -This is unnecessary in Spice Lisp - -; break mechanism: -(proclaim '(special erm *break-character*)) - -(defun setbreak nil (setq *break-flag* t)) -(setq *break-character* #\control-D) -(bind-keyboard-function *break-character* #'setbreak) -(princ "*** use control-d for ops break, or setq *break-character asciival***") - -|# diff --git a/contrib/ops/ops.catalog b/contrib/ops/ops.catalog deleted file mode 100644 index c961a8199c0c935bddaba17c49cbffd7995d91e1..0000000000000000000000000000000000000000 --- a/contrib/ops/ops.catalog +++ /dev/null @@ -1,43 +0,0 @@ -Name: - OPS - -Package Name: - OPS - -Description: - Interpreter for Ops5, a programming language for production systems. - -Author: - Charles L. Forgy. Ported to Common lisp by George Wood and Jim Kowalski. -CMU Common Lisp mods by Dario Guise, Skef Wholey, and Dan Kuokka. - -Maintainer: - Not really maintained. - -Copyright Status: - Public domain. - -Files: - ops.lisp, ops-backup.lisp, ops-compile.lisp, ops-io.lisp, ops-main.lisp, -ops-match.lisp, ops-rhs.lisp, ops-util.lisp, ops.catalog, *.ops - -Portability: - Should run in any legal Common Lisp implementation. - -Instructions: - -To compile for CMU Common Lisp, (load "library:contrib/ops/compile-ops"). -After OPS has been compiled, you can (load "library:contrib/ops/ops.fasl"). -Then go into the OPS package with (in-package :ops). Now you can load your -OPS5 code or start typing in productions. - -There are a number of demos and sample programs; particularly amusing is the -Haunt adventure game. Do (load "<name>.ops"), then "(run)". Many systems -require an initial "(make start)" before the "(run)" --- if this is missing, -"(run)" will do nothing. Set *ptrace* to NIL to eliminate production tracing. - -See the OPS5 User's Manual, July 1981, by Forgy, CMU CSD. - -Bugs: - This has been put in its own package, but only a few interfaces have been -exported. You must run in the ops package. diff --git a/contrib/ops/ops.lisp b/contrib/ops/ops.lisp deleted file mode 100644 index d4ed92997b634d08763fb02903015ed9440cdccf..0000000000000000000000000000000000000000 --- a/contrib/ops/ops.lisp +++ /dev/null @@ -1,42 +0,0 @@ -; -;************************************************************************ -; -; VPS2 -- Interpreter for OPS5 -; -; -; -; This Common Lisp version of OPS5 is in the public domain. It is based -; in part on based on a Franz Lisp implementation done by Charles L. Forgy -; at Carnegie-Mellon University, which was placed in the public domain by -; the author in accordance with CMU policies. This version has been -; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen, -; and Dan Kuokka. -; -; This code is made available is, and without warranty of any kind by the -; authors or by Carnegie-Mellon University. -; - -;;;; This file performs the necessary initialization of the OPS interpreter. - - -(in-package "OPS") - -(defun ops-init () - ; Allows ^ , { , and } operators to be right next to another symbol. - (set-macro-character #\{ #'(lambda (s c) - (declare (ignore s c)) - '\{)) - (set-macro-character #\} #'(lambda (s c) - (declare (ignore s c)) - '\})) - (set-macro-character #\^ #'(lambda (s c) - (declare (ignore s c)) - '\^)) - (backup-init) - (compile-init) - (main-init) - (match-init) - (io-init) - (rhs-init)) - -(ops-init) diff --git a/contrib/ops/pp.ops b/contrib/ops/pp.ops deleted file mode 100644 index 1fe316ec63e5e81353a5ef83eff3ee2a28836a1f..0000000000000000000000000000000000000000 --- a/contrib/ops/pp.ops +++ /dev/null @@ -1,53 +0,0 @@ -; Production pretty printer. -; The program takes productions in any lousy -; format and attempts to print them properly. - -(declare (special pcount oport cinp)) - -(defun pp (ifile ofile) - (prog (iport) - (setq iport (infile ifile)) - (setq oport (outfile ofile)) - (setq pcount 1) - (setq cinp (read iport)) - (while cinp - (cond ((atom cinp) (print cinp oport) (terpri oport)) - ((not (equal (car cinp) 'p)) (print cinp oport) - (terpri oport)) - (t (print-prod) (terpri oport))) - (setq cinp (read iport))) - (terpri oport))) - - -(defun print-prod () - (prog nil - (princ "(p " oport) - (print (cadr cinp) oport) (terpri oport) - (setq cinp (cddr cinp)) - (while cinp - (cond ((and (atom (car cinp)) (equal (car cinp) '-->)) - (princ " -->" oport) (terpri oport) - (setq cinp (cdr cinp))) - ((and (atom (car cinp)) (equal (car cinp) '{)) - (princ " " oport) - (print-ce-with-var) (terpri oport)) - ((and (atom (car cinp)) (equal (car cinp) '-)) - (princ " - " oport) - (print (cadr cinp) oport) (terpri oport) - (setq cinp (cddr cinp))) - (t (princ " " oport) - (print (car cinp) oport) (terpri oport) - (setq cinp (cdr cinp))))) - (setq pcount (1+ pcount)) - (princ ")" oport) (terpri oport))) - - -(defun print-ce-with-var () - (prog nil - (while (not (equal (car cinp) '})) - (print (car cinp) oport) (princ " " oport) - (setq cinp (cdr cinp))) - (print (car cinp) oport) - (setq cinp (cdr cinp)))) - - diff --git a/contrib/ops/rubik.ops b/contrib/ops/rubik.ops deleted file mode 100644 index ee615986f3b5aa5b6c76bec50791c75dcbf26af6..0000000000000000000000000000000000000000 --- a/contrib/ops/rubik.ops +++ /dev/null @@ -1,2026 +0,0 @@ - - - -(literalize goal - want - object - number - direction - value - id - seq - status) - -(literalize vodor - right - left - top - bottom - front - posterior - id - status) - -(literalize task-list - task - object - subtask - subtask-object) - -(literalize face - number - block - color) - -(literalize cubie-order - face-num - direction - adj-face-num - block - adj-blk-num) - -(literalize face-relation - front - posterior - right - left - top - bottom) - -(literalize front-face - number - color - id - status) - -(literalize source-face - number - color - ic - id - status) - -(literalize bottom-corner - number - face - color - cubie - id - status) - -(literalize bottom-edge - number - face - color - cubie - id - status) - - - - -(p start - (start) ---> - (remove 1) - (make face ^number 1 ^block 1 ^color blue) - (make face ^number 1 ^block 2 ^color blue) - (make face ^number 1 ^block 3 ^color blue) - (make face ^number 1 ^block 4 ^color blue) - (make face ^number 1 ^block 5 ^color blue) - (make face ^number 1 ^block 6 ^color blue) - (make face ^number 1 ^block 7 ^color blue) - (make face ^number 1 ^block 8 ^color blue) - (make face ^number 1 ^block 9 ^color blue) - (make face ^number 2 ^block 1 ^color red) - (make face ^number 2 ^block 2 ^color red) - (make face ^number 2 ^block 3 ^color red) - (make face ^number 2 ^block 4 ^color red) - (make face ^number 2 ^block 5 ^color red) - (make face ^number 2 ^block 6 ^color red) - (make face ^number 2 ^block 7 ^color red) - (make face ^number 2 ^block 8 ^color red) - (make face ^number 2 ^block 9 ^color red) - (make face ^number 3 ^block 1 ^color green) - (make face ^number 3 ^block 2 ^color green) - (make face ^number 3 ^block 3 ^color green) - (make face ^number 3 ^block 4 ^color green) - (make face ^number 3 ^block 5 ^color green) - (make face ^number 3 ^block 6 ^color green) - (make face ^number 3 ^block 7 ^color green) - (make face ^number 3 ^block 8 ^color green) - (make face ^number 3 ^block 9 ^color green) - (make face ^number 4 ^block 1 ^color white) - (make face ^number 4 ^block 2 ^color white) - (make face ^number 4 ^block 3 ^color white) - (make face ^number 4 ^block 4 ^color white) - (make face ^number 4 ^block 5 ^color white) - (make face ^number 4 ^block 6 ^color white) - (make face ^number 4 ^block 7 ^color white) - (make face ^number 4 ^block 8 ^color white) - (make face ^number 4 ^block 9 ^color white) - (make face ^number 5 ^block 1 ^color yellow) - (make face ^number 5 ^block 2 ^color yellow) - (make face ^number 5 ^block 3 ^color yellow) - (make face ^number 5 ^block 4 ^color yellow) - (make face ^number 5 ^block 5 ^color yellow) - (make face ^number 5 ^block 6 ^color yellow) - (make face ^number 5 ^block 7 ^color yellow) - (make face ^number 5 ^block 8 ^color yellow) - (make face ^number 5 ^block 9 ^color yellow) - (make face ^number 6 ^block 1 ^color orange) - (make face ^number 6 ^block 2 ^color orange) - (make face ^number 6 ^block 3 ^color orange) - (make face ^number 6 ^block 4 ^color orange) - (make face ^number 6 ^block 5 ^color orange) - (make face ^number 6 ^block 6 ^color orange) - (make face ^number 6 ^block 7 ^color orange) - (make face ^number 6 ^block 8 ^color orange) - (make face ^number 6 ^block 9 ^color orange) - (make cubie-order ^face-num 1 ^direction dn - ^adj-face-num 2 ^block 7 ^adj-blk-num 1) - (make cubie-order ^face-num 1 ^direction dn - ^adj-face-num 2 ^block 8 ^adj-blk-num 2) - (make cubie-order ^face-num 1 ^direction dn - ^adj-face-num 2 ^block 9 ^adj-blk-num 3) - (make cubie-order ^face-num 1 ^direction rt - ^adj-face-num 3 ^block 3 ^adj-blk-num 3) - (make cubie-order ^face-num 1 ^direction rt - ^adj-face-num 3 ^block 6 ^adj-blk-num 2) - (make cubie-order ^face-num 1 ^direction rt - ^adj-face-num 3 ^block 9 ^adj-blk-num 1) - (make cubie-order ^face-num 1 ^direction up - ^adj-face-num 4 ^block 1 ^adj-blk-num 3) - (make cubie-order ^face-num 1 ^direction up - ^adj-face-num 4 ^block 2 ^adj-blk-num 2) - (make cubie-order ^face-num 1 ^direction up - ^adj-face-num 4 ^block 3 ^adj-blk-num 1) - (make cubie-order ^face-num 1 ^direction lf - ^adj-face-num 5 ^block 1 ^adj-blk-num 1) - (make cubie-order ^face-num 1 ^direction lf - ^adj-face-num 5 ^block 4 ^adj-blk-num 2) - (make cubie-order ^face-num 1 ^direction lf - ^adj-face-num 5 ^block 7 ^adj-blk-num 3) - (make cubie-order ^face-num 2 ^direction up - ^adj-face-num 1 ^block 1 ^adj-blk-num 7) - (make cubie-order ^face-num 2 ^direction up - ^adj-face-num 1 ^block 2 ^adj-blk-num 8) - (make cubie-order ^face-num 2 ^direction up - ^adj-face-num 1 ^block 3 ^adj-blk-num 9) - (make cubie-order ^face-num 2 ^direction rt - ^adj-face-num 3 ^block 3 ^adj-blk-num 1) - (make cubie-order ^face-num 2 ^direction rt - ^adj-face-num 3 ^block 6 ^adj-blk-num 4) - (make cubie-order ^face-num 2 ^direction rt - ^adj-face-num 3 ^block 9 ^adj-blk-num 7) - (make cubie-order ^face-num 2 ^direction dn - ^adj-face-num 6 ^block 7 ^adj-blk-num 1) - (make cubie-order ^face-num 2 ^direction dn - ^adj-face-num 6 ^block 8 ^adj-blk-num 2) - (make cubie-order ^face-num 2 ^direction dn - ^adj-face-num 6 ^block 9 ^adj-blk-num 3) - (make cubie-order ^face-num 2 ^direction lf - ^adj-face-num 5 ^block 1 ^adj-blk-num 3) - (make cubie-order ^face-num 2 ^direction lf - ^adj-face-num 5 ^block 4 ^adj-blk-num 6) - (make cubie-order ^face-num 2 ^direction lf - ^adj-face-num 5 ^block 7 ^adj-blk-num 9) - (make cubie-order ^face-num 3 ^direction up - ^adj-face-num 1 ^block 1 ^adj-blk-num 9) - (make cubie-order ^face-num 3 ^direction up - ^adj-face-num 1 ^block 2 ^adj-blk-num 6) - (make cubie-order ^face-num 3 ^direction up - ^adj-face-num 1 ^block 3 ^adj-blk-num 3) - (make cubie-order ^face-num 3 ^direction rt - ^adj-face-num 4 ^block 3 ^adj-blk-num 1) - (make cubie-order ^face-num 3 ^direction rt - ^adj-face-num 4 ^block 6 ^adj-blk-num 4) - (make cubie-order ^face-num 3 ^direction rt - ^adj-face-num 4 ^block 9 ^adj-blk-num 7) - (make cubie-order ^face-num 3 ^direction dn - ^adj-face-num 6 ^block 7 ^adj-blk-num 3) - (make cubie-order ^face-num 3 ^direction dn - ^adj-face-num 6 ^block 8 ^adj-blk-num 6) - (make cubie-order ^face-num 3 ^direction dn - ^adj-face-num 6 ^block 9 ^adj-blk-num 9) - (make cubie-order ^face-num 3 ^direction lf - ^adj-face-num 2 ^block 1 ^adj-blk-num 3) - (make cubie-order ^face-num 3 ^direction lf - ^adj-face-num 2 ^block 4 ^adj-blk-num 6) - (make cubie-order ^face-num 3 ^direction lf - ^adj-face-num 2 ^block 7 ^adj-blk-num 9) - (make cubie-order ^face-num 4 ^direction up - ^adj-face-num 1 ^block 1 ^adj-blk-num 3) - (make cubie-order ^face-num 4 ^direction up - ^adj-face-num 1 ^block 2 ^adj-blk-num 2) - (make cubie-order ^face-num 4 ^direction up - ^adj-face-num 1 ^block 3 ^adj-blk-num 1) - (make cubie-order ^face-num 4 ^direction rt - ^adj-face-num 5 ^block 3 ^adj-blk-num 1) - (make cubie-order ^face-num 4 ^direction rt - ^adj-face-num 5 ^block 6 ^adj-blk-num 4) - (make cubie-order ^face-num 4 ^direction rt - ^adj-face-num 5 ^block 9 ^adj-blk-num 7) - (make cubie-order ^face-num 4 ^direction dn - ^adj-face-num 6 ^block 7 ^adj-blk-num 9) - (make cubie-order ^face-num 4 ^direction dn - ^adj-face-num 6 ^block 8 ^adj-blk-num 8) - (make cubie-order ^face-num 4 ^direction dn - ^adj-face-num 6 ^block 9 ^adj-blk-num 7) - (make cubie-order ^face-num 4 ^direction lf - ^adj-face-num 3 ^block 1 ^adj-blk-num 3) - (make cubie-order ^face-num 4 ^direction lf - ^adj-face-num 3 ^block 4 ^adj-blk-num 6) - (make cubie-order ^face-num 4 ^direction lf - ^adj-face-num 3 ^block 7 ^adj-blk-num 9) - (make cubie-order ^face-num 5 ^direction up - ^adj-face-num 1 ^block 1 ^adj-blk-num 1) - (make cubie-order ^face-num 5 ^direction up - ^adj-face-num 1 ^block 2 ^adj-blk-num 4) - (make cubie-order ^face-num 5 ^direction up - ^adj-face-num 1 ^block 3 ^adj-blk-num 7) - (make cubie-order ^face-num 5 ^direction rt - ^adj-face-num 2 ^block 3 ^adj-blk-num 1) - (make cubie-order ^face-num 5 ^direction rt - ^adj-face-num 2 ^block 6 ^adj-blk-num 4) - (make cubie-order ^face-num 5 ^direction rt - ^adj-face-num 2 ^block 9 ^adj-blk-num 7) - (make cubie-order ^face-num 5 ^direction dn - ^adj-face-num 6 ^block 7 ^adj-blk-num 7) - (make cubie-order ^face-num 5 ^direction dn - ^adj-face-num 6 ^block 8 ^adj-blk-num 4) - (make cubie-order ^face-num 5 ^direction dn - ^adj-face-num 6 ^block 9 ^adj-blk-num 1) - (make cubie-order ^face-num 5 ^direction lf - ^adj-face-num 4 ^block 1 ^adj-blk-num 3) - (make cubie-order ^face-num 5 ^direction lf - ^adj-face-num 4 ^block 4 ^adj-blk-num 6) - (make cubie-order ^face-num 5 ^direction lf - ^adj-face-num 4 ^block 7 ^adj-blk-num 9) - (make cubie-order ^face-num 6 ^direction up - ^adj-face-num 2 ^block 1 ^adj-blk-num 7) - (make cubie-order ^face-num 6 ^direction up - ^adj-face-num 2 ^block 2 ^adj-blk-num 8) - (make cubie-order ^face-num 6 ^direction up - ^adj-face-num 2 ^block 3 ^adj-blk-num 9) - (make cubie-order ^face-num 6 ^direction rt - ^adj-face-num 3 ^block 3 ^adj-blk-num 7) - (make cubie-order ^face-num 6 ^direction rt - ^adj-face-num 3 ^block 6 ^adj-blk-num 8) - (make cubie-order ^face-num 6 ^direction rt - ^adj-face-num 3 ^block 9 ^adj-blk-num 9) - (make cubie-order ^face-num 6 ^direction dn - ^adj-face-num 4 ^block 7 ^adj-blk-num 9) - (make cubie-order ^face-num 6 ^direction dn - ^adj-face-num 4 ^block 8 ^adj-blk-num 8) - (make cubie-order ^face-num 6 ^direction dn - ^adj-face-num 4 ^block 9 ^adj-blk-num 7) - (make cubie-order ^face-num 6 ^direction lf - ^adj-face-num 5 ^block 1 ^adj-blk-num 9) - (make cubie-order ^face-num 6 ^direction lf - ^adj-face-num 5 ^block 4 ^adj-blk-num 8) - (make cubie-order ^face-num 6 ^direction lf - ^adj-face-num 5 ^block 7 ^adj-blk-num 7) - (make face-relation ^front 2 ^right 3 ^left 5 - ^top 1 ^bottom 6 ^posterior 4) - (make face-relation ^front 3 ^right 4 ^left 2 - ^top 1 ^bottom 6 ^posterior 5) - (make face-relation ^front 4 ^right 5 ^left 3 - ^top 1 ^bottom 6 ^posterior 2) - (make face-relation ^front 5 ^right 2 ^left 4 - ^top 1 ^bottom 6 ^posterior 3) - (make face-relation ^front 6 ^posterior 1) - (make task-list ^task orient ^object bottom-edge - ^subtask position ^subtask-object bottom-edge) - (make task-list ^task position ^object bottom-edge - ^subtask orient ^subtask-object bottom-corner) - (make task-list ^task orient ^object bottom-corner - ^subtask position ^subtask-object bottom-corner) - (make task-list ^task position ^object bottom-corner - ^subtask orient ^subtask-object vertical-edge) - (make task-list ^task orient ^object vertical-edge - ^subtask position ^subtask-object vertical-edge) - (make task-list ^task position ^object vertical-edge - ^subtask orient ^subtask-object top-corner) - (make task-list ^task orient ^object top-corner - ^subtask position ^subtask-object top-corner) - (make task-list ^task position ^object top-corner - ^subtask orient ^subtask-object top-edge) - (make task-list ^task orient ^object top-edge - ^subtask position ^subtask-object top-edge) - (write (crlf) normal cube order is |:|) - (write (crlf) (tabto 20) top face 1 |:| blue) - (write (crlf) (tabto 20) bottom face 6 |:| orange) - (write (crlf) (tabto 20) front face 2 |:| red) - (write (crlf) (tabto 20) right face 3 |:| green) - (write (crlf) (tabto 20) posterior face 4 |:| white) - (write (crlf) (tabto 20) left face 5 |:| yellow) - (make goal ^want scramble ^object cube ^id 1 ^number nil ^status active)) - -(p scramble*initiate - (goal ^want scramble ^object cube ^id <id> ^number nil ^status active) ---> - (write (crlf) how many scrambling operations >0 shall i perform |?_| ) - (modify 1 ^number (accept))) - -(p scramble*sequence - (goal ^want scramble ^object cube ^id <id> ^number {<n> > 0} - ^status active) ---> - (modify 1 ^number (compute <n> - 1)) - (write (crlf) about which face 1-6 shall i perform this rotation |?_|) - (bind <f> (accept)) - (write (crlf) in which direction pos neg shall i rotate |?_|) - (bind <d> (accept)) - (write (crlf) what size rotation shall i perform 90-180 |?_|) - (bind <v> (accept)) - (make goal ^want rotate ^object face ^number <f> ^direction <d> - ^value <v> ^seq 1 ^status active)) - -(p scramble*exit - (goal ^want scramble ^object cube ^id <id> ^number 0 ^status active) ---> - (remove 1) - (write (crlf) initiating solution |:| (crlf)) - (make goal ^want orient ^object bottom-edge ^id 1 ^status consider)) - - - - -(p sequence-1 - (goal ^want { << orient position >> <w> } ^object <o> - ^id <id> ^status consider) - (task-list ^task <w> ^object <o> ^subtask <st> ^subtask-object <sto>) - -(goal ^want <st> ^object <sto> ^status done) - -(goal ^want rotate ^status active) ---> - (write (crlf) (crlf) suspending task to <w> <o>) - (write (crlf) considering task to <st> <sto>) - (modify 1 ^status pending) - (make goal ^want <st> ^object <sto> ^id (compute <id> + 1) - ^status consider)) - - -(p sequence-2 - (goal ^want { << orient position >> <w> } ^object <o> - ^id <id> ^status consider) - -(task-list ^task <w> ^object <o>) - -(goal ^want rotate ^status active) ---> - (write (crlf) (crlf) initiating task to <w> <o>) - (modify 1 ^status active)) - - -(p sequence-3 - (goal ^want { << orient position >> <w> } ^object <o> - ^id <id> ^status active) - -(goal ^want rotate ^status active) ---> - (write (crlf) (crlf) i find no further tasks to <w> <o>) - (modify 1 ^status done)) - - -(p sequence-4 - (goal ^want { << orient position >> <w> } ^object <o> - ^id <id> ^status pending) - -(goal ^status << active consider >>) - -(goal ^id > <id> ^status pending) ---> - (write (crlf) (crlf) reconsidering task to <w> <o>) - (modify 1 ^status consider)) - -(p sequence-5 - (goal ^want { << orient position >> <w> } ^object <o> - ^id <id> ^status consider) - (task-list ^task <w> ^object <o> ^subtask <st> ^subtask-object <sto>) - (goal ^want <st> ^object <sto> ^status done) - -(goal ^want rotate ^status active) ---> - (write (crlf) (crlf) initiating task to <w> <o>) - (modify 1 ^status active)) - - -(p detect_normal-order - (goal ^want { << orient position >> <w> } ^object <o>) - (face ^number 1 ^block 5 ^color <c1>) - -(face ^number 1 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c1>) - (face ^number 2 ^block 5 ^color <c2>) - -(face ^number 2 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c2>) - (face ^number 3 ^block 5 ^color <c3>) - -(face ^number 3 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c3>) - (face ^number 4 ^block 5 ^color <c4>) - -(face ^number 4 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c4>) - (face ^number 5 ^block 5 ^color <c5>) - -(face ^number 2 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c2>) - (face ^number 6 ^block 5 ^color <c6>) - -(face ^number 6 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c6>) ---> - (write (crlf) i find cube in normal order while attempting to <w> <o>) - (halt)) - - - -(p plus-90 - (goal ^want rotate ^object face ^number <n> ^direction pos - ^value 90 ^id <id> ^seq <seq> ^status active) - -(goal ^want rotate ^object face ^id <id> ^seq < <seq> ^status active) - (face ^number <n> ^block 1 ^color <c1>) - (face ^number <n> ^block 2 ^color <c2>) - (face ^number <n> ^block 3 ^color <c3>) - (face ^number <n> ^block 4 ^color <c4>) - (face ^number <n> ^block 5 ^color <c5>) - (face ^number <n> ^block 6 ^color <c6>) - (face ^number <n> ^block 7 ^color <c7>) - (face ^number <n> ^block 8 ^color <c8>) - (face ^number <n> ^block 9 ^color <c9>) - (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup> - ^block 1 ^adj-blk-num <nup1>) - (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup> - ^block 2 ^adj-blk-num <nup2>) - (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup> - ^block 3 ^adj-blk-num <nup3>) - (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt> - ^block 3 ^adj-blk-num <nrt3>) - (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt> - ^block 6 ^adj-blk-num <nrt6>) - (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt> - ^block 9 ^adj-blk-num <nrt9>) - (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn> - ^block 7 ^adj-blk-num <ndn7>) - (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn> - ^block 8 ^adj-blk-num <ndn8>) - (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn> - ^block 9 ^adj-blk-num <ndn9>) - (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf> - ^block 1 ^adj-blk-num <nlf1>) - (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf> - ^block 4 ^adj-blk-num <nlf4>) - (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf> - ^block 7 ^adj-blk-num <nlf7>) - (face ^number <nrt> ^block <nrt3> ^color <cnrt3>) - (face ^number <nrt> ^block <nrt6> ^color <cnrt6>) - (face ^number <nrt> ^block <nrt9> ^color <cnrt9>) - (face ^number <nlf> ^block <nlf7> ^color <cnlf7>) - (face ^number <nlf> ^block <nlf4> ^color <cnlf4>) - (face ^number <nlf> ^block <nlf1> ^color <cnlf1>) - (face ^number <nup> ^block <nup1> ^color <cnup1>) - (face ^number <nup> ^block <nup2> ^color <cnup2>) - (face ^number <nup> ^block <nup3> ^color <cnup3>) - (face ^number <ndn> ^block <ndn9> ^color <cndn9>) - (face ^number <ndn> ^block <ndn8> ^color <cndn8>) - (face ^number <ndn> ^block <ndn7> ^color <cndn7>) ---> - (write (crlf) rotating face <n> the <c5> face plus 90) - (modify 1 ^status done) - (modify 2 ^color <c7>) - (modify 3 ^color <c4>) - (modify 4 ^color <c1>) - (modify 5 ^color <c8>) - (modify 6 ^color <c5>) - (modify 7 ^color <c2>) - (modify 8. ^color <c9>) - (modify 9. ^color <c6>) - (modify 10. ^color <c3>) - (modify 23. ^color <cnup1>) - (modify 24. ^color <cnup2>) - (modify 25. ^color <cnup3>) - (modify 26. ^color <cndn9>) - (modify 27. ^color <cndn8>) - (modify 28. ^color <cndn7>) - (modify 29. ^color <cnlf7>) - (modify 30. ^color <cnlf4>) - (modify 31. ^color <cnlf1>) - (modify 32. ^color <cnrt3>) - (modify 33. ^color <cnrt6>) - (modify 34. ^color <cnrt9>)) - -(p minus-90 - (goal ^want rotate ^object face ^number <n> ^direction neg - ^value 90 ^id <id> ^seq <seq> ^status active) - -(goal ^want rotate ^object face ^id <id> ^seq < <seq> ^status active) - (face ^number <n> ^block 1 ^color <c1>) - (face ^number <n> ^block 2 ^color <c2>) - (face ^number <n> ^block 3 ^color <c3>) - (face ^number <n> ^block 4 ^color <c4>) - (face ^number <n> ^block 5 ^color <c5>) - (face ^number <n> ^block 6 ^color <c6>) - (face ^number <n> ^block 7 ^color <c7>) - (face ^number <n> ^block 8 ^color <c8>) - (face ^number <n> ^block 9 ^color <c9>) - (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup> - ^block 1 ^adj-blk-num <nup1>) - (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup> - ^block 2 ^adj-blk-num <nup2>) - (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup> - ^block 3 ^adj-blk-num <nup3>) - (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt> - ^block 3 ^adj-blk-num <nrt3>) - (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt> - ^block 6 ^adj-blk-num <nrt6>) - (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt> - ^block 9 ^adj-blk-num <nrt9>) - (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn> - ^block 7 ^adj-blk-num <ndn7>) - (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn> - ^block 8 ^adj-blk-num <ndn8>) - (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn> - ^block 9 ^adj-blk-num <ndn9>) - (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf> - ^block 1 ^adj-blk-num <nlf1>) - (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf> - ^block 4 ^adj-blk-num <nlf4>) - (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf> - ^block 7 ^adj-blk-num <nlf7>) - (face ^number <nrt> ^block <nrt3> ^color <cnrt3>) - (face ^number <nrt> ^block <nrt6> ^color <cnrt6>) - (face ^number <nrt> ^block <nrt9> ^color <cnrt9>) - (face ^number <nlf> ^block <nlf7> ^color <cnlf7>) - (face ^number <nlf> ^block <nlf4> ^color <cnlf4>) - (face ^number <nlf> ^block <nlf1> ^color <cnlf1>) - (face ^number <nup> ^block <nup1> ^color <cnup1>) - (face ^number <nup> ^block <nup2> ^color <cnup2>) - (face ^number <nup> ^block <nup3> ^color <cnup3>) - (face ^number <ndn> ^block <ndn9> ^color <cndn9>) - (face ^number <ndn> ^block <ndn8> ^color <cndn8>) - (face ^number <ndn> ^block <ndn7> ^color <cndn7>) ---> - (write (crlf) rotating face <n> the <c5> face minus 90) - (modify 1 ^status done) - (modify 2 ^color <c3>) - (modify 3 ^color <c6>) - (modify 4 ^color <c9>) - (modify 5 ^color <c2>) - (modify 6 ^color <c5>) - (modify 7 ^color <c8>) - (modify 8. ^color <c1>) - (modify 9. ^color <c4>) - (modify 10. ^color <c7>) - (modify 23. ^color <cndn9>) - (modify 24. ^color <cndn8>) - (modify 25. ^color <cndn7>) - (modify 26. ^color <cnup1>) - (modify 27. ^color <cnup2>) - (modify 28. ^color <cnup3>) - (modify 29. ^color <cnrt3>) - (modify 30. ^color <cnrt6>) - (modify 31. ^color <cnrt9>) - (modify 32. ^color <cnlf7>) - (modify 33. ^color <cnlf4>) - (modify 34. ^color <cnlf1>)) - -(p plus-minus-180 - (goal ^want rotate ^object face ^number <n> - ^direction { << pos neg >> <dir> } ^value 180 ^id <id> ^seq <seq> - ^status active) - -(goal ^want rotate ^object face ^id <id> ^seq < <seq> ^status active) - (face ^number <n> ^block 1 ^color <c1>) - (face ^number <n> ^block 2 ^color <c2>) - (face ^number <n> ^block 3 ^color <c3>) - (face ^number <n> ^block 4 ^color <c4>) - (face ^number <n> ^block 5 ^color <c5>) - (face ^number <n> ^block 6 ^color <c6>) - (face ^number <n> ^block 7 ^color <c7>) - (face ^number <n> ^block 8 ^color <c8>) - (face ^number <n> ^block 9 ^color <c9>) - (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup> - ^block 1 ^adj-blk-num <nup1>) - (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup> - ^block 2 ^adj-blk-num <nup2>) - (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup> - ^block 3 ^adj-blk-num <nup3>) - (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt> - ^block 3 ^adj-blk-num <nrt3>) - (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt> - ^block 6 ^adj-blk-num <nrt6>) - (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt> - ^block 9 ^adj-blk-num <nrt9>) - (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn> - ^block 7 ^adj-blk-num <ndn7>) - (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn> - ^block 8 ^adj-blk-num <ndn8>) - (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn> - ^block 9 ^adj-blk-num <ndn9>) - (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf> - ^block 1 ^adj-blk-num <nlf1>) - (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf> - ^block 4 ^adj-blk-num <nlf4>) - (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf> - ^block 7 ^adj-blk-num <nlf7>) - (face ^number <nrt> ^block <nrt3> ^color <cnrt3>) - (face ^number <nrt> ^block <nrt6> ^color <cnrt6>) - (face ^number <nrt> ^block <nrt9> ^color <cnrt9>) - (face ^number <nlf> ^block <nlf7> ^color <cnlf7>) - (face ^number <nlf> ^block <nlf4> ^color <cnlf4>) - (face ^number <nlf> ^block <nlf1> ^color <cnlf1>) - (face ^number <nup> ^block <nup1> ^color <cnup1>) - (face ^number <nup> ^block <nup2> ^color <cnup2>) - (face ^number <nup> ^block <nup3> ^color <cnup3>) - (face ^number <ndn> ^block <ndn9> ^color <cndn9>) - (face ^number <ndn> ^block <ndn8> ^color <cndn8>) - (face ^number <ndn> ^block <ndn7> ^color <cndn7>) ---> - (write (crlf) rotating face <n> the <c5> face <dir> 180) - (modify 1 ^status done) - (modify 2 ^color <c9>) - (modify 3 ^color <c8>) - (modify 4 ^color <c7>) - (modify 5 ^color <c6>) - (modify 6 ^color <c5>) - (modify 7 ^color <c4>) - (modify 8. ^color <c3>) - (modify 9. ^color <c2>) - (modify 10. ^color <c1>) - (modify 23. ^color <cnlf7>) - (modify 24. ^color <cnlf4>) - (modify 25. ^color <cnlf1>) - (modify 26. ^color <cnrt3>) - (modify 27. ^color <cnrt6>) - (modify 28. ^color <cnrt9>) - (modify 29. ^color <cndn9>) - (modify 30. ^color <cndn8>) - (modify 31. ^color <cndn7>) - (modify 32. ^color <cnup1>) - (modify 33. ^color <cnup2>) - (modify 34. ^color <cnup3>)) - - - -(p position_top_edge*get_defining_faces - (goal ^want position ^object top-edge ^id <id> ^status active) - (face ^number 1 ^block 5 ^color <ct>) - (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>) - -(front-face ^status active) - -(front-face ^number <nf> ^id <id> ^status used) - (face ^number <n1> ^block { << 2 4 6 8 >> <b1> } ^color <ct>) - (face ^number { <n2> <> <n1> } ^block { << 2 4 6 8 >> <b2> } ^color <cf>) - (cubie-order ^face-num <n1> ^adj-face-num <n2> - ^block <b1> ^adj-blk-num <b2>) ---> - (make front-face ^number <nf> ^color <cf> ^id <id> ^status active) - (make source-face ^number <n1> ^color <ct> ^id <id> ^status active) - (make source-face ^number <n2> ^color <cf> ^id <id> ^status active)) - -(p position_top_edge*desired_cubie_in_position - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number 1 ^id <id> ^status active) - (face-relation ^front <nf> ^top 1) ---> - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - - -(p rt-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <nr> ^id <id> ^status active) - (source-face ^number {<nt> <> <nr>} ^id <id> ^status active) - (face-relation ^front <nf> ^right <nr>) ---> - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p pt-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <np> ^id <id> ^status active) - (source-face ^number {<nt> <> <np>} ^id <id> ^status active) - (face-relation ^front <nf> ^posterior <np> ^right <nr> ^top <nt>) ---> - (make goal ^want rotate ^object face ^number <nt> ^direction pos - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nt> ^direction neg - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 4 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p lt-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <nl> ^id <id> ^status active) - (source-face ^number {<nt> <> <nl>} ^id <id> ^status active) - (face-relation ^front <nf> ^left <nl> ^top <nt>) ---> - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 2 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p fr-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <nf> ^id <id> ^status active) - (source-face ^number {<nr> <> <nf>} ^id <id> ^status active) - (face-relation ^front <nf> ^right <nr>) ---> - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p pr-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <np> ^id <id> ^status active) - (source-face ^number {<nr> <> <np>} ^id <id> ^status active) - (face-relation ^front <nf> ^posterior <np> ^right <nr>) ---> - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 180 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 180 ^id <id> ^seq 3 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p lp-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <nl> ^id <id> ^status active) - (source-face ^number {<np> <> <nl>} ^id <id> ^status active) - (face-relation ^front <nf> ^posterior <np> ^left <nl>) ---> - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 180 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 180 ^id <id> ^seq 3 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p fl-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <nf> ^id <id> ^status active) - (source-face ^number {<nl> <> <nf>} ^id <id> ^status active) - (face-relation ^front <nf> ^left <nl>) ---> - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 1 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p bf-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <nb> ^id <id> ^status active) - (source-face ^number {<nf> <> <nb>} ^id <id> ^status active) - (face-relation ^front <nf> ^bottom <nb>) ---> - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 180 ^id <id> ^seq 1 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p br-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <nb> ^id <id> ^status active) - (source-face ^number {<nr> <> <nb>} ^id <id> ^status active) - (face-relation ^front <nf> ^right <nr> ^bottom <nb>) ---> - (make goal ^want rotate ^object face ^number <nb> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 180 ^id <id> ^seq 2 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p bp-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <nb> ^id <id> ^status active) - (source-face ^number {<np> <> <nb>} ^id <id> ^status active) - (face-relation ^front <nf> ^posterior <np> ^bottom <nb>) ---> - (make goal ^want rotate ^object face ^number <nb> ^direction pos - ^value 180 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 180 ^id <id> ^seq 2 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p bl-to-ft - (goal ^want position ^object top-edge ^id <id> ^status active) - (front-face ^number <nf> ^id <id> ^status active) - (source-face ^number <nb> ^id <id> ^status active) - (source-face ^number {<nl> <> <nb>} ^id <id> ^status active) - (face-relation ^front <nf> ^left <nl> ^bottom <nb>) ---> - (make goal ^want rotate ^object face ^number <nb> ^direction pos - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 180 ^id <id> ^seq 2 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p orient_top_edge - (goal ^want orient ^object top-edge ^id <id> ^status active) - (face ^number 1 ^block 5 ^color <ct>) - (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>) - (face ^number 1 ^block { << 2 4 6 8 >> <b> } ^color <cf>) - (face ^number <nf> ^block 2 ^color <ct>) - (cubie-order ^face-num <nf> ^direction up - ^adj-face-num 1 ^block 2 ^adj-blk-num <b>) - (face-relation ^front <nf> ^top 1 ^left <nl>) ---> - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 1 ^direction pos - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number 1 ^direction neg - ^value 90 ^id <id> ^seq 4 ^status active)) - -(p position_top_corner*get_defining_faces - (goal ^want position ^object top-corner ^id <id> ^status active) - -(front-face ^id <id> ^status active) - -(source-face ^id <id> ^status active) - (face ^number 1 ^block 5 ^color <ct>) - (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>) - -(front-face ^number <nf> ^id <id> ^status used) - (face ^number { <nr> <> <nf> <> 1 <> 6 } ^block 5 ^color <cr>) - (face-relation ^front <nf> ^right <nr> ^top 1) - (face ^number <n1> ^block { << 1 3 7 9 >> <b1> } ^color <ct>) - (face ^number { <n2> <> <n1> } ^block { << 1 3 7 9 >> <b2> } ^color <cf>) - (face ^number { <n3> <> <n2> } ^block { << 1 3 7 9 >> <b3> } ^color <cr>) - (cubie-order ^face-num <n1> ^adj-face-num <n2> ^block <b1> - ^adj-blk-num <b2>) - (cubie-order ^face-num <n1> ^adj-face-num <n3> ^block <b1> - ^adj-blk-num <b3>) - (cubie-order ^face-num <n2> ^adj-face-num <n3> ^block <b2> - ^adj-blk-num <b3>) ---> - (make front-face ^number <nf> ^color <cf> ^id <id> ^status active) - (make source-face ^number <n1> ^color <ct> ^id <id> ^status active) - (make source-face ^number <n2> ^color <cf> ^id <id> ^status active) - (make source-face ^number <n3> ^color <cr> ^id <id> ^status active)) - -(p position_top_corner*desired_cubie_in_position - (goal ^want position ^object top-corner ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nt> <> <nf> <> 6} ^id <id> ^status active) - (source-face ^number {<nr> <> <nt> <> <nf> <> 6} ^id <id> ^status active) - (face-relation ^front <nf> ^right <nr> ^top <nt>) ---> - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used) - (modify 5 ^status used)) - -(p position_top_corner*desired_cubie_on_left_front_top - (goal ^want position ^object top-corner ^id <id> ^status active) - (front-face ^number {<n3> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number 1 ^id <id> ^status active) - (source-face ^number {<n2> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<n3> <> <n2> <> 1 <> 6} ^id <id> ^status active) - (face-relation ^front {<n2> <> 1 <> 6} ^posterior <n4> ^right <n3> ^top 1) ---> - (make goal ^want rotate ^object face ^number <n3> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <n3> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number <n4> ^direction neg - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number <n4> ^direction pos - ^value 90 ^id <id> ^seq 7 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used) - (modify 5 ^status used)) - -(p position_top_corner*desired_cubie_on_top_right_posterior - (goal ^want position ^object top-corner ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number 1 ^id <id> ^status active) - (source-face ^number {<n2> <> <nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<n3> <> <n2> <> 1 <> 6} ^id <id> ^status active) - (face-relation ^front {<n2> <> 1 <> 6} ^right {<n3> <> 1 <> 6} ^top 1) - (face-relation ^front {<nf> <> 1 <> 6} ^right {<n2> <> 1 <> 6} ^top 1) ---> - (make goal ^want rotate ^object face ^number <n3> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <n3> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <n2> ^direction neg - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <n2> ^direction pos - ^value 90 ^id <id> ^seq 6 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used) - (modify 5 ^status used)) - -(p position_top_corner*desired_cubie_on_top_left_posterior - (goal ^want position ^object top-corner ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number 1 ^id <id> ^status active) - (source-face ^number {<n2> <> <nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<n3> <> <n2> <> 1 <> 6} ^id <id> ^status active) - (face-relation ^front {<n2> <> <nf>} ^right {<n3> <> <nf>} ^top 1) - (face-relation ^front <nf> ^right <n4> ^left <n3> ^top 1) ---> - (make goal ^want rotate ^object face ^number <n3> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <n3> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <n4> ^direction neg - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <n4> ^direction pos - ^value 90 ^id <id> ^seq 6 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used) - (modify 5 ^status used)) - -(p position_top_corner*desired_cubie_under_desired_position - (goal ^want position ^object top-corner ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nr> <> <nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number 6 ^id <id> ^status active) - (face-relation ^front <nf> ^right <nr> ^bottom 6) ---> - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used) - (modify 5 ^status used)) - -(p position_top_corner*desired_cubie_on_bottom_left_front - (goal ^want position ^object top-corner ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nl> <> <nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number 6 ^id <id> ^status active) - (face-relation ^front <nl> ^posterior <np> ^right <nf> ^bottom 6) ---> - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <np> ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <np> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used) - (modify 5 ^status used)) - -(p position_top_corner*desired_cubie_on_bottom_left_posterior - (goal ^want position ^object top-corner ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nl> <> <nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<np> <> <nl> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number 6 ^id <id> ^status active) - (face-relation ^front <nf> ^posterior <np> ^right <nr> - ^left <nl> ^bottom 6) ---> - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used) - (modify 5 ^status used)) - -(p position_top_corner*desired_cubie_on_bottom_right_posterior - (goal ^want position ^object top-corner ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nr> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<np> <> <nr> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number 6 ^id <id> ^status active) - (face-relation ^front <nf> ^posterior <np> ^right <nr> ^bottom 6) ---> - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used) - (modify 5 ^status used)) - -(p orient_top_corner - (goal ^want orient ^object top-corner ^id <id> ^status active) - (face ^number 1 ^block 5 ^color <ct>) - (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>) - (face ^number { <nr> <> <nf> <> 1 <> 6 } ^block 5 ^color <cr>) - (face-relation ^front <nf> ^right <nr> ^top 1 ^bottom 6) - (face ^number <nf> ^block 3 ^color <> <cf>) ---> - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 6 ^status active)) - -(p position_vertical_edge*get_defining_faces - (goal ^want position ^object vertical-edge ^id <id> ^status active) - -(source-face ^id <id> ^status active) - (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>) - -(front-face ^number <nf> ^id <id> ^status used) - (face ^number { <nr> <> <nf> <> 1 <> 6 } ^block 5 ^color <cr>) - (face-relation ^front <nf> ^right <nr> ^top 1 ^bottom 6) - (face ^number {<n1> <> 1} ^block { << 2 4 6 8 >> <b1> } ^color <cf>) - (face ^number {<n2> <> <n1> <> 1} ^block { << 2 4 6 8 >> <b2> } - ^color <cr>) - (cubie-order ^face-num <n1> ^adj-face-num <n2> - ^block <b1> ^adj-blk-num <b2>) ---> - (make front-face ^number <nf> ^color <cf> ^id <id> ^status active) - (make source-face ^number <n1> ^color <cf> ^id <id> ^status active) - (make source-face ^number <n2> ^color <cr> ^id <id> ^status active)) - -(p position_vertical_edge*desired_cube_in_position - (goal ^want position ^object vertical-edge ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nr> <> <nf> <> 1 <> 6} ^id <id> ^status active) - (face-relation ^front <nf> ^right <nr> ^top 1) ---> - (modify 2 ^status used) - (modify 3 ^status used) - (modify 4 ^status used)) - -(p position_vertical_edge*fr-to-bp - (goal ^want position ^object vertical-edge ^id <id> ^status active) - (front-face ^number {<n1> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number {<nr> <> <nf> <> 1 <> 6} ^id <id> - ^status active) - (face-relation ^front <nf> ^posterior <np> ^right <nr> ^bottom 6) - -(face-relation ^front <n1> ^right <nr> ^bottom 6) ---> - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 7 ^status active) - (modify 3 ^number 6) - (modify 4 ^number <np>)) - -(p position_vertical_edge*try_bottom_rotation - (goal ^want position ^object vertical-edge ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (source-face ^number { << 2 3 4 5 >> <ns> } ^color <cs> - ^id <id>^status active) - (face ^number <ns> ^block 5 ^color <> <cs>) - (source-face ^number 6 ^id <id> ^status active) - (face-relation ^front <ns> ^right <nsr> ^bottom 6) ---> - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 1 ^status active) - (modify 3 ^number <nsr>)) - -(p position_vertical_edge*match_on_f-face - (goal ^want position ^object vertical-edge ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (face-relation ^front <nf> ^right <nr> ^bottom 6) - (face ^number <nf> ^block 5 ^color <cf>) - (face ^number <nf> ^block 8 ^color <cf>) - (face ^number <nr> ^block 5 ^color <cr>) - (source-face ^number {<nf> <> 1 <> 6} ^color <cf> ^id <id> ^status active) - (source-face ^number 6 ^color <cr> ^id <id> ^status active) ---> - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 8 ^status active) - (modify 2 ^status used) - (modify 7 ^status used) - (modify 8 ^status used)) - -(p position_vertical_edge*match_on_r-face - (goal ^want position ^object vertical-edge ^id <id> ^status active) - (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active) - (face-relation ^front <nf> ^right <nr> ^bottom 6) - (face ^number <nf> ^block 5 ^color <cf>) - (face ^number <nr> ^block 5 ^color <cr>) - (face ^number <nr> ^block 8 ^color <cr>) - (source-face ^number {<nr> <> 1 <> 6} ^color <cr> ^id <id> ^status active) - (source-face ^number 6 ^color <cf> ^id <id> ^status active) ---> - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 8 ^status active) - (modify 2 ^status used) - (modify 7 ^status used) - (modify 8 ^status used)) - -(p orient_vertical_edge - (goal ^want orient ^object vertical-edge ^id <id> ^status active) - (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>) - (face ^number { <nr> <> <nf> <> 1 <> 6 } ^block 5 ^color <cr>) - (face ^number <nf> ^block 6 ^color <cr>) - (face ^number <nr> ^block 4 ^color <cf>) - (cubie-order ^face-num <nf> ^direction rt - ^adj-face-num <nr> ^block 6 ^adj-blk-num 4) - (face-relation ^front <nf> ^top 1 ^right <nr>) ---> - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 8 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 9 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 10 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 11 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 12 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 13 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 14 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 15 ^status active)) - -(p position_bottom_corner - (goal ^want position ^object bottom-corner ^id <id> ^status active) - -(bottom-corner ^id <id> ^status << active done >>) - -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active) - (face ^number 2 ^block 9 ^color <c29>) - (face ^number 3 ^block 7 ^color <c37>) - (cubie-order ^face-num 2 ^direction dn ^adj-face-num 6 - ^block 9 ^adj-blk-num <blk269>) - (face ^number 6 ^block <blk269> ^color <c269>) - (face ^number 3 ^block 9 ^color <c39>) - (face ^number 4 ^block 7 ^color <c47>) - (cubie-order ^face-num 3 ^direction dn ^adj-face-num 6 - ^block 9 ^adj-blk-num <blk369>) - (face ^number 6 ^block <blk369> ^color <c369>) - (face ^number 4 ^block 9 ^color <c49>) - (face ^number 5 ^block 7 ^color <c57>) - (cubie-order ^face-num 4 ^direction dn ^adj-face-num 6 - ^block 9 ^adj-blk-num <blk469>) - (face ^number 6 ^block <blk469> ^color <c469>) - (face ^number 5 ^block 9 ^color <c59>) - (face ^number 2 ^block 7 ^color <c27>) - (cubie-order ^face-num 5 ^direction dn ^adj-face-num 6 - ^block 9 ^adj-blk-num <blk569>) - (face ^number 6 ^block <blk569> ^color <c569>) ---> - (make bottom-corner ^number 1 ^face 2 ^color <c29> - ^id <id> ^status active) - (make bottom-corner ^number 1 ^face 3 ^color <c37> - ^id <id> ^status active) - (make bottom-corner ^number 1 ^face 6 ^color <c269> - ^id <id> ^status active) - (make bottom-corner ^number 2 ^face 3 ^color <c39> - ^id <id> ^status active) - (make bottom-corner ^number 2 ^face 4 ^color <c47> - ^id <id> ^status active) - (make bottom-corner ^number 2 ^face 6 ^color <c369> - ^id <id> ^status active) - (make bottom-corner ^number 3 ^face 4 ^color <c49> - ^id <id> ^status active) - (make bottom-corner ^number 3 ^face 5 ^color <c57> - ^id <id> ^status active) - (make bottom-corner ^number 3 ^face 6 ^color <c469> - ^id <id> ^status active) - (make bottom-corner ^number 4 ^face 5 ^color <c59> - ^id <id> ^status active) - (make bottom-corner ^number 4 ^face 2 ^color <c27> - ^id <id> ^status active) - (make bottom-corner ^number 4 ^face 6 ^color <c569> - ^id <id> ^status active)) - -(p position_bottom_corner*find_no_match - (goal ^want position ^object bottom-corner ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active) - -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active) - (bottom-corner ^number 1 ^face 2 ^id <id> ^status active) ---> - (make goal ^want clean-up ^object bottom-corner ^id <id> ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 1 ^status active)) - -(p position_bottom_corner*clean_up_bottom_corner - (goal ^want position ^object bottom-corner ^id <id> ^status active) - (goal ^want clean-up ^object bottom-corner ^id <id> ^status active) - -(goal ^want rotate ^object face ^id <id> ^status active) - (bottom-corner ^id <id> ^status active) ---> - (modify 3 ^status used)) - -(p position_bottom_corner*clean_up_bottom_corner*exit - (goal ^want position ^object bottom-corner ^id <id> ^status active) - (goal ^want clean-up ^object bottom-corner ^id <id> ^status active) - -(goal ^want rotate ^object face ^id <id> ^status active) - -(bottom-corner ^id <id> ^status active) ---> - (remove 2)) - -(p position_bottom_corner*find_one_match - (goal ^want position ^object bottom-corner ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active) - -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active) - -(bottom-corner ^id <id> ^status done) - (face ^number <nf> ^block 5 ^color <cf>) - (face ^number <nr> ^block 5 ^color <cr>) - (face ^number <nb> ^block 5 ^color <cb>) - (face-relation ^front <nf> ^right <nr> ^bottom <nb>) - (bottom-corner ^number <n1> ^color <cf> ^status active) - (bottom-corner ^number <n1> ^color <cr> ^status active) - (bottom-corner ^number <n1> ^color <cb> ^status active) - (bottom-corner ^number <n1> ^face <nf> ^status active) - (bottom-corner ^number <n1> ^face <nr> ^status active) - (bottom-corner ^number <n1> ^face <nb> ^status active) ---> - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want clean-up ^object bottom-corner ^id <id> ^status active)) - -(p position_bottom_corner*exchange_two_adjacent - (goal ^want position ^object bottom-corner ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active) - -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active) - -(bottom-corner ^id <id> ^status done) - (face ^number <nf> ^block 5 ^color <cf>) - (face ^number <nl> ^block 5 ^color <cl>) - (face ^number <nb> ^block 5 ^color <cb>) - (face-relation ^front <nf> ^posterior <np> ^left <nl> ^right <nr> - ^bottom <nb>) - (bottom-corner ^number <n1> ^color <cf> ^status active) - (bottom-corner ^number <n1> ^color <cl> ^status active) - (bottom-corner ^number <n1> ^color <cb> ^status active) - (bottom-corner ^number <n1> ^face <nf> ^status active) - (bottom-corner ^number <n1> ^face <nl> ^status active) - (bottom-corner ^number <n1> ^face <nb> ^status active) - (face ^number <nf> ^block 5 ^color <cf>) - (face ^number <nr> ^block 5 ^color <cr>) - (bottom-corner ^number {<n2> <> <n1>} ^color <cf> ^status active) - (bottom-corner ^number <n2> ^color <cr> ^status active) - (bottom-corner ^number <n2> ^color <cb> ^status active) - (bottom-corner ^number <n2> ^face <nf> ^status active) - (bottom-corner ^number <n2> ^face <nr> ^status active) - (bottom-corner ^number <n2> ^face <nb> ^status active) ---> - (make bottom-corner ^id <id> ^status done) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <np> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <np> ^direction neg - ^value 90 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 8 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 9 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 10 ^status active) - (make goal ^want clean-up ^object bottom-corner ^id <id> ^status active)) - -(p position_bottom_corner*exchange_two_diagonal - (goal ^want position ^object bottom-corner ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active) - -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active) - -(bottom-corner ^id <id> ^status done) - (face ^number <nf> ^block 5 ^color <cf>) - (face ^number <nl> ^block 5 ^color <cl>) - (face ^number <nb> ^block 5 ^color <cb>) - (face-relation ^front <nf> ^posterior <np> ^left <nl> ^right <nr> - ^bottom <nb>) - (bottom-corner ^number <n1> ^color <cf> ^status active) - (bottom-corner ^number <n1> ^color <cl> ^status active) - (bottom-corner ^number <n1> ^color <cb> ^status active) - (bottom-corner ^number <n1> ^face <nf> ^status active) - (bottom-corner ^number <n1> ^face <nl> ^status active) - (bottom-corner ^number <n1> ^face <nb> ^status active) - (face ^number <nr> ^block 5 ^color <cr>) - (face ^number <np> ^block 5 ^color <cp>) - (face-relation ^front <nr> ^right <np> ^bottom <nb>) - (bottom-corner ^number {<n2> > <n1>} ^color <cr> ^status active) - (bottom-corner ^number <n2> ^color <cp> ^status active) - (bottom-corner ^number <n2> ^color <cb> ^status active) - (bottom-corner ^number <n2> ^face <nr> ^status active) - (bottom-corner ^number <n2> ^face <np> ^status active) - (bottom-corner ^number <n2> ^face <nb> ^status active) ---> - (make bottom-corner ^id <id> ^status done) - (make goal ^want rotate ^object face ^number <np> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <np> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number <np> ^direction neg - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 8 ^status active) - (make goal ^want rotate ^object face ^number <np> ^direction pos - ^value 90 ^id <id> ^seq 9 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 10 ^status active) - (make goal ^want clean-up ^object bottom-corner ^id <id> ^status active)) - -(p position_bottom_corner*match_four - (goal ^want position ^object bottom-corner ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active) - -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active) - -(bottom-corner ^id <id> ^status done) - (face ^number <n1f> ^block 5 ^color <c1f>) - (face ^number <n1r> ^block 5 ^color <c1r>) - (face ^number <nb> ^block 5 ^color <c1b>) - (face-relation ^front <n1f> ^right <n1r> ^bottom <nb>) - (bottom-corner ^number 1 ^color <c1f> ^status active) - (bottom-corner ^number 1 ^color <c1r> ^status active) - (bottom-corner ^number 1 ^color <c1b> ^status active) - (bottom-corner ^number 1 ^face <n1f> ^status active) - (bottom-corner ^number 1 ^face <n1r> ^status active) - (bottom-corner ^number 1 ^face <nb> ^status active) - (face ^number <n2f> ^block 5 ^color <c2f>) - (face ^number <n2r> ^block 5 ^color <c2r>) - (face-relation ^front <n2f> ^right <n2r> ^bottom <nb>) - (bottom-corner ^number 2 ^color <c2f> ^status active) - (bottom-corner ^number 2 ^color <c2r> ^status active) - (bottom-corner ^number 2 ^color <c2b> ^status active) - (bottom-corner ^number 2 ^face <n2f> ^status active) - (bottom-corner ^number 2 ^face <n2r> ^status active) - (bottom-corner ^number 2 ^face <nb> ^status active) - (face ^number <n3f> ^block 5 ^color <c3f>) - (face ^number <n3r> ^block 5 ^color <c3r>) - (face-relation ^front <n3f> ^right <n3r> ^bottom <nb>) - (bottom-corner ^number 3 ^color <c3f> ^status active) - (bottom-corner ^number 3 ^color <c3r> ^status active) - (bottom-corner ^number 3 ^color <c3b> ^status active) - (bottom-corner ^number 3 ^face <n3f> ^status active) - (bottom-corner ^number 3 ^face <n3r> ^status active) - (bottom-corner ^number 3 ^face <nb> ^status active) - (face ^number <n4f> ^block 5 ^color <c4f>) - (face ^number <n4r> ^block 5 ^color <c4r>) - (face-relation ^front <n4f> ^right <n4r> ^bottom <nb>) - (bottom-corner ^number 4 ^color <c4f> ^status active) - (bottom-corner ^number 4 ^color <c4r> ^status active) - (bottom-corner ^number 4 ^color <c4b> ^status active) - (bottom-corner ^number 4 ^face <n4f> ^status active) - (bottom-corner ^number 4 ^face <n4r> ^status active) - (bottom-corner ^number 4 ^face <nb> ^status active) ---> - (make bottom-corner ^id <id> ^status done) - (modify 6 ^status used) - (modify 7 ^status used) - (modify 8 ^status used) - (modify 15 ^status used) - (modify 16 ^status used) - (modify 17 ^status used) - (modify 24 ^status used) - (modify 25 ^status used) - (modify 26 ^status used) - (modify 33 ^status used) - (modify 34 ^status used) - (modify 35 ^status used)) - -(p orient_bottom_corner*bc1 - (goal ^want orient ^object bottom-corner ^id <id> ^status active) - (face ^number 6 ^block 5 ^color <cb>) - (face ^number <nf> ^block 9 ^color <cb>) - (face ^number <nr> ^block 9 ^color <cb>) - (face ^number <np> ^block 9 ^color <cb>) - (cubie-order ^face-num <nf> ^direction dn ^adj-face-num 6 - ^block 7 ^adj-blk-num <abn>) - (face ^number 6 ^block <abn> ^color <cb>) - (face-relation ^front <nf> ^right <nr> ^posterior <np> - ^top 1 ^bottom 6) ---> - (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active)) - -(p orient_bottom_corner*bc2 - (goal ^want orient ^object bottom-corner ^id <id> ^status active) - (face ^number 6 ^block 5 ^color <cb>) - (face ^number <nr> ^block 7 ^color <cb>) - (face ^number <np> ^block 7 ^color <cb>) - (face ^number <nl> ^block 7 ^color <cb>) - (cubie-order ^face-num <nl> ^direction dn ^adj-face-num 6 - ^block 9 ^adj-blk-num <abn>) - (face ^number 6 ^block <abn> ^color <cb>) - (face-relation ^front <nf> ^right <nr> ^left <nl> ^posterior <np> - ^top 1 ^bottom 6) ---> - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 8 ^status active)) - -(p orient_bottom_corner*bc3 - (goal ^want orient ^object bottom-corner ^id <id> ^status active) - (face ^number 6 ^block 5 ^color <cb>) - (face ^number <nr> ^block 7 ^color <cb>) - (face ^number <np> ^block 7 ^color <cb>) - (face ^number <np> ^block 9 ^color <cb>) - (face ^number <nl> ^block 9 ^color <cb>) - (face-relation ^front <nf> ^right <nr> ^left <nl> ^posterior <np> - ^top 1 ^bottom 6) ---> - (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active)) - -(p orient_bottom_corner*bc4 - (goal ^want orient ^object bottom-corner ^id <id> ^status active) - (face ^number 6 ^block 5 ^color <cb>) - (face ^number <nf> ^block 7 ^color <cb>) - (face ^number <np> ^block 9 ^color <cb>) - (face-relation ^front <nf> ^right <nr> ^posterior <np> - ^top 1 ^bottom 6) - (cubie-order ^face-num <nf> ^direction dn ^adj-face-num 6 - ^block 9 ^adj-blk-num <abn1>) - (face ^number 6 ^block <abn1> ^color <cb>) - (cubie-order ^face-num <np> ^direction dn ^adj-face-num 6 - ^block 7 ^adj-blk-num <abn2>) - (face ^number 6 ^block <abn2> ^color <cb>) ---> - (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active)) - -(p orient_bottom_corner*bc5 - (goal ^want orient ^object bottom-corner ^id <id> ^status active) - (face ^number 6 ^block 5 ^color <cb>) - (face ^number <nf> ^block 7 ^color <cb>) - (face ^number <nf> ^block 9 ^color <cb>) - (face-relation ^front <nf> ^right <nr> ^posterior <np> - ^top 1 ^bottom 6) - (cubie-order ^face-num <np> ^direction dn ^adj-face-num 6 - ^block 7 ^adj-blk-num <abn1>) - (face ^number 6 ^block <abn1> ^color <cb>) - (cubie-order ^face-num <np> ^direction dn ^adj-face-num 6 - ^block 9 ^adj-blk-num <abn2>) - (face ^number 6 ^block <abn2> ^color <cb>) ---> - (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active)) - -(p orient_bottom_corner*bc6 - (goal ^want orient ^object bottom-corner ^id <id> ^status active) - (face ^number 6 ^block 5 ^color <cb>) - (face ^number <nf> ^block 7 ^color <cb>) - (face ^number <nr> ^block 9 ^color <cb>) - (face-relation ^front <nf> ^right <nr> ^posterior <np> - ^top 1 ^bottom 6) - (cubie-order ^face-num <nf> ^direction dn ^adj-face-num 6 - ^block 9 ^adj-blk-num <abn1>) - (face ^number 6 ^block <abn1> ^color <cb>) - (cubie-order ^face-num <np> ^direction dn ^adj-face-num 6 - ^block 9 ^adj-blk-num <abn2>) - (face ^number 6 ^block <abn2> ^color <cb>) ---> - (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active)) - -(p orient_bottom_corner*bc7 - (goal ^want orient ^object bottom-corner ^id <id> ^status active) - (face ^number 6 ^block 5 ^color <cb>) - (face ^number <nr> ^block 7 ^color <cb>) - (face ^number <nr> ^block 9 ^color <cb>) - (face ^number <nl> ^block 7 ^color <cb>) - (face ^number <nl> ^block 9 ^color <cb>) - (face-relation ^front <nf> ^right <nr> ^left <nl> ^posterior <np> - ^top 1 ^bottom 6) ---> - (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active)) - -(p orient_bottom_corner*rotate_utility - (goal ^want orient ^object bottom-corner ^id <id> ^status active) - (vodor ^right <nr> ^bottom 6 ^id <id> ^status active) ---> - (modify 2 ^status used) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction neg - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number 6 ^direction pos - ^value 180 ^id <id> ^seq 8 ^status active)) - -(p position_orient_bottom_edge*make_bottom_edges - (goal ^want << position orient >> ^object bottom-edge ^id <id> - ^status active) - -(bottom-edge ^id <id> ^status << active done >>) - -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active) - (face ^number 2 ^block 8 ^color <c28>) - (cubie-order ^face-num 2 ^direction dn ^adj-face-num 6 - ^block 8 ^adj-blk-num <blk268>) - (face ^number 6 ^block <blk268> ^color <c268>) - (face ^number 3 ^block 8 ^color <c38>) - (cubie-order ^face-num 3 ^direction dn ^adj-face-num 6 - ^block 8 ^adj-blk-num <blk368>) - (face ^number 6 ^block <blk368> ^color <c368>) - (face ^number 4 ^block 8 ^color <c48>) - (cubie-order ^face-num 4 ^direction dn ^adj-face-num 6 - ^block 8 ^adj-blk-num <blk468>) - (face ^number 6 ^block <blk468> ^color <c468>) - (face ^number 5 ^block 8 ^color <c58>) - (cubie-order ^face-num 5 ^direction dn ^adj-face-num 6 - ^block 8 ^adj-blk-num <blk568>) - (face ^number 6 ^block <blk568> ^color <c568>) ---> - (make bottom-edge ^number 1 ^face 2 ^color <c28> - ^id <id> ^status active) - (make bottom-edge ^number 1 ^face 6 ^color <c268> - ^id <id> ^status active) - (make bottom-edge ^number 2 ^face 3 ^color <c38> - ^id <id> ^status active) - (make bottom-edge ^number 2 ^face 6 ^color <c368> - ^id <id> ^status active) - (make bottom-edge ^number 3 ^face 4 ^color <c48> - ^id <id> ^status active) - (make bottom-edge ^number 3 ^face 6 ^color <c468> - ^id <id> ^status active) - (make bottom-edge ^number 4 ^face 5 ^color <c58> - ^id <id> ^status active) - (make bottom-edge ^number 4 ^face 6 ^color <c568> - ^id <id> ^status active)) - -(p position_bottom_edge*find_no_match - (goal ^want position ^object bottom-edge ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active) - -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active) - (bottom-edge ^number 1 ^face 2 ^id <id> ^status active) ---> - (make goal ^want clean-up ^object bottom-edge ^id <id> ^status active) - (make vodor ^right 4 ^left 2 ^front 3 ^bottom 6 ^id <id> - ^status active)) - -(p position_bottom_edge*clean_up_bottom_edge - (goal ^want position ^object bottom-edge ^id <id> ^status active) - (goal ^want clean-up ^object bottom-edge ^id <id> ^status active) - -(goal ^want rotate ^object face ^id <id> ^status active) - (bottom-edge ^id <id> ^status active) ---> - (modify 3 ^status used)) - -(p position_bottom_edge*clean_up_bottom_edge*exit - (goal ^want position ^object bottom-edge ^id <id> ^status active) - (goal ^want clean-up ^object bottom-edge ^id <id> ^status active) - -(goal ^want rotate ^object face ^id <id> ^status active) - -(bottom-edge ^id <id> ^status active) ---> - (remove 2)) - -(p position_bottom_edge*find_one_match - (goal ^want position ^object bottom-edge ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active) - -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active) - -(bottom-edge ^id <id> ^status done) - (face ^number <nf> ^block 5 ^color <cf>) - (face ^number <nb> ^block 5 ^color <cb>) - (face-relation ^front <nf> ^right <nr> ^left <nl> ^bottom <nb>) - (bottom-edge ^number <n1> ^color <cf> ^status active) - (bottom-edge ^number <n1> ^color <cb> ^status active) - (bottom-edge ^number <n1> ^face <nf> ^status active) - (bottom-edge ^number <n1> ^face <nb> ^status active) ---> - (make vodor ^right <nr> ^left <nl> ^front <nf> ^bottom <nb> ^id <id> - ^status active) - (make goal ^want clean-up ^object bottom-edge ^id <id> ^status active)) - -(p position_bottom_edge*match_four - (goal ^want position ^object bottom-edge ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active) - -(goal ^want rotate ^object face ^id <id> ^status active) - -(bottom-edge ^id <id> ^status done) - (face ^number <n1f> ^block 5 ^color <c1f>) - (face ^number <nb> ^block 5 ^color <cb>) - (face-relation ^front <n1f> ^bottom <nb>) - (bottom-edge ^number 1 ^color <c1f> ^status active) - (bottom-edge ^number 1 ^color <cb> ^status active) - (bottom-edge ^number 1 ^face <n1f> ^status active) - (bottom-edge ^number 1 ^face <nb> ^status active) - (face ^number <n2f> ^block 5 ^color <c2f>) - (face-relation ^front <n2f> ^bottom <nb>) - (bottom-edge ^number 2 ^color <c2f> ^status active) - (bottom-edge ^number 2 ^color <cb> ^status active) - (bottom-edge ^number 2 ^face <n2f> ^status active) - (bottom-edge ^number 2 ^face <nb> ^status active) - (face ^number <n3f> ^block 5 ^color <c3f>) - (face-relation ^front <n3f> ^bottom <nb>) - (bottom-edge ^number 3 ^color <c3f> ^status active) - (bottom-edge ^number 3 ^color <cb> ^status active) - (bottom-edge ^number 3 ^face <n3f> ^status active) - (bottom-edge ^number 3 ^face <nb> ^status active) - (face ^number <n4f> ^block 5 ^color <c4f>) - (face-relation ^front <n4f> ^bottom <nb>) - (bottom-edge ^number 4 ^color <c4f> ^status active) - (bottom-edge ^number 4 ^color <cb> ^status active) - (bottom-edge ^number 4 ^face <n4f> ^status active) - (bottom-edge ^number 4 ^face <nb> ^status active) ---> - (make bottom-edge ^id <id> ^status done) - (modify 5 ^status used) - (modify 6 ^status used) - (modify 11 ^status used) - (modify 12 ^status used) - (modify 17 ^status used) - (modify 18 ^status used) - (modify 23 ^status used) - (modify 24 ^status used)) - -(p orient_bottom_edge*be1 - (goal ^want orient ^object bottom-edge ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active) - -(goal ^want rotate ^object face ^id <id> ^status active) - -(bottom-edge ^id <id> ^status done) - (face ^number {2 <nf>} ^block 5 ^color <cf>) - (face ^number <nb> ^block 5 ^color <cb>) - (face-relation ^front <nf> ^posterior <np> ^right <nr> ^left <nl> - ^bottom <nb>) - (bottom-edge ^number <n1> ^face <nf> ^color <cb> ^status active) - (bottom-edge ^number <n1> ^face <nb> ^color <cf> ^status active) - (face ^number <nr> ^block 5 ^color <cr>) - (bottom-edge ^number <n2> ^face <nr> ^color <cb> ^status active) - (bottom-edge ^number <n2> ^face <nb> ^color <cr> ^status active) - (face ^number <np> ^block 5 ^color <cp>) - (bottom-edge ^number <n3> ^face <np> ^color <cb> ^status active) - (bottom-edge ^number <n3> ^face <nb> ^color <cp> ^status active) - (face ^number <nl> ^block 5 ^color <cl>) - (bottom-edge ^number <n4> ^face <nl> ^color <cb> ^status active) - (bottom-edge ^number <n4> ^face <nb> ^color <cl> ^status active) ---> - (make bottom-edge ^id <id> ^status done) - (modify 5 ^status used) - (modify 6 ^status used) - (modify 8 ^status used) - (modify 9 ^status used) - (modify 11 ^status used) - (modify 12 ^status used) - (modify 14 ^status used) - (modify 15 ^status used) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 180 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction pos - ^value 180 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 8 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 9 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 10 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 11 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction pos - ^value 180 ^id <id> ^seq 12 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 13 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 14 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 180 ^id <id> ^seq 15 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 16 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 17 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction neg - ^value 90 ^id <id> ^seq 18 ^status active)) - -(p orient_bottom_edge*be2 - (goal ^want orient ^object bottom-edge ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active) - -(goal ^want rotate ^object face ^id <id> ^status active) - -(bottom-edge ^id <id> ^status done) - (face ^number <nf> ^block 5 ^color <cf>) - (face ^number <nb> ^block 5 ^color <cb>) - (face-relation ^front <nf> ^posterior <np> ^right <nr> ^left <nl> - ^bottom <nb>) - (bottom-edge ^number <n1> ^face <nf> ^color <cb> ^status active) - (bottom-edge ^number <n1> ^face <nb> ^color <cf> ^status active) - (face ^number <nr> ^block 5 ^color <cr>) - (bottom-edge ^number <n2> ^face <nr> ^color <cr> ^status active) - (bottom-edge ^number <n2> ^face <nb> ^color <cb> ^status active) - (face ^number <np> ^block 5 ^color <cp>) - (bottom-edge ^number <n3> ^face <np> ^color <cb> ^status active) - (bottom-edge ^number <n3> ^face <nb> ^color <cp> ^status active) - (face ^number <nl> ^block 5 ^color <cl>) - (bottom-edge ^number <n4> ^face <nl> ^color <cl> ^status active) - (bottom-edge ^number <n4> ^face <nb> ^color <cb> ^status active) ---> - (make bottom-edge ^id <id> ^status done) - (modify 5 ^status used) - (modify 6 ^status used) - (modify 8 ^status used) - (modify 9 ^status used) - (modify 11 ^status used) - (modify 12 ^status used) - (modify 14 ^status used) - (modify 15 ^status used) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction pos - ^value 90 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 8 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 9 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 10 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 11 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction pos - ^value 90 ^id <id> ^seq 12 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 13 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 14 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 180 ^id <id> ^seq 15 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 16 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 17 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction pos - ^value 90 ^id <id> ^seq 18 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 19 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 20 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 21 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 22 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 23 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction pos - ^value 90 ^id <id> ^seq 24 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 25 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 26 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 27 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 28 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 29 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction pos - ^value 180 ^id <id> ^seq 30 ^status active)) - -(p orient_bottom_edge*be3 - (goal ^want orient ^object bottom-edge ^id <id> ^status active) - -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active) - -(goal ^want rotate ^object face ^id <id> ^status active) - -(bottom-edge ^id <id> ^status done) - (face ^number <nf> ^block 5 ^color <cf>) - (face ^number <nb> ^block 5 ^color <cb>) - (face-relation ^front <nf> ^posterior <np> ^right <nr> ^left <nl> - ^bottom <nb>) - (bottom-edge ^number <n1> ^face <nf> ^color <cf> ^status active) - (bottom-edge ^number <n1> ^face <nb> ^color <cb> ^status active) - (face ^number <nr> ^block 5 ^color <cr>) - (bottom-edge ^number <n2> ^face <nr> ^color <cr> ^status active) - (bottom-edge ^number <n2> ^face <nb> ^color <cb> ^status active) - (face ^number <np> ^block 5 ^color <cp>) - (bottom-edge ^number <n3> ^face <np> ^color <cb> ^status active) - (bottom-edge ^number <n3> ^face <nb> ^color <cp> ^status active) - (face ^number <nl> ^block 5 ^color <cl>) - (bottom-edge ^number <n4> ^face <nl> ^color <cb> ^status active) - (bottom-edge ^number <n4> ^face <nb> ^color <cl> ^status active) - (goal ^id <oldid>) - -(goal ^id > <oldid>) ---> - (modify 1 ^status done) - (modify 1 ^want position ^object bottom-edge ^id (compute <oldid> + 1) - ^status active) - (make bottom-edge ^id <id> ^status done) - (modify 5 ^status used) - (modify 6 ^status used) - (modify 8 ^status used) - (modify 9 ^status used) - (modify 11 ^status used) - (modify 12 ^status used) - (modify 14 ^status used) - (modify 15 ^status used) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction neg - ^value 90 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 8 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction neg - ^value 90 ^id <id> ^seq 9 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 10 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 11 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction neg - ^value 90 ^id <id> ^seq 12 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 13 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 14 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 180 ^id <id> ^seq 15 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 16 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 17 ^status active)) - -(p orient_position_bottom_edge*rotate_utility - (goal ^want { << orient position >> <w> } ^object bottom-edge ^id <id> - ^status active) - (vodor ^right <nr> ^left <nl> ^front <nf> ^bottom <nb> ^id <id> - ^status active) ---> - (modify 2 ^status used) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 1 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 2 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 3 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 4 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 5 ^status active) - (make goal ^want rotate ^object face ^number <nb> ^direction pos - ^value 180 ^id <id> ^seq 6 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction neg - ^value 90 ^id <id> ^seq 7 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction pos - ^value 90 ^id <id> ^seq 8 ^status active) - (make goal ^want rotate ^object face ^number <nf> ^direction pos - ^value 90 ^id <id> ^seq 9 ^status active) - (make goal ^want rotate ^object face ^number <nl> ^direction pos - ^value 90 ^id <id> ^seq 10 ^status active) - (make goal ^want rotate ^object face ^number <nr> ^direction neg - ^value 90 ^id <id> ^seq 11 ^status active)) - - - - - - - - - - - diff --git a/contrib/ops/test1.ops b/contrib/ops/test1.ops deleted file mode 100644 index a257cb2a2dec3df7d4393bac13ef0287bb75e742..0000000000000000000000000000000000000000 --- a/contrib/ops/test1.ops +++ /dev/null @@ -1,21 +0,0 @@ -(literalize c1 a1 a2) -(literalize c2 a1 a2) -(literalize c3 a1 a2) - -(p p1 - (start) - --> - (make c1 ^a1 5 ^a2 foo) - (make c2 ^a1 foo ^a2 1 ) - (make c3 ^a1 5 ^a2 foo) - (make c1 ^a1 10 ^a2 foo)) - - - -(p p2 - (c1 ^a1 <x> ^a2 <y>) - (c2 ^a1 <y> ^a2 < <x>) - - (c3 ^a1 <x> ^a2 foo) - --> - (write -------- x: <x> all fine --------- (crlf))) - diff --git a/contrib/ops/test2.ops b/contrib/ops/test2.ops deleted file mode 100644 index dba08b059b1b0474b8d3be5f5e2ffbccdd8ffaeb..0000000000000000000000000000000000000000 --- a/contrib/ops/test2.ops +++ /dev/null @@ -1,74 +0,0 @@ - -(literalize loop ; loop counter - count) -(literalize buf ; input buffer - input) -(literalize buffield ; holds an atom from the input - extracted value) - -(vector-attribute input) - -(literal extracted = 2 - value = 3) - -; Test acceptline - -(p p1 - (start) ; begin here - --> - (make loop ^count 1) - (make buffield ^extracted FALSE ^value nil) ) - - -(p p2 - (loop ^count 1) ; Get a new line of input - --> - (write (crlf) Enter a line of "input: ") - (make buf ^input (acceptline nothing read)) - (modify 1 ^count 2) ) - - - - -(p p3 - (loop ^count { <x> > 1 < 128 }) ; Extract a field - (buf ^input <> end-of-file) - (buffield ^extracted FALSE) - --> - (modify 3 ^extracted TRUE ^value (substr 2 <x> <x>)) ) - - - -(p p4 - (loop ^count <x>) ; Print non-nil field - (buffield ^extracted TRUE ^value { <v> <> nil }) - --> - (write (crlf) Field <x> is <v>) - (modify 1 ^count (compute (<x> + 1))) - (modify 2 ^extracted FALSE) ) - - - -(p p5 - (loop ^count <x>) ; Skip over nil field - (buffield ^extracted TRUE ^value nil) - --> - (modify 1 ^count (compute (<x> + 1))) - (modify 2 ^extracted FALSE) ) - - - -(p p6 - (loop ^count 128) ; Start over again - (buf) - --> - (modify 1 ^count 1) - (remove 2) ) - - - -(p p7 - (buf ^input end-of-file) ; Exit on EOF - --> - (write (crlf) End-of-file reached in input.) - (halt) ) diff --git a/contrib/ops/test3.ops b/contrib/ops/test3.ops deleted file mode 100644 index 539650eb9cf17cc00028ddb1c8716755e38467e8..0000000000000000000000000000000000000000 --- a/contrib/ops/test3.ops +++ /dev/null @@ -1,110 +0,0 @@ - - -(literalize component) (literalize context) (literalize pcon) (literalize datum) -(literalize computation) (literalize setattr) (literalize template) (literalize interaction) -(literalize lineitem) (literalize local) (literalize discrlist) (literalize task) -(literalize arg) (literalize call) (literalize order) (literalize wip) -(literalize location) (literalize input) (literalize object) (literalize x) -(literalize status) (literalize place) (literalize time) (literalize port) -(literalize module) (literalize link) (literalize lists) (literalize outnode) -(literalize operator) (literalize current) (literalize attval) (literalize choice) -(literalize applied) (literalize stateop) (literalize exit) -(literalize component0) (literalize context0) (literalize pcon0) (literalize datum0) -(literalize computation0) (literalize setattr0) (literalize template0) (literalize interaction0) -(literalize lineitem0) (literalize local0) (literalize discrlist0) (literalize task0) -(literalize arg0) (literalize call0) (literalize order0) (literalize wip0) -(literalize location0) (literalize input0) (literalize object0) (literalize x0) -(literalize status0) (literalize place0) (literalize time0) (literalize port0) -(literalize module0) (literalize link0) (literalize lists0) (literalize outnode0) -(literalize operator0) (literalize current0) (literalize attval0) (literalize choice0) -(literalize applied0) (literalize stateop0) (literalize exit0) -(literalize tank) (literalize pipe) (literalize measurement) (literalize reading) -(literalize goal) (literalize material) - -(literalize primer - spacer - role - cnt - null) - -(literalize count - spacer - role - null - val - delta - null2) - - - -(p start - (start) - --> - (remove 1) - (make primer ^role exist ^cnt 1) - (make primer ^role exist ^cnt 2) - (make primer ^role exist ^cnt 3) - (make primer ^role exist ^cnt 4) - (make primer ^role exist ^cnt 5) - (make primer ^role exist ^cnt 6) - (make primer ^role exist ^cnt 7) - (make primer ^role exist ^cnt 8) - (make primer ^role exist ^cnt 9) - (make primer ^role exist ^cnt 10) - (make primer ^role exist ^cnt 11) - (make primer ^role exist ^cnt 12) - (make primer ^role exist ^cnt 13) - (make primer ^role exist ^cnt 14) - (make primer ^role exist ^cnt 15) - (make primer ^role exist ^cnt 16) - (make primer ^role exist ^cnt 17) - (make primer ^role exist ^cnt 18) - (make primer ^role exist ^cnt 19) - (make primer ^role exist ^cnt 20) - (make primer ^role exist ^cnt 21) - (make primer ^role exist ^cnt 22) - (make primer ^role exist ^cnt 23) - (make primer ^role exist ^cnt 24) - (make primer ^role exist ^cnt 25) - (make primer ^role exist ^cnt 26) - (make primer ^role exist ^cnt 27) - (make primer ^role exist ^cnt 28) - (make primer ^role exist ^cnt 29) - (make primer ^role exist ^cnt 30) - (make count ^role exist ^val 1 ^delta 7) - (make count ^role exist ^val 2 ^delta 7) - (make count ^role exist ^val 3 ^delta 7) - (make count ^role exist ^val 4 ^delta 7) - (make count ^role exist ^val 5 ^delta 7) - (make count ^role exist ^val 6 ^delta 7) - (make count ^role exist ^val 7 ^delta 7) - (make primer ^role driver ^cnt -1)) - - - -(p driver - (primer ^role driver ^null <x>) - (count ^null <x> ^val <val> ^delta <delta>) - - (count ^val < <val>) - --> - (modify 2 ^val (compute <val> + <delta>))) - - -(p driverCopy - (primer ^role driver ^null <x>) - (count ^null <x> ^val <val> ^delta <delta>) - - (count ^val < <val>) - --> - (modify 2 ^val (compute <val> + <delta>))) - - - -(p cs - (primer ^role exist ^cnt <= 2) - (primer ^role exist ^cnt <= 2) - (primer ^role exist ^cnt <= 2) - (primer ^role exist ^cnt <= 1) - (primer ^role exist ^cnt <= 1) - (primer ^role exist ^cnt <= 1) - --> - (halt)) diff --git a/contrib/ops/tourney.ops b/contrib/ops/tourney.ops deleted file mode 100644 index edfef50c56f2eaa39b5433718943871e7c0d8fb9..0000000000000000000000000000000000000000 --- a/contrib/ops/tourney.ops +++ /dev/null @@ -1,299 +0,0 @@ - -(literalize player - number - nights-scheduled) - -(literalize foursome - night - group - north - south - east - west) - -(literalize context - name) - -(literalize scheduling - night) - -(literalize already-played - player1 - player2) - -(literalize candidate - group - chosen - south - east - west) - - -(p startup - (start) ---> - (make player ^number 1 ^nights-scheduled 0) - (make player ^number 2 ^nights-scheduled 0) - (make player ^number 3 ^nights-scheduled 0) - (make player ^number 4 ^nights-scheduled 0) - (make player ^number 5 ^nights-scheduled 0) - (make player ^number 6 ^nights-scheduled 0) - (make player ^number 7 ^nights-scheduled 0) - (make player ^number 8 ^nights-scheduled 0) - (make player ^number 9 ^nights-scheduled 0) - (make player ^number 10 ^nights-scheduled 0) - (make player ^number 11 ^nights-scheduled 0) - (make player ^number 12 ^nights-scheduled 0) - (make player ^number 13 ^nights-scheduled 0) - (make player ^number 14 ^nights-scheduled 0) - (make player ^number 15 ^nights-scheduled 0) - (make player ^number 16 ^nights-scheduled 0) - (make foursome ^night 1 ^group a ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 1 ^group b ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 1 ^group c ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 1 ^group d ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 2 ^group a ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 2 ^group b ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 2 ^group c ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 2 ^group d ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 3 ^group a ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 3 ^group b ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 3 ^group c ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 3 ^group d ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 4 ^group a ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 4 ^group b ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 4 ^group c ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 4 ^group d ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 5 ^group a ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 5 ^group b ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 5 ^group c ^north nil ^south nil ^east nil ^west nil) - (make foursome ^night 5 ^group d ^north nil ^south nil ^east nil ^west nil) - (make context ^name north) - (make scheduling ^night 1) - (write (tabto 32) |Tournament Schedule| (crlf) (crlf) - (tabto 15) |N S E W| - (tabto 42) |N S E W| - (tabto 68) |N S E W| (crlf) - (tabto 15) |= = = =| - (tabto 42) |= = = =| - (tabto 68) |= = = =| (crlf))) - -(p north-pick-one-1 - (context ^name north) - (scheduling ^night <n>) - { <THE-FOURSOME> (foursome ^night <n> ^north nil) } - { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) } - (foursome ^night <n> ^north { <p1> <> nil }) - (foursome ^night <n> ^north { <p2> <> <p1> <> nil }) - (foursome ^night <n> ^north { <p3> <> <p2> <> <p1> <> nil }) - (already-played ^player1 <p> ^player2 <p1>) - (already-played ^player1 <p> ^player2 <p2>) - (already-played ^player1 <p> ^player2 <p3>) ---> - (modify <THE-PLAYER> ^nights-scheduled <n>) - (modify <THE-FOURSOME> ^north <p>) ) - -(p north-pick-one-2 - (context ^name north) - (scheduling ^night <n>) - { <THE-FOURSOME> (foursome ^night <n> ^north nil) } - { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) } - (foursome ^night <n> ^north { <p1> <> nil }) - (foursome ^night <n> ^north { <p2> <> <p1> <> nil }) - (already-played ^player1 <p> ^player2 <p1>) - (already-played ^player1 <p> ^player2 <p2>) ---> - (modify <THE-PLAYER> ^nights-scheduled <n>) - (modify <THE-FOURSOME> ^north <p>) ) - -(p north-pick-one-3 - (context ^name north) - (scheduling ^night <n>) - { <THE-FOURSOME> (foursome ^night <n> ^north nil) } - { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) } - (foursome ^night <n> ^north { <p1> <> nil }) - (already-played ^player1 <p> ^player2 <p1>) ---> - (modify <THE-PLAYER> ^nights-scheduled <n>) - (modify <THE-FOURSOME> ^north <p>) ) - -(p north-pick-one-4 - (context ^name north) - (scheduling ^night <n>) - { <THE-FOURSOME> (foursome ^night <n> ^north nil) } - { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) } ---> - (modify <THE-PLAYER> ^nights-scheduled <n>) - (modify <THE-FOURSOME> ^north <p>) ) - -(p north-done - { <THE-CONTEXT> (context ^name north) } ---> - (modify <THE-CONTEXT> ^name make-candidates)) - -(p make-candidates-make-candidate - (context ^name make-candidates) - (scheduling ^night { <n> < 3 }) - (foursome ^night <n> ^group <g> ^north <yankee>) - (player ^number <redneck> ^nights-scheduled < <n>) - (player ^number { <oriental> < <redneck> } ^nights-scheduled < <n>) - (player ^number { <cowboy> < <oriental> } ^nights-scheduled < <n>) - - (already-played ^player1 <yankee> ^player2 <redneck>) - - (already-played ^player1 <yankee> ^player2 <oriental>) - - (already-played ^player1 <yankee> ^player2 <cowboy>) - - (already-played ^player1 <redneck> ^player2 <oriental>) - - (already-played ^player1 <redneck> ^player2 <cowboy>) - - (already-played ^player1 <oriental> ^player2 <cowboy>) - - (candidate ^group <g> ^chosen no ^south <redneck> ^east <oriental>) - - (candidate ^group <g> ^chosen no ^south <redneck> ^west <cowboy>) - - (candidate ^group <g> ^chosen no ^east <oriental> ^west <cowboy>) ---> - (make candidate ^group <g> ^chosen no - ^south <redneck> ^east <oriental> ^west <cowboy>)) - -(p make-candidates-make-candidate-late - (context ^name make-candidates) - (scheduling ^night { <n> > 2 }) - (foursome ^night <n> ^group <g> ^north <yankee>) - (player ^number <redneck> ^nights-scheduled < <n>) - (player ^number { <oriental> < <redneck> } ^nights-scheduled < <n>) - (player ^number { <cowboy> < <oriental> } ^nights-scheduled < <n>) - - (already-played ^player1 <yankee> ^player2 <redneck>) - - (already-played ^player1 <yankee> ^player2 <oriental>) - - (already-played ^player1 <yankee> ^player2 <cowboy>) - - (already-played ^player1 <redneck> ^player2 <oriental>) - - (already-played ^player1 <redneck> ^player2 <cowboy>) - - (already-played ^player1 <oriental> ^player2 <cowboy>) ---> - (make candidate ^group <g> ^chosen no - ^south <redneck> ^east <oriental> ^west <cowboy>)) - -(p make-candidates-done - { <THE-CONTEXT> (context ^name make-candidates) } ---> - (modify <THE-CONTEXT> ^name make-choice)) - -(p make-choice-doit - { <THE-CONTEXT> (context ^name make-choice) } - { <WINNER-A> (candidate ^group a ^chosen no - ^south <sa> - ^east <ea> - ^west <wa>) } - { <WINNER-B> (candidate ^group b ^chosen no - ^south { <sb> <> <sa> <> <ea> <> <wa> } - ^east { <eb> <> <sa> <> <ea> <> <wa> } - ^west { <wb> <> <sa> <> <ea> <> <wa> }) } - { <WINNER-C> (candidate ^group c ^chosen no - ^south { <sc> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> } - ^east { <ec> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> } - ^west { <wc> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> }) } - { <WINNER-D> (candidate ^group d ^chosen no - ^south { <sd> - <> <sa> <> <ea> <> <wa> - <> <sb> <> <eb> <> <wb> - <> <sc> <> <ec> <> <wc> } - ^east { <ed> - <> <sa> <> <ea> <> <wa> - <> <sb> <> <eb> <> <wb> - <> <sc> <> <ec> <> <wc> } - ^west { <wd> - <> <sa> <> <ea> <> <wa> - <> <sb> <> <eb> <> <wb> - <> <sc> <> <ec> <> <wc> }) } ---> - (modify <WINNER-A> ^chosen yes) - (modify <WINNER-B> ^chosen yes) - (modify <WINNER-C> ^chosen yes) - (modify <WINNER-D> ^chosen yes) - (modify <THE-CONTEXT> ^name remove-candidates)) - -(p remove-candidates-bye - (context ^name remove-candidates) - { <THE-CANDIDATE> (candidate ^chosen no) } ---> - (remove <THE-CANDIDATE>)) - -(p remove-candidates-done - { <THE-CONTEXT> (context ^name remove-candidates) } ---> - (modify <THE-CONTEXT> ^name apply-choice)) - -(p apply-choice-doit - (context ^name apply-choice) - (scheduling ^night <n>) - { <THE-FOURSOME> (foursome ^night <n> ^group <g> ^north <yankee>) } - { <THE-CHOICE> (candidate ^group <g> ^chosen yes - ^south <redneck> ^east <oriental> ^west <cowboy>) } ---> - (modify <THE-FOURSOME> ^south <redneck> ^east <oriental> ^west <cowboy>) - (remove <THE-CHOICE>) - (make already-played ^player1 <yankee> ^player2 <redneck>) - (make already-played ^player2 <yankee> ^player1 <redneck>) - (make already-played ^player1 <yankee> ^player2 <oriental>) - (make already-played ^player2 <yankee> ^player1 <oriental>) - (make already-played ^player1 <yankee> ^player2 <cowboy>) - (make already-played ^player2 <yankee> ^player1 <cowboy>) - (make already-played ^player1 <redneck> ^player2 <oriental>) - (make already-played ^player2 <redneck> ^player1 <oriental>) - (make already-played ^player1 <redneck> ^player2 <cowboy>) - (make already-played ^player2 <redneck> ^player1 <cowboy>) - (make already-played ^player1 <oriental> ^player2 <cowboy>) - (make already-played ^player2 <oriental> ^player1 <cowboy>)) - -(p apply-choice-done - { <THE-CONTEXT> (context ^name apply-choice) } ---> - (modify <THE-CONTEXT> ^name report)) - -(p report-night-schedule - { <THE-CONTEXT> (context ^name report) } - (scheduling ^night <n>) - (foursome ^night <n> ^group a ^north <an> ^south <as> ^east <ae> ^west <aw>) - (foursome ^night <n> ^group b ^north <bn> ^south <bs> ^east <be> ^west <bw>) - (foursome ^night <n> ^group c ^north <cn> ^south <cs> ^east <ce> ^west <cw>) - (foursome ^night <n> ^group d ^north <dn> ^south <ds> ^east <de> ^west <dw>) ---> - (modify <THE-CONTEXT> ^name next-night) - (bind <n2> (compute <n> + 5)) - (bind <n3> (compute <n> + 10)) - (write (crlf) (rjust 1) |#| (rjust 1) <n> (rjust 1) - (tabto 5) - |Group A-| (rjust 3) <an> (rjust 3) <as> (rjust 3) <ae> (rjust 3) <aw> - (tabto 27) (rjust 1) |#| (rjust 2) <n2> (rjust 1) - (tabto 32) - |Group A-| (rjust 3) <an> (rjust 3) <ae> (rjust 3) <as> (rjust 3) <aw> - (tabto 53) (rjust 1) |#| (rjust 2) <n3> (rjust 1) - (tabto 58) - |Group A-| (rjust 3) <an> (rjust 3) <aw> (rjust 3) <ae> (rjust 3) <as>) - (write (crlf) - (tabto 5) - |Group B-| (rjust 3) <bn> (rjust 3) <bs> (rjust 3) <be> (rjust 3) <bw> - (tabto 32) - |Group B-| (rjust 3) <bn> (rjust 3) <be> (rjust 3) <bs> (rjust 3) <bw> - (tabto 58) - |Group B-| (rjust 3) <bn> (rjust 3) <bw> (rjust 3) <be> (rjust 3) <bs>) - (write (crlf) - (tabto 5) - |Group C-| (rjust 3) <cn> (rjust 3) <cs> (rjust 3) <ce> (rjust 3) <cw> - (tabto 32) - |Group C-| (rjust 3) <cn> (rjust 3) <ce> (rjust 3) <cs> (rjust 3) <cw> - (tabto 58) - |Group C-| (rjust 3) <cn> (rjust 3) <cw> (rjust 3) <ce> (rjust 3) <cs>) - (write (crlf) - (tabto 5) - |Group D-| (rjust 3) <dn> (rjust 3) <ds> (rjust 3) <de> (rjust 3) <dw> - (tabto 32) - |Group D-| (rjust 3) <dn> (rjust 3) <de> (rjust 3) <ds> (rjust 3) <dw> - (tabto 58) - |Group D-| (rjust 3) <dn> (rjust 3) <dw> (rjust 3) <de> (rjust 3) <ds> - (crlf))) - -(p next-night-more - { <THE-CONTEXT> (context ^name next-night) } - { <THE-NIGHT> (scheduling ^night { <n> < 5 }) } ---> - (modify <THE-CONTEXT> ^name north) - (modify <THE-NIGHT> ^night (compute <n> + 1))) - -(p next-night-done - (context ^name next-night) ---> - (write (tabto 32) |End of Scheduling| (crlf) (crlf))) - diff --git a/contrib/ops/ttt.ops b/contrib/ops/ttt.ops deleted file mode 100644 index defe3823d8ed8db1f01b6550ee9766aed5676048..0000000000000000000000000000000000000000 --- a/contrib/ops/ttt.ops +++ /dev/null @@ -1,308 +0,0 @@ -(strategy mea) -(watch 0) - - -(literalize task - actor) -(literalize position - row column value identity) -(literalize opposite - of is) -(literalize player - with-mark is) -(literalize move - status whose-turn input) -(vector-attribute input) - - - -(p start -; generate the wm-elements defining the "board" and find out whether -; the human wants his mark to be x or o - (ready) - --> - (make task ^actor referee) - (make position ^row 1 ^column 1 ^value | | ^identity top-left) - (make position ^row 1 ^column 2 ^value | | ^identity top-middle) - (make position ^row 1 ^column 3 ^value | | ^identity top-right) - (make position ^row 2 ^column 1 ^value | | ^identity middle-left) - (make position ^row 2 ^column 2 ^value | | ^identity center) - (make position ^row 2 ^column 3 ^value | | ^identity middle-right) - (make position ^row 3 ^column 1 ^value | | ^identity bottom-left) - (make position ^row 3 ^column 2 ^value | | ^identity bottom-middle) - (make position ^row 3 ^column 3 ^value | | ^identity bottom-right) - (make opposite ^of x ^is o) - (make opposite ^of o ^is x) - (write (crlf) Do you want to be x or "o? " ) - (make player ^with-mark (accept) ^is human) ) - -(make ready) - -(p pop - ; if there is nothing more to do in the most recently generated task, - ; delete the task - (task) - --> - (remove 1) ) - - -(p referee--display-the-board - ; after each move, display the board - (task ^actor referee) - (move ^status made ^whose-turn <mark>) - (opposite ^of <mark> ^is <opponent-mark>) - (position ^row 1 ^column 1 ^value <l1>) - (position ^row 1 ^column 2 ^value <m1>) - (position ^row 1 ^column 3 ^value <r1>) - (position ^row 2 ^column 1 ^value <l2>) - (position ^row 2 ^column 2 ^value <m2>) - (position ^row 2 ^column 3 ^value <r2>) - (position ^row 3 ^column 1 ^value <l3>) - (position ^row 3 ^column 2 ^value <m3>) - (position ^row 3 ^column 3 ^value <r3>) - --> - (modify 2 ^status unmade ^whose-turn <opponent-mark>) - (write (crlf) (crlf) (crlf) - (tabto 12) <l1> (tabto 15) "|" (tabto 18) <m1> - (tabto 21) "|" (tabto 24) <r1> - (tabto 10) ----------------- - (tabto 12) <l2> (tabto 15) "|" (tabto 18) <m2> - (tabto 21) "|" (tabto 24) <r2> - (tabto 10) ----------------- - (tabto 12) <l3> (tabto 15) "|" (tabto 18) <m3> - (tabto 21) "|" (tabto 24) <r3>) ) - -(p referee--prepare-for-first-move -; identify the mark of the computer and create the move wm-element that -; will drive the game - (task ^actor referee) - (player ^with-mark <mark> ^is human) - (opposite ^of <mark> ^is <other-mark>) - --> - (write (crlf) (crlf) When you are asked where you want your |mark,| - enter two |numbers.| - (crlf) The first number should be the row you |want,| the - second |number, the column.|) - (make player ^with-mark <other-mark> ^is computer) - (make move ^status unmade ^whose-turn x) ) - -(p referee--get-a-good-mark -; if the human says he wants to be something other than x or o, make -; him x - (task ^actor referee) - (player ^with-mark <mark> ^is human) - - (opposite ^of <mark>) - --> - (modify 2 ^with-mark x) - (write (crlf) (crlf) Try to remember that |you're x.|) ) - -(p referee--next-move -; if it's time for the next move to be made, generate the appropriate -; subtask - (task ^actor referee) - (move ^status unmade ^whose-turn <mark>) - (player ^with-mark <mark> ^is <who>) - --> - (make task ^actor <who>) ) - -(p referee--recognize-column-win -; if someone has filled a column, note that fact - (task ^actor referee) - (move ^status unmade ^whose-turn <mark>) - (opposite ^of <mark> ^is <other-mark>) - (player ^with-mark <other-mark>) - (position ^column <c> ^value <other-mark>) - - (position ^column <c> ^value <> <other-mark>) - --> - (remove 2) - (make player ^with-mark <other-mark> ^is winner) ) - -(p referee--recognize-row-win -; if someone has filled a row, note that fact - (task ^actor referee) - (move ^status unmade ^whose-turn <mark>) - (opposite ^of <mark> ^is <other-mark>) - (player ^with-mark <other-mark>) - (position ^row <r> ^value <other-mark>) - - (position ^row <r> ^value <> <other-mark>) - --> - (remove 2) - (make player ^with-mark <other-mark> ^is winner) ) - -(p referee--recognize-diagonal-win -; if someone has filled a diagonal, note that fact - (task ^actor referee) - (move ^status unmade ^whose-turn <mark>) - (opposite ^of <mark> ^is <other-mark>) - (player ^with-mark <other-mark>) - (position ^row 2 ^column 2 ^value <other-mark>) - (position ^row {<r> <> 2} ^column {<c> <> 2} - ^identity <id> ^value <other-mark>) - (position ^row <c> ^column <r> - ^identity <> <id> ^value <other-mark>) - --> - (remove 2) - (make player ^with-mark <other-mark> ^is winner) ) - -(p referee--human-wins -; if the human won, let him know - (task ^actor referee) - (player ^with-mark <other-mark> ^is winner) - (player ^with-mark <other-mark> ^is human) - --> - (write (crlf) (crlf) You |win.| (crlf) (crlf)) ) - -(p referee--computer-wins -; if the computer won, let the human know - (task ^actor referee) - (player ^with-mark <other-mark> ^is winner) - (player ^with-mark <other-mark> ^is computer) - --> - (write (crlf) (crlf) I |win.| (crlf) (crlf)) ) - -(p referee--draw -; if there are no empty spaces, the game is a draw - (task ^actor referee) - (move ^status unmade ^whose-turn <mark>) - (player ^with-mark <mark>) - - (position ^value | |) - --> - (write (crlf) (crlf) We |drew.| (crlf) (crlf)) - (remove 2) ) - -(p referee--cleanup -; if the game is over, delete all of the wm-elements - (task ^actor referee) - - (move) - (<> task) - --> - (remove 2) ) - - -(p human--ask-for-next-move - ; get the position (row and column) where the human wants his mark - (task ^actor human) - (move ^status unmade ^input nil) - --> - (write (crlf) (crlf) Where do you want your "mark? ") - (modify 2 ^input (acceptline)) ) - -(p human--accept-move - ; if the move is legal, accept it - ; the move wm-element is remade so that the value of ^input becomes - ; nil (there are 2 simpler but less educational ways of achieving - ; this same end) - (task ^actor human) - (move ^status unmade ^whose-turn <mark> - ^input {<row> >= 0 <= 3} {<column> >= 0 <= 3} nil) - (position ^row <row> ^column <column> ^value | |) - --> - (remove 2) - (make move (substr 2 2 input) ^status made ^input nil) - (modify 3 ^value <mark>) ) - -(p human--reject-attempt-to-overwrite - ; if the position specified is not empty, complain - ; the move condition element in this rule differs from the move - ; condition in the previous rule only so you can see two equivalent - ; ways of expressing the same condition - (task ^actor human) - (move ^status unmade - ^input <row> <column> nil ^input << 1 2 3 >> << 1 2 3 >>) - (position ^row <row> ^column <column> ^value {<mark> <> | |}) - --> - (write (crlf) (crlf) There is already an <mark> in <row> <column>) - (modify 2 ^input nil nil) ) - -(p human--reject-out-of-bounds-move - ; if the row or column specified is not within bounds or if more than - ; two numbers have been entered, complain - ; the move wm-element is remade so that the value of ^input becomes - ; nil (there is a simpler but less educational way of achieving this - ; same end) - (task ^actor human) - (move ^status unmade ^input <> nil) - --> - (write (crlf) (crlf) (substr 2 input inf) is not a legal |move.|) - (remove 2) - (make move (substr 2 2 input) ^input nil) ) - - -(p computer--select-move - ; select any empty position - (task ^actor computer) - (move ^status unmade ^whose-turn <mark>) - - (position ^row 2 ^column 2 ^value | |) - (position ^row <r> ^column <c> ^value | |) - --> - (modify 2 ^status made) - (modify 3 ^value <mark>) ) - -(p computer--select-center - ; select the center if it's available - (task ^actor computer) - (move ^status unmade ^whose-turn <mark>) - (position ^row 2 ^column 2 ^value | |) - --> - (modify 2 ^status made) - (modify 3 ^value <mark>) ) - -(p computer--block-column-win - ; if the human has two in a column, block - (task ^actor computer) - (move ^status unmade ^whose-turn <mark>) - (position ^row <r> ^column <c> - ^value {<other-mark> <> <mark> <> | |}) - (position ^column <c> ^value | |) - (position ^row <> <r> ^column <c> ^value <other-mark>) - --> - (modify 2 ^status made) - (modify 4 ^value <mark>) ) - -(p computer--block-row-win - ; if the human has two in a row, block - (task ^actor computer) - (move ^status unmade ^whose-turn <mark>) - (position ^row <r> ^column <c> - ^value {<other-mark> <> <mark> <> | |}) - (position ^row <r> ^value | |) - (position ^row <r> ^column <> <c> ^value <other-mark>) - --> - (modify 2 ^status made) - (modify 4 ^value <mark>) ) - -(p computer--block-diagonal-win - ; if the human has two on a diagonal, block - (task ^actor computer) - (move ^status unmade ^whose-turn <mark>) - (position ^row 2 ^column 2 - ^value {<other-mark> <> <mark> <> | |}) - (position ^row {<r> <> 2} ^column {<c> <> 2} ^value | |) - (position ^row <c> ^column <r> ^value <other-mark>) - --> - (modify 2 ^status made) - (modify 4 ^value <mark>) ) - -(p computer--possible-column - ; if the computer has one mark in an otherwise empty column, put - ; another mark in that column - (task ^actor computer) - (move ^status unmade ^whose-turn <mark>) - (position ^row <r> ^column <c> ^value <mark>) - - (position ^row <> <r> ^column <c> ^value <> | |) - (position ^row <> <r> ^column <c> ^value | |) - --> - (modify 2 ^status made) - (modify 4 ^value <mark>) ) - -(p computer--possible-row - ; if the computer has one mark in an otherwise empty row, put - ; another mark in that row - (task ^actor computer) - (move ^status unmade ^whose-turn <mark>) - (position ^row <r> ^column <c> ^value <mark>) - - (position ^row <r> ^column <> <c> ^value <> | |) - (position ^row <r> ^column <> <c> ^value | |) - --> - (modify 2 ^status made) - (modify 4 ^value <mark>) ) diff --git a/contrib/ops/weaver.ops b/contrib/ops/weaver.ops deleted file mode 100644 index c1b8711d9cf21c72d8eca49700b97dd24a720075..0000000000000000000000000000000000000000 --- a/contrib/ops/weaver.ops +++ /dev/null @@ -1,8850 +0,0 @@ -(literalize unit unit-name file-name) - -(literalize pin net-name pin-name external-net-name external-pin-name pin-left-x pin-left-y fixed-pin pin-x pin-y pin-layer pin-layer-constraint pin-channel-side pin-is-attached) - -(literalize channel channel-bottom-left-x channel-bottom-left-y channel-top-right-x channel-top-right-y channel-width channel-length no-of-left-pins no-of-right-pins no-of-bottom-pins no-of-top-pins right-fixed left-fixed bottom-fixed top-fixed channel-type no-of-fixed-sides) - -(literalize net net-name parent-name net-no-of-pins net-left-x net-left-y net-right-x net-right-y no-of-left-pins no-of-right-pins no-of-top-pins no-of-bottom-pins net-is-routed left-most-pin-name right-most-pin-name bottom-most-pin-name top-most-pin-name fixed-net net-layer external-net-name no-of-inter max-no-of-via) - -(literalize layer-info layer-name layer-order layer-priority) - -(literalize context present previous saved) - -(literalize ff net-name pin-name grid-layer grid-x grid-y came-from can-chng-layer) - -(literalize next-net-to-be-routed net-name no-of-attached-pins criteria) - -(literalize to-be-routed net-name no-of-attached-pins) - -(literalize occupied x y m) - -(literalize constraint constraint-type constraint-relation channel-side constraint-reason net-name-1 net-name-2 pin-name-1 pin-name-2 seg-id-1 seg-id-2) - -(literalize congestion direction coordinate no-of-nets extra-nets como) - -(literalize intersection net-name direction min max) - -(literalize horizontal min max com compo commo layer status min-net max-net net-name pin-name) - -(literalize vertical min max com compo commo layer status min-net max-net net-name pin-name) - -(literalize horizontal-s net-name min max com id top-count bot-count sum difference absolute side) - -(literalize vertical-s net-name min max com id top-count bot-count sum difference absolute side) - -(literalize total net-name row-col coor level-pins total-pins cong min-xy max-xy last-pin last-xy nets) - -(literalize tree net-name orientation com min max count id) - -(vector-attribute nets) - -(p p327 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> > <min> } ^com 1 ^id <id>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side bottom) - (constraint ^constraint-type vertical ^seg-id-1 <id>) - (total ^net-name <> <nn>) - - (total-verti <nn>) - --> - (remove <t>) -) - -(p p328 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> < <max> } ^max { <hmax> >= <gx> } ^com <lr> ^id <id>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <> <id>) - (last-row <lr>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side top) - (constraint ^constraint-type vertical ^seg-id-2 <id>) - (total ^net-name <> <nn>) - - (total-verti <nn>) - --> - (remove <t>) -) - -(p p329 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> > <min> } ^com 1 ^id <id>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side left) - (constraint ^constraint-type horizontal ^seg-id-1 <id>) - (total ^net-name <> <nn>) - - (total-verti <nn>) - --> - (remove <t>) -) - -(p p330 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> < <max> } ^max { <vmax> >= <gy> } ^com <lc> ^id <id>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <> <id>) - (last-col <lc>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side right) - (constraint ^constraint-type horizontal ^seg-id-2 <id>) - (total ^net-name <> <nn>) - - (total-verti <nn>) - --> - (remove <t>) -) - -(p p331 - { <c> (context ^present modify-total) } - --> - (modify <c> ^present delete-total) -) - -(p p332 - { <c> (context ^present delete-total) } - - (total) - --> - (remove <c>) - (make context ^previous find-no-of-pins-on-a-row-col) -) - -(p p333 - { <c> (context ^present extend-total) } - (last-row <lr>) - --> - (make maximum-total 0 0 0 1 0 <lr> 0) - (make merge-direction left) - (modify <c> ^present merge) - (make eliminate-total) -) - -(p p334 - { <c> (context ^present delete-total) } - --> - (modify <c> ^present extend-total) -) - -(p p335 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> } ^com 1 ^id <id> ^absolute <a> ^sum <s>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>) - - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <hmax> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side bottom) - --> - (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <hmax>) -) - -(p p336 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> } ^com <lr> ^id <id> ^absolute <a> ^sum <s>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <> <id>) - - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <hmax> ^last-pin checked) - (last-row <lr>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side top) - --> - (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <hmax>) -) - -(p p337 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com 1 ^id <id> ^absolute <a> ^sum <s>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>) - - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <vmax> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side left) - --> - (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <vmax>) -) - -(p p338 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com <lc> ^id <id> ^absolute <a> ^sum <s>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <> <id>) - - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <vmax> ^last-pin checked) - (last-col <lc>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side right) - --> - (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <vmax>) -) - -(p p339 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min 1 ^max { <hmax> >= <gx> } ^com <com> ^id <id> ^absolute <a> ^sum <s>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>) - - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy 1 ^max-xy <hmax> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x 0 ^pin-y <com> ^pin-channel-side left) - --> - (make (substr <t> 1 inf) ^min-xy 1 ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> 1 <hmax>) -) - -(p p340 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>) - (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max <lc> ^com <com> ^id <id> ^absolute <a> ^sum <s>) - - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>) - - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <lc> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-y <com> ^pin-channel-side right) - (last-col <lc>) - --> - (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <lc> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <lc>) -) - -(p p341 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min 1 ^max { <vmax> >= <gy> } ^com <com> ^id <id> ^absolute <a> ^sum <s>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>) - - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy 1 ^max-xy <vmax> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x <com> ^pin-channel-side bottom) - --> - (make (substr <t> 1 inf) ^min-xy 1 ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> 1 <vmax>) -) - -(p p342 - (context ^present modify-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> }) - (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max <lr> ^com <com> ^id <id> ^absolute <a> ^sum <s>) - - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>) - - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <lr> ^last-pin checked) - (pin ^net-name <nn> ^pin-name <pn> ^pin-x <com> ^pin-channel-side top) - (last-row <lr>) - --> - (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <lr> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <lr>) -) - -(p p343 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (total ^net-name <nn> ^row-col <rc> ^coor <y> ^last-pin checked) - --> - (remove <t>) -) - -(p p344 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - --> - (remove <t>) -) - -(p p345 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - (net ^net-name <nn> ^net-no-of-pins 2) - --> - (modify <t> ^last-pin checked ^nets <nn> <min> <max>) -) - -(p p346 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) } - - (total ^last-pin checked) - --> - (modify <t> ^last-pin checked ^nets <nn> <min> <max>) -) - -(p p347 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) } - (last-col <lc>) - (horizontal-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { >= <min> <> <lc> } ^com <y> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x 0 ^pin-y <y>) - - (pin ^net-name <nn> ^pin-y <y> ^pin-channel-side right) - --> - (remove <t>) -) - -(p p348 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <tmin> ^max-xy <max>) } - (last-col <lc>) - (horizontal-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { <maxs> <> <lc> } ^com <y> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x 0 ^pin-y <y>) - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com { <min> > 1 <= <maxs> }) - - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com < <min>) - { <h> (horizontal ^net-name <nn1> ^min 0 ^max { <hmax> < <min> } ^com <y> ^layer <lay>) } - { <ff> (ff ^net-name <nn1> ^grid-x <hmax> ^grid-y <y> ^grid-layer <lay> ^came-from west) } - { <h1> (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <y> ^layer <lay>) } - - (pin ^net-name <nn> ^pin-y <y>) - - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <y> ^max >= <y> ^com <min> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <min> ^max >= <min> ^com <y> ^layer <lay>) - --> - (remove <t>) - (modify <h> ^max <min>) - (modify <h1> ^min <min> ^min-net <nn1>) - (modify <ff> ^grid-x <min> ^can-chng-layer nil) -) - -(p p349 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) } - (last-col <lc>) - (horizontal-s ^net-name { <nn1> <> <nn> } ^min { <= <max> <> 1 } ^max <lc> ^com <y> ^id <=> 1) - (pin ^net-name <nn1> ^pin-y <y> ^pin-channel-side right) - - (pin ^net-name <nn> ^pin-y <y> ^pin-channel-side left) - --> - (remove <t>) -) - -(p p350 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <tmax>) } - (last-col <lc>) - (horizontal-s ^net-name { <nn1> <> <nn> } ^min { <mins> <> 1 } ^max <lc> ^com <y> ^id <=> 1) - (pin ^net-name <nn1> ^pin-y <y> ^pin-channel-side right) - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com { <max> >= <mins> < <lc> }) - - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com > <max>) - { <h> (horizontal ^net-name <nn1> ^min { <hmin> > <max> } ^max <garb> ^com <y> ^layer <lay>) } - { <ff> (ff ^net-name <nn1> ^grid-x <hmin> ^grid-y <y> ^grid-layer <lay> ^came-from east) } - { <h1> (horizontal ^net-name nil ^min < <max> ^max <hmin> ^com <y> ^layer <lay>) } - - (pin ^net-name <nn> ^pin-y <y>) - - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <y> ^max >= <y> ^com <max> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <max> ^max >= <max> ^com <y> ^layer <lay>) - --> - (remove <t>) - (modify <h> ^min <max>) - (modify <h1> ^max <max> ^max-net <nn1>) - (modify <ff> ^grid-x <max> ^can-chng-layer nil) -) - -(p p351 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) } - (last-row <lr>) - (vertical-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { >= <min> <> <lr> } ^com <x> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x <x> ^pin-channel-side top) - --> - (remove <t>) -) - -(p p352 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <tmin> ^max-xy <max>) } - (last-row <lr>) - (vertical-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { <maxs> <> <lr> } ^com <x> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side bottom) - (horizontal ^net-name <nn> ^min <= <x> ^max <x> ^com { <min> > 1 <= <maxs> }) - - (horizontal ^net-name <nn> ^min <= <x> ^max <x> ^com < <min>) - { <v> (vertical ^net-name <nn1> ^min 0 ^max { <vmax> < <min> } ^com <x> ^layer <lay>) } - { <ff> (ff ^net-name <nn1> ^grid-x <x> ^grid-y <vmax> ^grid-layer <lay> ^came-from south) } - { <v1> (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <x> ^layer <lay>) } - - (pin ^net-name <nn> ^pin-x <x>) - - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <min> ^max >= <min> ^com <x>) - - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <x> ^max >= <x> ^com <min>) - --> - (remove <t>) - (modify <v> ^max <min>) - (modify <v1> ^min <min> ^min-net <nn1>) - (modify <ff> ^grid-y <min> ^can-chng-layer nil) -) - -(p p353 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) } - (last-row <lr>) - (vertical-s ^net-name { <nn1> <> <nn> } ^min { <= <max> <> 1 } ^max <lr> ^com <x> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x <x> ^pin-channel-side bottom) - --> - (remove <t>) -) - -(p p354 - (context ^present delete-total) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <tmax>) } - (last-row <lr>) - (vertical-s ^net-name { <nn1> <> <nn> } ^min { <mins> <> 1 } ^max <lr> ^com <x> ^id <=> 1) - (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side top) - (horizontal ^net-name <nn> ^min <= <x> ^max >= <x> ^com { <max> >= <mins> < <lr> }) - - (horizontal ^net-name <nn> ^min <= <x> ^max >= <x> ^com > <max>) - { <v> (vertical ^net-name <nn1> ^min { <vmin> > <max> } ^max <garb> ^com <x> ^layer <lay>) } - { <ff> (ff ^net-name <nn1> ^grid-x <x> ^grid-y <vmin> ^grid-layer <lay> ^came-from north) } - { <v1> (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <x> ^layer <lay>) } - - (pin ^net-name <nn> ^pin-x <x>) - - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <max> ^max >= <max> ^com <x>) - - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <x> ^max >= <x> ^com <max>) - --> - (remove <t>) - (modify <v> ^min <max>) - (modify <v1> ^max <max> ^max-net <nn1>) - (modify <ff> ^grid-y <max> ^can-chng-layer nil) -) - -(p p355 - (context ^present extend-total) - - (switch-box) - { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>) } - (last-row > <y>) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>) - - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>) - - (horizontal ^net-name <nn> ^min <= <min> ^max >= <min> ^com <y>) - - (horizontal ^net-name <nn> ^min <= <max> ^max >= <max> ^com <y>) - - (horizontal ^net-name <nn> ^min >= <min> ^max <= <max> ^com <y>) - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com > <y>) - - (ff ^net-name <nn> ^grid-x { >= <min> <= <max> } ^grid-y <y> ^pin-name >= 1000) - --> - (modify <t> ^coor (compute <y> + 1)) -) - -(p p356 - (context ^present extend-total) - - (switch-box) - { <t> (total ^net-name <nn> ^row-col row ^coor { <y> > 0 } ^min-xy <min> ^max-xy <max> ^last-xy <id>) } - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <id>) - (last-row <lr>) - - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>) - - (horizontal ^net-name <nn> ^min <= <min> ^max >= <min> ^com <y>) - - (horizontal ^net-name <nn> ^min <= <max> ^max >= <max> ^com <y>) - - (horizontal ^net-name <nn> ^min >= <min> ^max <= <max> ^com <y>) - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com < <y>) - - (ff ^net-name <nn> ^grid-x { >= <min> <= <max> } ^grid-y <y> ^pin-name >= 1000) - --> - (modify <t> ^coor (compute <y> - 1)) -) - -(p p357 - (context ^present extend-total) - - (switch-box) - { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>) } - (last-col > <x>) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>) - - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>) - - (vertical ^net-name <nn> ^min <= <min> ^max >= <min> ^com <x>) - - (vertical ^net-name <nn> ^min <= <max> ^max >= <max> ^com <x>) - - (vertical ^net-name <nn> ^min >= <min> ^max <= <max> ^com <x>) - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com > <x>) - - (ff ^net-name <nn> ^grid-x <x> ^grid-y { >= <min> <= <max> } ^pin-name >= 1000) - --> - (modify <t> ^coor (compute <x> + 1)) -) - -(p p358 - (context ^present extend-total) - - (switch-box) - { <t> (total ^net-name <nn> ^row-col col ^coor { <x> > 0 } ^min-xy <min> ^max-xy <max> ^last-xy <id>) } - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <id>) - (last-col <lc>) - - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>) - - (vertical ^net-name <nn> ^min <= <min> ^max >= <min> ^com <x>) - - (vertical ^net-name <nn> ^min <= <max> ^max >= <max> ^com <x>) - - (vertical ^net-name <nn> ^min >= <min> ^max <= <max> ^com <x>) - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com < <x>) - - (ff ^net-name <nn> ^grid-x <x> ^grid-y { >= <min> <= <max> } ^pin-name >= 1000) - --> - (modify <t> ^coor (compute <x> - 1)) -) - -(p p359 - (context ^present extend-total) - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>) - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> < <y> } ^grid-layer <lay> ^pin-name <pn>) } - { <v> (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> >= <y> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <y> ^max >= <y> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <y> ^layer <lay>) - --> - (make vertical ^min <y> ^max <vmax> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>) - (modify <v> ^max <gy> ^max-net <nn>) - (make vertical ^min <gy> ^max <y> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>) - (modify <ff> ^grid-y <y> ^came-from south ^can-chng-layer nil) -) - -(p p360 - (context ^present extend-total) - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <id>) - (last-row <lr>) - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> > <y> } ^grid-layer <lay> ^pin-name <pn>) } - { <v> (vertical ^net-name nil ^min { <vmin> <= <y> } ^max { <vmax> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <y> ^max >= <y> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <y> ^layer <lay>) - --> - (make vertical ^min <gy> ^max <vmax> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>) - (modify <v> ^max <y> ^max-net <nn>) - (make vertical ^min <y> ^max <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>) - (modify <ff> ^grid-y <y> ^came-from north ^can-chng-layer nil) -) - -(p p361 - (context ^present extend-total) - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>) - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx> < <x> } ^grid-y { <gy> >= <min> <= <max> } ^grid-layer <lay> ^pin-name <pn>) } - { <v> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> >= <x> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <x> ^max >= <x> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <x> ^layer <lay>) - --> - (make horizontal ^min <x> ^max <hmax> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>) - (modify <v> ^max <gx> ^max-net <nn>) - (make horizontal ^min <gx> ^max <x> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>) - (modify <ff> ^grid-x <x> ^came-from west ^can-chng-layer nil) -) - -(p p362 - (context ^present extend-total) - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <id>) - (last-col <lc>) - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx> > <x> } ^grid-y { <gy> >= <min> <= <max> } ^grid-layer <lay> ^pin-name <pn>) } - { <v> (horizontal ^net-name nil ^min { <hmin> <= <x> } ^max { <hmax> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <x> ^max >= <x> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <x> ^layer <lay>) - --> - (make horizontal ^min <gx> ^max <hmax> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>) - (modify <v> ^max <x> ^max-net <nn>) - (make horizontal ^min <x> ^max <gx> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>) - (modify <ff> ^grid-x <x> ^came-from east ^can-chng-layer nil) -) - -(p p490 - { <c> (context ^present separate) } - --> - (modify <c> ^present reconnect) -) - -(p p491 - { <c> (context ^present reconnect) } - --> - (modify <c> ^present form-verti) -) - -(p p492 - { <c> (context ^present form-verti) } - --> - (modify <c> ^present partial-route) -) - -(p p493 - { <c> (context ^present partial-route) } - --> - (modify <c> ^present extend-pins) -) - -(p p494 - { <c1> (context ^present extend-pins) } - --> - (modify <c1> ^present nil ^previous extend-pins) -) - -(p p495 - { <c1> (context ^previous extend-pins) } - --> - (make switch-box) - (make context ^present propagate-constraint) - (remove <c1>) -) - -(p p496 - { <c1> (context ^previous extend-pins) } - (channel ^no-of-left-pins 0 ^no-of-right-pins 0) - --> - (remove <c1>) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p497 - { <c1> (context ^previous extend-pins) } - (channel ^no-of-bottom-pins 0 ^no-of-top-pins 0) - --> - (remove <c1>) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p498 - (context ^previous propagate-constraint) - (net ^net-is-routed <> yes) - --> - (remove 1) - (make context ^present lshape1) -) - -(p p499 - (context ^present lshape1) - --> - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p500 - { <c> (context ^previous find-no-of-pins-on-a-row-col) } - - (total) - - (extend-ff-tried) - --> - (remove <c>) - (make context ^present lshape4) -) - -(p p501 - { <c> (context ^present lshape4) } - --> - (remove <c>) - (make extend-ff-tried) - (make context ^present extend-ff) -) - -(p p502 - { <c> (context ^present extend-ff) } - --> - (remove <c>) - (make context ^previous extend-ff) -) - -(p p503 - { <c> (context ^previous extend-ff) } - - (extended-ff) - --> - (remove <c>) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p504 - { <c> (context ^previous extend-ff) } - { <e> (extended-ff) } - { <ex> (extend-ff-tried) } - --> - (remove <c> <e> <ex>) - (make context ^present find-no-of-pins-on-a-row-col) - (make goal cleanup extended-ff) -) - -(p p505 - (context ^previous find-no-of-pins-on-a-row-col) - - (total) - (extend-ff-tried) - - (total-verti) - --> - (remove 1) - (make context ^present find-no-of-vcg-hcg) - (make goal cleanup counted-verti) -) - -(p p506 - (context ^previous find-no-of-pins-on-a-row-col) - - (total) - (total-verti) - - (verti-has-loop) - --> - (remove 1) - (make verti-has-loop) - (make context ^present choose-between-total-verti) -) - -(p p507 - (context ^previous find-no-of-pins-on-a-row-col) - - (total) - (total-verti) - (verti-has-loop) - --> - (make context ^present extend-h-v-s) - (make goal cleanup total-verti) - (make goal cleanup counted-verti) - (make goal cleanup extend-ff-tried) - (remove 1 3) -) - -(p p508 - (context ^present choose-between-total-verti) - - (total-verti ^4 > 0) - --> - (modify 1 ^present extend-h-v-s) - (make goal cleanup counted-verti) -) - -(p p509 - (context ^previous find-no-of-vcg-hcg) - - (total-verti) - --> - (remove 1) - (make context ^present extend-h-v-s) -) - -(p p510 - (context ^present loose-constraint) - --> - (make context ^present lshape2) - (remove 1) -) - -(p p511 - (context ^present lshape2) - --> - (modify 1 ^present lshape3) -) - -(p p512 - (context ^present lshape3) - --> - (remove 1) - (make context ^present random0) -) - -(p p513 - (context ^present random0) - --> - (remove 1) - (make context ^present random1) -) - -(p p514 - (context ^present remove-routed-net-segments) - - (net ^net-is-routed <> yes) - - (horizontal ^net-name <> nil ^status nil) - - (vertical ^net-name <> nil ^status nil) - --> - (write (crlf) | Finished with the routing.|) - (halt) -) - -(p p1 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^com <min>) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top) - - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>) - (pin ^net-name <> <nn> ^pin-x <min> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { < <px> > <min> }) - (pin ^net-name <nn> ^pin-x > <px> ^pin-channel-side top) - --> - (modify <h> ^min <px>) - (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p2 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^com <min>) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom) - - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>) - (pin ^net-name <> <nn> ^pin-x <min> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { < <px> > <min> }) - (pin ^net-name <nn> ^pin-x > <px> ^pin-channel-side bottom) - --> - (modify <h> ^min <px>) - (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p3 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^com <max>) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top) - - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>) - (pin ^net-name <> <nn> ^pin-x <max> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { < <max> > <px> }) - (pin ^net-name <nn> ^pin-x < <px> ^pin-channel-side top) - --> - (modify <h> ^max <px>) - (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p4 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^com <max>) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom) - - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>) - (pin ^net-name <> <nn> ^pin-x <max> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { < <max> > <px> }) - (pin ^net-name <nn> ^pin-x < <px> ^pin-channel-side bottom) - --> - (modify <h> ^max <px>) - (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p5 - (context ^present reconnect) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top) - - (pin ^pin-x <max> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^max <max>) -) - -(p p6 - (context ^present reconnect) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom) - - (pin ^pin-x <min> ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^min <min>) -) - -(p p7 - (context ^present reconnect) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top) - - (pin ^pin-x <max> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^max <max>) -) - -(p p8 - (context ^present reconnect) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom) - - (pin ^pin-x <min> ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^min <min>) -) - -(p p9 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <com>) - { <v> (vertical-s ^net-name <nn> ^com { <com1> >= <min1> <= <max1> }) } - (pin ^net-name <> <nn> ^pin-x <com1>) - (congestion ^direction col ^coordinate { <px> >= <min1> <= <max1> }) - - (pin ^net-name <> <nn> ^pin-x <px>) - - (vertical-s ^com <px>) - --> - (modify <v> ^com <px>) -) - -(p p10 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <com>) - { <v> (vertical-s ^net-name <nn> ^com { <com1> >= <min1> <= <max> }) } - (pin ^net-name <> <nn> ^pin-x <com1>) - (congestion ^direction col ^coordinate { <px> >= <min1> <= <max> }) - - (pin ^net-name <> <nn> ^pin-x <px>) - - (vertical-s ^com <px>) - --> - (modify <v> ^com <px>) -) - -(p p11 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <hcom>) - - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max1> }) - { <v> (vertical-s ^net-name <nn> ^com { <vcom> < <min1> }) } - - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>) - --> - (modify <v> ^com <min1>) -) - -(p p12 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <hcom>) - - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max1> }) - { <v> (vertical-s ^net-name <nn> ^com { <vcom> > <max1> }) } - - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>) - --> - (modify <v> ^com <max1>) -) - -(p p13 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <hcom>) - - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max> }) - { <v> (vertical-s ^net-name <nn> ^com { <vcom> < <min1> }) } - - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>) - --> - (modify <v> ^com <min1>) -) - -(p p14 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>) - (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <hcom>) - - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max> }) - { <v> (vertical-s ^net-name <nn> ^com { <vcom> > <max> }) } - - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>) - --> - (modify <v> ^com <max>) -) - -(p p15 - (context ^present reconnect) - (horizontal-s ^net-name <nn> ^min <min1> ^max <max1> ^id <id1>) - { <h> (horizontal-s ^net-name <nn> ^min <max1> ^max <max2> ^com <com> ^id <id2>) } - (horizontal-s ^net-name <nn> ^min <max2> ^max <max3> ^id <id3>) - - (horizontal-s ^net-name <nn> ^id { <> <id1> <> <id2> <> <id3> }) - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max1>) - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max2>) - --> - (modify <h> ^min <min1> ^max <max3>) -) - -(p p16 - (context ^present reconnect) - (vertical-s ^net-name <nn> ^min <min1> ^max <max1> ^id <id1>) - { <h> (vertical-s ^net-name <nn> ^min <max1> ^max <max2> ^com <com> ^id <id2>) } - (vertical-s ^net-name <nn> ^min <max2> ^max <max3> ^id <id3>) - - (vertical-s ^net-name <nn> ^id { <> <id1> <> <id2> <> <id3> }) - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max1>) - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max2>) - --> - (modify <h> ^min <min1> ^max <max3>) -) - -(p p17 - (context ^present separate) - { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <max>) - (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side right) - - (pin ^net-name <nn> ^pin-x > <com> ^pin-y { > <py> <= <max> }) - - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side top) - - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <py> < <max> }) - - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <max>) - --> - (modify <v> ^max <py>) - (make vertical-s ^net-name <nn> ^min <py> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p18 - (context ^present separate) - { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <max>) - (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side left) - - (pin ^net-name <nn> ^pin-x < <com> ^pin-y { > <py> <= <max> }) - - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side top) - - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <py> < <max> }) - - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <max>) - --> - (modify <v> ^max <py>) - (make vertical-s ^net-name <nn> ^min <py> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p19 - (context ^present separate) - { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <min>) - (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side right) - - (pin ^net-name <nn> ^pin-x > <com> ^pin-y { < <py> >= <min> }) - - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side bottom) - - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <py> }) - - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <min>) - --> - (modify <v> ^min <py>) - (make vertical-s ^net-name <nn> ^min <min> ^max <py> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p20 - (context ^present separate) - { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <min>) - (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side left) - - (pin ^net-name <nn> ^pin-x < <com> ^pin-y { < <py> >= <min> }) - - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side bottom) - - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <py> }) - - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <min>) - --> - (modify <v> ^min <py>) - (make vertical-s ^net-name <nn> ^min <min> ^max <py> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p21 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <min>) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { < <px> >= <min> } ^pin-y > <com>) - - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side left) - - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <px> }) - - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <min>) - --> - (modify <h> ^min <px>) - (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p22 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <min>) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { < <px> >= <min> } ^pin-y < <com>) - - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side left) - - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <px> }) - - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <min>) - --> - (modify <h> ^min <px>) - (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p23 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <max>) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top) - - (pin ^net-name <nn> ^pin-x { > <px> <= <max> } ^pin-y > <com>) - - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side right) - - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <px> < <max> }) - - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <max>) - --> - (modify <h> ^max <px>) - (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p24 - (context ^present separate) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) } - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <max>) - (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom) - - (pin ^net-name <nn> ^pin-x { > <px> <= <max> } ^pin-y < <com>) - - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side right) - - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <px> < <max> }) - - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <max>) - --> - (modify <h> ^max <px>) - (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2) -) - -(p p604 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side top) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>) - - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical) -) - -(p p605 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side bottom) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>) - - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top) - - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>) - --> - (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical) -) - -(p p606 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side top) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1> ^com 1) - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical) -) - -(p p607 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side bottom) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1> ^com <> 1) - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top) - - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>) - --> - (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical) -) - -(p p608 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0) - (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side top) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical) -) - -(p p609 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0) - (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side bottom) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top) - - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>) - --> - (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical) -) - -(p p610 - (context ^present form-verti) - (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com 1 ^id <id>) - (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <lr> ^id <id1>) - (last-row <lr>) - (vertical-s ^net-name <bnn> ^com <vcom>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side top) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical) -) - -(p p611 - (context ^present form-verti) - (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y { <vcom> >= <min> <= <max> } ^pin-channel-side right) - (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal) -) - -(p p612 - (context ^present form-verti) - (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y { <vcom> >= <min> <= <max> } ^pin-channel-side left) - (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side right) - - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>) - --> - (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type horizontal) -) - -(p p613 - (context ^present form-verti) - (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0) - (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side right) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal) -) - -(p p614 - (context ^present form-verti) - (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0) - (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side left) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side right) - - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>) - --> - (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type horizontal) -) - -(p p615 - (context ^present form-verti) - (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com 1 ^id <id>) - (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> }) - (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <lc> ^id <id1>) - (last-col <lc>) - (horizontal-s ^net-name <bnn> ^com <vcom>) - (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side right) - (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left) - - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - --> - (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal) -) - -(p p616 - (context ^present form-verti) - (constraint ^constraint-type vertical ^net-name-1 <tnn> ^net-name-2 <bnn> ^seg-id-1 <tid> ^seg-id-2 <bid>) - (constraint ^constraint-type vertical ^net-name-1 <nn1> ^net-name-2 <tnn> ^seg-id-1 <id1> ^seg-id-2 <tid2>) - - (vertical-cycle <tnn> <tid> <tid2>) - --> - (make vertical-cycle <tnn> <tid> <tid2>) -) - -(p p617 - (context ^present form-verti) - (constraint ^constraint-type horizontal ^net-name-1 <tnn> ^net-name-2 <bnn> ^seg-id-1 <tid> ^seg-id-2 <bid>) - (constraint ^constraint-type horizontal ^net-name-1 <nn1> ^net-name-2 <tnn> ^seg-id-1 <id1> ^seg-id-2 <tid2>) - - (horizontal-cycle <tnn> <tid> <tid2>) - --> - (make horizontal-cycle <tnn> <tid> <tid2>) -) - -(p p618 - (context ^present remove-cycle) - { <h> (horizontal-cycle <nn>) } - - (constraint ^constraint-type horizontal ^net-name-1 <nn>) - - (constraint ^constraint-type horizontal ^net-name-2 <nn>) - --> - (remove <h>) -) - -(p p619 - (context ^present remove-cycle) - { <h> (horizontal-cycle <nn>) } - - (constraint ^constraint-type horizontal ^net-name-2 <nn>) - --> - (remove <h>) -) - -(p p620 - (context ^present remove-cycle) - { <h> (horizontal-cycle <nn>) } - - (constraint ^constraint-type horizontal ^net-name-1 <nn>) - --> - (remove <h>) -) - -(p p621 - (context ^present remove-cycle) - { <h> (vertical-cycle <nn>) } - - (constraint ^constraint-type vertical ^net-name-1 <nn>) - - (constraint ^constraint-type vertical ^net-name-2 <nn>) - --> - (remove <h>) -) - -(p p622 - (context ^present remove-cycle) - { <h> (vertical-cycle <nn>) } - - (constraint ^constraint-type vertical ^net-name-2 <nn>) - --> - (remove <h>) -) - -(p p623 - (context ^present remove-cycle) - { <h> (vertical-cycle <nn>) } - - (constraint ^constraint-type vertical ^net-name-1 <nn>) - --> - (remove <h>) -) - -(p p624 - { <c> (context ^present remove-cycle) } - --> - (remove <c>) -) - -(p p625 - (context ^present remove-cycle) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <max>) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^max <max>) -) - -(p p626 - (context ^present remove-cycle) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <min>) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^min <min>) -) - -(p p627 - (context ^present remove-cycle) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <max>) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^max <max>) -) - -(p p628 - (context ^present remove-cycle) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) } - (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top) - (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <min>) - - (pin ^net-name <nn> ^pin-x { < <max> > <min> }) - (last-row <lr>) - - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> }) - - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> }) - --> - (remove <h1>) - (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) - (modify <h2> ^min <min>) -) - -(p p629 - (context ^present remove-cycle) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com 1) - (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from south) - - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y < <gy>) - - (vertical-s ^net-name <nn> ^min 1 ^max > <gy> ^com <gx>) - --> - (make vertical-s ^net-name <nn> ^min 1 ^max (compute <gy> + 1) ^com <gx> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) -) - -(p p630 - (context ^present remove-cycle) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com 1) - (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from south) - - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y <= <gy>) - { <v> (vertical-s ^net-name <nn> ^min 1 ^max <= <gy> ^com <gx>) } - --> - (modify <v> ^max (compute <gy> + 1)) -) - -(p p631 - (context ^present remove-cycle) - (last-row <lr>) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com <lr>) - (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from north) - - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y > <gy>) - - (vertical-s ^net-name <nn> ^min < <gy> ^max <lr> ^com <gx>) - --> - (make vertical-s ^net-name <nn> ^min (compute <gy> - 1) ^max <lr> ^com <gx> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) -) - -(p p632 - (context ^present remove-cycle) - (last-row <lr>) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com <lr>) - (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from north) - - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y >= <gy>) - { <v> (vertical-s ^net-name <nn> ^min >= <gy> ^max <lr> ^com <gx>) } - --> - (modify <v> ^min (compute <gy> - 1)) -) - -(p p633 - (context ^present remove-cycle) - (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com 1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from west) - - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y <> <gy>) - - (horizontal-s ^net-name <nn> ^min 1 ^max > <gx> ^com <gy>) - --> - (make horizontal-s ^net-name <nn> ^min 1 ^max (compute <gx> + 1) ^com <gy> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) -) - -(p p634 - (context ^present remove-cycle) - (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com 1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from west) - - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y <> <gy>) - { <h> (horizontal-s ^net-name <nn> ^min 1 ^max <= <gx> ^com <gy>) } - --> - (modify <h> ^max (compute <gx> + 1)) -) - -(p p635 - (context ^present remove-cycle) - (last-col <lc>) - (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com <lc>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from east) - - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y <> <gy>) - - (horizontal-s ^net-name <nn> ^min < <gx> ^max <lc> ^com <gy>) - --> - (make horizontal-s ^net-name <nn> ^min (compute <gx> - 1) ^max <lc> ^com <gy> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2) -) - -(p p636 - (context ^present remove-cycle) - (last-col <lc>) - (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com <lc>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from east) - - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y <> <gy>) - { <h> (horizontal-s ^net-name <nn> ^min >= <gx> ^max <lc> ^com <gy>) } - --> - (modify <h> ^min (compute <gx> - 1)) -) - -(p p637 - (context ^present remove-cycle) - (last-row <lr>) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0) - { <v> (vertical-s ^net-name <nn> ^min 1 ^max { <lr> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) } - (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side top) - (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from south) - --> - (modify <v> ^min (compute <lr> - 1)) -) - -(p p638 - (context ^present remove-cycle) - (last-row <lr>) - (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0) - { <v> (vertical-s ^net-name <nn> ^min 1 ^max { <lr> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) } - (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side bottom) - (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from north) - --> - (modify <v> ^max 2) -) - -(p p639 - (context ^present remove-cycle) - (last-col <lc>) - (vertical-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0) - { <v> (horizontal-s ^net-name <nn> ^min 1 ^max { <lc> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) } - (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side right) - (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from west) - --> - (modify <v> ^min (compute <lc> - 1)) -) - -(p p640 - (context ^present remove-cycle) - (last-col <lc>) - (vertical-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0) - { <v> (horizontal-s ^net-name <nn> ^min 1 ^max { <lc> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) } - (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side left) - (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from east) - --> - (modify <v> ^max 2) -) - -(p p472 - (context ^present partial-route) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) } - { <vs> (vertical-s ^net-name <nn> ^min <gy1> ^max <gy> ^com <gx>) } - { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1> ^came-from south) } - { <v> (vertical ^net-name nil ^min <gy1> ^max <gy> ^com <gx> ^layer <lay>) } - --> - (modify <v> ^net-name <nn> ^pin-name <pn>) - (remove <ff1> <ff2> <vs>) -) - -(p p473 - (context ^present partial-route) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east) } - { <vs> (horizontal-s ^net-name <nn> ^min <gx1> ^max <gx> ^com <gy>) } - { <ff2> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn1> ^came-from west) } - { <v> (horizontal ^net-name nil ^min <gx1> ^max <gx> ^com <gy> ^layer <lay>) } - --> - (modify <v> ^net-name <nn> ^pin-name <pn>) - (remove <ff1> <ff2> <vs>) -) - -(p p474 - (context ^present partial-route) - { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) } - { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <min> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from east) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from north) - --> - (remove <v2>) - (modify <h> ^com <vmin>) - (modify <v1> ^min <vmin>) -) - -(p p475 - (context ^present partial-route) - { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <min> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from east) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from north) - --> - (modify <v2> ^com <vcom>) - (modify <h> ^com <vmin>) -) - -(p p476 - (context ^present partial-route) - { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) } - { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <min> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from west) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from north) - --> - (remove <v2>) - (modify <h> ^com <vmin>) - (modify <v1> ^min <vmin>) -) - -(p p477 - (context ^present partial-route) - { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <min> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from west) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from north) - --> - (modify <v2> ^com <vcom>) - (modify <h> ^com <vmin>) -) - -(p p478 - (context ^present partial-route) - { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) } - { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <max> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from east) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from south) - --> - (remove <v2>) - (modify <h> ^com <vmax>) - (modify <v1> ^max <vmax>) -) - -(p p479 - (context ^present partial-route) - { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <max> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from east) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from south) - --> - (modify <v2> ^com <vcom>) - (modify <h> ^com <vmax>) -) - -(p p480 - (context ^present partial-route) - { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) } - { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <max> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from west) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from south) - --> - (remove <v2>) - (modify <h> ^com <vmax>) - (modify <v1> ^max <vmax>) -) - -(p p481 - (context ^present partial-route) - { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <max> ^top-count 1 ^bot-count 1) } - { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from west) - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from south) - --> - (modify <v2> ^com <vcom>) - (modify <h> ^com <vmax>) -) - -(p p482 - (context ^present partial-route) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) } - { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <min> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from north) - (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from east) - --> - (remove <h2>) - (modify <v> ^com <hmin>) - (modify <h1> ^min <hmin>) -) - -(p p483 - (context ^present partial-route) - { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <min> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from north) - (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from east) - --> - (modify <h2> ^com <hcom>) - (modify <v> ^com <hmin>) -) - -(p p484 - (context ^present partial-route) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) } - { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <max> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from north) - (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from west) - --> - (remove <h2>) - (modify <v> ^com <hmax>) - (modify <h1> ^max <hmax>) -) - -(p p485 - (context ^present partial-route) - { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <max> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmax> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from north) - (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from west) - --> - (modify <h2> ^com <hcom>) - (modify <v> ^com <hmax>) -) - -(p p486 - (context ^present partial-route) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) } - { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <min> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from south) - (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from east) - --> - (remove <h2>) - (modify <v> ^com <hmin>) - (modify <h1> ^min <hmin>) -) - -(p p487 - (context ^present partial-route) - { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <min> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from south) - (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from east) - --> - (modify <h2> ^com <hcom>) - (modify <v> ^com <hmin>) -) - -(p p488 - (context ^present partial-route) - { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) } - { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <max> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from south) - (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from west) - --> - (remove <h2>) - (modify <v> ^com <hmax>) - (modify <h1> ^max <hmax>) -) - -(p p489 - (context ^present partial-route) - { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <max> ^top-count 1 ^bot-count 1) } - { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmin> ^top-count 1 ^bot-count 1) } - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from south) - (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from west) - --> - (modify <h2> ^com <hcom>) - (modify <v> ^com <hmax>) -) - -(p p186 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> < 0 }) - - (horizontal-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) } - - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y < <gy1>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y <gy1>) - - (horizontal ^net-name nil ^min < <gx2> ^max > <gx1> ^com <gy1>) - - (horizontal ^net-name nil ^min <gx2> ^max > <gx1> ^com <gy1> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx2> ^max <gx1> ^com <gy1> ^max-net nil) - { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> bottom) - - (vertical-cycle <nn>) - --> - (modify <v> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p187 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> < 0 }) - - (horizontal-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) } - - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y < <gy1>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y <gy1>) - - (horizontal ^net-name nil ^min < <gx1> ^max > <gx2> ^com <gy1>) - - (horizontal ^net-name nil ^min <gx1> ^max > <gx2> ^com <gy1> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx1> ^max <gx2> ^com <gy1> ^max-net nil) - { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> bottom) - - (vertical-cycle <nn>) - --> - (modify <v> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p188 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> < 0 }) - - (horizontal-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) } - (vertical-s ^net-name <nn> ^min <= <gy1> ^max > <gy1> ^com <gx1>) - - (ff ^net-name <nn> ^grid-x <> <gx1> ^grid-y <= <gy1>) - { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy1>) - - (vertical-s ^net-name <> <nn> ^min <= <gy2> ^max >= <gy2> ^com <gx1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> bottom) - - (vertical-cycle <nn>) - --> - (make extended-ff <nn> bottom) - (modify <v> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p189 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> > 0 }) - - (horizontal-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) } - - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y > <gy1>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y <gy1>) - - (horizontal ^net-name nil ^min < <gx2> ^max > <gx1> ^com <gy1>) - - (horizontal ^net-name nil ^min <gx2> ^max > <gx1> ^com <gy1> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx2> ^max <gx1> ^com <gy1> ^max-net nil) - { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy1> ^como <gy2>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> top) - - (vertical-cycle <nn>) - --> - (modify <v> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p190 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> > 0 }) - - (horizontal-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) } - - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y > <gy1>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y <gy1>) - - (horizontal ^net-name nil ^min < <gx1> ^max > <gx2> ^com <gy1>) - - (horizontal ^net-name nil ^min <gx1> ^max > <gx2> ^com <gy1> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx1> ^max <gx2> ^com <gy1> ^max-net nil) - { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy1> ^como <gy2>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> top) - - (vertical-cycle <nn>) - --> - (modify <v> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p191 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^difference { <d> > 0 }) - - (horizontal-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) } - (vertical-s ^net-name <nn> ^min < <gy1> ^max >= <gy1> ^com <gx1>) - - (ff ^net-name <nn> ^grid-x <> <gx1> ^grid-y >= <gy1>) - { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy1> ^como <gy2>) - - (vertical-s ^net-name <> <nn> ^min <= <gy2> ^max >= <gy2> ^com <gx1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>) - - (extended-ff <nn> top) - - (vertical-cycle <nn>) - --> - (make extended-ff <nn> top) - (modify <v> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p192 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (horizontal-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <max> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) } - - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com <gy>) - { <v> (vertical ^net-name nil ^max { <vmax> > <gy> } ^min { < <vmax> <= <gy> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <max> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gy2> ^layer <lay>) - - (vertical-cycle <nn>) - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com > <gy>) - --> - (modify <v> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p193 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (horizontal-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <min> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) } - - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com <gy>) - { <v> (vertical ^net-name nil ^max { <vmax> > <gy> } ^min { < <vmax> <= <gy> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <min> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gy2> ^layer <lay>) - - (vertical-cycle <nn>) - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com > <gy>) - --> - (modify <v> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p194 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (horizontal-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <max> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) } - - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com <gy>) - { <v> (vertical ^net-name nil ^max { <vmax> >= <gy> } ^min { < <vmax> < <gy> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy> ^como <gy2>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <max> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gy2> ^layer <lay>) - - (vertical-cycle <nn>) - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com < <gy>) - --> - (modify <v> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p195 - (context ^present extend-ff) - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (horizontal-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <min> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) } - - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com <gy>) - { <v> (vertical ^net-name nil ^max { <vmax> >= <gy> } ^min { < <vmax> < <gy> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction row ^coordinate <gy> ^como <gy2>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <min> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gy2> ^layer <lay>) - - (vertical-cycle <nn>) - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com < <gy>) - --> - (modify <v> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) -) - -(p p196 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> < 0 }) - - (vertical-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) } - - (ff ^net-name <nn> ^grid-x < <gx1> ^grid-y <garb1>) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> < <gy1> }) - - (vertical ^net-name nil ^min < <gy2> ^max > <gy1> ^com <gx1>) - - (vertical ^net-name nil ^min <gy2> ^max > <gy1> ^com <gx1> ^min-net nil) - - (vertical ^net-name nil ^min < <gy2> ^max <gy1> ^com <gx1> ^max-net nil) - { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> left) - - (horizontal-cycle <nn>) - --> - (modify <v> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p197 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> < 0 }) - - (vertical-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) } - - (ff ^net-name <nn> ^grid-x < <gx1> ^grid-y <garb1>) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> > <gy1> }) - - (vertical ^net-name nil ^min < <gy1> ^max > <gy2> ^com <gx1>) - - (vertical ^net-name nil ^min <gy1> ^max > <gy2> ^com <gx1> ^min-net nil) - - (vertical ^net-name nil ^min < <gy1> ^max <gy2> ^com <gx1> ^max-net nil) - { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> left) - - (horizontal-cycle <nn>) - --> - (modify <v> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p198 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> < 0 }) - - (vertical-s ^difference < <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) } - (horizontal-s ^net-name <nn> ^min <= <gx1> ^max > <gx1> ^com <gy1>) - - (ff ^net-name <nn> ^grid-x <= <gx1> ^grid-y <> <gy1>) - { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx1>) - - (horizontal-s ^net-name <> <nn> ^min <= <gx2> ^max >= <gx2> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> left) - - (horizontal-cycle <nn>) - --> - (make extended-ff <nn> left) - (modify <v> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p199 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> > 0 }) - - (vertical-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) } - - (ff ^net-name <nn> ^grid-x > <gx1> ^grid-y <garb1>) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> < <gy1> }) - - (vertical ^net-name nil ^min < <gy2> ^max > <gy1> ^com <gx1>) - - (vertical ^net-name nil ^min <gy2> ^max > <gy1> ^com <gx1> ^min-net nil) - - (vertical ^net-name nil ^min < <gy2> ^max <gy1> ^com <gx1> ^max-net nil) - { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx1> ^como <gx2>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> right) - - (horizontal-cycle <nn>) - --> - (modify <v> ^max <gx2> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p200 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> > 0 }) - - (vertical-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) } - - (ff ^net-name <nn> ^grid-x > <gx1> ^grid-y <gy1>) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> > <gy1> }) - - (vertical ^net-name nil ^min < <gy1> ^max > <gy2> ^com <gx1>) - - (vertical ^net-name nil ^min <gy1> ^max > <gy2> ^com <gx1> ^min-net nil) - - (vertical ^net-name nil ^min < <gy1> ^max <gy2> ^com <gx1> ^max-net nil) - { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx1> ^como <gx2>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> right) - - (horizontal-cycle <nn>) - --> - (modify <v> ^max <gx2> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p201 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^difference { <d> > 0 }) - - (vertical-s ^difference > <d>) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) } - (horizontal-s ^net-name <nn> ^min < <gx1> ^max >= <gx1> ^com <gy1>) - - (ff ^net-name <nn> ^grid-x >= <gx1> ^grid-y <> <gy1>) - { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx1> ^como <gx2>) - - (horizontal-s ^net-name <> <nn> ^min <= <gx2> ^max >= <gx2> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>) - - (extended-ff <nn> right) - - (horizontal-cycle <nn>) - --> - (make extended-ff <nn> right) - (modify <v> ^max <gx2> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p202 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (vertical-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <max> ^grid-layer <lay> ^came-from west ^pin-name <pn>) } - - (vertical ^net-name nil ^min < <max> ^max >= <max> ^com <gx>) - { <v> (horizontal ^net-name nil ^max { <vmax> > <gx> } ^min { < <vmax> <= <gx> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <max> ^layer <lay>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gx2> ^layer <lay>) - - (horizontal-cycle <nn>) - --> - (modify <v> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^max <gx2> ^min <gx> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p203 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (vertical-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <min> ^grid-layer <lay> ^came-from west ^pin-name <pn>) } - - (vertical ^net-name nil ^min <= <min> ^max > <min> ^com <gx>) - { <v> (horizontal ^net-name nil ^max { <vmax> > <gx> } ^min { < <vmax> <= <gx> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <min> ^layer <lay>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gx2> ^layer <lay>) - - (horizontal-cycle <nn>) - --> - (modify <v> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^max <gx2> ^min <gx> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p204 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (vertical-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <max> ^grid-layer <lay> ^came-from east ^pin-name <pn>) } - - (vertical ^net-name nil ^min < <max> ^max >= <max> ^com <gx>) - { <v> (horizontal ^net-name nil ^max { <vmax> >= <gx> } ^min { < <vmax> < <gx> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx> ^como <gx2>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <max> ^layer <lay>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gx2> ^layer <lay>) - - (horizontal-cycle <nn>) - --> - (modify <v> ^max <gx2> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx> ^min <gx2> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p205 - (context ^present extend-ff) - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0) - - (vertical-s ^difference <> 0) - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <min> ^grid-layer <lay> ^came-from east ^pin-name <pn>) } - - (vertical ^net-name nil ^min <= <min> ^max > <min> ^com <gx>) - { <v> (horizontal ^net-name nil ^max { <vmax> >= <gx> } ^min { < <vmax> < <gx> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (congestion ^direction col ^coordinate <gx> ^como <gx2>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <min> ^layer <lay>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gx2> ^layer <lay>) - - (horizontal-cycle <nn>) - --> - (modify <v> ^max <gx2> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx> ^min <gx2> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) -) - -(p p206 - { <c> (context ^present extend-h-v-s) } - --> - (modify <c> ^present loose-constraint0) -) - -(p p207 - { <c> (context ^present extend-h-v-s) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from west ^pin-name <pn>) } - (horizontal-s ^net-name <nn> ^min <= <gx> ^max { <hmaxs> > <gx> } ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^com <gy>) - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <vcoms> > <gx> <= <hmaxs> }) - - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { >= <gx> < <vcoms> }) - { <h> (horizontal ^net-name nil ^min <gx> ^max { <hmax> >= <vcoms> } ^com <gy> ^layer <lay>) } - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <vcoms> ^layer <lay>) - --> - (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <vcoms>) - (modify <h> ^min <vcoms> ^min-net <nn>) - (modify <ff> ^grid-x <vcoms> ^can-chng-layer nil) - (modify <c> ^present propagate-constraint) -) - -(p p208 - { <c> (context ^present extend-h-v-s) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from east ^pin-name <pn>) } - (horizontal-s ^net-name <nn> ^min { <hmins> < <gx> } ^max >= <gx> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^com <gy>) - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <vcoms> < <gx> >= <hmins> }) - - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <= <gx> > <vcoms> }) - { <h> (horizontal ^net-name nil ^min { <hmin> <= <vcoms> } ^max <gx> ^com <gy> ^layer <lay>) } - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <vcoms> ^layer <lay>) - --> - (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcoms>) - (modify <h> ^max <vcoms> ^max-net <nn>) - (modify <ff> ^grid-x <vcoms> ^can-chng-layer nil) - (modify <c> ^present propagate-constraint) -) - -(p p209 - { <c> (context ^present extend-h-v-s) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) } - (vertical-s ^net-name <nn> ^min <= <gy> ^max { <vmaxs> > <gy> } ^com <gx>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <gx>) - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <hcoms> > <gy> <= <vmaxs> }) - - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { >= <gy> < <hcoms> }) - { <v> (vertical ^net-name nil ^min <gy> ^max { <vmax> >= <hcoms> } ^com <gx> ^layer <lay>) } - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <hcoms> ^layer <lay>) - --> - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <hcoms>) - (modify <v> ^min <hcoms> ^min-net <nn>) - (modify <ff> ^grid-y <hcoms> ^can-chng-layer nil) - (modify <c> ^present propagate-constraint) -) - -(p p210 - { <c> (context ^present extend-h-v-s) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) } - (vertical-s ^net-name <nn> ^min { <vmins> < <gy> } ^max >= <gy> ^com <gx>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <gx>) - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <hcoms> < <gy> >= <vmins> }) - - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <= <gy> > <hcoms> }) - { <v> (vertical ^net-name nil ^min { <vmin> <= <hcoms> } ^max <gy> ^com <gx> ^layer <lay>) } - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <hcoms> ^layer <lay>) - --> - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <hcoms>) - (modify <v> ^max <hcoms> ^max-net <nn>) - (modify <ff> ^grid-y <hcoms> ^can-chng-layer nil) - (modify <c> ^present propagate-constraint) -) - -(p p29 - (goal cleanup <c>) - (<c>) - --> - (remove 2) -) - -(p p30 - (goal cleanup <c>) - - (<c>) - --> - (remove 1) -) - -(p p31 - (goal cleanup) - (verti-has-loop) - --> - (remove 2) -) - -(p p83 - (context ^present propagate-constraint) - --> - (remove 1) - (make context ^previous propagate-constraint) - (make context ^present remove-cycle) -) - -(p p84 - (context ^present << propagate-constraint extend-pins move-ff >>) - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com> ^layer <lay> ^compo <cpo> ^commo <egarb1>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <min2> <= <max1> } ^max { <max2> >= <min1> } ^com <cpo> ^layer <lay> ^compo <garb1> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <cpo> > <min3> } ^com { <com2> <= <max1> >= <min1> <= <max2> >= <min2> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) } - --> - (make vertical ^min <min3> ^max <com> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn1> ^min-net <mnn>) - (make vertical ^min <cpo> ^max <max3> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn2> ^max-net <man>) - (remove <v1>) -) - -(p p85 - (context ^present << propagate-constraint extend-pins >>) - (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <com> ^layer <lay> ^compo <egarb2> ^commo <gy>) - { <v1> (vertical ^net-name nil ^min { <min3> <= <gy> } ^max { <max3> >= <com> > <min3> } ^com <gx> ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) } - --> - (make vertical ^min <min3> ^max <gy> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn1> ^min-net <mnn>) - (make vertical ^min <com> ^max <max3> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn2> ^max-net <man>) - (remove <v1>) -) - -(p p86 - (context ^present << propagate-constraint extend-pins >>) - (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <com> ^layer <lay> ^compo <gy> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <gy> > <min3> } ^com <gx> ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) } - --> - (make vertical ^min <min3> ^max <com> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn2> ^min-net <mnn>) - (make vertical ^min <gy> ^max <max3> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn1> ^max-net <man>) - (remove <v1>) -) - -(p p87 - (context ^present propagate-constraint) - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min <min2> ^max <gar2> ^com <com> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <min2> > <max1> } ^com <com> ^layer <lay> ^compo <egarb5> ^commo <egarb6>) } - - (vertical ^com { > <max1> < <min2> }) - --> - (remove <h1>) -) - -(p p88 - (context ^present << propagate-constraint extend-pins move-ff >>) - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com> ^layer <lay> ^compo <cpo> ^commo <egarb1>) - (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <min2> <= <max1> } ^max { <max2> >= <min1> } ^com <cpo> ^layer <lay> ^compo <garb1> ^compo <egarb2>) - { <h1> (horizontal ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <cpo> } ^com { <com2> <= <max1> >= <min1> <= <max2> >= <min2> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) } - --> - (make horizontal ^min <min3> ^max <com> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <mnn> ^max-net <nn1>) - (make horizontal ^min <cpo> ^max <max3> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <man> ^min-net <nn2>) - (remove <h1>) -) - -(p p89 - (context ^present propagate-constraint) - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min <min2> ^max <garb2> ^com <com> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) - - (horizontal ^com { > <max1> < <min2> }) - { <v1> (vertical ^net-name nil ^min <max1> ^max { <min2> > <max1> } ^com <com> ^layer <lay> ^compo <egarb5> ^commo <egarb6>) } - --> - (remove <v1>) -) - -(p p90 - (context ^present propagate-constraint) - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <vmin> ^max <garb1> ^com <vcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <hcom> ^layer <lay> ^compo <vmin> ^commo <garb5>) - { <v1> (vertical ^net-name nil ^min <garb4> ^max { <vmin> > <garb4> } ^com <vcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) } - --> - (modify <v1> ^max <hcom> ^max-net <nn2>) -) - -(p p91 - (context ^present propagate-constraint) - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <vmax>) - { <v1> (vertical ^net-name nil ^min <vmax> ^max { <garb5> > <vmax> } ^com <vcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) } - --> - (modify <v1> ^min <hcom> ^min-net <nn2>) -) - -(p p92 - (context ^present propagate-constraint) - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <min> ^max <garb1> ^com <hcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <vcom> ^layer <lay> ^compo <min> ^commo <egarb3>) - { <h1> (horizontal ^net-name nil ^min <garb4> ^max { <min> > <garb4> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - --> - (modify <h1> ^max <vcom> ^max-net <nn2>) -) - -(p p93 - (context ^present propagate-constraint) - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max> ^com <hcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <max>) - { <h1> (horizontal ^net-name nil ^min <max> ^max { <garb4> > <max> } ^com <hcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) } - --> - (modify <h1> ^min <vcom> ^min-net <nn2>) -) - -(p p94 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - { <h1> (horizontal ^net-name nil ^min <garb3> ^max { <gx> > <garb3> } ^com <gy> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) } - (vertical ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <vcom> ^layer <lay> ^compo <gx> ^commo <egarb2>) - --> - (modify <h1> ^max <vcom> ^max-net <nn2>) -) - -(p p95 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { <garb4> > <gx> } ^com <gy> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - (vertical ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <vcom> ^layer <lay> ^compo <garb3> ^commo <gx>) - --> - (modify <h1> ^min <vcom> ^min-net <nn2>) -) - -(p p96 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - (horizontal ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <hcom> ^layer <lay> ^compo <gy> ^commo <garb3>) - { <v1> (vertical ^net-name nil ^min <garb4> ^max { <gy> > <garb4> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - --> - (modify <v1> ^max <hcom> ^max-net <nn2>) -) - -(p p97 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - (horizontal ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <hcom> ^layer <lay> ^compo <garb3> ^commo <gy>) - { <v1> (vertical ^net-name nil ^min <gy> ^max { <garb4> > <gy> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - --> - (modify <v1> ^min <hcom> ^min-net <nn2>) -) - -(p p98 - (context ^present << propagate-constraint extend-pins random1 check-for-routed-net >>) - { <h1> (horizontal ^min <min> ^max <= <min>) } - --> - (remove <h1>) -) - -(p p99 - (context ^present << propagate-constraint extend-pins random1 check-for-routed-net >>) - { <v1> (vertical ^min <min> ^max <= <min>) } - --> - (remove <v1>) -) - -(p p100 - { <h1> (horizontal ^min <min> ^max <= <min>) } - --> - (remove <h1>) -) - -(p p101 - { <v1> (vertical ^min <min> ^max <= <min>) } - --> - (remove <v1>) -) - -(p p102 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com <min1>) - - (horizontal ^status nil ^min < <min1> ^max >= <min1> ^com <com1>) - (vertical ^status nil ^net-name <garb1> ^min { <vmin> <= <com1> } ^max { >= <com1> > <vmin> } ^com { <com2> > <min1> <= <max1> } ^layer <garb2> ^compo <egarb4> ^commo <egarb5>) - - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com { < <com2> >= <min1> }) - --> - (modify <h1> ^min <com2> ^min-net nil) -) - -(p p103 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com <min1>) - - (vertical ^status nil ^min < <min1> ^max >= <min1> ^com <com1>) - (horizontal ^status nil ^net-name <garb1> ^min { <hmin> <= <com1> } ^max { <garb2> >= <com1> > <hmin> } ^com { <com2> > <min1> <= <max1> } ^layer <garb3> ^compo <egarb4> ^commo <egarb5>) - - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com { < <com2> >= <min1> }) - --> - (modify <v1> ^min <com2> ^min-net nil) -) - -(p p104 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com <max1>) - - (horizontal ^status nil ^min <= <max1> ^max > <max1> ^com <com1>) - (vertical ^status nil ^net-name <garb1> ^min { <vmin> <= <com1> } ^max { <garb2> >= <com1> > <vmin> } ^com { <com2> >= <min1> < <max1> } ^layer <egarb1> ^compo <egarb2> ^commo <egarb3>) - - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com { > <com2> <= <max1> }) - --> - (modify <h1> ^max <com2> ^max-net nil) -) - -(p p105 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com <max1>) - - (vertical ^status nil ^min <= <max1> ^max > <max1> ^com <com1>) - (horizontal ^status nil ^net-name <garb1> ^min { <hmin> <= <com1> } ^max { <garb2> >= <com1> > <hmin> } ^com { <com2> >= <min1> < <max1> } ^layer <egarb1> ^compo <egarb4> ^commo <egarb5>) - - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com { > <com2> <= <max1> }) - --> - (modify <v1> ^max <com2> ^max-net nil) -) - -(p p106 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <hmin> ^max { <hmax> > <hmin> } ^com <hcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) } - - (vertical ^com { > <hmin> < <hmax> }) - - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <lay>) - - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <lay>) - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <> <lay> ^compo <egarb4> ^commo <egarb5>) - (vertical ^net-name { <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <hmin> ^layer <> <lay> ^compo <egarb2> ^commo <egarb3>) - --> - (remove <h1>) -) - -(p p107 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (horizontal ^com { > <vmin> < <vmax> }) - - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmax> ^layer <lay>) - - (vertical ^status nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <lay>) - (horizontal ^net-name { <nn1> <> nil } ^min { <garb1> <= <vcom> } ^max { <garb2> >= <vcom> } ^com <vmax> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - (horizontal ^net-name { <> <nn1> <> nil } ^min { <garb4> <= <vcom> } ^max { <garb5> >= <vcom> } ^com <vmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>) - --> - (remove <v1>) -) - -(p p108 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <hmin> ^max { <hmax> > <hmin> } ^com <hcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) } - - (vertical ^com { > <hmin> < <hmax> }) - - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmin> ^layer <lay>) - - (horizontal ^status nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <lay>) - - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <lay>) - (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <hmax> ^layer { <garb3> <> <lay> } ^compo <egarb2> ^commo <egarb3>) - (vertical ^net-name { <garb7> <> <nn1> <> nil } ^min { <gabr4> <= <hcom> } ^max { <garb5> >= <hcom> } ^com <hmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>) - --> - (remove <h1>) -) - -(p p109 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) } - - (horizontal ^com { > <vmin> < <vmax> }) - - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmin> ^layer <lay>) - - (vertical ^status nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <lay>) - (horizontal ^net-name { <nn1> <> nil } ^min { <garb1> <= <vcom> } ^max { <garb2> >= <vcom> } ^com <vmax> ^layer { <garb3> <> <lay> } ^compo <egarb2> ^commo <egarb3>) - (horizontal ^net-name { <garb7> <> <nn1> <> nil } ^min { <garb4> <= <vcom> } ^max { <garb5> >= <vcom> } ^com <vmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>) - --> - (remove <v1>) -) - -(p p110 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>) - - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> }) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil) - (horizontal ^net-name { <nn> <> nil } ^min <garb1> ^max <max1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) - (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <garb4> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max2> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> }) - --> - (modify <h1> ^max (compute <max2> - 1) ^max-net nil) -) - -(p p111 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max1> ^layer <lay>) - - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> }) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil) - (horizontal ^net-name { <nn> <> nil } ^min <max2> ^max <garb1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) - (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <garb4> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max1> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> }) - --> - (modify <h1> ^min (compute <max1> + 1) ^min-net nil) -) - -(p p112 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>) - - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { >= <max1> < <max2> }) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { >= <max1> < <max2> } ^max-net nil) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { >= <max1> < <max2> } ^min-net nil) - - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>) - (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max2> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { >= <max1> < <max2> }) - --> - (modify <h1> ^max (compute <max2> - 1) ^max-net nil) -) - -(p p113 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max1> ^layer <lay>) - - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> <= <max2> }) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> <= <max2> } ^max-net nil) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> <= <max2> } ^min-net nil) - - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>) - (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max1> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> <= <max2> }) - --> - (modify <h1> ^min (compute <max1> + 1) ^min-net nil) -) - -(p p114 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) } - (vertical ^net-name { <nn> <> nil } ^min <garb1> ^max <max1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) - - (horizontal ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>) - - (vertical ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>) - - (horizontal ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> }) - - (horizontal ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil) - - (horizontal ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil) - (horizontal ^net-name { <nn1> <> <nn> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <max2> ^layer { <garb4> <> <lay> } ^compo <egarb6> ^commo <egarb7>) - - (horizontal ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> }) - --> - (modify <v1> ^max (compute <max2> - 1) ^max-net nil) -) - -(p p115 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^compo <gy>) - { <v1> (vertical ^net-name nil ^min <vmin> ^max { <gy> > <vmin> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { >= <vmin> < <gy> }) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { >= <vmin> < <gy> } ^max-net nil) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { >= <vmin> < <gy> } ^min-net nil) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <vmin> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <vmin> ^max >= <vmin> ^com <gx>) - --> - (modify <v1> ^max (compute <gy> - 1) ^max-net nil) -) - -(p p116 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { <max2> > <gx> } ^com <gy> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) } - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> <= <max2> } ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> <= <max2> }) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> <= <max2> } ^max-net nil) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> <= <max2> }) - --> - (modify <h1> ^min (compute <gx> + 1) ^min-net nil) -) - -(p p117 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^min-net { <nn> <> nil }) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { <hmax> >= <vcom> > <hmin> } ^com <vmax> ^layer <lay> ^commo <vmin> ^min-net { <> <nn> <> nil } ^max-net { <> <nn> <> nil }) - - (vertical ^net-name nil ^min < <vmax> ^max > <vmax> ^com { > <hmin> < <hmax> }) - - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { > <hmin> < <vcom> } ^max-net nil) - - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { > <vcom> < <hmax> } ^max-net nil) - - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com { > <hmin> < <hmax> } ^min-net nil) - - (vertical ^net-name { <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { > <hmin> < <hmax> }) - --> - (remove <v1>) -) - -(p p118 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>) - - (vertical ^net-name nil ^com <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com > <max1>) - - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com < <min1>) - { <h1> (horizontal ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) } - - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com { >= <min1> <= <max1> } ^layer <lay2>) - { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) } - - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>) - (pin ^net-name <nn2> ^pin-x < <com1>) - (pin ^net-name <nn2> ^pin-x > <com1>) - { <b1> (branch-no <pn>) } - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <b1>) - (make horizontal ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make horizontal ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (make horizontal ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cmo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from east) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cpo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west) - (remove <h1>) -) - -(p p119 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>) - - (vertical ^net-name nil ^com <com1>) - { <h1> (horizontal ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) } - - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com > <com2>) - - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com < <com2>) - { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) } - - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>) - (pin ^net-name <nn2> ^pin-x < <com1>) - (pin ^net-name <nn2> ^pin-x > <com1>) - { <b1> (branch-no <pn>) } - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <b1>) - (make horizontal ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make horizontal ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (make horizontal ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cmo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from east) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cpo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west) - (remove <h1>) -) - -(p p120 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>) - - (horizontal ^net-name nil ^com <com1>) - - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com > <max1>) - - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com < <min1>) - { <v1> (vertical ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) } - - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com { >= <min1> <= <max1> } ^layer <lay2>) - { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) } - - (vertical ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>) - (pin ^net-name <nn2> ^pin-y < <com1>) - (pin ^net-name <nn2> ^pin-y > <com1>) - { <b1> (branch-no <pn>) } - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <b1>) - (make vertical ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make vertical ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (make vertical ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cmo1> ^grid-layer <lay2> ^came-from north) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cpo1> ^grid-layer <lay2> ^came-from south) - (remove <v1>) -) - -(p p121 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>) - - (horizontal ^net-name nil ^com <com1>) - { <v1> (vertical ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) } - - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com > <com2>) - - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com < <com2>) - { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) } - - (vertical ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>) - (pin ^net-name <nn2> ^pin-y < <com1>) - (pin ^net-name <nn2> ^pin-y > <com1>) - { <b1> (branch-no <pn>) } - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <b1>) - (make vertical ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make vertical ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (make vertical ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cmo1> ^grid-layer <lay2> ^came-from north) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cpo1> ^grid-layer <lay2> ^came-from south) - (remove <v1>) -) - -(p p122 - (context ^present propagate-constraint) - { <h1> (horizontal ^net-name nil ^min <min2> ^max { <max2> > <min2> } ^com <com2> ^layer <lay2> ^compo <cpo2> ^commo <cmo2>) } - - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com > <com2>) - - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com < <com2>) - - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com <com2> ^layer <> <lay2>) - (congestion ^direction col ^coordinate { <x1> <= <max2> } ^como { <x2> >= <min2> }) - - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com > <com2>) - - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com < <com2>) - - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com <com2> ^layer <> <lay2>) - { <t1> (to-be-routed ^net-name <nn2> ^no-of-attached-pins <nap>) } - - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <x2> ^max >= <x1>) - (pin ^net-name <nn2> ^pin-x <= <x2>) - (pin ^net-name <nn2> ^pin-x >= <x1>) - { <b1> (branch-no <pn>) } - - (horizontal ^net-name { <> <nn2> <> nil } ^min <= <x2> ^max >= <x2> ^com <com2> ^layer <lay2>) - - (vertical ^net-name { <> <nn2> <> nil } ^min <= <com2> ^max >= <com2> ^com <x2> ^layer <lay2>) - - (horizontal ^net-name { <> <nn2> <> nil } ^min <= <x1> ^max >= <x1> ^com <com2> ^layer <lay2>) - - (vertical ^net-name { <> <nn2> <> nil } ^min <= <com2> ^max >= <com2> ^com <x1> ^layer <lay2>) - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <b1>) - (make horizontal ^min <x2> ^max <x1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make horizontal ^min <min2> ^max <x2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (make horizontal ^min <x1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <x2> ^grid-y <com2> ^grid-layer <lay2> ^came-from east) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <x1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west) - (remove <h1>) -) - -(p p123 - (context ^present propagate-constraint) - { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com { <com1> <> 1 } ^layer <lay1> ^compo <cpo1> ^commo <cmo1> ^min-net <mnn> ^max-net <xnn>) } - - (horizontal ^net-name nil ^min < <com1> ^max > <com1>) - (horizontal ^net-name nil ^min <com1> ^max { <garb3> > <com1> } ^com { <bhcom> <= <max1> >= <min1> } ^layer <garb4>) - (horizontal ^net-name nil ^min { <garb1> < <com1> } ^max <com1> ^com { <thcom> <= <max1> > <bhcom> } ^layer <garb2>) - - (horizontal ^net-name nil ^min < <com1> ^max <com1> ^com { < <thcom> > <bhcom> }) - - (horizontal ^net-name nil ^min <com1> ^max > <com1> ^com { < <thcom> > <bhcom> }) - { <t1> (to-be-routed ^net-name <nn2> ^no-of-attached-pins <nap>) } - - (vertical ^status nil ^net-name { <nn2> <> nil } ^com <com1>) - - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>) - (pin ^net-name <nn2> ^pin-x < <com1>) - (pin ^net-name <nn2> ^pin-x > <com1>) - { <b1> (branch-no <pn>) } - --> - (make branch-no (compute <pn> + 1)) - (modify <t1> ^no-of-attached-pins (compute <nap> - 1)) - (remove <v1> <b1>) - (make vertical ^min <min1> ^max <bhcom> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^max-net <nn2> ^min-net <mnn>) - (make vertical ^min <thcom> ^max <max1> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^min-net <nn2> ^max-net <xnn>) - (make vertical ^min <bhcom> ^max <thcom> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^net-name <nn2> ^pin-name <pn>) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com1> ^grid-y <bhcom> ^grid-layer <lay1> ^came-from north) - (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com1> ^grid-y <thcom> ^grid-layer <lay1> ^came-from south) -) - -(p p124 - (context ^present propagate-constraint) - (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <com2> ^grid-layer <lay1> ^pin-name <egarb1>) - - (vertical ^net-name nil ^min <= <com2> ^max >= <com2> ^com <gx>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com > <com2>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com < <com2>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min < <gx>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^com < <gx>) - { <h1> (horizontal ^net-name nil ^min { <min2> < <gx> } ^max { <max2> >= <gx> > <min2> } ^com <com2> ^layer <lay1> ^compo <cpo2> ^commo <cmo2> ^min-net <nn2>) } - --> - (make horizontal ^min <min2> ^max (compute <gx> - 1) ^com <com2> ^layer <lay1> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>) - (modify <h1> ^min <gx> ^min-net <nn1>) -) - -(p p125 - (context ^present propagate-constraint) - (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <com2> ^grid-layer <lay1> ^pin-name <egarb1>) - - (vertical ^net-name nil ^min <= <com2> ^max >= <com2> ^com <gx>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com > <com2>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com < <com2>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^max > <gx>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^com > <gx>) - { <h1> (horizontal ^net-name nil ^min { <min2> <= <gx> } ^max { <max2> > <gx> > <min2> } ^com <com2> ^layer <lay1> ^compo <cpo2> ^commo <cmo2> ^max-net <nn2>) } - --> - (make horizontal ^min (compute <gx> + 1) ^max <max2> ^com <com2> ^layer <lay1> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>) - (modify <h1> ^max <gx> ^max-net <nn1>) -) - -(p p126 - (context ^present << propagate-constraint extend-total-verti >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> east ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) } - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) } - - (horizontal ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>) - - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>) - --> - (modify <h1> ^min (compute <max1> + 1) ^min-net <nn>) - (make horizontal ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>) - (modify <ff1> ^grid-x (compute <max1> + 1) ^came-from west ^can-chng-layer nil) -) - -(p p127 - (context ^present << propagate-constraint extend-total-verti >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> west ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) } - { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) } - - (horizontal ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>) - - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>) - --> - (modify <h1> ^max (compute <max1> - 1) ^max-net <nn>) - (make horizontal ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>) - (modify <ff1> ^grid-x (compute <max1> - 1) ^came-from east ^can-chng-layer nil) -) - -(p p128 - (context ^present << propagate-constraint extend-total-verti >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> north ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) } - { <v1> (vertical ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) } - - (vertical ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>) - - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>) - --> - (modify <v1> ^min (compute <max1> + 1) ^min-net <nn>) - (make vertical ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>) - (modify <ff1> ^grid-y (compute <max1> + 1) ^came-from south ^can-chng-layer nil) -) - -(p p129 - (context ^present << propagate-constraint extend-total-verti >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> south ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) } - { <v1> (vertical ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) } - - (vertical ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>) - - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>) - --> - (modify <v1> ^max (compute <max1> - 1) ^max-net <nn>) - (make vertical ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>) - (modify <ff1> ^grid-y (compute <max1> - 1) ^came-from north ^can-chng-layer nil) -) - -(p p130 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <h1> (horizontal ^status nil ^net-name <nn> ^min <min> ^max { <max> > <min> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <gar1>) } - { <h2> (horizontal ^status nil ^net-name <nn> ^min <max> ^max { <max2> > <max> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <nn1>) } - --> - (modify <h1> ^max <max2> ^max-net <nn1>) - (remove <h2>) -) - -(p p131 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <v1> (vertical ^status nil ^net-name <nn> ^min <min> ^max { <max> > <min> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <gar1>) } - { <v2> (vertical ^status nil ^net-name <nn> ^min <max> ^max { <max2> > <max> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <nn1>) } - --> - (modify <v1> ^max <max2> ^max-net <nn1>) - (remove <v2>) -) - -(p p132 - (context ^present propagate-constraint) - { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gar1> ^max <max> ^com <com> ^layer <lay> ^pin-name <pn>) } - { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) } - (vertical ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>) - --> - (modify <h1> ^max <max2>) - (remove <h2>) -) - -(p p133 - (context ^present propagate-constraint) - { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <gar1> ^com <com> ^layer <lay> ^pin-name <pn>) } - { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min2> ^max <min> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) } - (vertical ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>) - --> - (modify <h1> ^min <min2>) - (remove <h2>) -) - -(p p134 - (context ^present propagate-constraint) - { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <gar1> ^max <max> ^com <com> ^layer <lay> ^pin-name <pn>) } - { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>) - --> - (modify <v1> ^max <max2>) - (remove <v2>) -) - -(p p135 - (context ^present propagate-constraint) - { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <gar1> ^com <com> ^layer <lay> ^pin-name <pn>) } - { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min2> ^max <min> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>) - --> - (modify <v1> ^min <min2>) - (remove <v2>) -) - -(p p136 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> east ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) } - { <h1> (horizontal ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) } - - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>) - - (horizontal ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>) - --> - (modify <h1> ^min (compute <max1> + 1) ^min-net <nn>) - (make horizontal ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>) - (modify <ff1> ^grid-x (compute <max1> + 1) ^came-from west ^can-chng-layer nil) -) - -(p p137 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> west ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) } - { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) } - - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>) - - (horizontal ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>) - --> - (modify <h1> ^max (compute <max1> - 1) ^max-net <nn>) - (make horizontal ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>) - (modify <ff1> ^grid-x (compute <max1> - 1) ^came-from east ^can-chng-layer nil) -) - -(p p138 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> north ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) } - { <v1> (vertical ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) } - - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>) - - (vertical ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>) - --> - (modify <v1> ^min (compute <max1> + 1) ^min-net <nn>) - (make vertical ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>) - (modify <ff1> ^grid-y (compute <max1> + 1) ^came-from south ^can-chng-layer nil) -) - -(p p139 - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <ff1> (ff ^can-chng-layer no ^came-from <> south ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) } - { <v1> (vertical ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) } - - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>) - - (vertical ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>) - --> - (modify <v1> ^max (compute <max1> - 1) ^max-net <nn>) - (make vertical ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>) - (modify <ff1> ^grid-y (compute <max1> - 1) ^came-from north ^can-chng-layer nil) -) - -(p p140 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com> ^max >= <com> ^com { >= <min> <= <max> } ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - - (included <nn> <pn1>) - (included <nn> <pn2>) - --> - (make included <nn> <pn1>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p141 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com> ^max >= <com> ^com { >= <min> <= <max> } ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - (included <nn> <pn1>) - - (included <nn> <pn2>) - --> - (make included <nn> <pn2>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p142 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - (included <nn> <pn1>) - - (included <nn> <pn2>) - --> - (make included <nn> <pn2>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p143 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <egarb4> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - - (included <nn> <pn1>) - (included <nn> <pn2>) - --> - (make included <nn> <pn1>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p144 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <egarb4> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - (included <nn> <pn1>) - - (included <nn> <pn2>) - --> - (make included <nn> <pn2>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p145 - (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> }) - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - - (included <nn> <pn1>) - (included <nn> <pn2>) - --> - (make included <nn> <pn1>) - (modify <t1> ^no-of-attached-pins (compute <nap> + 1)) -) - -(p p146 - { <c1> (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) } - { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) } - { <n1> (net ^net-name <nn> ^net-no-of-pins <nap>) } - --> - (remove <c1> <t1>) - (make join-routed-net <nn>) - (modify <n1> ^net-is-routed yes) -) - -(p p147 - { <c1> (context ^present check-for-routed-net) } - --> - (remove <c1>) - (make context ^present move-ff) -) - -(p p148 - { <con> (context ^present move-ff) } - --> - (modify <con> ^present set-min-max) -) - -(p p149 - { <con> (context ^present set-min-max) } - --> - (remove <con>) - (make context ^present propagate-constraint) -) - -(p p150 - (context ^present propagate-constraint) - { <c1> (constraint ^pin-name-2 <pn>) } - - (ff ^pin-name <pn>) - --> - (remove <c1>) -) - -(p p151 - (context ^present propagate-constraint) - { <c1> (constraint ^pin-name-1 <pn>) } - - (ff ^pin-name <pn>) - --> - (remove <c1>) -) - -(p p152 - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (context ^present << propagate-constraint extend-total-verti move-ff >>) - { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <> <pn>) } - --> - (remove <ff1> <ff2>) -) - -(p p153 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) } - { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2> ^grid-layer <lay> ^pin-name <> <pn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy1>) - { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1> <ff2>) - (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <v1> ^min <gy2> ^min-net <nn>) - (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p154 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy2> ^layer <lay> ^compo <egarb1> ^commo <gy1> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>) - { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1>) - (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <v1> ^min <gy2> ^min-net <nn>) - (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p155 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2> ^grid-layer <lay> ^pin-name <pn>) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy1> ^layer <lay> ^compo <gy2> ^commo <egarb1> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1>) - { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1>) - (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <v1> ^min <gy2> ^min-net <nn>) - (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p156 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) } - (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> > <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^pin-name <garb1>) - { <ff2> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <max> } ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx1>) - { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1> <ff2>) - (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <h1> ^min <gx2> ^min-net <nn>) - (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p157 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) } - (vertical ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <gx2> ^layer <lay> ^compo <egarb1> ^commo <gx1> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y <gy>) - { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1>) - (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <h1> ^min <gx2> ^min-net <nn>) - (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p158 - (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>) - { <ff1> (ff ^net-name <nn> ^grid-x <gx2> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) } - (vertical ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <gx1> ^layer <lay> ^compo <gx2> ^commo <egarb1> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy>) - { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1>) - (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <h1> ^min <gx2> ^min-net <nn>) - (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p159 - (context ^present propagate-constraint) - { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) } - - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (vertical ^net-name <> nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - - (horizontal ^net-name <> nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { >= <gy> > <vmin> } ^com <gx> ^layer { <lay2> <> <lay> }) - --> - (modify <ff1> ^grid-layer <lay2> ^can-chng-layer no) -) - -(p p160 - (context ^present propagate-constraint) - { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) } - - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (vertical ^net-name <> nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - - (horizontal ^net-name <> nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { >= <gx> > <hmin> } ^com <gy> ^layer { <lay2> <> lay> }) - --> - (modify <ff1> ^grid-layer <lay2> ^can-chng-layer no) -) - -(p p161 - (context ^present propagate-constraint) - { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) } - - (horizontal ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - - (vertical ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - --> - (modify <ff1> ^can-chng-layer no) -) - -(p p162 - (context ^present << propagate-constraint move-ff >>) - { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) } - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - --> - (modify <ff1> ^can-chng-layer no) -) - -(p p163 - (context ^present << propagate-constraint move-ff >>) - { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) } - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - --> - (modify <ff1> ^can-chng-layer no) -) - -(p p164 - (context ^present propagate-constraint) - { <ff1> (ff ^can-chng-layer no ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn>) } - { <ff2> (ff ^can-chng-layer no ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay2> ^pin-name <garb1>) } - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx2>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy1>) - { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> >= <gx1> > <hmin> } ^com <gy1> ^layer <lay1> ^compo <hcpo> ^commo <gy2> ^min-net <hnn1>) } - { <v1> (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy1> > <vmin> } ^com <gx2> ^layer <lay2> ^compo <gx1> ^commo <vcmo> ^min-net <vnn1>) } - --> - (make horizontal ^min <hmin> ^max <gx2> ^com <gy1> ^commo <gy2> ^compo <hcpo> ^layer <lay1> ^min-net <hnn1> ^max-net <nn>) - (modify <h1> ^min <gx1> ^min-net <nn>) - (make vertical ^min <vmin> ^max <gy2> ^com <gx2> ^commo <vcmo> ^compo <gx1> ^layer <lay2> ^min-net <vnn1> ^max-net <nn>) - (modify <v1> ^min <gy1> ^min-net <nn>) - (remove <ff1> <ff2>) - (make horizontal ^min <gx2> ^max <gx1> ^com <gy1> ^commo <gy2> ^compo <hcpo> ^layer <lay1> ^net-name <nn> ^pin-name <pn>) - (make vertical ^min <gy2> ^max <gy1> ^com <gx2> ^commo <vcmo> ^compo <gx1> ^layer <lay2> ^net-name <nn> ^pin-name <pn>) -) - -(p p165 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <garb1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min <garb2> ^max { <max> > <garb2> } ^com <com> ^layer <lay> ^max-net <> <nn>) } - --> - (modify <v1> ^max-net <nn>) -) - -(p p166 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <min> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min <min> ^max { <garb2> > <min> } ^com <com> ^layer <lay> ^min-net <> <nn>) } - --> - (modify <v1> ^min-net <nn>) -) - -(p p167 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <max> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min { <garb1> < <max> } ^max <max> ^com { >= <hmin> <= <hmax> } ^layer <lay> ^max-net <> <nn>) } - --> - (modify <v1> ^max-net <nn>) -) - -(p p168 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <min> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <v1> (vertical ^net-name nil ^min <min> ^max { <garb1> > <min> } ^com { >= <hmin> <= <hmax> } ^layer <lay> ^min-net <> <nn>) } - --> - (modify <v1> ^min-net <nn>) -) - -(p p169 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <garb1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <h1> (horizontal ^net-name nil ^min <garb2> ^max { <max> > <garb2> } ^com <com> ^layer <lay> ^max-net <> <nn>) } - --> - (modify <h1> ^max-net <nn>) -) - -(p p170 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <min> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <h1> (horizontal ^net-name nil ^min <min> ^max { <garb2> > <min> } ^com <com> ^layer <lay> ^min-net <> <nn>) } - --> - (modify <h1> ^min-net <nn>) -) - -(p p171 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <max> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max> > <garb1> } ^com { >= <vmin> <= <vmax> } ^layer <lay> ^max-net <> <nn>) } - --> - (modify <h1> ^max-net <nn>) -) - -(p p172 - (context ^present << propagate-constraint extend-pins set-min-max >>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <min> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - { <h1> (horizontal ^net-name nil ^min <min> ^max { <garb1> > <min> } ^com { >= <vmin> <= <vmax> } ^layer <lay> ^min-net <> <nn>) } - --> - (modify <h1> ^min-net <nn>) -) - -(p p173 - (context ^present propagate-constraint) - { <ff1> (ff ^can-chng-layer no ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy2> ^layer <garb3> ^compo <garb4> ^commo <gy1> ^pin-name <> <pn>) - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy2>) - - (vertical ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx>) - { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) } - --> - (remove <ff1>) - (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (modify <v1> ^min <gy2> ^min-net <nn>) - (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>) -) - -(p p174 - (join-routed-net <nn>) - { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <lay> ^compo <garb1> ^commo <garb2>) } - { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>) } - --> - (modify <h1> ^max <max2>) - (remove <h2>) -) - -(p p175 - (join-routed-net <nn>) - { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <max> ^com <com> ^layer <lay> ^compo <garb2> ^commo <garb3>) } - { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - --> - (modify <v1> ^max <max2>) - (remove <v2>) -) - -(p p176 - { <j1> (join-routed-net <nn>) } - --> - (remove <j1>) - (make move-via <nn>) -) - -(p p177 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <vlayer> ^pin-name <egarb1>) - (horizontal ^net-name nil ^min <hmin2> ^max { <gx> > <hmin2> } ^com <vmax> ^layer <vlayer> ^compo <egarb8> ^commo <egarb9>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { < <vmax> > <gy> }) - { <v1> (vertical ^net-name nil ^min { <garb1> <= <gy> } ^max { <vmax> > <garb1> > <gy> } ^com <gx> ^layer <vlayer> ^commo <cmo> ^compo <cpo> ^max-net <maxn>) } - (horizontal ^net-name { <> <nn> <> nil } ^min { <hmin1> <= <gx> } ^max >= <gx> ^com <vmax> ^layer <> <vlayer>) - (vertical ^net-name { <> <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { <vcom> < <gx> >= <hmin1> >= <hmin2> } ^layer <vlayer>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com <vmax>) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { < <vmax> > <gy> } ^max-net nil) - - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <gx>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmax> ^max > <vmax> ^com <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gx> ^max > <gx> ^com <vmax>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { < <vmax> > <gy> } ^min-net nil) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { < <vmax> > <gy> }) - - (vertical ^net-name nil ^min < <vmax> ^max > <vmax> ^com { < <gx> > <vcom> }) - - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { < <gx> > <vcom> } ^max-net nil) - - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com { < <gx> > <vcom> } ^min-net nil) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { < <gx> > <vcom> }) - --> - (make vertical ^min (compute <gy> + 1) ^max <vmax> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <vlayer> ^max-net <maxn>) - (modify <v1> ^max <gy> ^max-net <nn>) -) - -(p p178 - (context ^present propagate-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <layer> ^pin-name <pn>) - { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <gx> > <hmin> } ^com <gy> ^layer <layer> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - (vertical ^net-name { <> <nn> <> nil } ^min <cpo> ^max { <garb2> >= <cpo> } ^com <vcom> ^layer <layer1> ^compo <vcpo> ^commo <gx>) - (horizontal ^net-name { <> <nn> <> nil } ^min { <garb3> <= <vcom> } ^max { <garb4> >= <vcom> } ^com <cpo> ^layer <> <layer1> ^compo <garb5> ^commo <gy>) - (vertical ^net-name { <> <nn> <> nil } ^min { <garb6> <= <cmo> } ^max <cmo> ^com <vcom> ^layer <layer2> ^compo <vcpo> ^commo <gx>) - (horizontal ^net-name { <> <nn> <> nil } ^min { <garb7> <= <vcom> } ^max { <garb8> >= <vcom> } ^com <cmo> ^layer <> <layer2> ^compo <gy> ^commo <garb9>) - (vertical ^net-name { <> <nn> <> nil } ^min { <garb13> <= <gy> } ^max { <garb14> >= <gy> } ^com <vcpo> ^layer <layer3> ^compo <garb10> ^commo <vcom>) - (horizontal ^net-name { <> <nn> <> nil } ^min { <garb11> <= <vcpo> } ^max { <garb12> >= <vcpo> } ^com <gy> ^layer <> <layer3> ^compo <cpo> ^commo <cmo>) - --> - (make horizontal ^min (compute <gx> + 1) ^max <hmax> ^com <gy> ^compo <cpo> ^commo <cmo> ^layer <layer> ^max-net <mn>) - (modify <h1> ^max <gx> ^max-net <nn>) -) - -(p p179 - (context ^present propagate-constraint) - { <ff1> (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <pn>) } - (vertical ^net-name { <> <nn> <> nil } ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com <vcom> ^layer <lay2> ^compo <garb1> ^commo <gx>) - (vertical ^net-name { <> <nn> <> nil } ^min { <vmax2> > <gy> <= <vmax> } ^max <garb4> ^com <gx> ^layer <lay4>) - (vertical ^net-name { <> <nn> <> nil } ^min <garb2> ^max { <vmin2> < <gy> >= <vmin> } ^com <gx> ^layer <lay3>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmin2> < <gy> }) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmin2> < <gy> } ^layer <> <lay2> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmin2> < <gy> } ^max-net nil) - - (horizontal ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { > <vmin2> < <gy> }) - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <vmin2> ^layer <> <lay3>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmax2> }) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmax2> } ^layer <> <lay2> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmax2> } ^max-net nil) - - (horizontal ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmax2> }) - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <vmax2> ^layer <> <lay4>) - { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> >= <vcom> > <hmin> } ^com <gy> ^layer { <lay5> <> <lay2> } ^compo <hcpo> ^commo <hcmo> ^max-net <mn>) } - --> - (make horizontal ^layer <lay5> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <nn> ^max-net <mn> ^min <vcom> ^max <hmax>) - (modify <h1> ^max <gx> ^max-net <nn>) - (make horizontal ^layer <lay5> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom>) - (modify <ff1> ^grid-x <vcom> ^grid-layer <lay5> ^can-chng-layer no) -) - -(p p180 - (context ^present propagate-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <vmax> ^com <vcom> ^layer <lay1> ^compo <cpo> ^commo <cmo>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <vmax> ^layer { <garb4> <> <lay1> }) - (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <vmin> > <vmax> } ^max <garb5> ^com <vcom> ^layer <lay2>) - (horizontal ^net-name { <nn1> <> nil } ^min { <garb6> <= <vcom> } ^max { <garb7> >= <vcom> } ^com <vmin> ^layer { <garb8> <> <lay2> }) - (vertical ^net-name { <> <nn> <> nil } ^min { <vmin2> <= <vmax> } ^max { <vmax2> >= <vmin> } ^com <cpo> ^layer <lay3>) - { <v1> (vertical ^net-name nil ^min <vmax> ^max { <vmax3> > <vmax> } ^com <vcom> ^layer <lay3>) } - - (vertical ^net-name nil ^min <vmax3> ^com <vcom>) - - (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com { > <vmax> <= <vmax3> }) - - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com { > <vmax> <= <vmax3> } ^layer <> <lay3> ^min-net nil) - - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com { > <vmax> <= <vmax3> } ^max-net nil) - - (horizontal ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com { > <vmax> <= <vmax3> }) - --> - (modify <v1> ^min (compute <vmax> + 1) ^min-net nil) -) - -(p p181 - (context ^present propagate-constraint) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) } - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <garb1> ^grid-layer <lay> ^pin-name <> <pn>) - - (vertical ^com { > <gx> < <gx2> }) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { <egarb1> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2>) - --> - (modify <h1> ^min (compute <gx> + 1) ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^com <gy> ^max (compute <gx> + 1) ^commo <hcmo> ^compo <hcpo> ^layer <lay>) - (modify <ff1> ^grid-x (compute <gx> + 1) ^came-from west) -) - -(p p182 - (context ^present propagate-constraint) - { <v3> (vertical ^net-name nil ^min <vmin2> ^max { <vmax2> > <vmin2> } ^com <vcom> ^layer <garb1> ^compo <vcpo> ^commo <egarb1>) } - (congestion ^direction row ^coordinate <vmax2> ^como <vmin2>) - - (horizontal ^status nil ^min < <vcom> ^max >= <vcom> ^com { <= <vmax2> >= <vmin2> }) - - (vertical ^status nil ^min <vmax2> ^max > <vmax2> ^com <vcom>) - - (vertical ^status nil ^max <vmin2> ^min < <vmin2> ^com <vcom>) - (vertical ^net-name nil ^min { <vmin> <= <vmin2> } ^max { > <vmin> >= <vmax2> } ^com <vcpo> ^layer <lay>) - (horizontal ^net-name nil ^min <vcom> ^max { <egarb2> > <vcom> } ^com <vmax2> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) - (horizontal ^net-name nil ^min <vcom> ^max { <egarb5> > <vcom> } ^com <vmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) - --> - (remove <v3>) -) - -(p p183 - (context ^present propagate-constraint) - { <v3> (vertical ^net-name nil ^min <vmin2> ^max { <vmax2> > <vmin2> } ^com <vcom> ^layer <garb1> ^compo <garb2> ^commo <vcmo>) } - (congestion ^direction row ^coordinate <vmax2> ^como <vmin2>) - - (horizontal ^status nil ^min <= <vcom> ^max > <vcom> ^com { <= <vmax2> >= <vmin2> }) - - (vertical ^status nil ^min <vmax2> ^max > <vmax2> ^com <vcom>) - - (vertical ^status nil ^max <vmin2> ^min < <vmin2> ^com <vcom>) - (vertical ^net-name nil ^min { <vmin> <= <vmin2> } ^max { > <vmin> >= <vmax2> } ^com <vcmo> ^layer <lay>) - (horizontal ^net-name nil ^min <egarb1> ^max { <vcom> > <egarb1> } ^com <vmax2> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) - (horizontal ^net-name nil ^min <egarb6> ^max { <vcom> > <egarb6> } ^com <vmin2> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) - --> - (remove <v3>) -) - -(p p184 - (context ^present propagate-constraint) - { <h3> (horizontal ^net-name nil ^min <hmin2> ^max { <hmax2> > <hmin2> } ^com <hcom> ^layer <garb1> ^compo <hcpo> ^commo <egarb1>) } - (congestion ^direction col ^coordinate <hmax2> ^como <hmin2>) - - (vertical ^status nil ^min < <hcom> ^max >= <hcom> ^com { <= <hmax2> >= <hmin2> }) - - (horizontal ^status nil ^min <hmax2> ^max > <hmax2> ^com <hcom>) - - (horizontal ^status nil ^max <hmin2> ^min < <hmin2> ^com <hcom>) - (horizontal ^net-name nil ^min { <hmin> <= <hmin2> } ^max { > <hmin> >= <hmax2> } ^com <hcpo> ^layer <lay>) - (vertical ^net-name nil ^min <hcom> ^max { <egarb2> > <hcom> } ^com <hmax2> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) - (vertical ^net-name nil ^min <hcom> ^max { <egarb5> > <hcom> } ^com <hmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) - --> - (remove <h3>) -) - -(p p185 - (context ^present propagate-constraint) - { <h3> (horizontal ^net-name nil ^min <hmin2> ^max { <hmax2> > <hmin2> } ^com <hcom> ^layer <garb1> ^compo <garb2> ^commo <hcmo>) } - (congestion ^direction col ^coordinate <hmax2> ^como <hmin2>) - - (vertical ^status nil ^min <= <hcom> ^max > <hcom> ^com { <= <hmax2> >= <hmin2> }) - - (horizontal ^status nil ^min <hmax2> ^max > <hmax2> ^com <hcom>) - - (horizontal ^status nil ^max <hmin2> ^min < <hmin2> ^com <hcom>) - (horizontal ^net-name nil ^min { <hmin> <= <hmin2> } ^max { > <hmin> >= <hmax2> } ^com <hcmo> ^layer <lay>) - (vertical ^net-name nil ^min <egarb1> ^max { <hcom> > <egarb1> } ^com <hmax2> ^layer <lay> ^compo <egarb3> ^compo <egarb4>) - (vertical ^net-name nil ^min <egarb5> ^max { <hcom> > <egarb5> } ^com <hmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) - --> - (remove <h3>) -) - -(p p538 - (finally-routed <nn>) - { <i1> (included <nn>) } - --> - (remove <i1>) -) - -(p p539 - (finally-routed <nn>) - { <ff1> (ff ^net-name <nn>) } - --> - (remove <ff1>) -) - -(p p540 - (finally-routed <nn>) - { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-1 <nn>) } - --> - (remove <c1>) -) - -(p p541 - (finally-routed <nn>) - { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-2 <nn>) } - --> - (remove <c1>) -) - -(p p542 - (finally-routed <nn>) - { <c> (<< horizontal-cycle vertical-cycle >> <nn>) } - --> - (remove <c>) -) - -(p p543 - (finally-routed <nn>) - { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-2 <nn>) } - --> - (remove <c1>) -) - -(p p544 - (finally-routed <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) - { <h1> (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { <hmax> > <hmin> >= <vcom> } ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <nn1>) } - --> - (make horizontal ^min <hmin> ^max (compute <vcom> - 1) ^com <hcom> ^compo <hcpo> ^commo <hcmo> ^layer <lay> ^min-net <nn1>) - (modify <h1> ^min (compute <vcom> + 1) ^min-net nil) -) - -(p p545 - (finally-routed <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) - { <v1> (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { <vmax> > <vmin> >= <hcom> } ^com { <vcom> >= <hmin> <= <hmax> } ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <nn1>) } - --> - (make vertical ^min <vmin> ^max (compute <hcom> - 1) ^com <vcom> ^compo <vcpo> ^commo <vcmo> ^layer <lay> ^min-net <nn1>) - (modify <v1> ^min (compute <hcom> + 1) ^min-net nil) -) - -(p p546 - (finally-routed <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <rmax> ^com <com> ^layer <lay> ^compo <garb4> ^commo <garb3>) - { <v1> (vertical ^net-name nil ^min <rmax> ^max { <garb2> > <rmax> } ^com <com> ^layer <lay> ^compo <garb6> ^commo <garb5>) } - --> - (modify <v1> ^min (compute <rmax> + 1) ^min-net nil) -) - -(p p547 - (finally-routed <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <rmin> ^max <garb1> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>) - { <v1> (vertical ^net-name nil ^min <garb2> ^max { <rmin> > <garb2> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) } - --> - (modify <v1> ^max (compute <rmin> - 1) ^max-net nil) -) - -(p p548 - (finally-routed <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <rmax> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>) - { <h1> (horizontal ^net-name nil ^min <rmax> ^max { <garb2> > <rmax> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) } - --> - (modify <h1> ^min (compute <rmax> + 1) ^min-net nil) -) - -(p p549 - (finally-routed <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <rmin> ^max <garb1> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>) - { <h1> (horizontal ^net-name nil ^min <garb2> ^max { <rmin> > <garb2> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) } - --> - (modify <h1> ^max (compute <rmin> - 1) ^max-net nil) -) - -(p p550 - { <f1> (finally-routed <nn>) } - --> - (remove <f1>) - (make context ^present remove-routed-net-segments <nn>) -) - -(p p551 - (context ^present remove-routed-net-segments <nn>) - { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <c> ^layer <lay> ^compo <garb1> ^commo <garb2>) } - --> - (modify <h1> ^status routed) - (write (crlf) |hor | <nn> <min> <max> <c> <lay>) -) - -(p p552 - (context ^present remove-routed-net-segments <nn>) - { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <c> ^layer <lay> ^compo <garb1> ^commo <garb2>) } - --> - (modify <v1> ^status routed) - (write (crlf) |ver | <nn> <min> <max> <c> <lay>) -) - -(p p553 - (context ^present remove-routed-net-segments <nn>) - { <h> (horizontal-s ^net-name <nn>) } - --> - (remove <h>) -) - -(p p554 - (context ^present remove-routed-net-segments <nn>) - { <v> (vertical-s ^net-name <nn>) } - --> - (remove <v>) -) - -(p p555 - (context ^present remove-routed-net-segments <nn>) - { <p> (pin ^net-name <nn>) } - --> - (remove <p>) -) - -(p p556 - (context ^present remove-routed-net-segments <nn>) - { <n> (net ^net-name <nn>) } - --> - (remove <n>) -) - -(p p557 - { <c1> (context ^present remove-routed-net-segments) } - --> - (remove <c1>) - (make context ^present check-for-routed-net) -) - -(p p32 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - { <v> (vertical ^net-name nil ^min <gy2> ^max > <gy2> ^com <gx2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^min-net <garb2>) } - - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com <gy2> ^layer <lay>) - (congestion ^direction row ^coordinate <gy3> ^como <gy2>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx2> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy3> ^layer <lay>) - --> - (modify <v> ^min <gy3> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn2> ^min <gy2> ^max <gy3> ^com <gx2> ^compo <gx1> ^commo <cmo> ^layer <lay>) - (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from south) -) - -(p p33 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - { <v> (vertical ^net-name nil ^min < <gy1> ^max <gy1> ^com <gx1> ^layer <lay> ^commo <gx2> ^compo <cpo> ^min-net <garb2>) } - - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com <gy1> ^layer <lay>) - (congestion ^direction row ^coordinate <gy1> ^como <gy3>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx1> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy3> ^layer <lay>) - --> - (modify <v> ^max <gy3> ^max-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn1> ^min <gy3> ^max <gy1> ^com <gx1> ^compo <cpo> ^commo <gx2> ^layer <lay>) - (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from north) -) - -(p p34 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - { <v> (vertical ^net-name nil ^min <gy2> ^max > <gy2> ^com <gx2> ^layer <lay> ^commo <gx1> ^compo <cpo> ^min-net <garb2>) } - - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy2> ^layer <lay>) - (congestion ^direction row ^coordinate <gy3> ^como <gy2>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx2> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy3> ^layer <lay>) - --> - (modify <v> ^min <gy3> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn2> ^min <gy2> ^max <gy3> ^com <gx2> ^compo <cpo> ^commo <gx1> ^layer <lay>) - (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from south) -) - -(p p35 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - { <v> (vertical ^net-name nil ^min < <gy1> ^max <gy1> ^com <gx1> ^layer <lay> ^commo <cmo> ^compo <gx2> ^min-net <garb2>) } - - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy1> ^layer <lay>) - (congestion ^direction row ^coordinate <gy1> ^como <gy3>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx1> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy3> ^layer <lay>) - --> - (modify <v> ^max <gy3> ^max-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn1> ^min <gy3> ^max <gy1> ^com <gx1> ^compo <gx2> ^commo <cmo> ^layer <lay>) - (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from north) -) - -(p p36 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - { <v> (horizontal ^net-name nil ^min <gx2> ^max > <gx2> ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^min-net <garb2>) } - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx2> ^layer <lay>) - (congestion ^direction col ^coordinate <gx3> ^como <gx2>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy2> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx3> ^layer <lay>) - --> - (modify <v> ^min <gx3> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn2> ^min <gx2> ^max <gx3> ^com <gy2> ^compo <gy1> ^commo <cmo> ^layer <lay>) - (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from west) -) - -(p p37 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - { <v> (horizontal ^net-name nil ^min < <gx1> ^max <gx1> ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <garb2>) } - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx1> ^layer <lay>) - (congestion ^direction col ^coordinate <gx1> ^como <gx3>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy1> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx3> ^layer <lay>) - --> - (modify <v> ^max <gx3> ^max-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn1> ^min <gx3> ^max <gx1> ^com <gy1> ^compo <cpo> ^commo <gy2> ^layer <lay>) - (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from east) -) - -(p p38 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - { <v> (horizontal ^net-name nil ^min < <gx2> ^max <gx2> ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^min-net <garb2>) } - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx2> ^layer <lay>) - (congestion ^direction col ^coordinate <gx2> ^como <gx3>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy2> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx3> ^layer <lay>) - --> - (modify <v> ^max <gx3> ^max-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn2> ^min <gx3> ^max <gx2> ^com <gy2> ^compo <gy1> ^commo <cmo> ^layer <lay>) - (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from east) -) - -(p p39 - (context ^present propagate-constraint) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - { <v> (horizontal ^net-name nil ^min <gx1> ^max > <gx1> ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <garb2>) } - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx1> ^layer <lay>) - (congestion ^direction col ^coordinate <gx3> ^como <gx1>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy1> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx3> ^layer <lay>) - --> - (modify <v> ^min <gx3> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn1> ^min <gx1> ^max <gx3> ^com <gy1> ^compo <cpo> ^commo <gy2> ^layer <lay>) - (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from west) -) - -(p p40 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p41 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p42 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>) - (last-row <gy>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p43 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>) - (last-row <gy>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p44 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay> ^commo 0) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p45 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay> ^commo 0) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p46 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <h1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <vmax2> ^max-net nil) -) - -(p p47 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p48 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>) - (last-col <gx>) - --> - (modify <v1> ^max <vmax2> ^max-net nil) -) - -(p p49 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>) - (last-col <gx>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p50 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay> ^commo 0) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^max <vmax2> ^max-net nil) -) - -(p p51 - (context ^present propagate-constraint) - (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay> ^commo 0) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p52 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p53 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p54 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>) - (last-row <gy>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p55 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>) - (last-row <gy>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p56 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay> ^commo 0) } - (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>) - (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <hmax2> ^max-net nil) -) - -(p p57 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>) - (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>) - - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>) - - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil) - - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil) - { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay> ^commo 0) } - (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>) - (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>) - (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^min <hmax2> ^min-net nil) -) - -(p p58 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <h1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>) - --> - (modify <h1> ^max <vmax2> ^max-net nil) -) - -(p p59 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p60 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>) - (last-col <gx>) - --> - (modify <v1> ^max <vmax2> ^max-net nil) -) - -(p p61 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>) - (last-col <gx>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p62 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay> ^commo 0) } - (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>) - (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^max <vmax2> ^max-net nil) -) - -(p p63 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>) - (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>) - - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>) - - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil) - - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil) - { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay> ^commo 0) } - (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>) - (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>) - (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>) - --> - (modify <v1> ^min <vmax2> ^min-net nil) -) - -(p p64 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max { <hmax> > <vcom> } ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>) - (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcpo> ^layer <lay> ^compo <garb2> ^commo <vcom>) - (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com <hcmo> ^layer <lay>) - - (vertical ^status nil ^min <vmax> ^max > <vmax> ^com <vcom>) - - (horizontal ^status nil ^min { <temp> <= <vcom> } ^max { > <temp> >= <vcom> } ^com <vmax> ^layer <> <lay>) - --> - (modify <v> ^max <hcmo> ^max-net nil) - (make (substr <h> 1 inf) ^max <vcmo> ^max-net <nn1>) - (modify <h> ^min <vcpo> ^min-net <nn2>) -) - -(p p65 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max { <hmax> > <vcom> } ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>) - (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcpo> ^layer <lay> ^compo <garb2> ^commo <vcom>) - (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com <hcpo> ^layer <lay>) - - (vertical ^status nil ^min < <vmin> ^max <vmin> ^com <vcom>) - - (horizontal ^status nil ^min { <temp> <= <vcom> } ^max { > <temp> >= <vcom> } ^com <vmin> ^layer <> <lay>) - --> - (modify <v> ^min <hcpo> ^min-net nil) - (make (substr <h> 1 inf) ^max <vcmo> ^max-net <nn1>) - (modify <h> ^min <vcpo> ^min-net <nn2>) -) - -(p p66 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max { <vmax> > <hcom> } ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>) - (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcpo> ^layer <lay> ^compo <garb2> ^commo <hcom>) - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com <vcmo> ^layer <lay>) - - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom>) - - (vertical ^status nil ^min { <temp> <= <hcom> } ^max { > <temp> >= <hcom> } ^com <hmax> ^layer <> <lay>) - --> - (modify <h> ^max <vcmo> ^max-net nil) - (make (substr <v> 1 inf) ^max <hcmo> ^max-net <nn1>) - (modify <v> ^min <hcpo> ^min-net <nn2>) -) - -(p p67 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max { <vmax> > <hcom> } ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>) - (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcpo> ^layer <lay> ^compo <garb2> ^commo <hcom>) - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com <vcpo> ^layer <lay>) - - (horizontal ^status nil ^min < <hmin> ^max <hmin> ^com <hcom>) - - (vertical ^status nil ^min { <temp> <= <hcom> } ^max { > <temp> >= <hcom> } ^com <hmin> ^layer <> <lay>) - --> - (modify <h> ^min <vcpo> ^min-net nil) - (make (substr <v> 1 inf) ^max <hcmo> ^max-net <nn1>) - (modify <v> ^min <hcpo> ^min-net <nn2>) -) - -(p p68 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>) - (horizontal ^net-name nil ^min < <vcom> ^max >= <vcom> ^com <hcmo> ^layer <lay>) - - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com <vmax> ^layer <> <lay>) - --> - (modify <h> ^max <vcmo> ^max-net <nn1>) -) - -(p p69 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min <vcom> ^max { <hmax> > <vcom> } ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcpo> ^layer <lay> ^compo <garb1> ^commo <vcom>) - (horizontal ^net-name nil ^min <= <vcom> ^max > <vcom> ^com <hcmo> ^layer <lay>) - - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com <vmax> ^layer <> <lay>) - --> - (modify <h> ^min <vcpo> ^min-net <nn1>) -) - -(p p70 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>) - (horizontal ^net-name nil ^min < <vcom> ^max >= <vcom> ^com <hcpo> ^layer <lay>) - - (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com <vmin> ^layer <> <lay>) - --> - (modify <h> ^max <vcmo> ^max-net <nn1>) -) - -(p p71 - (context ^present propagate-constraint) - { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - { <h> (horizontal ^net-name nil ^min <vcom> ^max { <hmax> > <vcom> } ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcpo> ^layer <lay> ^compo <garb1> ^commo <vcom>) - (horizontal ^net-name nil ^min <= <vcom> ^max > <vcom> ^com <hcpo> ^layer <lay>) - - (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com <vmin> ^layer <> <lay>) - --> - (modify <h> ^min <vcpo> ^min-net <nn1>) -) - -(p p72 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min <hcom> ^max { <vmax> > <hcom> } ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcpo> ^layer <lay> ^compo <garb1> ^commo <hcom>) - (vertical ^net-name nil ^min <= <hcom> ^max > <hcom> ^com <vcmo> ^layer <lay>) - - (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com <hmax> ^layer <> <lay>) - --> - (modify <v> ^min <hcpo> ^min-net <nn1>) -) - -(p p73 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>) - (vertical ^net-name nil ^min < <hcom> ^max >= <hcom> ^com <vcmo> ^layer <lay>) - - (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com <hmax> ^layer <> <lay>) - --> - (modify <v> ^max <hcmo> ^max-net <nn1>) -) - -(p p74 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min <hcom> ^max { <vmax> > <hcom> } ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcpo> ^layer <lay> ^compo <garb1> ^commo <hcom>) - (vertical ^net-name nil ^min <= <hcom> ^max > <hcom> ^com <vcpo> ^layer <lay>) - - (horizontal ^net-name nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com <hmin> ^layer <> <lay>) - --> - (modify <v> ^min <hcpo> ^min-net <nn1>) -) - -(p p75 - (context ^present propagate-constraint) - { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) } - { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) } - (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>) - (vertical ^net-name nil ^min < <hcom> ^max >= <hcom> ^com <vcpo> ^layer <lay>) - - (horizontal ^net-name nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com <hmin> ^layer <> <lay>) - --> - (modify <v> ^max <hcmo> ^max-net <nn1>) -) - -(p p76 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay>) - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <vlay>) - (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer { <hlay> <> <vlay> } ^compo <hcpo> ^commo <vmax>) - - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmax>) - { <v> (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <hlay>) } - --> - (modify <v> ^min <hcom> ^min-net <nn2>) -) - -(p p77 - (context ^present propagate-constraint) - (vertical ^net-name { <nn1> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay>) - (vertical ^net-name nil ^min <garb1> ^max { <vmin> > <garb1> } ^com <vcom> ^layer <vlay>) - (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer { <hlay> <> <vlay> } ^compo <vmin> ^commo <hcmo>) - - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmin>) - { <v> (vertical ^net-name nil ^min <garb2> ^max { <vmin> > <garb2> } ^com <vcom> ^layer <hlay>) } - --> - (modify <v> ^max <hcom> ^max-net <nn2>) -) - -(p p78 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay>) - (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <hlay>) - (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer { <vlay> <> <hlay> } ^compo <vcpo> ^commo <hmax>) - - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax>) - { <h> (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <vlay>) } - --> - (modify <h> ^min <vcom> ^min-net <nn2>) -) - -(p p79 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn1> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay>) - (horizontal ^net-name nil ^min <garb1> ^max { <hmin> > <garb1> } ^com <hcom> ^layer <hlay>) - (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer { <vlay> <> <hlay> } ^compo <hmin> ^commo <vcmo>) - - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmin>) - { <h> (horizontal ^net-name nil ^min <garb2> ^max { <hmin> > <garb2> } ^com <hcom> ^layer <vlay>) } - --> - (modify <h> ^max <vcom> ^max-net <nn2>) -) - -(p p80 - (context ^present propagate-constraint) - (last-col <lc>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> <= 1 } ^max <vmax> ^com <vcom> ^layer <vlay> ^pin-name <pn> ^commo <vcmo>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max { <hmax> >= <lc> } ^com <vmax> ^layer <hlay>) - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay>) } - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> }) - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> }) - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name <nn> ^min <= <vmax> ^max >= <vmax> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com <vcom>) - - (vertical ^net-name <nn> ^min <vmax> ^max > <vmax> ^com <vcom>) - - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com <vcom>) - - (vertical ^net-name <nn> ^min < <vmin> ^max <vmin> ^com <vcom>) - --> - (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcmo>) - (modify <h> ^max <vcmo> ^max-net <nn>) - (make ff ^grid-x <vcmo> ^grid-y <hcom> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from east) -) - -(p p81 - (context ^present propagate-constraint) - (last-row <lr>) - (last-col <lc>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max { <vmax> >= <lr> } ^com <vcom> ^layer <vlay> ^pin-name <pn> ^commo <vcmo>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max { <hmax> >= <lc> } ^com <vmin> ^layer <hlay>) - { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay>) } - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> }) - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> }) - - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>) - - (vertical ^net-name <nn> ^min <= <vmin> ^max >= <vmin> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com <vcom>) - - (vertical ^net-name <nn> ^min < <vmin> ^max <vmin> ^com <vcom>) - - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com <vcom>) - - (vertical ^net-name <nn> ^min <vmax> ^max > <vmax> ^com <vcom>) - --> - (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcmo>) - (modify <h> ^max <vcmo> ^max-net <nn>) - (make ff ^grid-x <vcmo> ^grid-y <hcom> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from east) -) - -(p p82 - (context ^present propagate-constraint) - (horizontal ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^pin-name <pn> ^commo <hcmo>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max <vmax1> ^com <hmin> ^layer <vlay1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max <vmax2> ^com <hmax> ^layer <vlay2>) - { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer <lay>) } - - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com { < <vcom> >= <hmin> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com { > <vcom> <= <hmax> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com { < <vcom> >= <hmin> }) - - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com <vcom> ^layer <> <lay>) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <> <lay>) - - (horizontal ^net-name <nn> ^min <= <hmax> ^max >= <hmax> ^com { > <hcom> <= <vmax2> }) - - (horizontal ^net-name <nn> ^min <= <hmin> ^max >= <hmin> ^com { > <hcom> <= <vmax1> }) - - (horizontal ^net-name nil ^min <= <hmax> ^max >= <hmax> ^com { > <hcom> <= <vmax2> }) - - (horizontal ^net-name nil ^min <= <hmin> ^max >= <hmin> ^com { > <hcom> <= <vmax1> }) - - (horizontal ^net-name nil ^min <= <hmax> ^max >= <hmax> ^com <hcom>) - - (horizontal ^net-name <nn> ^min <hmax> ^max > <hmax> ^com <hcom>) - - (horizontal ^net-name nil ^min <= <hmin> ^max >= <hmin> ^com <hcom>) - - (horizontal ^net-name <nn> ^min < <hmin> ^max <hmin> ^com <hcom>) - --> - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <hcmo>) - (modify <v> ^max <hcmo> ^max-net <nn>) - (make ff ^grid-x <vcom> ^grid-y <hcmo> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from north) -) - -(p p377 - (context ^present find-no-of-pins-on-a-row-col) - (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay> ^compo <egarb1> ^commo <egabr2>) - (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>) - (ff ^net-name <nn> ^grid-y <gy> ^pin-name { <pn2> <> <pn1> } ^grid-x { <gx> > <fx> <= <max> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <fx> ^max >= <gx> ^com <gy>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <fx> <= <gx> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col row ^coor <gy>) - --> - (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <fx> ^max-xy <gx> ^last-pin <pn1> ^last-xy <fx>) -) - -(p p378 - (context ^present find-no-of-pins-on-a-row-col) - (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx> > <fx> <= <max> } ^pin-name { <pn2> <> <pn1> }) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <fx> ^max >= <gx> ^com <gy>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <fx> <= <gx> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col row ^coor <gy>) - --> - (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <fx> ^max-xy <gx> ^last-pin <pn1> ^last-xy <fx>) -) - -(p p379 - (context ^present find-no-of-pins-on-a-row-col) - (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay>) - (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx> < <fx> >= <min> } ^pin-name { <pn2> <> <pn1> }) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <fx> >= <gx> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col row ^coor <gy>) - --> - (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <gx> ^max-xy <fx> ^last-pin <pn2> ^last-xy <gx>) -) - -(p p380 - (context ^present find-no-of-pins-on-a-row-col) - (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>) - (ff ^net-name <nn> ^grid-x <gx> ^pin-name { <pn2> <> <pn1> } ^grid-y { <gy> > <fy> <= <max> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <fy> ^max >= <gy> ^com <gx>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <fy> <= <gy> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col col ^coor <gx>) - --> - (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <fy> ^max-xy <gy> ^last-pin <pn1> ^last-xy <fy>) -) - -(p p381 - (context ^present find-no-of-pins-on-a-row-col) - (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy> > <fy> <= <max> } ^pin-name { <pn2> <> <pn1> }) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <fy> ^max >= <gy> ^com <gx>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <fy> <= <gy> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col col ^coor <gx>) - --> - (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <fy> ^max-xy <gy> ^last-pin <pn1> ^last-xy <fy>) -) - -(p p382 - (context ^present find-no-of-pins-on-a-row-col) - (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy> < <fy> >= <min> } ^pin-name { <pn2> <> <pn1> }) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <fy> ^com <gx>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <fy> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - (net ^net-name <nn> ^net-no-of-pins <np>) - - (total ^net-name <nn> ^row-col col ^coor <gx>) - --> - (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <gy> ^max-xy <fy> ^last-pin <pn2> ^last-xy <gy>) -) - -(p p383 - (context ^present find-no-of-pins-on-a-row-col) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <pn>) - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb3>) - - (ff ^net-name <nn> ^grid-y <= <gy> ^pin-name <> <pn>) - - (total ^net-name <nn>) - --> - (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins <np> ^total-pins <np>) -) - -(p p384 - (context ^present find-no-of-pins-on-a-row-col) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <pn>) - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb3> ^no-of-bottom-pins <np>) - - (ff ^net-name <nn> ^grid-y >= <gy> ^pin-name <> <pn>) - - (total ^net-name <nn>) - --> - (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins <np> ^total-pins <np>) -) - -(p p385 - (context ^present find-no-of-pins-on-a-row-col) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb2>) - - (total ^net-name <nn>) - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn> ^grid-x { <fx> > <gx> }) - - (ff ^net-name <nn> ^grid-y < <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <fx> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>) - { <v1> (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <mn>) } - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <gy> ^como <hcmo>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify <v1> ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff1> ^grid-y <hcmo> ^can-chng-layer nil) - (make total ^net-name <nn> ^row-col row ^coor <hcmo> ^level-pins <np> ^total-pins <np>) -) - -(p p386 - (context ^present find-no-of-pins-on-a-row-col) - { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb2> ^no-of-bottom-pins <np>) - - (total ^net-name <nn>) - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn> ^grid-x { <fx> > <gx> }) - - (ff ^net-name <nn> ^grid-y > <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <fx> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>) - { <v1> (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <mn>) } - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <hcmo> ^como <gy>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <nn> ^max-net <mn>) - (modify <v1> ^max <gy> ^max-net <nn>) - (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify <ff1> ^grid-y <hcmo> ^can-chng-layer nil) - (make total ^net-name <nn> ^row-col row ^coor <hcmo> ^level-pins <np> ^total-pins <np>) -) - -(p p387 - { <t1> (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <np> ^total-pins <np> ^min-xy nil ^max-xy nil) } - (pin ^net-name <nn> ^pin-x <px1>) - - (pin ^net-name <nn> ^pin-x < <px1>) - (pin ^net-name <nn> ^pin-x { <px2> > <px1> }) - - (pin ^net-name <nn> ^pin-x > <px2>) - --> - (modify <t1> ^min-xy <px1> ^max-xy <px2>) -) - -(p p388 - (context ^present find-no-of-pins-on-a-row-col) - --> - (make context ^previous find-no-of-pins-on-a-row-col) - (remove 1) -) - -(p p389 - (context ^previous find-no-of-pins-on-a-row-col) - (total) - --> - (remove 1) - (make context ^present modify-total) -) - -(p p390 - (context ^present delete-totals) - --> - (modify 1 ^present choose-between-nets-on-the-same-row-col) -) - -(p p391 - { <c1> (context ^present << choose-between-nets-on-the-same-row-col choose-between-nets-on-the-same-row-col-con >>) } - { <t1> (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <garb1>) } - - (total ^net-name <> <nn> ^level-pins >= <cou>) - - (total ^net-name <nn> ^row-col <> <rc> ^level-pins >= <cou>) - --> - (remove <c1> <t1>) - (make change-priority) - (make tran-total <rc> <xy> (substr <t1> nets inf)) -) - -(p p392 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <garb1> ^row-col { << row col >> <garb2> } ^coor <garb3> ^level-pins <cou> ^total-pins <cou>) - { <t1> (total ^level-pins < <cou>) } - --> - (remove <t1>) -) - -(p p393 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <garb1> ^row-col { << row col >> <garb2> } ^coor <garb3> ^level-pins <cou> ^total-pins <garb4>) - { <t1> (total ^level-pins <cou1> ^total-pins { < <cou> <> <cou1> }) } - --> - (remove <t1>) -) - -(p p394 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <garb1> ^level-pins <cou>) - { <t1> (total ^net-name <nn> ^row-col <> <rc> ^level-pins <cou>) } - --> - (remove <t1>) -) - -(p p395 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <garb1>) - { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <> <xy> ^level-pins <cou>) } - --> - (remove <t1>) -) - -(p p396 - { <c1> (context ^present << choose-between-nets-on-the-same-row-col choose-between-nets-on-the-same-row-col-con >>) } - { <t1> (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <cou>) } - - (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou>) - --> - (remove <c1> <t1>) - (make change-priority) - (make tran-total <rc> <xy> (substr <t1> nets inf)) -) - -(p p397 - { <t1> (tran-total <rc> <xy> { <nn> <> nil <> end } <min> <max>) } - --> - (write (crlf) |***** next net to be routed is| <nn> *****) - (make next-segment <nn> <rc> <xy> useless <min> <max>) - (remove <t1>) - (make tran-total <rc> <xy> (substr <t1> 7 inf)) -) - -(p p398 - { <t1> (tran-total <rc> <xy> nil) } - --> - (make dominant-layer) - (remove <t1>) - (make goal cleanup total-verti) - (make goal cleanup counted-verti) - (make goal cleanup total) - (make goal cleanup extend-ff-tried) -) - -(p p399 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn> ^row-col { << row col >> <garb1> } ^coor <garb2> ^level-pins <cou> ^total-pins <cou>) - { <t1> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins > <cou>) } - --> - (remove <t1>) -) - -(p p400 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn> ^row-col { << row col >> <garb1> } ^coor <garb2> ^level-pins <cou> ^total-pins <cou1>) - { <t1> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins > <cou1>) } - - (total ^net-name <garb3> ^row-col <garb4> ^coor <garb5> ^level-pins <cou2> ^total-pins <cou2>) - --> - (remove <t1>) -) - -(p p401 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <garb1> ^row-col <garb2> ^coor <garb3> ^level-pins <cou1> ^total-pins <cou2>) - { <t1> (total ^net-name <garb4> ^row-col <garb5> ^coor <garb6> ^level-pins < <cou1> ^total-pins < <cou2>) } - --> - (remove <t1>) -) - -(p p402 - (context ^present choose-between-nets-on-the-same-row-col) - --> - (modify 1 ^present choose-between-nets-on-the-same-row-col-con) -) - -(p p403 - (context ^present choose-between-nets-on-the-same-row-col-con) - { <t1> (total ^net-name <nn> ^row-col row ^level-pins <cou> ^total-pins <cou2> ^cong nil) } - (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2>) - (pin ^net-name <nn> ^pin-x <px1>) - - (pin ^net-name <nn> ^pin-x < <px1>) - (pin ^net-name <nn> ^pin-x { <px2> > <px1> }) - - (pin ^net-name <nn> ^pin-x > <px2>) - (congestion ^direction col ^coordinate { >= <px1> <= <px2> } ^no-of-nets <non>) - - (congestion ^direction col ^coordinate { >= <px1> <= <px2> } ^no-of-nets > <non>) - --> - (modify <t1> ^cong <non>) -) - -(p p404 - (context ^present choose-between-nets-on-the-same-row-col-con) - { <t1> (total ^net-name <nn> ^row-col col ^level-pins <cou> ^total-pins <cou2> ^cong nil) } - (total <> <nn> { } { } <cou> <cou2>) - (pin ^net-name <nn> ^pin-y <py1>) - - (pin ^net-name <nn> ^pin-y < <py1>) - (pin ^net-name <nn> ^pin-y { <py2> > <py1> }) - - (pin ^net-name <nn> ^pin-y > <py2>) - (congestion ^direction row ^coordinate { >= <py1> <= <py2> } ^no-of-nets <non>) - - (congestion ^direction row ^coordinate { >= <py1> <= <py2> } ^no-of-nets > <non>) - --> - (modify <t1> ^cong <non>) -) - -(p p405 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <min1> ^max-xy <max1>) - (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy { <min2> > <max1> } ^max-xy <max2>) - { <t> (total ^net-name <nn1> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <= <max1> ^max-xy >= <min2>) } - --> - (remove <t>) -) - -(p p406 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <min1> ^max-xy <max1>) - { <t> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy >= <min1> ^max-xy <= <max1>) } - --> - (remove <t>) -) - -(p p407 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) - { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) } - (<< vertical-cycle horizontal-cycle >> <nn1>) - --> - (remove <t>) -) - -(p p408 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) - { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) } - (pin ^net-name <nn1> ^pin-y { <py> < <y> } ^pin-channel-side << left right >>) - - (pin ^net-name <nn> ^pin-y { > <py> < <y> } ^pin-channel-side << left right >>) - --> - (remove <t>) -) - -(p p409 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) - { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) } - (pin ^net-name <nn1> ^pin-y { <py> > <y> } ^pin-channel-side << left right >>) - - (pin ^net-name <nn> ^pin-y { > <y> < <py> } ^pin-channel-side << left right >>) - --> - (remove <t>) -) - -(p p410 - (context ^present choose-between-nets-on-the-same-row-col-con) - (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong <non>) - - (total ^cong nil) - { <t> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong <= <non>) } - --> - (remove <t>) -) - -(p p411 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn1> ^row-col <rc1> ^coor <xy1> ^level-pins <cou> ^total-pins > <cou>) - { <t1> (total ^net-name <nn2> ^row-col { <rc2> <> <rc1> } ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) } - { <t2> (total ^net-name <> <nn2> ^row-col <rc2> ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) } - --> - (remove <t1> <t2>) -) - -(p p412 - (context ^present choose-between-nets-on-the-same-row-col) - (total ^net-name <nn1> ^row-col <rc1> ^coor <xy1> ^level-pins <cou> ^total-pins > <cou>) - { <t1> (total ^net-name <nn2> ^row-col <rc2> ^coor { <xy2> <> <xy1> } ^level-pins <cou> ^total-pins > <cou>) } - { <t2> (total ^net-name <> <nn2> ^row-col <rc2> ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) } - --> - (remove <t1> <t2>) -) - -(p p413 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-bottom-pins { <np> > 1 } ^net-is-routed <> yes) - - (total-verti <nn> bottom) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom) - --> - (make total-verti <nn> bottom 0 <np>) -) - -(p p414 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> bottom) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom) - (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>) - --> - (make total-verti <nn> bottom 0 <np>) -) - -(p p415 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> bottom) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom) - (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>) - --> - (make total-verti <nn> bottom 0 <np>) -) - -(p p416 - (context ^present find-no-of-vcg-hcg) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <garb1>) - (pin ^net-name <nn> ^pin-x <gx> ^pin-channel-side top ^pin-name <pn1>) - (net ^net-name { <nn1> <> <nn> } ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes) - (pin ^net-name <nn1> ^pin-x <gx> ^pin-channel-side bottom ^pin-name <pn2>) - - (total-verti <nn1> bottom) - - (constraint ^constraint-type vertical ^net-name-1 <nn> ^net-name-2 <nn1> ^pin-name-1 <pn1> ^pin-name-2 <pn2>) - --> - (make counted-verti <nn1> bottom <nn> <pn1> <pn2>) - (make total-verti <nn1> bottom 1 <np>) -) - -(p p417 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-left-pins { <np> > 1 } ^net-is-routed <> yes) - - (total-verti <nn> left) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left) - --> - (make total-verti <nn> left 0 <np>) -) - -(p p418 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> left) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left) - (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>) - --> - (make total-verti <nn> left 0 <np>) -) - -(p p419 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> left) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left) - (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>) - --> - (make total-verti <nn> left 0 <np>) -) - -(p p420 - (context ^present find-no-of-vcg-hcg) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb3> ^pin-name <garb2>) - (pin ^net-name <nn> ^pin-y <gy> ^pin-channel-side right ^pin-name <pn1>) - (net ^net-name { <nn1> <> <nn> } ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes) - (pin ^net-name <nn1> ^pin-y <gy> ^pin-channel-side left ^pin-name <pn2>) - - (total-verti <nn1> left) - - (constraint ^constraint-type horizontal ^net-name-1 <nn> ^net-name-2 <nn1> ^pin-name-1 <pn1> ^pin-name-2 <pn2>) - --> - (make counted-verti <nn1> left <nn> <pn1> <pn2>) - (make total-verti <nn1> left 1 <np>) -) - -(p p421 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-top-pins { <np> > 1 } ^net-is-routed <> yes) - - (total-verti <nn> top) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top) - --> - (make total-verti <nn> top 0 <np>) -) - -(p p422 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-top-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> top) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top) - (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>) - --> - (make total-verti <nn> top 0 <np>) -) - -(p p423 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-top-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> top) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top) - (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>) - --> - (make total-verti <nn> top 0 <np>) -) - -(p p424 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-right-pins { <np> > 1 } ^net-is-routed <> yes) - - (total-verti <nn> right) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right) - --> - (make total-verti <nn> right 0 <np>) -) - -(p p425 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-right-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> right) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right) - (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>) - --> - (make total-verti <nn> right 0 <np>) -) - -(p p426 - (context ^present find-no-of-vcg-hcg) - (net ^net-name <nn> ^no-of-right-pins { <np> > 0 } ^net-is-routed <> yes) - - (total-verti <nn> right) - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right) - (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>) - --> - (make total-verti <nn> right 0 <np>) -) - -(p p427 - (context ^present find-no-of-vcg-hcg) - (total-verti <nn> bottom <ntc>) - (constraint ^constraint-type vertical ^net-name-1 <tn> ^net-name-2 <nn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - - (counted-verti <nn> bottom <tn> <tpn> <bpn>) - --> - (make counted-verti <nn> bottom <tn> <tpn> <bpn>) - (modify 2 ^4 (compute <ntc> + 1)) -) - -(p p428 - (context ^present find-no-of-vcg-hcg) - (total-verti <nn> left <ntc>) - (constraint ^constraint-type horizontal ^net-name-1 <tn> ^net-name-2 <nn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - - (counted-verti <nn> left <tn> <tpn> <bpn>) - --> - (make counted-verti <nn> left <tn> <tpn> <bpn>) - (modify 2 ^4 (compute <ntc> + 1)) -) - -(p p429 - (context ^present find-no-of-vcg-hcg) - (total-verti <nn> top <ntc>) - (constraint ^constraint-type vertical ^net-name-1 <nn> ^net-name-2 <bn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - - (counted-verti <nn> top <bn> <tpn> <bpn>) - --> - (make counted-verti <nn> top <bn> <tpn> <bpn>) - (modify 2 ^4 (compute <ntc> + 1)) -) - -(p p430 - (context ^present find-no-of-vcg-hcg) - (total-verti <nn> right <ntc>) - (constraint ^constraint-type horizontal ^net-name-1 <nn> ^net-name-2 <bn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>) - - (counted-verti <nn> right <bn> <tpn> <bpn>) - --> - (make counted-verti <nn> right <bn> <tpn> <bpn>) - (modify 2 ^4 (compute <ntc> + 1)) -) - -(p p431 - (context ^present find-no-of-vcg-hcg) - --> - (remove 1) - (make context ^previous find-no-of-vcg-hcg) -) - -(p p432 - (context ^previous find-no-of-vcg-hcg) - (total-verti) - --> - (remove 1) - (make context ^present choose-between-total-verti) - (make context ^present choose-between-total-verti-0) -) - -(p p433 - (context ^present choose-between-total-verti) - - (total-verti ^4 0) - { <t> (total-verti <nn> bottom <garb> > 1) } - - (ff ^net-name <nn> ^came-from south) - --> - (remove <t>) -) - -(p p434 - (context ^present choose-between-total-verti) - - (total-verti ^4 0) - { <t> (total-verti <nn> top <garb> > 1) } - - (ff ^net-name <nn> ^came-from north) - --> - (remove <t>) -) - -(p p435 - (context ^present choose-between-total-verti) - - (total-verti ^4 0) - { <t> (total-verti <nn> left <garb> > 1) } - - (ff ^net-name <nn> ^came-from west) - --> - (remove <t>) -) - -(p p436 - (context ^present choose-between-total-verti) - - (total-verti ^4 0) - { <t> (total-verti <nn> right <garb> > 1) } - - (ff ^net-name <nn> ^came-from east) - --> - (remove <t>) -) - -(p p437 - (context ^present choose-between-total-verti) - --> - (modify 1 ^present extend-total-verti) -) - -(p p438 - (context ^present choose-between-total-verti) - (total-verti ^4 > 0) - (total-verti ^4 0) - --> - (remove 3) -) - -(p p439 - (context ^present choose-between-total-verti) - (total-verti <nn> { << top bottom >> <tb> } > 0) - (total-verti <nn> { << top bottom >> <> <tb> } 0) - --> - (remove 3) -) - -(p p440 - (context ^present choose-between-total-verti) - (total-verti <nn> { << left right >> <tb> } > 0) - (total-verti <nn> { << left right >> <> <tb> } 0) - --> - (remove 3) -) - -(p p441 - (context ^present choose-between-total-verti-0) - (total-verti <nn> { << top bottom >> <tb> } > 0) - (total-verti <nn> { << top bottom >> <> <tb> } > 0) - --> - (remove 2 3) -) - -(p p442 - (context ^present choose-between-total-verti-0) - (total-verti <nn> { << left right >> <tb> } > 0) - (total-verti <nn> { << left right >> <> <tb> } > 0) - --> - (remove 2 3) -) - -(p p443 - (context ^present choose-between-total-verti-0) - --> - (remove 1) -) - -(p p444 - (context ^present extend-total-verti) - (total-verti <nn> bottom ^5 > 1) - - (total-verti ^5 1) - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) - - (ff ^net-name <nn> ^grid-y < <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com <gx>) - (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> > <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - (congestion ^direction row ^coordinate <como> ^como <gy>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <como> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^min <min> ^max <gy> ^min-net <mn> ^max-net <nn> ^commo <vcmo> ^compo <vcpo> ^com <gx> ^layer <lay>) - (modify 4 ^min <como> ^min-net <nn>) - (make vertical ^net-name <nn> ^min <gy> ^max <como> ^layer <lay> ^commo <vcmo> ^compo <vcpo> ^pin-name <pn> ^com <gx>) - (modify 3 ^grid-y <como> ^can-chng-layer nil) - (remove 2) -) - -(p p445 - (context ^present extend-total-verti) - (total-verti <nn> left ^5 > 1) - - (total-verti ^5 1) - (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) - - (ff ^net-name <nn> ^grid-x < <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx> ^com <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { > <min> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - (congestion ^direction col ^coordinate <como> ^como <gx>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gy> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <como> ^layer <lay>) - --> - (make horizontal ^net-name nil ^min <min> ^max <gx> ^min-net <mn> ^max-net <nn> ^commo <hcmo> ^compo <hcpo> ^com <gy> ^layer <lay>) - (modify 4 ^min <como> ^min-net <nn>) - (make horizontal ^net-name <nn> ^min <gx> ^max <como> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^pin-name <pn> ^com <gy>) - (modify 3 ^grid-x <como> ^can-chng-layer nil) - (remove 2) -) - -(p p446 - (context ^present extend-total-verti) - (total-verti <nn> top ^5 > 1) - - (total-verti ^5 1) - (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) - - (ff ^net-name <nn> ^grid-y > <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com <gx>) - (vertical ^net-name nil ^max { <max> >= <gy> } ^min { < <max> < <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^max-net <mn>) - (congestion ^direction row ^coordinate <gy> ^como <como>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <como> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^min <gy> ^max <max> ^max-net <mn> ^min-net <nn> ^commo <vcmo> ^compo <vcpo> ^com <gx> ^layer <lay>) - (modify 4 ^max <como> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <como> ^layer <lay> ^commo <vcmo> ^compo <vcpo> ^pin-name <pn> ^com <gx>) - (modify 3 ^grid-y <como> ^can-chng-layer nil) - (remove 2) -) - -(p p447 - (context ^present extend-total-verti) - (total-verti <nn> right ^5 > 1) - - (total-verti ^5 1) - (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) - - (ff ^net-name <nn> ^grid-x > <gx>) - - (horizontal ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx> ^status nil ^com <gy>) - (horizontal ^net-name nil ^max { <max> >= <gx> } ^min { < <max> < <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^max-net <mn>) - (congestion ^direction col ^coordinate <gx> ^como <como>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gy> ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <como> ^layer <lay>) - --> - (make horizontal ^net-name nil ^min <gx> ^max <max> ^max-net <mn> ^min-net <nn> ^commo <hcmo> ^compo <hcpo> ^com <gy> ^layer <lay>) - (modify 4 ^max <como> ^max-net <nn>) - (make horizontal ^net-name <nn> ^max <gx> ^min <como> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^pin-name <pn> ^com <gy>) - (modify 3 ^grid-x <como> ^can-chng-layer nil) - (remove 2) -) - -(p p448 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> bottom ^5 1) } - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin>) - { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c6> ^max <hcom> ^max-net <nn>) - (modify <c4> ^min <hcom>) - (make pull-ff north <nn> <gx> <gy> <gx> <hcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from north) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p449 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> bottom ^5 1) } - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin> ^grid-layer <garb1> ^pin-name <garb2>) } - { <c7> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb3> ^commo <garb4>) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c7> ^max <hcom> ^max-net <nn>) - (modify <c4> ^min <hcom>) - (make pull-ff north <nn> <gx> <gy> <gx> <hcom>) - (modify <c5> ^grid-y <hcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p450 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> bottom ^5 1) } - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> }) - { <c41> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin1> > <gy> } ^com { <vcom1> > <gx> } ^layer <lay> ^pin-name <pn1>) } - - (vertical-s ^net-name <> <nn> ^com <vcom1>) - { <c61> (vertical ^net-name nil ^min <vvmin1> ^max { <vmin1> > <vvmin1> } ^com <vcom1> ^layer <lay>) } - (horizontal ^net-name nil ^min { <hmin1> <= <gx> } ^max { > <hmin1> >= <vcom1> } ^com { <hcom1> >= <vvmin1> < <vmin1> <= <hcom> }) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom1> ^com { >= <vvmin1> < <hcom1> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom1> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin1> > <hcom1> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <hcom1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <vcom> ^layer <lay>) - --> - (modify <c61> ^max <hcom1> ^max-net <nn>) - (modify <c41> ^min <hcom1>) - (make pull-ff north <nn> <gx> <gy> <gx> <hcom1>) - (make ff ^net-name <nn> ^pin-name <pn1> ^grid-layer <lay> ^grid-x <vcom1> ^grid-y <hcom1> ^came-from north) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p451 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> bottom ^5 1) } - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin>) - { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay>) } - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> >= <vvmin> < <vmin> }) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { >= <vvmin> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c6> ^max <hcom> ^max-net <nn>) - (modify <c4> ^min <hcom>) - (make pull-ff north <nn> <gx> <gy> <gx> <hcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from north) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p452 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> bottom ^5 1) } - (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin> ^grid-layer <garb1> ^pin-name <garb2>) } - { <c7> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay>) } - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> >= <vvmin> < <vmin> }) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { >= <vvmin> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c7> ^max <hcom> ^max-net <nn>) - (modify <c4> ^min <hcom>) - (make pull-ff north <nn> <gx> <gy> <gx> <hcom>) - (modify <c5> ^grid-y <hcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p453 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> top ^5 1) } - (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax>) - { <c6> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> <= <vvmax> > <vmax> }) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { <= <vvmax> > <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c6> ^min <hcom> ^min-net <nn>) - (modify <c4> ^max <hcom>) - (make pull-ff south <nn> <gx> <gy> <gx> <hcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from south) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p454 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> top ^5 1) } - (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax> ^grid-layer <garb2> ^pin-name <garb3>) } - { <c7> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> <= <vvmax> > <vmax> }) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { <= <vvmax> > <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c7> ^min <hcom> ^min-net <nn>) - (modify <c4> ^max <hcom>) - (make pull-ff south <nn> <gx> <gy> <gx> <hcom>) - (modify <c5> ^grid-y <hcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p455 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> top ^5 1) } - (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax>) - { <c6> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> <= <vvmax> > <vmax> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { <= <vvmax> > <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c6> ^min <hcom> ^min-net <nn>) - (modify <c4> ^max <hcom>) - (make pull-ff south <nn> <gx> <gy> <gx> <hcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from south) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p456 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> top ^5 1) } - (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (vertical-s ^net-name <> <nn> ^com <vcom>) - { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax> ^grid-layer <garb4> ^pin-name <garb5>) } - { <c7> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) } - (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> <= <vvmax> > <vmax> }) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { <= <vvmax> > <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> }) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - --> - (modify <c7> ^min <hcom> ^min-net <nn>) - (modify <c4> ^max <hcom>) - (make pull-ff south <nn> <gx> <gy> <gx> <hcom>) - (modify <c5> ^grid-y <hcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p457 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> left ^5 1) } - (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom>) - { <c6> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> >= <hhmin> < <hmin> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { >= <hhmin> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c6> ^max <vcom> ^max-net <nn>) - (modify <c4> ^min <vcom>) - (make pull-ff east <nn> <gx> <gy> <gy> <vcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from east) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p458 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> left ^5 1) } - (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - { <c5> (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) } - { <c7> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) } - (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> >= <hhmin> < <hmin> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { >= <hhmin> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c7> ^max <vcom> ^max-net <nn>) - (modify <c4> ^min <vcom>) - (make pull-ff east <nn> <gx> <gy> <gy> <vcom>) - (modify <c5> ^grid-x <vcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p459 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> left ^5 1) } - (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom>) - { <c6> (horizontal ^net-name nil ^max <hmin> ^min { <hhmin> < <hmin> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> >= <hhmin> < <hmin> }) - - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { >= <hhmin> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c6> ^max <vcom> ^max-net <nn>) - (modify <c4> ^min <vcom>) - (make pull-ff east <nn> <gx> <gy> <gy> <vcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from east) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p460 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> left ^5 1) } - (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - { <c5> (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) } - { <c7> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) } - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> >= <hhmin> < <hmin> }) - - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { >= <hhmin> < <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c7> ^max <vcom> ^max-net <nn>) - (modify <c4> ^min <vcom>) - (make pull-ff east <nn> <gx> <gy> <gy> <vcom>) - (modify <c5> ^grid-x <vcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p461 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> right ^5 1) } - (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom>) - { <c6> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) } - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> <= <hhmax> > <hmax> }) - - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { <= <hhmax> > <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c6> ^min <vcom> ^min-net <nn>) - (modify <c4> ^max <vcom>) - (make pull-ff west <nn> <gx> <gy> <gy> <vcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from west) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p462 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> right ^5 1) } - (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - { <c5> (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) } - { <c7> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <gabr6> ^commo <garb7>) } - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> <= <hhmax> > <hmax> }) - - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { <= <hhmax> > <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c7> ^min <vcom> ^min-net <nn>) - (modify <c4> ^max <vcom>) - (make pull-ff west <nn> <gx> <gy> <gy> <vcom>) - (modify <c5> ^grid-x <vcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p463 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> right ^5 1) } - (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom>) - { <c6> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <gabr5>) } - (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> <= <hhmax> > <hmax> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { <= <hhmax> > <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c6> ^min <vcom> ^min-net <nn>) - (modify <c4> ^max <vcom>) - (make pull-ff west <nn> <gx> <gy> <gy> <vcom>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from west) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p464 - (context ^present extend-total-verti) - { <c2> (total-verti <nn> right ^5 1) } - (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>) - { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) } - - (horizontal-s ^net-name <> <nn> ^com <hcom>) - { <c5> (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) } - { <c7> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) } - (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> <= <hhmax> > <hmax> }) - - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { <= <hhmax> > <vcom> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> }) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>) - --> - (modify <c7> ^min <vcom> ^min-net <nn>) - (modify <c4> ^max <vcom>) - (make pull-ff west <nn> <gx> <gy> <gy> <vcom>) - (modify <c5> ^grid-x <vcom> ^grid-layer <lay>) - (modify 1 ^present find-no-of-pins-on-a-row-col) -) - -(p p465 - { <c1> (context ^present remove-total-verti-gt1) } - --> - (modify <c1> ^present find-no-of-pins-on-a-row-col) -) - -(p p466 - { <c1> (context ^present extend-total-verti) } - --> - (modify <c1> ^present remove-total-verti-gt1) -) - -(p p467 - (context ^present remove-total-verti-gt1) - (total-verti ^5 > 1) - { <t> (total-verti ^5 1) } - --> - (remove <t>) -) - -(p p468 - { <c1> (context ^present remove-total-verti-gt1) } - (total-verti ^5 > 1) - - (total-verti ^5 1) - --> - (make remove-all-total-vertis) - (modify <c1> ^present extend-total-verti) -) - -(p p469 - { <c1> (context ^present remove-total-verti-gt1) } - { <c> (remove-all-total-vertis) } - - (total-verti) - --> - (remove <c>) - (modify <c1> ^present propagate-constraint) -) - -(p p470 - { <c1> (context ^present remove-total-verti-gt1) } - { <c> (remove-all-total-vertis) } - --> - (remove <c>) - (modify <c1> ^present find-no-of-pins-on-a-row-col) -) - -(p p471 - { <c1> (context ^present << extend-total-verti remove-total-verti-gt1 >>) } - - (total-verti) - --> - (modify <c1> ^present propagate-constraint) -) - -(p p515 - { <c> (context ^previous find-no-of-pins-on-a-row-col) } - - (total) - { <p> (pull-ff north <nn> <gx> <gy1> <gx> <gy2>) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from south ^pin-name <pn>) } - { <v> (vertical ^net-name nil ^min <gy1> ^max >= <gy2> ^com <gx> ^layer <lay>) } - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - --> - (remove <p> <c>) - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <gy2>) - (modify <v> ^min <gy2> ^min-net <nn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p516 - { <c> (context ^previous find-no-of-pins-on-a-row-col) } - - (total) - { <p> (pull-ff south <nn> <gx> <gy1> <gx> <gy2>) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from north ^pin-name <pn>) } - { <v> (vertical ^net-name nil ^min <= <gy2> ^max <gy1> ^com <gx> ^layer <lay>) } - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - --> - (remove <p> <c>) - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <gy2>) - (modify <v> ^max <gy2> ^max-net <nn>) - (modify <ff> ^grid-y <gy2> ^can-chng-layer nil) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p517 - { <c> (context ^previous find-no-of-pins-on-a-row-col) } - - (total) - { <p> (pull-ff east <nn> <gx1> <gy> <gx2> <gy>) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from west ^pin-name <pn>) } - { <v> (horizontal ^net-name nil ^min <gx1> ^max >= <gx2> ^com <gy> ^layer <lay>) } - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove <p> <c>) - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <gx2>) - (modify <v> ^min <gx2> ^min-net <nn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p518 - { <c> (context ^previous find-no-of-pins-on-a-row-col) } - - (total) - { <p> (pull-ff west <nn> <gx1> <gy> <gx2> <gy>) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from east ^pin-name <pn>) } - { <v> (horizontal ^net-name nil ^min <= <gx2> ^max <gx1> ^com <gy> ^layer <lay>) } - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove <p> <c>) - (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <gx2>) - (modify <v> ^max <gx2> ^max-net <nn>) - (modify <ff> ^grid-x <gx2> ^can-chng-layer nil) - (make context ^present find-no-of-pins-on-a-row-col) -) - -(p p293 - (eliminate-total) - (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>) - { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy <min2> ^max-xy { <max2> > <max1> } ^level-pins < <p1>) } - - (total ^row-col <rc> ^coor <xy> ^max-xy < <min2>) - - (total ^row-col <rc> ^coor <xy> ^min-xy { > <max1> < <max2> }) - --> - (remove <t1>) -) - -(p p294 - (eliminate-total) - (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>) - { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy <min2> ^max-xy { <max2> < <max1> } ^level-pins < <p1>) } - - (total ^row-col <rc> ^coor <xy> ^max-xy < <min2>) - - (total ^row-col <rc> ^coor <xy> ^min-xy { > <max2> < <max1> }) - --> - (remove <t1>) -) - -(p p295 - (eliminate-total) - (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>) - { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy { <min2> < <min1> } ^max-xy <max2> ^level-pins < <p1>) } - - (total ^row-col <rc> ^coor <xy> ^min-xy > <max2>) - - (total ^row-col <rc> ^coor <xy> ^max-xy { > <min2> < <min1> }) - --> - (remove <t1>) -) - -(p p296 - (eliminate-total) - (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>) - { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy { <min2> > <min1> } ^max-xy <max2> ^level-pins < <p1>) } - - (total ^row-col <rc> ^coor <xy> ^min-xy > <max2>) - - (total ^row-col <rc> ^coor <xy> ^max-xy { > <min1> < <min2> }) - --> - (remove <t1>) -) - -(p p297 - (context ^present merge) - { <m> (merge-direction left) } - { <t1> (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins <lcou> ^total-pins <tcou> ^min-xy <min> ^max-xy <max>) } - - (rmerge) - - (total ^net-name <> <nn1> ^row-col <rc> ^coor <xy> ^max-xy < <max>) - (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy > <max>) - --> - (remove <m>) - (make merge-direction right) - (make lmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou> (substr <t1> nets inf)) -) - -(p p298 - (context ^present merge) - { <m> (merge-direction right) } - { <t1> (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins <lcou> ^total-pins <tcou> ^min-xy <min> ^max-xy <max>) } - - (lmerge) - - (total ^net-name <> <nn1> ^row-col <rc> ^coor <xy> ^min-xy > <min>) - (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^max-xy < <min>) - --> - (remove <m>) - (make merge-direction left) - (make rmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou> (substr <t1> nets inf)) -) - -(p p299 - { <c> (lmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou>) } - { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy { <min1> > <max> } ^max-xy <max1>) } - - (total ^row-col <rc> ^coor <xy> ^min-xy > <max> ^max-xy < <min1>) - - (place-holder <rc> <xy> > <max> < <min1>) - --> - (make total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins (compute <lcou> + <cou3>) ^total-pins (compute <tcou> + <cou4>) ^min-xy <min> ^max-xy <max1> ^nets (substr <c> 9 inf) (substr <t2> nets inf)) - (make delete-merged <nn2> <rc> <xy> <min1> <max1> (genatom)) -) - -(p p300 - { <c> (rmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou>) } - { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy <min1> ^max-xy { <max1> < <min> }) } - - (total ^row-col <rc> ^coor <xy> ^min-xy > <max1> ^max-xy < <min>) - - (place-holder <rc> <xy> > <max1> < <min>) - --> - (make total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins (compute <lcou> + <cou3>) ^total-pins (compute <tcou> + <cou4>) ^min-xy <min1> ^max-xy <max> ^nets (substr <c> 9 inf) (substr <t2> nets inf)) - (make rdelete-merged <nn2> <rc> <xy> <min1> <max1> (genatom)) -) - -(p p301 - { <d> (delete-merged <nn> <rc> <xy> <min> <max> <id>) } - (delete-merged <nn> <rc> <xy> <min> <max> <> <id>) - --> - (remove <d>) -) - -(p p302 - { <d> (rdelete-merged <nn> <rc> <xy> <min> <max> <id>) } - (rdelete-merged <nn> <rc> <xy> <min> <max> <> <id>) - --> - (remove <d>) -) - -(p p303 - (delete-merged <nn> <rc> <xy> <min> <max>) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) } - - (lmerge) - --> - (remove <t>) -) - -(p p304 - (rdelete-merged <nn> <rc> <xy> <min> <max>) - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) } - - (rmerge) - --> - (remove <t>) -) - -(p p305 - { <d> (<< delete-merged rdelete-merged >>) } - - (<< lmerge rmerge >>) - --> - (remove <d>) -) - -(p p306 - (delete-merged <nn> <rc> <xy> <min> <max>) - { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max> ^level-pins <cou1> ^total-pins <cou2>) } - { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy <min1> ^max-xy { <max1> < <min> }) } - - (lmerge) - --> - (make place-holder <rc> <xy> <min> <max> (genatom)) - (make total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins (compute <cou1> + <cou3>) ^total-pins (compute <cou2> + <cou4>) ^min-xy <min1> ^max-xy <max> ^nets (substr <t1> nets inf) (substr <t2> nets inf)) -) - -(p p307 - (rdelete-merged <nn> <rc> <xy> <min> <max>) - { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max> ^level-pins <cou1> ^total-pins <cou2>) } - { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy { <min1> > <max> } ^max-xy <max1>) } - - (rmerge) - --> - (make place-holder <rc> <xy> <min> <max> (genatom)) - (make total ^net-name <nn> ^row-col <rc> ^coor <xy> ^level-pins (compute <cou1> + <cou3>) ^total-pins (compute <cou2> + <cou4>) ^min-xy <min> ^max-xy <max1> ^nets (substr <t1> nets inf) (substr <t2> nets inf)) -) - -(p p308 - { <p> (place-holder <rc> <xy> <min> <max> <id>) } - (place-holder <rc> <xy> <min> <max> <> <id>) - --> - (remove <p>) -) - -(p p309 - (<< lmerge rmerge >>) - { <p> (place-holder <rc> <xy> <min> <max> <id>) } - - (total ^row-col <rc> ^coor <xy> ^max-xy < <min>) - --> - (remove <p>) -) - -(p p310 - (<< lmerge rmerge >>) - { <p> (place-holder <rc> <xy> <min> <max> <id>) } - - (total ^row-col <rc> ^coor <xy> ^min-xy > <max>) - --> - (remove <p>) -) - -(p p311 - (context ^present merge) - { <l> (lmerge <nn> <rc> <xy> <min> <max>) } - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) } - --> - (remove <l> <t>) -) - -(p p312 - (context ^present merge) - { <l> (rmerge <nn> <rc> <xy> <min> <max>) } - { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) } - --> - (remove <l> <t>) -) - -(p p313 - (context ^present merge) - (total ^level-pins <cou> ^total-pins <cou>) - - (total ^level-pins { <cou1> > <cou> } ^total-pins <cou1>) - { <m> (maximum-total < <cou>) } - --> - (modify <m> ^2 <cou>) -) - -(p p314 - (context ^present merge) - (total ^row-col row ^coor 1 ^level-pins <cou> ^total-pins <cou>) - - (total ^row-col row ^coor 1 ^level-pins { <cou1> > <cou> } ^total-pins <cou1>) - { <m> (maximum-total ^5 1 < <cou>) } - --> - (modify <m> ^6 <cou>) -) - -(p p315 - (context ^present merge) - (last-row <lr>) - (total ^row-col row ^coor <lr> ^level-pins <cou> ^total-pins <cou>) - - (total ^row-col row ^coor <lr> ^level-pins { <cou1> > <cou> } ^total-pins <cou1>) - { <m> (maximum-total ^7 <lr> < <cou>) } - --> - (modify <m> ^8 <cou>) -) - -(p p316 - (context ^present merge) - (total ^level-pins <cou1> ^total-pins <cou2>) - - (total ^level-pins > <cou1> ^total-pins > <cou2>) - { <m> (maximum-total <garb4> { <min1> < <cou1> }) } - --> - (modify <m> ^3 <cou1> ^4 <cou2>) -) - -(p p317 - { <con> (context ^present merge) } - --> - (modify <con> ^present delete-totals) - (make goal cleanup eliminate-total) - (make goal cleanup merge-direction) -) - -(p p318 - (context ^present delete-totals) - (maximum-total <max> <garb1> <garb2>) - { <t> (total ^level-pins { <cou> < <max> } ^total-pins <> <cou>) } - --> - (remove <t>) -) - -(p p319 - (context ^present delete-totals) - (maximum-total ^5 1 ^6 <cou>) - { <t> (total ^row-col row ^coor 1 ^level-pins { <cou1> < <cou> } ^total-pins <cou1>) } - --> - (remove <t>) -) - -(p p320 - (context ^present delete-totals) - (maximum-total ^7 <lr> ^8 <cou>) - { <t> (total ^row-col row ^coor <lr> ^level-pins { <cou1> < <cou> } ^total-pins <cou1>) } - --> - (remove <t>) -) - -(p p321 - (context ^present delete-totals) - (maximum-total <garb1> <min> <max>) - { <t> (total ^level-pins { <cou> < <min> }) } - (last-row <lr>) - (total ^row-col row ^coor { <> 1 <> <lr> }) - --> - (remove <t>) -) - -(p p322 - (context ^present delete-totals) - (total ^row-col <rc> ^coor <xy> ^level-pins <min> ^total-pins <max>) - { <t1> (total ^row-col <rc> ^coor <xy> ^level-pins { <cou> <= <min> } ^total-pins > <max>) } - --> - (remove <t1>) -) - -(p p323 - (context ^present delete-totals) - { <m> (maximum-total <garb1> <garb2> <garb3>) } - --> - (remove <m>) -) - -(p p324 - { <c1> (context ^present delete-totals) } - - (maximum-total) - { <t1> (total ^net-name <nn1> ^row-col row ^coor 1) } - { <t2> (total ^net-name <nn2> ^row-col row ^coor <lr>) } - - (total ^row-col row ^coor { <> 1 <> <lr> }) - (last-row <lr>) - --> - (remove <c1> <t1> <t2>) - (make change-priority) - (make tran-total row 1 (substr <t1> nets inf) end) - (make tran-total row <lr> (substr <t2> nets inf) end) - (make goal cleanup total) -) - -(p p325 - (context ^present delete-totals) - - (maximum-total) - (total ^net-name <nn1> ^row-col row ^coor 1) - (total ^net-name <nn2> ^row-col row ^coor <lr>) - { <t1> (total ^net-name <> <nn1> ^row-col row ^coor 1) } - (last-row <lr>) - --> - (remove <t1>) -) - -(p p326 - { <t1> (tran-total <rc> <xy1> end) } - { <t2> (tran-total <rc> <> <xy1> end) } - --> - (remove <t2>) - (modify <t1> ^4 nil) -) - -(p p519 - (context ^present random1) - (net ^net-name <nn> ^net-no-of-pins 2) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) - (vertical-layer <lay>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> <= <gy1> } ^grid-layer <lay>) - (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^compo <gx2> ^commo <cmo> ^min-net <vnn1>) - (vertical ^net-name nil ^min { <vmin2> <= <gy2> } ^max { <vmax2> > <vmin2> >= <gy2> >= <vmin1> } ^com <gx2> ^layer <lay> ^compo <cpo> ^commo <garb1> ^max-net <vnn2>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> >= <gx2> > <hmin> } ^com { <hcom> <= <vmax1> >= <vmin1> <= <vmax2> >= <vmin2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - - (horizontal ^net-name <> nil ^com <hcom>) - --> - (remove 1 3 5) - (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gx2> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>) - (modify 6 ^min <gy1> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax2> ^compo <cpo> ^commo <gx1> ^min-net <nn> ^max-net <vnn2>) - (modify 7 ^max <gy2> ^max-net <nn>) - (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 8 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <cmo> ^compo <gx2> ^net-name <nn> ^pin-name <pn>) - (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <gx1> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p520 - (context ^present random1) - (net ^net-name <nn> ^net-no-of-pins 2) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) - (horizontal-layer <lay>) - (ff ^net-name <nn> ^grid-x { <gx2> >= <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <lay>) - (horizontal ^net-name nil ^min { <hmin1> <= <gx1> } ^max { <hmax1> > <hmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^compo <gy2> ^commo <cmo> ^max-net <hnn1>) - (horizontal ^net-name nil ^min { <hmin2> <= <gx2> } ^max { <hmax2> > <hmin2> >= <gx2> >= <hmax1> } ^com <gy2> ^layer <lay> ^compo <cpo> ^commo <garb1> ^min-net <hnn2>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> >= <gy2> > <vmin> } ^com { <vcom> <= <hmax1> >= <hmin1> <= <hmax2> >= <hmin2> } ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - - (vertical ^net-name <> nil ^com <vcom>) - --> - (remove 1 3 5) - (make horizontal ^com <gy1> ^layer <lay> ^min <vcom> ^max <hmax1> ^compo <gy2> ^commo <cmo> ^min-net <nn> ^max-net <hnn1>) - (modify 6 ^max <gx1> ^max-net <nn>) - (make horizontal ^com <gy2> ^layer <lay> ^min <hmin2> ^max <vcom> ^compo <cpo> ^commo <gy1> ^min-net <hnn2> ^max-net <nn>) - (modify 7 ^min <gx2> ^min-net <nn>) - (make vertical ^min <vmin> ^max <gy1> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 8 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <lay> ^min <gx1> ^max <vcom> ^commo <cmo> ^compo <gy2> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <lay> ^min <vcom> ^max <gx2> ^commo <gy1> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (make vertical ^com <vcom> ^layer <lay> ^min <gy1> ^max <gy2> ^commo <vcmo> ^compo <vcpo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p521 - (context ^present random1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> > <gx> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { >= <gx> < <vcom1> }) - (vertical ^com { <vcom2> <= <vcom1> > <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom2>) - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom2> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <vcom2> >= <gx> } ^layer <lay>) - - (ff ^net-name <nn> ^grid-x < <gx>) - - (ff ^grid-x <vcom2> ^grid-y <gy>) - --> - (make made-random-move) - (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <vcom2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from west) -) - -(p p522 - (context ^present random1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> < <gx> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> }) - (vertical ^com { <vcom2> >= <vcom1> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom2> ^max >= <gx>) - (horizontal ^net-name nil ^min { <hmin> <= <vcom2> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <gx> >= <vcom2> } ^layer <lay>) - - (ff ^net-name <nn> ^grid-x > <gx>) - - (ff ^grid-x <vcom2> ^grid-y <gy>) - --> - (make made-random-move) - (make horizontal ^min <hmin> ^layer <lay> ^max <vcom2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east) -) - -(p p523 - (context ^present random1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <vcom1> < <gx> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> }) - (vertical ^com { <vcom2> >= <vcom1> < <gx> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom2> ^max >= <gx>) - (horizontal ^net-name nil ^min { <hmin> <= <vcom2> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <gx> >= <vcom2> } ^layer <lay>) - - (ff ^net-name <nn> ^grid-x > <gx>) - - (ff ^grid-x <vcom2> ^grid-y <gy>) - --> - (make made-random-move) - (make horizontal ^min <hmin> ^layer <lay> ^max <vcom2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east) -) - -(p p524 - (context ^present random1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> < <gy> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom1> <= <gy> }) - (horizontal ^com { <hcom2> >= <hcom1> < <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcom2> ^max >= <gy>) - (vertical ^net-name nil ^min { <vmin> <= <hcom2> } ^max { > <vmin> >= <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <hcom2> <= <gy> } ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom2> ^max >= <hcom2> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y > <gy>) - - (ff ^grid-x <gx> ^grid-y <hcom2>) - --> - (make made-random-move) - (make vertical ^min <vmin> ^layer <lay> ^max <hcom2> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <hcom2> ^max <gy> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>) - (modify 2 ^grid-y <hcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from north) -) - -(p p525 - (context ^present random1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> > <gy> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <hcom1> >= <gy> }) - (horizontal ^com { <hcom2> <= <hcom1> > <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <hcom2>) - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom2> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <hcom2> } ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom2> ^max >= <hcom2> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y < <gy>) - - (ff ^grid-x <gx> ^grid-y <hcom2>) - --> - (make made-random-move) - (make vertical ^min <vmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <hcom2> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <hcom2> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>) - (modify 2 ^grid-y <hcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from south) -) - -(p p526 - (context ^present random1) - --> - (remove 1) - (make context ^present check-random-move) -) - -(p p527 - { <c> (context ^present check-random-move) } - { <m> (made-random-move) } - --> - (remove <c> <m>) - (make context ^present check-for-routed-net) - (make goal cleanup made-random-move) -) - -(p p528 - { <c> (context ^present check-random-move) } - - (made-random-move) - --> - (remove <c>) - (make context ^present random2) -) - -(p p529 - (context ^present random2) - --> - (write (crlf) |Sorry, I can not proceed anymore because of my ignorance.|) - (halt) -) - -(p p530 - (context ^present random0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - - (ff ^net-name <nn> ^pin-name <> <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> < <gy> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom1> <= <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcom1> ^max >= <gy>) - (vertical ^net-name nil ^min { <vmin> <= <hcom1> } ^max { > <vmin> >= <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - (vertical-layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <hcom1> <= <gy> } ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y > <gy>) - --> - (remove 1) - (make vertical ^min <vmin> ^layer <lay> ^max <hcom1> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>) - (modify 4 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <hcom1> ^max <gy> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>) - (modify 2 ^grid-y <hcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from north) - (make context ^present propagate-constraint) -) - -(p p531 - (context ^present random0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - - (ff ^net-name <nn> ^pin-name <> <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> > <gy> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <hcom1> >= <gy> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <hcom1>) - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom1> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - (vertical-layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <hcom1> } ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y < <gy>) - --> - (remove 1) - (make vertical ^min <vmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>) - (modify 4 ^min <hcom1> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <hcom1> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>) - (modify 2 ^grid-y <hcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from south) - (make context ^present propagate-constraint) -) - -(p p532 - (context ^present random0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - - (ff ^net-name <nn> ^pin-name <> <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> < <gx> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom1> ^max >= <gx>) - (horizontal ^net-name nil ^min { <hmin> <= <vcom1> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - (horizontal-layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <vcom1> <= <gx> } ^layer <lay>) - - (ff ^net-name <nn> ^grid-x > <gx>) - --> - (remove 1) - (make horizontal ^min <hmin> ^layer <lay> ^max <vcom1> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify 4 ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom1> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify 2 ^grid-x <vcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from east) - (make context ^present propagate-constraint) -) - -(p p533 - (context ^present random0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - - (ff ^net-name <nn> ^pin-name <> <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> > <gx> }) - - (vertical ^status nil ^net-name { <nn> <> nil } ^com { >= <gx> < <vcom1> }) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom1>) - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom1> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - (horizontal-layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <gx> <= <vcom1> } ^layer <lay>) - - (ff ^net-name <nn> ^grid-x < <gx>) - --> - (remove 1) - (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify 4 ^min <vcom1> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom1> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify 2 ^grid-x <vcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from west) - (make context ^present propagate-constraint) -) - -(p p534 - { <c> (context ^present random2) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (vertical ^status nil ^net-name { <nn> <> nil } ^com > <gx>) - { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) } - (congestion ^direction col ^coordinate <gx2> ^como <gx>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - --> - (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify <h> ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify <ff> ^grid-x <gx2> ^grid-layer <lay> ^can-chng-layer nil ^came-from west) - (remove <c>) - (make context ^present check-for-routed-net) -) - -(p p535 - { <c> (context ^present random2) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (vertical ^status nil ^net-name { <nn> <> nil } ^com < <gx>) - { <h> (horizontal ^net-name nil ^min { <hmin> < <gx> } ^max { <hmax> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) } - (congestion ^direction col ^coordinate <gx> ^como <gx2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - --> - (make horizontal ^min <hmin> ^layer <lay> ^max <gx2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify <h> ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>) - (modify <ff> ^grid-x <gx2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east) - (remove <c>) - (make context ^present check-for-routed-net) -) - -(p p536 - { <c> (context ^present random2) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^com > <gy>) - { <h> (vertical ^net-name nil ^min { <hmin> <= <gy> } ^max { <hmax> > <gy> } ^com <gx> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) } - (congestion ^direction row ^coordinate <gy2> ^como <gy>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - --> - (make vertical ^min <hmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify <h> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <gy2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gx>) - (modify <ff> ^grid-y <gy2> ^grid-layer <lay> ^can-chng-layer nil ^came-from south) - (remove <c>) - (make context ^present check-for-routed-net) -) - -(p p537 - { <c> (context ^present random2) } - { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) } - (horizontal ^status nil ^net-name { <nn> <> nil } ^com < <gy>) - { <h> (vertical ^net-name nil ^min { <hmin> < <gy> } ^max { <hmax> >= <gy> } ^com <gx> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) } - (congestion ^direction row ^coordinate <gy> ^como <gy2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - --> - (make vertical ^min <hmin> ^layer <lay> ^max <gy2> ^com <gx> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>) - (modify <h> ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy2> ^max <gy> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gx>) - (modify <ff> ^grid-y <gy2> ^grid-layer <lay> ^can-chng-layer nil ^came-from north) - (remove <c>) - (make context ^present check-for-routed-net) -) - -(p p558 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <nmax> } ^grid-y <gy>) - - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy> ^layer <> <lay>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2 3) - (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>) -) - -(p p559 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> > <gx1> <= <nmax> }) - - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx1> < <gx2> }) - (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2) - (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>) -) - -(p p560 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> < <gx1> >= <nmin> }) - - (ff ^net-name <nn> ^grid-x { < <gx1> > <gx2> } ^grid-y <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { < <gx1> > <gx2> }) - (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx2> ^max >= <gx1> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2) - (make horizontal ^com <gy> ^min <min> ^max <gx2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx2> ^max <gx1> ^net-name <nn> ^pin-name <pn>) -) - -(p p561 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> > <gx1> <= <nmax> }) - - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx1> < <gx2> }) - (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (horizontal-layer <lay>) - (dominant-layer) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2) - (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>) -) - -(p p562 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> < <gx1> >= <nmin> }) - - (ff ^net-name <nn> ^grid-x { < <gx1> > <gx2> } ^grid-y <gy>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { < <gx1> > <gx2> }) - (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (horizontal-layer <lay>) - (dominant-layer) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx2> ^max >= <gx1> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2) - (make horizontal ^com <gy> ^min <min> ^max <gx2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx2> ^max <gx1> ^net-name <nn> ^pin-name <pn>) -) - -(p p563 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <nmax> } ^grid-y <gy>) - - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (horizontal-layer <lay>) - (dominant-layer) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - --> - (remove 2 3) - (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>) -) - -(p p564 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy1> <= <nmax> } ^grid-x <gx>) - - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>) - (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (vertical ^net-name nil ^min <= <gy1> ^max >= <gy2> ^com <gx> ^layer <> <lay>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2 3) - (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>) -) - -(p p565 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> > <gy1> <= <nmax> }) - - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy1> < <gy2> }) - (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2) - (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>) -) - -(p p566 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> < <gy1> >= <nmin> }) - - (ff ^net-name <nn> ^grid-y { > <gy2> < <gy1> } ^grid-x <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy2> < <gy1> }) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> >= <gy1> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy1> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2) - (make vertical ^com <gx> ^min <min> ^max <gy2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy2> ^max <gy1> ^net-name <nn> ^pin-name <pn>) -) - -(p p567 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> > <gy1> <= <nmax> }) - - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy1> < <gy2> }) - (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (vertical-layer <lay>) - (dominant-layer) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2) - (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>) -) - -(p p568 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> < <gy1> >= <nmin> }) - - (ff ^net-name <nn> ^grid-y { > <gy2> < <gy1> } ^grid-x <gx>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy2> < <gy1> }) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> >= <gy1> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (vertical-layer <lay>) - (dominant-layer) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy1> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2) - (make vertical ^com <gx> ^min <min> ^max <gy2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy2> ^max <gy1> ^net-name <nn> ^pin-name <pn>) -) - -(p p569 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy1> <= <nmax> } ^grid-x <gx>) - - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>) - (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>) - (vertical-layer <lay>) - (dominant-layer) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (remove 2 3) - (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>) - (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>) - (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>) -) - -(p p570 - (next-segment <nn> row <gy> nil <nmin> <nmax>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <max> >= <nmin> <= <nmax> } ^com <gy> ^layer <garb2> ^compo <garb3> ^commo <garb4> ^pin-name <pn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <max> ^max > <max> ^com <gy>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <min> > <max> <= <nmax> } ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <min> ^max >= <min> ^com <gy>) - (horizontal ^net-name nil ^min <max> ^max { <min> > <max> } ^com <gy> ^layer <garb5> ^compo <garb6> ^commo <garb7>) - --> - (modify 4 ^net-name <nn> ^pin-name <pn> ^max-net nil ^min-net nil) -) - -(p p571 - (next-segment <nn> col <gx> nil <nmin> <nmax>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <max> >= <nmin> <= <nmax> } ^com <gx> ^layer <garb2> ^compo <garb3> ^commo <garb4> ^pin-name <pn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <max> ^max > <max> ^com <gx>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min { <min> > <max> <= <nmax> } ^com <gx>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <min> ^max >= <min> ^com <gx>) - (vertical ^net-name nil ^min <max> ^max { <min> > <max> } ^com <gx> ^layer <garb5> ^compo <garb6> ^commo <garb7>) - --> - (modify 4 ^net-name <nn> ^pin-name <pn> ^max-net nil ^min-net nil) -) - -(p p572 - { <next> (next-segment <nn> row <gy>) } - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <pn> ^came-from north) - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb1>) - - (ff ^net-name <nn> ^grid-y < <gy>) - { <ff> (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^pin-name <pn2> ^grid-x <gx> ^grid-layer <lay> ^came-from north) } - { <v1> (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) } - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com { < <gy2> >= <gy> } ^layer <lay>) - --> - (make vertical ^net-name nil ^max <gy> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify <v1> ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn2>) - (modify <ff> ^grid-y <gy> ^can-chng-layer nil) - (modify <next> ^5 useless) -) - -(p p573 - { <next> (next-segment <nn> row <gy>) } - (ff ^came-from south ^net-name <nn> ^grid-y <gy> ^pin-name <pn>) - (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb1> ^no-of-bottom-pins <np>) - - (ff ^net-name <nn> ^grid-y > <gy>) - { <ff> (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^pin-name <pn2> ^grid-x <gx> ^grid-layer <lay> ^came-from south) } - { <v1> (vertical ^net-name nil ^max { <max> >= <gy> } ^min { < <max> <= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) } - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com { > <gy2> <= <gy> } ^layer <lay>) - --> - (make vertical ^net-name nil ^max <max> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <nn> ^max-net <mn>) - (modify <v1> ^max <gy2> ^max-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn2>) - (modify <ff> ^grid-y <gy> ^can-chng-layer nil) - (modify <v1> ^5 useless) -) - -(p p574 - (next-segment <nn> row <gy> <gg1> <nmin> <nmax>) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x { <gx> >= <nmin> <= <nmax> } ^grid-layer <lay> ^pin-name <pn>) - (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy2> ^com <gx>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <gy> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify 3 ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <gy> ^can-chng-layer nil) - (modify 1 ^2 <nn>) -) - -(p p575 - (next-segment <nn> row <gy> <gg1> <nmin> <nmax>) - (vertical ^net-name { <nn> <> nil } ^min { <gy2> > <gy> } ^com { <gx> >= <nmin> <= <nmax> } ^layer <lay> ^pin-name <pn>) - (vertical ^net-name nil ^min { < <gy2> <= <gy> } ^max <gy2> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy2> ^com <gx>) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>) - - (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy2> ^com <gx>) - - (ff ^net-name <> <nn> ^grid-x <gx>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - --> - (modify 3 ^max <gy> ^max-net <nn>) - (modify 2 ^min <gy>) - (make ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) - (modify 1 ^2 <nn>) -) - -(p p576 - (next-segment <nn> row <gy> <gg1> <nmin> <nmax>) - (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x { <gx> >= <nmin> <= <nmax> } ^grid-layer <lay> ^pin-name <pn>) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) - (vertical-s ^net-name <nn> ^min <= <gy2> ^max >= <gy> ^com <gx>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <gy2> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify 3 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <gy> ^can-chng-layer nil) - (modify 1 ^2 <nn>) -) - -(p p577 - (next-segment <nn> row <gy> <gg1> <nmin> <nmax>) - (vertical ^net-name { <nn> <> nil } ^min { <gy2> < <gy> } ^com { <gx> >= <nmin> <= <nmax> } ^layer <lay> ^pin-name <pn>) - (vertical ^net-name nil ^min <gy2> ^max { > <gy2> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>) - (vertical-s ^net-name <nn> ^min <= <gy2> ^max >= <gy> ^com <gx>) - - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>) - - (vertical ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy> ^com <gx>) - - (ff ^net-name <> <nn> ^grid-x <gx>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - --> - (modify 3 ^min <gy> ^min-net <nn>) - (modify 2 ^max <gy>) - (make ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south) - (modify 1 ^2 <nn>) -) - -(p p578 - (next-segment <nn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <garb2>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <garb3> ^compo <garb4> ^commo <garb5>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <garb6> ^compo <garb7> ^commo <garb8>) - --> - (remove 2) -) - -(p p579 - (next-segment <nn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <garb2>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max <gx> ^com <gy>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gx> ^max > <gx> ^com <gy>) - --> - (remove 2) -) - -(p p580 - (change-priority) - { <n> (next-segment ^5 useless) } - --> - (modify <n> ^5 nil) -) - -(p p581 - (change-priority) - { <n> (next-segment <nn> col <x> useless <min> <max>) } - (vertical-s ^net-name <nn> ^com <x> ^sum 2 ^difference 0) - (last-row <lr>) - --> - (modify <n> ^5 nil 1 <lr>) -) - -(p p582 - (change-priority) - { <n> (next-segment <nn> row <y> useless <min> <max>) } - (horizontal-s ^net-name <nn> ^com <x> ^sum 2 ^difference 0) - (last-col <lc>) - --> - (modify <n> ^5 nil 1 <lc>) -) - -(p p583 - { <n> (next-segment <nn> <rc> <xy> nil) } - - (next-segment ^5 <> nil) - --> - (remove <n>) - (make move-ff <nn> <rc> <xy>) -) - -(p p584 - { <c> (change-priority) } - --> - (remove <c>) - (make end-of-specialized-move-ff) -) - -(p p585 - (move-ff <nn> row <xy>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <xy> ^layer <lay> ^compo <cpo> ^commo <garb1>) - { <ff> (ff ^came-from south ^net-name { <nn1> <> <nn> } ^grid-x { <gx> >= <min> <= <max> } ^grid-y <xy> ^grid-layer { <flay> <> <lay> }) } - { <v1> (vertical ^status nil ^net-name <nn1> ^min < <xy> ^max <xy> ^com <gx> ^layer <flay>) } - - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <xy> ^layer <flay>) - { <v2> (vertical ^net-name nil ^min <xy> ^max { <garb4> > <xy> } ^com <gx> ^layer <flay> ^compo <garb2> ^commo <garb3>) } - --> - (modify <v2> ^min <cpo> ^min-net <nn1>) - (modify <v1> ^max <cpo>) - (modify <ff> ^grid-y <cpo> ^can-chng-layer nil) -) - -(p p586 - (move-ff <nn> row <xy>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <xy> ^layer <lay> ^compo <garb1> ^commo <cmo>) - { <ff> (ff ^came-from north ^net-name { <nn1> <> <nn> } ^grid-x { <gx> >= <min> <= <max> } ^grid-y <xy> ^grid-layer { <flay> <> <lay> }) } - { <v1> (vertical ^status nil ^net-name <nn1> ^min <xy> ^max > <xy> ^com <gx> ^layer <flay>) } - - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <xy> ^layer <flay>) - { <v2> (vertical ^net-name nil ^min <vmin> ^max { <xy> > <vmin> } ^com <gx> ^layer <flay> ^compo <garb2> ^commo <garb3>) } - --> - (modify <v2> ^max <cmo> ^max-net <nn1>) - (modify <v1> ^min <cmo>) - (modify <ff> ^grid-y <cmo> ^can-chng-layer nil) -) - -(p p587 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <min> ^max <max>) - { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max>) } - --> - (remove <h>) -) - -(p p588 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <min> ^max <max>) - { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max>) } - --> - (remove <v>) -) - -(p p589 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> < <com> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <com> } ^com <gx> ^id <id>) } - (vertical ^net-name nil ^min <= <gy> ^max >= <com> ^com <gx>) - - (vertical-s ^net-name <> <nn> ^com <gx>) - --> - (remove <v>) - (make next-segment <nn> col <gx> nil <vmin> <vmax>) -) - -(p p590 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> > <com> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <com> } ^max { <vmax> >= <gy> } ^com <gx> ^id <id>) } - (vertical ^net-name nil ^min <= <com> ^max >= <gy> ^com <gx>) - - (vertical-s ^net-name <> <nn> ^com <gx>) - --> - (remove <v>) - (make next-segment <nn> col <gx> nil <vmin> <vmax>) -) - -(p p591 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> < <hcom1> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) } - (vertical ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax2> }) - - (vertical-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> col <vcom2> nil <vmin> <vmax>) -) - -(p p592 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> > <hcom1> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) } - (vertical ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax2> }) - - (vertical-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> col <vcom2> nil <vmin> <vmax>) -) - -(p p593 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> < <hcom1> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) } - (vertical ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax1> }) - - (vertical-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> col <vcom2> nil <vmin> <vmax>) -) - -(p p594 - (move-ff <nn>) - (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> > <hcom1> }) - { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) } - (vertical ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax1> }) - - (vertical-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> col <vcom2> nil <vmin> <vmax>) -) - -(p p595 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (ff ^net-name <nn> ^grid-x { <gx> < <com> } ^grid-y { <gy> >= <min> <= <max> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <gx> } ^max { <vmax> >= <com> } ^com <gy> ^id <id>) } - (horizontal ^net-name nil ^min <= <gx> ^max >= <com> ^com <gy>) - - (horizontal-s ^net-name <> <nn> ^com <gy>) - --> - (remove <v>) - (make next-segment <nn> row <gy> nil <vmin> <vmax>) -) - -(p p596 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <min> ^max <max> ^com <com>) - (ff ^net-name <nn> ^grid-x { <gx> > <com> } ^grid-y { <gy> >= <min> <= <max> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <com> } ^max { <vmax> >= <gx> } ^com <gy> ^id <id>) } - (horizontal ^net-name nil ^min <= <com> ^max >= <gx> ^com <gy>) - - (horizontal-s ^net-name <> <nn> ^com <gy>) - --> - (remove <v>) - (make next-segment <nn> row <gy> nil <vmin> <vmax>) -) - -(p p597 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> < <hcom1> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) } - (horizontal ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax2> }) - - (horizontal-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> row <vcom2> nil <vmin> <vmax>) -) - -(p p598 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> > <hcom1> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) } - (horizontal ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax2> }) - - (horizontal-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> row <vcom2> nil <vmin> <vmax>) -) - -(p p599 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> < <hcom1> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) } - (horizontal ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax1> }) - - (horizontal-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> row <vcom2> nil <vmin> <vmax>) -) - -(p p600 - (move-ff <nn>) - (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>) - (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> > <hcom1> }) - { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) } - (horizontal ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax1> }) - - (horizontal-s ^net-name <> <nn> ^com <vcom2>) - --> - (remove <v>) - (make next-segment <nn> row <vcom2> nil <vmin> <vmax>) -) - -(p p601 - { <m> (move-ff) } - --> - (remove <m>) -) - -(p p602 - { <e> (end-of-specialized-move-ff) } - - (next-segment) - --> - (remove <e>) - (make context ^present check-for-routed-net) -) - -(p p603 - (context ^present << check-for-routed-net propagate-constraint >>) - (<< dominant-layer change-priority next-segment >>) - --> - (remove 2) -) - -(p p244 - (context ^present lshape1) - (<< total-verti counted-verti total counted >>) - --> - (remove 2) -) - -(p p245 - (context ^present lshape1) - (last-row <gy>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) - - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <gy2>) - - (vertical ^com { > <gx> < <gx2> }) - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^min-net <mn>) - - (pin ^pin-x <gx2> ^pin-y <hcpo>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - --> - (make horizontal ^layer <lay> ^min <hmin> ^max <gx> ^min-net <mn> ^max-net <nn> ^com <gy> ^commo <hcmo> ^compo <hcpo>) - (modify 5 ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx> ^max <gx2> ^com <gy> ^commo <hcmo> ^compo <hcpo>) - (modify 3 ^grid-x <gx2> ^came-from west) -) - -(p p246 - (context ^present lshape1) - (last-row <gy>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) - - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <gy2>) - - (vertical ^com { > <gx2> < <gx> }) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (pin ^pin-x <gx2> ^pin-y <hcpo>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>) - --> - (make horizontal ^layer <lay> ^min <hmin> ^max <gx2> ^min-net <mn> ^max-net <nn> ^com <gy> ^commo <hcmo> ^compo <hcpo>) - (modify 5 ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx2> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo>) - (modify 3 ^grid-x <gx2> ^came-from east) -) - -(p p247 - (context ^present lshape1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y 1 ^grid-layer <lay> ^pin-name <pn> ^came-from south) - - (ff ^net-name <nn> ^grid-y 1 ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <gy2>) - - (vertical ^com { > <gx> < <gx2> }) - (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <hmin> >= <gx2> } ^com 1 ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (pin ^pin-x <gx2> ^pin-y 0) - - (vertical ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gx2> ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com 1 ^layer <lay>) - --> - (make horizontal ^layer <lay> ^min <hmin> ^max <gx> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <hcmo> ^compo <hcpo>) - (modify 4 ^min <gx2> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx> ^max <gx2> ^com 1 ^commo <hcmo> ^compo <hcpo>) - (modify 2 ^grid-x <gx2> ^came-from west) -) - -(p p248 - (context ^present lshape1) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y 1 ^grid-layer <lay> ^pin-name <pn> ^came-from south) - - (ff ^net-name <nn> ^grid-y 1 ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <gy2>) - - (vertical ^com { > <gx2> < <gx> }) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx> } ^com 1 ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (pin ^pin-x <gx2> ^pin-y 0) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gx2> ^layer <lay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com 1 ^layer <lay>) - --> - (make horizontal ^layer <lay> ^min <hmin> ^max <gx2> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <hcmo> ^compo <hcpo>) - (modify 4 ^min <gx> ^min-net <nn>) - (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx2> ^max <gx> ^com 1 ^commo <hcmo> ^compo <hcpo>) - (modify 2 ^grid-x <gx2> ^came-from east) -) - -(p p249 - (context ^present lshape1) - (last-col <gx>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east) - - (ff ^net-name <nn> ^grid-x <gx> ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> > <gy> }) - - (horizontal ^com { > <gy> < <gy2> }) - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy2> > <vmin> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (pin ^pin-x <vcpo> ^pin-y <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (make vertical ^layer <lay> ^min <vmin> ^max <gy> ^min-net <mn> ^max-net <nn> ^com <gx> ^commo <vcmo> ^compo <vcpo>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy> ^max <gy2> ^com <gx> ^commo <vcmo> ^compo <vcpo>) - (modify 3 ^grid-y <gy2> ^came-from south) -) - -(p p250 - (context ^present lshape1) - (last-col <gx>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east) - - (ff ^net-name <nn> ^grid-x <gx> ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> < <gy> }) - - (horizontal ^com { > <gy2> < <gy> }) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy> > <vmin> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (pin ^pin-x <vcpo> ^pin-y <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>) - --> - (make vertical ^layer <lay> ^min <vmin> ^max <gy2> ^min-net <mn> ^max-net <nn> ^com <gx> ^commo <vcmo> ^compo <vcpo>) - (modify 5 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy2> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo>) - (modify 3 ^grid-y <gy2> ^came-from north) -) - -(p p251 - (context ^present lshape1) - (ff ^net-name <nn> ^grid-x 1 ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from west) - - (ff ^net-name <nn> ^grid-x 1 ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> > <gy> }) - - (horizontal ^com { > <gy> < <gy2> }) - (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> > <vmin> >= <gy2> } ^com 1 ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (pin ^pin-x 0 ^pin-y <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com 1 ^layer <lay>) - --> - (make vertical ^layer <lay> ^min <vmin> ^max <gy> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <vcmo> ^compo <vcpo>) - (modify 4 ^min <gy2> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy> ^max <gy2> ^com 1 ^commo <vcmo> ^compo <vcpo>) - (modify 2 ^grid-y <gy2> ^came-from south) -) - -(p p252 - (context ^present lshape1) - (ff ^net-name <nn> ^grid-x 1 ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from west) - - (ff ^net-name <nn> ^grid-x 1 ^pin-name <> <pn>) - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> < <gy> }) - - (horizontal ^com { > <gy2> < <gy> }) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy> } ^com 1 ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (pin ^pin-x 0 ^pin-y <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gy2> ^layer <lay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com 1 ^layer <lay>) - --> - (make vertical ^layer <lay> ^min <vmin> ^max <gy2> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <vcmo> ^compo <vcpo>) - (modify 4 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy2> ^max <gy> ^com 1 ^commo <vcmo> ^compo <vcpo>) - (modify 2 ^grid-y <gy2> ^came-from north) -) - -(p p253 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy1> > <vmin> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> >= <gx2> > <hmin> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p254 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p255 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p256 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p257 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>) - - (pin ^net-name <nn1> ^pin-x >= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p258 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x > <gx1>) - - (pin ^net-name <nn1> ^pin-x <= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p259 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>) - - (pin ^net-name <nn1> ^pin-x >= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p260 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>) - (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy1> ^grid-x > <gx2>) - - (pin ^net-name <nn1> ^pin-x <= <gx2>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p261 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>) - - (pin ^net-name <nn1> ^pin-y >= <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p262 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>) - - (pin ^net-name <nn1> ^pin-y >= <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p263 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y > <gy2>) - - (pin ^net-name <nn1> ^pin-y <= <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p264 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx2> ^grid-y > <gy1>) - - (pin ^net-name <nn1> ^pin-y <= <gy1>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p265 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>) - - (pin ^net-name <nn1> ^pin-y >= <gy2>) - (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>) - - (pin ^net-name <nn2> ^pin-x >= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p266 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>) - - (pin ^net-name <nn1> ^pin-y >= <gy2>) - (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x > <gx1>) - - (pin ^net-name <nn2> ^pin-x <= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p267 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y > <gy2>) - - (pin ^net-name <nn1> ^pin-y <= <gy2>) - (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>) - - (pin ^net-name <nn2> ^pin-x >= <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p268 - (context ^present lshape1) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx2> ^grid-y > <gy1>) - - (pin ^net-name <nn1> ^pin-y <= <gy1>) - (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy1> ^grid-x > <gx2>) - - (pin ^net-name <nn2> ^pin-x <= <gx2>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p269 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p270 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p271 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p272 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p273 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p274 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p275 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p276 - (context ^present lshape2) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p277 - (context ^present lshape3) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p278 - (context ^present lshape3) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p279 - (context ^present lshape3) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p280 - (context ^present lshape3) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p281 - (context ^present lshape4) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p282 - (context ^present lshape4) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p283 - (context ^present lshape4) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <garb2>) - (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>) - --> - (remove 1 3 4) - (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy2> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p284 - (context ^present lshape4) - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>) - (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>) - (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) - (vertical-layer <vlay>) - (horizontal-layer <hlay>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>) - - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>) - - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>) - --> - (remove 1 3 4) - (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>) - (modify 5 ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify 6 ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>) - (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>) - (make context ^present check-for-routed-net) -) - -(p p285 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - - (ff ^grid-x <gx1> ^net-name <> <nn>) - { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^commo <gx2> ^compo <cpo> ^min-net <vnn1>) } - { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com { <hcom> >= <vmin1> < <gy1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (vertical-layer <lay>) - (ff ^grid-x <gx2> ^net-name <> <nn>) - - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com { >= <vmin1> < <hcom> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>) - --> - (remove <c>) - (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <cpo> ^commo <gx2> ^min-net <vnn1> ^max-net <nn>) - (modify <v> ^min <gy1> ^min-net <nn>) - (make horizontal ^min <hmin> ^max <gx2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <gx2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>) - (make horizontal ^com <hcom> ^layer <lay> ^min <gx2> ^max <gx1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>) - (modify <ff> ^grid-x <gx2> ^grid-y <hcom> ^can-chng-layer nil ^came-from east) - (make context ^present check-for-routed-net) -) - -(p p286 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - - (ff ^grid-x <gx2> ^net-name <> <nn>) - { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy2> } ^max { <vmax1> > <vmin1> >= <gy2> } ^com <gx2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^max-net <vnn1>) } - { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com { <hcom> <= <vmax1> > <gy2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (vertical-layer <lay>) - (ff ^grid-x <gx1> ^net-name <> <nn>) - - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com { <= <vmax1> > <hcom> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>) - --> - (remove <c>) - (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <gx1> ^commo <cmo> ^max-net <vnn1> ^min-net <nn>) - (modify <v> ^max <gy2> ^max-net <nn>) - (make horizontal ^min <hmin> ^max <gx2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gx1> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <cmo> ^compo <gx1> ^net-name <nn> ^pin-name <pn2>) - (make horizontal ^com <hcom> ^layer <lay> ^min <gx2> ^max <gx1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>) - (modify <ff> ^grid-x <gx1> ^grid-y <hcom> ^can-chng-layer nil ^came-from west) - (make context ^present check-for-routed-net) -) - -(p p287 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - - (ff ^grid-x <gx1> ^net-name <> <nn>) - { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^commo <cmo> ^compo <gx2> ^min-net <vnn1>) } - { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com { <hcom> >= <vmin1> < <gy1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (vertical-layer <lay>) - (ff ^grid-x <gx2> ^net-name <> <nn>) - - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com { >= <vmin1> < <hcom> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>) - --> - (remove <c>) - (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gx2> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>) - (modify <v> ^min <gy1> ^min-net <nn>) - (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <cmo> ^compo <gx2> ^net-name <nn> ^pin-name <pn1>) - (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>) - (modify <ff> ^grid-x <gx2> ^grid-y <hcom> ^can-chng-layer nil ^came-from west) - (make context ^present check-for-routed-net) -) - -(p p288 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - - (ff ^grid-x <gx2> ^net-name <> <nn>) - { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy2> } ^max { <vmax1> > <vmin1> >= <gy2> } ^com <gx2> ^layer <lay> ^commo <gx1> ^compo <cpo> ^max-net <vnn1>) } - { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com { <hcom> <= <vmax1> > <gy2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (vertical-layer <lay>) - (ff ^grid-x <gx1> ^net-name <> <nn>) - - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com { <= <vmax1> > <hcom> } ^layer <lay>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>) - --> - (remove <c>) - (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <cpo> ^commo <gx1> ^max-net <vnn1> ^min-net <nn>) - (modify <v> ^max <gy2> ^max-net <nn>) - (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gx2> ^min-net <nn>) - (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <gx1> ^compo <cpo> ^net-name <nn> ^pin-name <pn2>) - (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>) - (modify <ff> ^grid-x <gx1> ^grid-y <hcom> ^can-chng-layer nil ^came-from east) - (make context ^present check-for-routed-net) -) - -(p p289 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - - (ff ^grid-y <gy1> ^net-name <> <nn>) - { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx1> } ^max { <vmax1> > <vmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <vnn1>) } - { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> >= <vmin1> < <gx1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (horizontal-layer <lay>) - (ff ^grid-y <gy2> ^net-name <> <nn>) - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { >= <vmin1> < <hcom> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>) - --> - (remove <c>) - (make horizontal ^com <gy1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <cpo> ^commo <gy2> ^min-net <vnn1> ^max-net <nn>) - (modify <v> ^min <gx1> ^min-net <nn>) - (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <lay> ^min <hcom> ^max <gx1> ^commo <gy2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>) - (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>) - (modify <ff> ^grid-y <gy2> ^grid-x <hcom> ^can-chng-layer nil ^came-from north) - (make context ^present check-for-routed-net) -) - -(p p290 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - - (ff ^grid-y <gy2> ^net-name <> <nn>) - { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx2> } ^max { <vmax1> > <vmin1> >= <gx2> } ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^max-net <vnn1>) } - { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> <= <vmax1> > <gx2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (horizontal-layer <lay>) - (ff ^grid-y <gy1> ^net-name <> <nn>) - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { <= <vmax1> > <hcom> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>) - --> - (remove <c>) - (make horizontal ^com <gy2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <gy1> ^commo <cmo> ^max-net <vnn1> ^min-net <nn>) - (modify <v> ^max <gx2> ^max-net <nn>) - (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <lay> ^max <hcom> ^min <gx2> ^commo <cmo> ^compo <gy1> ^net-name <nn> ^pin-name <pn2>) - (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>) - (modify <ff> ^grid-y <gy1> ^grid-x <hcom> ^can-chng-layer nil ^came-from south) - (make context ^present check-for-routed-net) -) - -(p p291 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) } - (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) - - (ff ^grid-y <gy1> ^net-name <> <nn>) - { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx1> } ^max { <vmax1> > <vmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^max-net <vnn1>) } - { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> <= <vmax1> > <gx1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (horizontal-layer <lay>) - (ff ^grid-y <gy2> ^net-name <> <nn>) - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { <= <vmax1> > <hcom> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>) - --> - (remove <c>) - (make horizontal ^com <gy1> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <cpo> ^commo <gy2> ^max-net <vnn1> ^min-net <nn>) - (modify <v> ^max <gx1> ^max-net <nn>) - (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy1> ^layer <lay> ^min <gx1> ^max <hcom> ^commo <gy2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>) - (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>) - (modify <ff> ^grid-y <gy2> ^grid-x <hcom> ^can-chng-layer nil ^came-from north) - (make context ^present check-for-routed-net) -) - -(p p292 - { <c> (context ^present lshape1) } - (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes) - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) - { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) } - - (ff ^grid-y <gy2> ^net-name <> <nn>) - { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx2> } ^max { <vmax1> > <vmin1> >= <gx2> } ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^min-net <vnn1>) } - { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> >= <vmin1> < <gx2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) } - (horizontal-layer <lay>) - (ff ^grid-y <gy1> ^net-name <> <nn>) - - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { >= <vmin1> < <hcom> } ^layer <lay>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>) - - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>) - - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>) - --> - (remove <c>) - (make horizontal ^com <gy2> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gy1> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>) - (modify <v> ^min <gx2> ^min-net <nn>) - (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>) - (modify <h> ^min <gy1> ^min-net <nn>) - (make horizontal ^com <gy2> ^layer <lay> ^max <gx2> ^min <hcom> ^commo <cmo> ^compo <gy1> ^net-name <nn> ^pin-name <pn2>) - (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>) - (modify <ff> ^grid-y <gy1> ^grid-x <hcom> ^can-chng-layer nil ^came-from south) - (make context ^present check-for-routed-net) -) - -(p p211 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx> }) - (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y < <gy>) - - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y > <gy>) - --> - (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min <gx> ^min-net <nn>) - (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p212 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> south ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> < <gy> }) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y >= <gy>) - - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y >= <gy>) - --> - (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min <gy> ^min-net <nn>) - (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p213 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> }) - (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y < <gy>) - - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y > <gy>) - --> - (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max <gx> ^max-net <nn>) - (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p214 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy> }) - (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y <= <gy>) - - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y <= <gy>) - --> - (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max <gy> ^max-net <nn>) - (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p215 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <= <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> > <min> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y > <gy>) - --> - (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min <gx> ^min-net <nn>) - (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p216 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y >= <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> > <min> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y < <gy>) - --> - (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min <gx> ^min-net <nn>) - (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p217 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <= <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>) - - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y > <gy>) - --> - (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max <gx> ^max-net <nn>) - (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p218 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no) - (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y >= <gy>) - (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>) - - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y < <gy>) - --> - (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max <gx> ^max-net <nn>) - (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p219 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x >= <gx>) - (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <lay>) - - (ff ^net-name <nn> ^grid-x < <gx>) - --> - (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>) - (modify 4 ^max <gy> ^max-net <nn>) - (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p220 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x <= <gx>) - (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (ff ^net-name <nn> ^grid-x > <gx>) - --> - (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>) - (modify 4 ^max <gy> ^max-net <nn>) - (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p221 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> south ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x <= <gx>) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>) - - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>) - - (ff ^net-name <nn> ^grid-x > <gx>) - --> - (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>) - (modify 4 ^min <gy> ^min-net <nn>) - (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p222 - (context ^present loose-constraint) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no) - (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x >= <gx>) - (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <lay>) - - (ff ^net-name <nn> ^grid-x < <gx>) - --> - (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>) - (modify 4 ^min <gy> ^min-net <nn>) - (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>) - (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p223 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - --> - (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p224 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-y { <gy2> > <com1> } ^grid-x <gx>) - (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - --> - (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p225 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - --> - (make horizontal ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p226 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-y { <gy2> < <com1> } ^grid-x <gx>) - (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - --> - (make vertical ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p227 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - --> - (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p228 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-y { <gy2> > <com1> } ^grid-x <gx>) - (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - --> - (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p229 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^layer <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - --> - (make horizontal ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p230 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> }) - (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^layer <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - --> - (make vertical ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p231 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (vertical ^net-name nil ^max <min1> ^com <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p232 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (vertical ^net-name nil ^max <min1> ^com <com1>) - - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p233 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (vertical ^net-name nil ^max <min1> ^com <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make horizontal ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p234 - (context ^present loose-constraint) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>) - (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (vertical ^net-name nil ^max <min1> ^com <com1>) - - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-x <com1>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make horizontal ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p235 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> > <com1> }) - (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (horizontal ^net-name nil ^max <min1> ^com <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p236 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> > <com1> }) - (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (horizontal ^net-name nil ^max <min1> ^com <com1>) - - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>) - (modify 4 ^min (compute <com1> + 1) ^min-net <nn>) - (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p237 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> }) - (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>) - - (horizontal ^net-name nil ^max <min1> ^com <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make vertical ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p238 - (context ^present loose-constraint) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> }) - (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^commo <cmo2> ^compo <cpo2> ^min-net <hnn>) - - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>) - - (horizontal ^net-name nil ^max <min1> ^com <com1>) - - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>) - - (ff ^net-name <nn> ^grid-y <com1>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>) - --> - (make vertical ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>) - (modify 4 ^max (compute <com1> - 1) ^max-net <nn>) - (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>) - (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north) - (remove 1) - (make context ^present propagate-constraint) -) - -(p p239 - (context ^present loose-constraint0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top) - (vertical ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com { <vcom> > <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-y > <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom> ^com <gy>) - (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <gy> ^como <hcmo>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <hcmo> ^can-chng-layer nil) - (modify 1 ^present propagate-constraint) -) - -(p p240 - (context ^present loose-constraint0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top) - (vertical ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com { <vcom> < <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-y > <gy>) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <gx> ^com <gy>) - (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <gy> ^como <hcmo>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>) - (modify 5 ^min <gy> ^min-net <nn>) - (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <hcmo> ^can-chng-layer nil) - (modify 1 ^present propagate-constraint) -) - -(p p241 - (context ^present loose-constraint0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom) - (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com { <vcom> > <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-y < <gy>) - - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom> ^com <gy>) - (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <hcmo> ^como <gy>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^max-net <mn> ^min-net <nn>) - (modify 5 ^max <gy> ^max-net <nn>) - (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <hcmo> ^can-chng-layer nil) - (modify 1 ^present propagate-constraint) -) - -(p p242 - (context ^present loose-constraint0) - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south) - (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom) - (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com { <vcom> < <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>) - - (ff ^net-name <nn> ^grid-y < <gy>) - - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com <gy>) - - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <gx> ^com <gy>) - (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) - - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>) - (congestion ^direction row ^coordinate <hcmo> ^como <gy>) - - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>) - --> - (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^max-net <mn> ^min-net <nn>) - (modify 5 ^max <gy> ^max-net <nn>) - (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>) - (modify 2 ^grid-y <hcmo> ^can-chng-layer nil) - (modify 1 ^present propagate-constraint) -) - -(p p243 - (context ^present loose-constraint0) - --> - (modify 1 ^present loose-constraint) -) - -(p p363 - (move-via <nn>) - --> - (remove 1) - (make finally-routed <nn>) -) - -(p p364 - (move-via <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <garb1> ^commo <hcmo> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcmo> ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> }) - (vertical ^net-name nil ^min { <vmin2> <= <hcmo> } ^max { <vmax2> > <vmin2> >= <hcom> } ^com <vcom> ^layer <hlay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (horizontal ^net-name <> <nn> ^min < <vcom> ^max >= <vcom> ^com <hcmo>) - - (vertical ^net-name <> <nn> ^min < <hcmo> ^max <hcmo> ^com <vcom>) - --> - (modify 3 ^max <hcmo>) - (make vertical ^layer <vlay> ^max <hcom> ^min <hcmo> ^com <vcom> ^min-net <nn> ^commo <vcmo> ^compo <vcpo>) - (make vertical ^layer <hlay> ^min <vmin2> ^max <hcmo> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>) - (modify 4 ^min <hcom> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcmo> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^com <vcom>) - (remove 1) - (make move-via <nn> <vlay> <vcom> <hcom>) -) - -(p p365 - (move-via <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <garb1> ^commo <hcmo> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcmo> ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> }) - (vertical ^net-name nil ^min { <vmin2> <= <hcmo> } ^max { <vmax2> > <vmin2> >= <hcom> } ^com <vcom> ^layer <hlay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>) - - (horizontal ^net-name <> <nn> ^min <= <vcom> ^max > <vcom> ^com <hcmo>) - - (vertical ^net-name <> <nn> ^min < <hcmo> ^max <hcmo> ^com <vcom>) - --> - (modify 3 ^max <hcmo>) - (make vertical ^layer <vlay> ^max <hcom> ^min <hcmo> ^com <vcom> ^min-net <nn> ^commo <vcmo> ^compo <vcpo>) - (make vertical ^layer <hlay> ^min <vmin2> ^max <hcmo> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>) - (modify 4 ^min <hcom> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcmo> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^com <vcom>) - (remove 1) - (make move-via <nn> <vlay> <vcom> <hcom>) -) - -(p p366 - (move-via <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <garb1> ^commo <vcmo> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcmo> ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> }) - (horizontal ^net-name nil ^min { <hmin2> <= <vcmo> } ^max { <hmax2> > <hmin2> >= <vcom> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (vertical ^net-name <> <nn> ^min < <hcom> ^max >= <hcom> ^com <vcmo>) - - (horizontal ^net-name <> <nn> ^min < <vcmo> ^max <vcmo> ^com <hcom>) - --> - (modify 3 ^max <vcmo>) - (make horizontal ^layer <hlay> ^max <vcom> ^min <vcmo> ^com <hcom> ^min-net <nn> ^commo <hcmo> ^compo <hcpo>) - (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcmo> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>) - (modify 4 ^min <vcom> ^min-net <nn>) - (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcmo> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^com <hcom>) - (remove 1) - (make move-via <nn> <hlay> <hcom> <vcom>) -) - -(p p367 - (move-via <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <garb1> ^commo <vcmo> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcmo> ^com { <hcom> >= <vmin> <= <vmax> } ^max <vcom> ^layer { <hlay> <> <vlay> }) - (horizontal ^net-name nil ^min { <hmin2> <= <vcmo> } ^max { <hmax2> > <hmin2> >= <vcom> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (vertical ^net-name <> <nn> ^min <= <hcom> ^max > <hcom> ^com <vcmo>) - - (horizontal ^net-name <> <nn> ^min < <vcmo> ^max <vcmo> ^com <hcom>) - --> - (modify 3 ^max <vcmo>) - (make horizontal ^layer <hlay> ^max <vcom> ^min <vcmo> ^com <hcom> ^min-net <nn> ^commo <hcmo> ^compo <hcpo>) - (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcmo> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>) - (modify 4 ^min <vcom> ^min-net <nn>) - (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcmo> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^com <hcom>) - (remove 1) - (make move-via <nn> <hlay> <hcom> <vcom>) -) - -(p p368 - (move-via <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <hcpo> ^commo <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max >= <hcpo> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> }) - (vertical ^net-name nil ^min { <vmin2> <= <hcom> } ^max { <vmax2> > <vmin2> >= <hcpo> } ^com <vcom> ^layer <hlay> ^commo <vcmo> ^compo <vcpo> ^min-net <mn>) - - (horizontal ^net-name <> <nn> ^min < <vcom> ^max >= <vcom> ^com <hcpo>) - - (vertical ^net-name <> <nn> ^min <hcpo> ^max > <hcpo> ^com <vcom>) - --> - (modify 3 ^min <hcpo>) - (make vertical ^layer <vlay> ^min <hcom> ^max <hcpo> ^com <vcom> ^max-net <nn> ^commo <vcmo> ^compo <vcpo>) - (make vertical ^layer <hlay> ^min <vmin2> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>) - (modify 4 ^min <hcpo> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcom> ^max <hcpo> ^commo <vcmo> ^compo <vcpo> ^com <vcom>) - (remove 1) - (make move-via <nn> <vlay> <vcom> <hcom>) -) - -(p p369 - (move-via <nn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <hcpo> ^commo <garb1> ^pin-name <pn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max >= <hcpo> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> }) - (vertical ^net-name nil ^min { <vmin2> <= <hcom> } ^max { <vmax2> > <vmin2> >= <hcpo> } ^com <vcom> ^layer <hlay> ^commo <vcmo> ^compo <vcpo> ^min-net <mn>) - - (horizontal ^net-name <> <nn> ^min <= <vcom> ^max > <vcom> ^com <hcpo>) - - (vertical ^net-name <> <nn> ^min <hcpo> ^max > <hcpo> ^com <vcom>) - --> - (modify 3 ^min <hcpo>) - (make vertical ^layer <vlay> ^min <hcom> ^max <hcpo> ^com <vcom> ^max-net <nn> ^commo <vcmo> ^compo <vcpo>) - (make vertical ^layer <hlay> ^min <vmin2> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>) - (modify 4 ^min <hcpo> ^min-net <nn>) - (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcom> ^max <hcpo> ^commo <vcmo> ^compo <vcpo> ^com <vcom>) - (remove 1) - (make move-via <nn> <vlay> <vcom> <hcom>) -) - -(p p370 - (move-via <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <vcpo> ^commo <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max >= <vcpo> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> }) - (horizontal ^net-name nil ^min { <hmin2> <= <vcom> } ^max { <hmax2> > <hmin2> >= <vcpo> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (vertical ^net-name <> <nn> ^min < <hcom> ^max >= <hcom> ^com <vcpo>) - - (horizontal ^net-name <> <nn> ^min <vcpo> ^max > <vcpo> ^com <hcom>) - --> - (modify 3 ^min <vcpo>) - (make horizontal ^layer <hlay> ^max <vcpo> ^min <vcom> ^com <hcom> ^max-net <nn> ^commo <hcmo> ^compo <hcpo>) - (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>) - (modify 4 ^min <vcpo> ^min-net <nn>) - (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcom> ^max <vcpo> ^commo <hcmo> ^compo <hcpo> ^com <hcom>) - (remove 1) - (make move-via <nn> <hlay> <hcom> <vcom>) -) - -(p p371 - (move-via <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <vcpo> ^commo <garb1> ^pin-name <pn>) - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max >= <vcpo> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> }) - (horizontal ^net-name nil ^min { <hmin2> <= <vcom> } ^max { <hmax2> > <hmin2> >= <vcpo> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) - - (vertical ^net-name <> <nn> ^min <= <hcom> ^max > <hcom> ^com <vcmo>) - - (horizontal ^net-name <> <nn> ^min <vcpo> ^max > <vcpo> ^com <hcom>) - --> - (modify 3 ^min <vcpo>) - (make horizontal ^layer <hlay> ^max <vcpo> ^min <vcom> ^com <hcom> ^max-net <nn> ^commo <hcmo> ^compo <hcpo>) - (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>) - (modify 4 ^min <vcpo> ^min-net <nn>) - (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcom> ^max <vcpo> ^commo <hcmo> ^compo <hcpo> ^com <hcom>) - (remove 1) - (make move-via <nn> <hlay> <hcom> <vcom>) -) - -(p p372 - (move-via <nn>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin1> ^max <vmax1> ^com <vcom1> ^layer <vlay> ^compo <vcpo1> ^commo <vcmo1> ^pin-name <pn1>) - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmax1> ^max <vmax2> ^com { <vcom2> > <vcom1> } ^layer <vlay> ^compo <vcpo2> ^commo <vcmo2> ^pin-name <pn2>) - { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom1> ^max <vcom2> ^com <vmax1> ^layer { <hlay> <> <vlay> }) } - { <h2> (horizontal ^status nil ^net-name nil ^min { <fmin> <= <vcom1> } ^max { <fmax> >= <vcom2> } ^com <vmax1> ^layer <vlay>) } - - (vertical ^min < <vmax1> ^max >= <vmax1> ^com { > <vcom1> < <vcom2> }) - --> - (remove <h2>) - (modify <h1> ^net-name nil ^pin-name nil ^min-net nil ^max-net nil) - (make (substr <h2> 1 inf) ^max <vcmo1> ^max-net nil) - (make (substr <h2> 1 inf) ^min <vcpo2> ^min-net nil) - (make (substr <h1> 1 inf) ^layer <vlay>) -) - -(p p373 - (move-via <nn> <lay> <x> <y>) - (horizontal ^min <x> ^max <garb1> ^com <y> ^layer <lay> ^min-net <nn> ^max-net <garb2>) - --> - (modify 2 ^min-net nil) -) - -(p p374 - (move-via <nn> <lay> <x> <y>) - (vertical ^min <y> ^max <garb1> ^com <x> ^layer <lay> ^min-net <nn> ^max-net <garb2>) - --> - (modify 2 ^min-net nil) -) - -(p p375 - (move-via <nn> <lay> <x> <y>) - (horizontal ^min <garb1> ^max <x> ^com <y> ^layer <lay> ^min-net <garb2> ^max-net <nn>) - --> - (modify 2 ^max-net nil) -) - -(p p376 - (move-via <nn> <lay> <x> <y>) - (vertical ^min <garb1> ^max <y> ^com <x> ^layer <lay> ^min-net <garb2> ^max-net <nn>) - --> - (modify 2 ^max-net nil) -) - -(p start-dummy - (start) - --> - (write (crlf) | Dummy START, do "loadwm" from "kuh.tmp".| (crlf)) -) - - diff --git a/contrib/psgraph/psgraph.catalog b/contrib/psgraph/psgraph.catalog deleted file mode 100644 index 2703a4a8757bbb9b3dc3d91bfadab1e25c3e40d4..0000000000000000000000000000000000000000 --- a/contrib/psgraph/psgraph.catalog +++ /dev/null @@ -1,61 +0,0 @@ -Name: - PSgrapher - -Description: - The PSgrapher is a set of Lisp routines that can be called to produce -Postscript commands that display a directed acyclic graph. - -Author: - Joseph Bates. Skef put the whole thing in the PSGRPAPH package and added -functionality which allows the user to specify EQ, EQUAL, or EQUALP as the -node equivalence function. Bill made all exported symbols have stars on them. - -Address: - Carnegie-Mellon University - Computer Science Department - Pittsburgh, PA 15213 - -Net Address: - Joseph.Bates@CS.CMU.EDU - -Copyright Status: - Public Domain. - -Files: - psgraph.lisp, psgraph.fasl, psgraph.doc, psgraph.log, psgraph.catalog - -How to Get: - The following unix command will copy the pertinent files into directory -<spec>. - cp /afs/cs.cmu.edu/project/clisp/library/psgraph/* <spec> - -Portability: - Should run in any legal Common Lisp. Requires Postscript for printing. - -Instructions: - See psgraph.doc. - -Bugs: - This code blindly outputs what the user gives it as node labels. It should -run through the output escaping any PS control characters. For example, if -node labels contain parentheses, your output PS file will not print. - -Examples: - Skef Wholey submitted this as a reasonable example: - -;;; I use this in my compiler so I can look at code trees without -;;; crawling around them in the inspector. The postsript previewer -;;; groks the generated ps file, which is bitchin' marvy. - - (defun code-graph-to-file (s file &optional shrink insert) - (let ((psgraph:*fontname* "Times-Roman") - (psgraph:*fontsize* 8) - (psgraph:*second-fontname* "Times-BoldItalic") - (psgraph:*second-fontsize* 6) - (psgraph:*boxgray* "0") - (psgraph:*edgegray* "0") - (psgraph:*extra-x-spacing* 30)) - (with-open-file (*standard-output* file - :direction :output - :if-exists :supersede) - (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq)))) diff --git a/contrib/psgraph/psgraph.doc b/contrib/psgraph/psgraph.doc deleted file mode 100644 index e7b17692d06d8a4714eb3ee0a3268ef9b1cff85d..0000000000000000000000000000000000000000 --- a/contrib/psgraph/psgraph.doc +++ /dev/null @@ -1,125 +0,0 @@ -Here is a brief summary of how to use the PSgrapher. - -The PSgrapher is a set of Lisp routines that can be called to produce -Postscript commands to display a directed acyclic graph. It uses the same -basic algorithm as the ISI Grapher. It is slower than the ISI grapher, but -produces much prettier output than using Xdump to copy an ISI Grapher screen -image to a Postscript printer. It also allows arbitrary information to be -displayed with a node, and can print as many output pages as are necessary to -accomodate large graphs (subject to Postscript printer limits, typically one or -two thousand nodes). - -The PSgrapher is small enough and easy enough to use to be included in other -systems without pain. It is also free and not copyrighted. - -Copy the file /afs/cs/project/clisp/library/psgraph/psgraph.lisp to your -directory. It is written in Common Lisp, and has been tested on CMU Common -Lisp on RTs and Lucid on SUNs. All interfaces described below are exported -from the "PSGRAPH" package. - -There are several useful global variables that can be modified and one function -to be called. The variables affect the style of the printed image, the -function walks a graph and produces output. - -A graph is defined by a root node and a function for getting children of a -node. Nodes are named by Lisp objects, and these names are checked using a -user-supplied test function (defaults to EQUAL) for purposes of walking the -graph and topologically sorting it. Typically one uses atoms to name nodes, -for example in graphing an inheritence net one could use the class names as -node names. - -To produce a graph call the function: - (psgraph:psgraph root-node-name - child-function - info-function - &optional (shrink nil) - &optional (insert nil) - &optional (test #'equal)) - -Root-node-name is a Lisp object naming the root of the graph (there must be -exactly one root). - -Child-function takes a node name and returns a list of node names. - -Info-function takes a node name and returns a list of strings. Each string -shows up as one line in the printed form of the node, with the first string -displayed in one font (determined by variables *fontname*, *fontsize*) and the -others in another font (determined by variables *second-fontname*, -*second-fontsize*). Typically the first string is just the name of the node, -eg, (string node-name). - -Shrink is a boolean. It defaults to nil, and in this case the graph -prints on as many pages as are needed to show the whole thing. If shrink -is t then the entire graph is squashed appropriately to fit on one page -of output. - -Insert is a boolean. It defaults to nil, and in this case the generated -Postscript file contains commands to print the output. If insert is t -then the output file is always shrunk (shrink is t) and no commands are -generated to print the page. This means the resulting file can be included -in Scribe files, for example, and Scribe can decide when to print the page. - -Test is a function that return whether two nodes are the same. - -After loading psgraph, one can play with the various global variables, all of -which have string values (except for the two font size variables). *fontname*, -*fontsize*, *second-fontname*, *second-fontsize* are as described above. They -default to "Helvetica" in 10 point and "Helvetica-Oblique" in 8 point, -respectively. *boxgray* and *boxkind* determine how the boxes around nodes -look. *boxkind* is either "fill" or "stroke", for solid or outline boxes, and -*boxgray* is "0" for solid black, "1" for solid white, or in between. These -default to ".2" and "stroke". - -Other variables: - *max-psnodes* - *extra-x-spacing* - *extra-y-spacing* - *edgewidth* - *edgegray* - *edgecap* - *textgray* - *pageheight* - *pagewidth* - *boxradius* - *boxedge* - *chunksize* - - -Psgraph sends its output to *standard-output*, so typically it is called -from within (with-open-file ....). For example, one might use it like this: - - (load "psgraph.fasl") - (setf psgraph:*boxkind* "fill") - (setf psgraph:*boxgray* ".8") - (setf psgraph:*fontsize* 8) - (setf psgraph:*second-fontsize* 6) - - (defun graph (&optional (shrink t)) - (with-open-file (*standard-output* "g.ps" - :direction :output - :if-exists :supersede) - (psgraph:psgraph 'A #'children #'info shrink nil #'eq))) - - (defun children (x) - (cond ((eq x 'A) '(B C D)) - ((member x '(B C D)) '(E F G)) - ((member x '(E F G)) '(H)) - (t nil))) - - (defun info (x) - (list (string x))) - - -Another example: - (defun code-graph-to-file (s file &optional shrink insert) - (let ((psgraph:*fontname* "Times-Roman") - (psgraph:*fontsize* 8) - (psgraph:*second-fontname* "Times-BoldItalic") - (psgraph:*second-fontsize* 6) - (psgraph:*boxgray* "0") - (psgraph:*edgegray* "0") - (psgraph:*extra-x-spacing* 30)) - (with-open-file (*standard-output* file - :direction :output - :if-exists :supersede) - (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq)))) diff --git a/contrib/psgraph/psgraph.lisp b/contrib/psgraph/psgraph.lisp deleted file mode 100644 index 09e37bbcf1871f09e96468e385606260f77bc3e4..0000000000000000000000000000000000000000 --- a/contrib/psgraph/psgraph.lisp +++ /dev/null @@ -1,506 +0,0 @@ -;;; -*- Mode: Lisp; Package: PSGRAPH; Log: psgraph.log -*- -;;; -;;; PostScript DAG Grapher -- Joseph Bates, CMU CSD, March 1988 -;;; -;;; See psgraph.log for other modifiers. -;;; -(in-package "PSGRAPH") - -(export '(*max-psnodes* *extra-x-spacing* *extra-y-spacing* *fontname* - *fontsize* *second-fontname* *second-fontsize* *boxgray* *boxkind* - *edgewidth* *edgegray* *edgecap* *textgray* *pageheight* *pagewidth* - *boxradius* *boxedge* *chunksize* - - psgraph)) - - -(defstruct psnode - name - info - children - parents - appears-in-top-sort - children-appear-in-top-sort - yvalue - height -) - -(defvar *max-psnodes* 5000) -(defvar *extra-x-spacing* 20) -(defvar *extra-y-spacing* 6) -(defvar *fontname* "Helvetica") -(defvar *fontsize* 10) -(defvar *second-fontname* "Helvetica-Oblique") -(defvar *second-fontsize* 8) -(defvar *boxgray* ".2") ;; 0 is black, 1 is white -(defvar *boxkind* "stroke") ;; stroke for outline, fill for solid -(defvar *edgewidth* ".5") ;; .5 is thin lines, 1 is fairly thick -(defvar *edgegray* ".2") ;; dark, but not solid black, lines -(defvar *edgecap* "1") ;; round the line caps -(defvar *textgray* "0") ;; solid black text -(defvar *pageheight* 720) -(defvar *pagewidth* (+ (* 7 72) 36)) -(defvar *boxradius* (floor *fontsize* 2)) -(defvar *boxedge* (floor *fontsize* 4)) -(defvar *chunksize* 400) - -(defvar num-psnodes) -(defvar narray) -(defvar psnode-index) -(defvar child-function) -(defvar info-function) -(defvar top-sort) -(defvar maximum-y) -(defvar minimum-y) -(defvar rows) -(defvar y-offset) -(defvar psnodes-at-y) -(defvar ancestor-cache) - -(defun psgraph (root childf infof &optional (shrink nil) (insert nil) (test #'equal)) - (unless (member test (list 'eq 'equal 'equalp #'eq #'equal #'equalp)) - (error "Test must be a function suitable to hand to Make-Hash-Table.")) - (when insert (setf shrink t)) - (setq narray (make-array *max-psnodes*)) - (setq num-psnodes 0) - (setq psnode-index (make-hash-table :test test - :size 500 - :rehash-size 2.0)) - (setq child-function childf) - (setq info-function infof) - (setq ancestor-cache (make-hash-table :test test - :size 1000 - :rehash-size 2.0)) - - ;;; walk the graph computing node info - (walk-graph root) - (dotimes (index num-psnodes) - (setf (psnode-parents (aref narray index)) - (nreverse (psnode-parents (aref narray index)))) - (setf (psnode-children (aref narray index)) - (nreverse (psnode-children (aref narray index))))) - - ;;; topological sort the graph - (setq top-sort nil) - (top-sort-node 0) - (setq top-sort (nreverse top-sort)) - - ;;; declare this as a PostScript file - (format t "%!PS-Adobe-1.0~%") - - ;;; this is required for the Apple LaserWriter (it likes to know the page - ;;; ordering so that it can print pages upside down). It is best not to - ;;; confuse the LaserWriter when inserting things into a other documents. - (when (not insert) - (format t "%%Page: ? ?~%")) - - ;;; define global functions - (dolist (line '( - - "/max {2 copy lt {exch} if pop} def" - - "/min {2 copy gt {exch} if pop} def" - - "/inch {72 mul} def" - - "/drawbox" - " {/height exch def" - " /width exch def" - " /y exch def" - " /x exch def" - " gsave newpath" - " x y boxradius add moveto" - " x y height add x width add y height add boxradius arcto pop pop pop pop" - " x width add y height add x width add y boxradius arcto pop pop pop pop" - " x width add y x y boxradius arcto pop pop pop pop" - " x y x y height add boxradius arcto pop pop pop pop" - " boxgray setgray boxkind grestore" - " } def" - - "/printposter" - " {/rows exch def" - " /columns exch def" - " /bigpictureproc exch def" - " newpath" - " leftmargin botmargin moveto" - " 0 pageheight rlineto" - " pagewidth 0 rlineto" - " 0 pageheight neg rlineto" - " closepath clip" - " leftmargin botmargin translate" - " 0 1 rows 1 sub" - " {/rowcount exch def" - " 0 1 columns 1 sub" - " {/colcount exch def" - " gsave" - " pagewidth colcount mul neg" - " pageheight rowcount mul neg" - " translate" - " bigpictureproc" - " gsave showpage grestore" - " grestore" - " } for" - " } for" - " } def" - - )) (format t "~A~%" line)) - - ;;; declare arrays - (format t "/xarray ~D array def~%" num-psnodes) - (format t "/widtharray ~D array def~%" num-psnodes) - - ;;; define global settings - (format t "/leftmargin 36 def~%") - (format t "/botmargin 36 def~%") - (format t "/pagewidth ~D def~%" *pagewidth*) - (format t "/pageheight ~D def~%" *pageheight*) - (format t "/boxradius ~D def ~%" *boxradius*) - (format t "/boxedge ~D def ~%" *boxedge*) - (format t "/boxgray ~A def ~%" *boxgray*) - (format t "/boxkind {~A} def~%" *boxkind*) - - ;;; compute width and height of each node - (format t "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*) - (dotimes (index num-psnodes) - (format t "widtharray ~D (~A) stringwidth pop put~%" - index - (car (psnode-info (aref narray index))))) - (format t "/~A findfont ~D scalefont setfont~%" - *second-fontname* *second-fontsize*) - (dotimes (index num-psnodes) - (format t "widtharray ~D get~%" index) - (dolist (info (cdr (psnode-info (aref narray index)))) - (format t "(~A) stringwidth pop max~%" info)) - (format t "~D add widtharray exch ~D exch put~%" - (* 2 *boxedge*) - index)) - (dotimes (index num-psnodes) - (setf (psnode-height (aref narray index)) - (+ (* 2 *boxedge*) - *extra-y-spacing* - *fontsize* - (* (- (length (psnode-info (aref narray index))) 1) - *second-fontsize*)))) - - ;;; compute x location of each node - (format t "xarray 0 0 put~%") - (dolist (index (cdr top-sort)) - (let ((parents (psnode-parents (aref narray index)))) - (format t "xarray ~D get widtharray ~D get add~%" - (car parents) (car parents)) - (dolist (parent (cdr parents)) - (format t "xarray ~D get widtharray ~D get add max~%" - parent parent)) - (format t "~D add xarray exch ~D exch put~%" *extra-x-spacing* index))) - - ;;; compute maximum x used - (format t "/maximum-x 0~%") - (dotimes (index num-psnodes) - (format t "xarray ~D get widtharray ~D get add max~%" - index index)) - (format t "def~%") - - ;;; compute y location of each node and maximum and minimum y used - (setq maximum-y 0) - (setq minimum-y 0) - (setq psnodes-at-y (make-hash-table :test test - :size (* num-psnodes *fontsize*) - :rehash-size 2.0)) - (let ((currenty 0)) - (dolist (index (reverse top-sort)) - (let (desired-y) - (cond ((null (psnode-children (aref narray index))) - (setf desired-y currenty) - (setf currenty (+ currenty (psnode-height - (aref narray index))))) - (t - (let ((children (psnode-children (aref narray index))) - (ysum 0)) - (dolist (child children) - (setf ysum (+ ysum (psnode-yvalue (aref narray child))))) - (setq desired-y (floor ysum (length children)))))) - - ;;; We may not be able to put the node at the desired y. - ;;; If there is another node that overlaps in the y direction - ;;; and that node is neither a parent* nor child* (hence its x - ;;; location may overlap this one) then we have to choose - ;;; another y value -- we choose the nearest (up or down) - ;;; location so that there is no possible overlap in y or x. - (let ((height (psnode-height (aref narray index))) - (related (make-hash-table :test test - :size (+ 50 num-psnodes) - :rehash-size 2.0)) - collision - upward-bot - upward-top - downward-bot - downward-top) - (setq upward-bot desired-y) - (setq upward-top upward-bot) - (setq downward-top (- (+ desired-y height) 1)) - (setq downward-bot downward-top) - (loop - ;;; check upward-top for collision - (setq collision nil) - (dolist (n (gethash upward-top psnodes-at-y)) - (let ((r (gethash n related))) - (when (null r) - (setf r (related-classes n index)) - (setf (gethash n related) r)) - (when (eql r 'no) - (setq collision t) - (return)))) - - ;;; if no collision and big enough space then we win - (incf upward-top) - (when (and (not collision) (= (- upward-top upward-bot) height)) - (setf desired-y upward-bot) - (return)) - - (when collision - (setf upward-bot upward-top)) - - ;;; check downward-bot for collision - (setq collision nil) - (dolist (n (gethash downward-bot psnodes-at-y)) - (let ((r (gethash n related))) - (when (null r) - (setf r (related-classes n index)) - (setf (gethash n related) r)) - (when (eql r 'no) - (setq collision t) - (return)))) - - ;;; if no collision and big enough space then we win - (decf downward-bot) - (when (and (not collision) (= (- downward-top downward-bot) height)) - (setf desired-y (+ 1 downward-bot)) - (return)) - - (when collision - (setf downward-top downward-bot)) - ) - ;;; add our name to psnodes-at-y table - (dotimes (i height) - (push index (gethash (+ i desired-y) psnodes-at-y))) - - (setf (psnode-yvalue (aref narray index)) desired-y) - ) - - (setf minimum-y (min minimum-y (psnode-yvalue (aref narray index)))) - (setf maximum-y - (max maximum-y (+ (psnode-yvalue (aref narray index)) - (psnode-height (aref narray index)))))))) - - ;;; compute y-offset to center graph vertically - (setq rows (ceiling (- maximum-y minimum-y) *pageheight*)) - (setq y-offset (- (floor (- (* rows *pageheight*) (- maximum-y minimum-y)) 2) - minimum-y)) - (when shrink (setq y-offset (- 0 minimum-y))) - - ;;; create dictionary big enough to hold all the - ;;; procedures defined below and make it a current dictionary - (format t "~D dict begin~%" - (+ (* 4 (+ num-psnodes (ceiling num-psnodes *chunksize*))) 50)) - - ;;; define procedures to display the background box for each node - (dotimes (index num-psnodes) - (format t "/box~D {~%" index) - (format t "xarray ~D get ~D widtharray ~D get ~D drawbox~%" - index - (+ y-offset - (psnode-yvalue (aref narray index)) - (floor *extra-y-spacing* 2)) - index - (- (psnode-height (aref narray index)) *extra-y-spacing*)) - (format t "} def~%")) - - ;;; define procedures to display the text info for each node - (dotimes (index num-psnodes) - (let ((yvalue (+ y-offset - (floor *extra-y-spacing* 2) - (floor *fontsize* 5) - *boxedge* - (psnode-yvalue (aref narray index)) - (* *second-fontsize* - (- (length (psnode-info (aref narray index))) 1))))) - (format t "/text~D {xarray ~D get boxedge add ~D moveto (~A) show} def~%" - index - index - yvalue - (car (psnode-info (aref narray index)))) - (when (not (null (cdr (psnode-info (aref narray index))))) - (format t "/secondtext~D {~%" index) - (dolist (info (cdr (psnode-info (aref narray index)))) - (setq yvalue (- yvalue *second-fontsize*)) - (format t "xarray ~D get boxedge add ~D moveto (~A) show~%" - index - yvalue - info)) - (format t "} def~%")))) - - ;;; define procedures to display the edges leading into each node - (dotimes (index num-psnodes) - (format t "/edge~D {newpath~%" index) - (dolist (parent (psnode-parents (aref narray index))) - (format t "xarray ~D get widtharray ~D get add ~D moveto~%" - parent - parent - (+ (psnode-yvalue (aref narray parent)) - (floor (psnode-height (aref narray parent)) 2) - y-offset)) - (format t "xarray ~D get ~D lineto~%" - index - (+ (psnode-yvalue (aref narray index)) - (floor (psnode-height (aref narray index)) 2) - y-offset))) - (format t "stroke } def~%")) - - ;;; Define procedures to display chunks of boxes, text, and edges. - ;;; We limit each chunk to at most *chunksize* calls, to avoid overflowing - ;;; the Postscript operand stack. - (dotimes (index num-psnodes) - (when (eql (mod index *chunksize*) 0) - (format t "/boxchunk~D {~%" (floor index *chunksize*))) - (format t "box~D~%" index) - (when (or (eql (mod index *chunksize*) (- *chunksize* 1)) - (eql index (- num-psnodes 1))) - (format t "} def~%"))) - (dotimes (index num-psnodes) - (when (eql (mod index *chunksize*) 0) - (format t "/textchunk~D {~%" (floor index *chunksize*))) - (format t "text~D~%" index) - (when (or (eql (mod index *chunksize*) (- *chunksize* 1)) - (eql index (- num-psnodes 1))) - (format t "} def~%"))) - (dotimes (index num-psnodes) - (when (eql (mod index *chunksize*) 0) - (format t "/secondtextchunk~D {~%" (floor index *chunksize*))) - (when (not (null (cdr (psnode-info (aref narray index))))) - (format t "secondtext~D~%" index)) - (when (or (eql (mod index *chunksize*) (- *chunksize* 1)) - (eql index (- num-psnodes 1))) - (format t "} def~%"))) - (dotimes (index num-psnodes) - (when (eql (mod index *chunksize*) 0) - (format t "/edgechunk~D {~%" (floor index *chunksize*))) - (format t "edge~D~%" index) - (when (or (eql (mod index *chunksize*) (- *chunksize* 1)) - (eql index (- num-psnodes 1))) - (format t "} def~%"))) - - ;;; Define procedure to display entire graph. - ;;; First do the boxes, then the edges, then the text. - (format t "/drawgraph { gsave~%") - (dotimes (i (ceiling num-psnodes *chunksize*)) - (format t "boxchunk~D~%" i)) - (format t "~A setlinewidth~%" *edgewidth*) - (format t "~A setlinecap~%" *edgecap*) - (format t "~A setgray~%" *edgegray*) - (dotimes (i (ceiling num-psnodes *chunksize*)) - (format t "edgechunk~D~%" i)) - (format t "~A setgray~%" *textgray*) - (format t "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*) - (dotimes (i (ceiling num-psnodes *chunksize*)) - (format t "textchunk~D~%" i)) - (format t "/~A findfont ~D scalefont setfont~%" *second-fontname* *second-fontsize*) - (dotimes (i (ceiling num-psnodes *chunksize*)) - (format t "secondtextchunk~D~%" i)) - (format t "grestore } def~%") - - ;;; show the virtual page in as many actual pages as needed - (cond (shrink - ;;; shrink the output to fit on one page - (format t "leftmargin botmargin translate~%") - (format t "pagewidth dup maximum-x max div pageheight dup ~D max ~ - div min dup scale~%" - (- maximum-y minimum-y)) - (if insert - (format t "drawgraph end~%") - (format t "drawgraph showpage end~%"))) - (t - (format t "{drawgraph} maximum-x pagewidth div ceiling ~ - ~D printposter end~%" - rows))) - -) - - -(defun walk-graph (root) - (when (eql num-psnodes *max-psnodes*) - (error "More than ~D nodes in graph. Graphing aborted.")) - (let ((root-index num-psnodes) - (child-names (apply child-function (list root)))) - (incf num-psnodes) - (setf (gethash root psnode-index) root-index) - (setf (aref narray root-index) (make-psnode)) - (setf (psnode-name (aref narray root-index)) root) - (setf (psnode-info (aref narray root-index)) - (apply info-function (list root))) - (setf (psnode-children (aref narray root-index)) nil) - (setf (psnode-parents (aref narray root-index)) nil) - (setf (psnode-appears-in-top-sort (aref narray root-index)) nil) - (setf (psnode-children-appear-in-top-sort (aref narray root-index)) nil) - (dolist (child child-names) - (let ((child-index (gethash child psnode-index))) - (cond (child-index - (push child-index - (psnode-children (aref narray root-index))) - (push root-index - (psnode-parents (aref narray child-index)))) - (t - (let ((child-index (walk-graph child))) - (push child-index - (psnode-children (aref narray root-index))) - (push root-index - (psnode-parents (aref narray child-index)))))))) - root-index) -) - -(defun top-sort-node (index) - (when (not (psnode-appears-in-top-sort (aref narray index))) - - ;;; make sure the parents are processed - (dolist (parent (psnode-parents (aref narray index))) - (top-sort-parent parent)) - - ;;; add this node to top-sort - (push index top-sort) - (setf (psnode-appears-in-top-sort (aref narray index)) t)) - - (when (not (psnode-children-appear-in-top-sort (aref narray index))) - (dolist (child (psnode-children (aref narray index))) - (top-sort-node child)) - (setf (psnode-children-appear-in-top-sort (aref narray index)) t)) -) - -(defun top-sort-parent (index) - (when (not (psnode-appears-in-top-sort (aref narray index))) - - ;;; make sure the parents are processed - (dolist (parent (psnode-parents (aref narray index))) - (top-sort-parent parent)) - - ;;; add this node to top-sort - (push index top-sort) - (setf (psnode-appears-in-top-sort (aref narray index)) t)) -) - -(defun related-classes (x y) - (cond ((ancestor x y) 'yes) - ((ancestor y x) 'yes) - (t 'no)) -) - -(defun ancestor (x y) - (let ((cached-value (gethash (list x y) ancestor-cache))) - (cond (cached-value (car cached-value)) - (t - (setq cached-value - (cond ((equal x y) t) - (t - (some #'(lambda (child) (ancestor child y)) - (psnode-children (aref narray x)))))) - (setf (gethash (list x y) ancestor-cache) (list cached-value)) - cached-value))) -) diff --git a/contrib/psgraph/psgraph.log b/contrib/psgraph/psgraph.log deleted file mode 100644 index 2214c46483006730ea5c185b074b31324f2678ef..0000000000000000000000000000000000000000 --- a/contrib/psgraph/psgraph.log +++ /dev/null @@ -1,18 +0,0 @@ -/usr1/chiles/work/psgraph.lisp, Jul-90 10:59:13, Edit by Mkant. - Fixed shrink mode so that it scales x and y axes uniformly (e.g., aspect - ratio = 1). - -/usr1/chiles/work/psgraph.lisp, 01-May-90 10:59:13, Edit by Chiles. - Made exported specials have stars. - -/usr1/chiles/work/psgraph.lisp, APR 90, Edit by Skef Wholey. - ;;; -- Now lives in the PSGRAPH package (instead of USER, or *package*...) - ;;; with user-tweakable stuff exported. - ;;; -- Node equivalence function can now be specified as EQ, EQUAL, - ;;; or EQUALP. - -/usr1/chiles/work/psgraph.lisp, DEC 88, Edit by Joseph Bates - Modified to include optional insert parameter to psgraph. - -/usr1/chiles/work/psgraph.lisp, MAR 88, Edit by Joseph Bates - File created. diff --git a/docs/cmu-user/cmu-user.dict b/docs/cmu-user/cmu-user.dict deleted file mode 100644 index ce86160b6440636b8f2b33b0077b932a5cd4cece..0000000000000000000000000000000000000000 --- a/docs/cmu-user/cmu-user.dict +++ /dev/null @@ -1,460 +0,0 @@ -'BAR -VARREF -'TEST -UPCASE -ENDLISP -SUBSEQ -ENDDEFUN -FUNARGS -GENSYM -VARS -UNINTERNED -VAR -VSOURCE -CLISP -COND -MYSTUFF -TRADEOFFS -PATHNAME -LLISP -CMUCL -REF -YETMOREKEYS -CLEANUP -ARGS -DEFUN -ZOQ -FOO -'S -CLTL -MACROEXPANDS -MACROEXPANSION -PROXY -ERRORFUL -EQ -ECASE -PYTHON -DEFMACRO -PROMISCUOUS -FLAMAGE -DEBUGGABILITY -FEATUREFULNESS -DEBUGGABLE -ENDDEFVAR -MACROEXPANDED -DEFVAR -ENDDEFMAC -KWD -MGROUP -MSTAR -DEFMAC -OFFS -NOTINLINE -TRADEOFF -FUNCALL -SOMEVAL -SOMEFUN -CM -DEFTYPE -CONSING -FIXNUMS -BIGNUMS -FROB -'FOO -RECOMPILES -FTYPE -TYPECASE -TYPEP -UNTYPED -UNIONED -GLOBALS -MODICUM -MACREF -SLEAZING -ES -STEELE -ETYPECASE -'EQL -'IDENTITY -'FUN -LOCALFUN -ISQRT -ODDP -MYFUN -POS -ZOW -YOW -'YOW -CADR -ZEROP -RES -EXPT -PARED -PUSHING -'ING -RPLACD -IOTA -NTHCDR -NTH -CADDDR -RPLACA -CADDR -FIENDS -SQRT -'SQRT -LISPY -BLANKSPACE -MYCHAPTER -UNENCAPSULATED -ENCAPSULATIONS -UNENCAPSULATE -UNTRACED -UNTRACE -EVALED -SPEC -PUSHES -TRUENAME -MYMAC -UNINFORMATIVE -FOOBAR -BAZ -BACKQUOTE -MALFORMED -MOREKEYS -FUNREF -QUIRKS -UNDILUTED -DISASSEMBLY -NAN -DENORMALIZED -ENDDEFCONST -DEFCONST -HASHTABLES -EFF -OBFUSCATING -SNOC -GRUE -GORP -FLO -NUM -VEC -MULTBY -SOMEOTHERFUN -'CHAR -NOTP -TESTP -FUNVAR -RAZ -ZUG -XFF -IO -GC'ING -EXT -MEGABYTE -SYS -UX -ED -MATCHMAKER -DIRED -PCL -CLOS -CONFORMANCE -ENDDEFCON -DEFCON -DECLAIM -DEFSTRUCT -ENUM -EXTERN -LOWERCASING -DEREFERENCED -MOPT -STRUCT -DEFTP -ENDDEFTP -MALLOC -CSH -PXLREF -ATYPE -CONSTRUCTUED -ANAME -PXREF -ENV -ONECOLUMN -TP -VR -FN -PRINTINDEX -UNNUMBERED -TWOCOLUMN -TLF -UNCOMPILED -DEACTIVATE -CALLABLE -UNREFERENCED -SUPPLIEDP -INTERNING -UNHANDLED -BACKTRACING -TEX -OOB -OBJ -PRIN -OBJS -GP -LINKERS -CC -AR -CFUN -INTS -SIZEOF -PRINTF -CFOO -SUBFORM -SVREF -STASH -FOOS -LC -LD -'N -'X -ERRNO -UPPERCASING -EXPR -ADDR -'STR -STR -DEREF -PTR -SWINDOW -IWINDOW -'SLIDER -DRAWABLE -'KEY -'EXT -TIMEOUTS -'MY -ID -PIXMAPS -'EQ -FUNCALLED -XWINDOW -'IH -SIGSTOP -GETPID -SIGTSTP -SCP -SIGINT -IH -CNT -GENERALRETURN -DEFMACX -'NUKEGARBAGE -GR -HASSLE -PREPENDS -TIMEOUT -FD -MSG -SYSCALL -UNHELPFUL -PREPENDED -VM -PAGEREF -INT -PORTSID -PORTSNAME -SERVPORT -KERN -DATATYPES -TTY -STDERR -STDOUT -STDIN -CMD -AUX -PS -UNACCOUNTED -RUNTIMES -PROFILER -UNPROFILE -REPROFILED -UNPROFILED -CF -ELT -VOPS -MAPCAR -OPTIONALS -CONSES -CONTORTIONS -ALISTS -ALIST -ASSOC -EXP -MYEXP -DEFCONSTANT -INCF -MEMQ -COERCIONS -EQL -LOGAND -AREF -CONSP -TYPEN -LOGIOR -EQUIV -SUPERTYPE -DEFMETHOD -SUBFORMS -CERROR -PSETQ -TAGBODY -DOTIMES -PLOQ -ROQ -SPECS -MPLUS -STEPPER -FDEFINITION -FUNCALLABLE -ST -BR -DB -LB -LL -HFILL -PP -VPRINT -TH -ARGLISTS -SETQ -NAMESPACE -SUBFUNCTION -BACKTRACE -'B -FLET -ARG -'A -CPSUBINDEX -PROGN -CONTRIB -WEEKDAYS -GREENWICH -TIMEZONE -DEST -WEEKDAY -JAN -CINDEX -NAMESTRING -PATHNAMES -FASL -SIGSEGV -PLIST -'ABLE -SETF -PID -EXECVE -DEV -SUBPROCESS -PTY -'TH -UNSUPPLIED -DEFVARX -GCS -CONSED -GC'ED -GC -TRASHING -XLIB -CL -HI -COMMONLOOPS -CTRL -XLREF -DEFUNX -DEFCONSTX -SUBSUBSECTION -VINDEXED -TINDEXED -RESEARCHCREDIT -EM -WHOLEY -SKEF -KAUFMANN -TODD -KOLOJEJCHICK -BUSDIECKER -'' -NOINDENT -MOORE -TIM -LOTT -LEINEN -HALLGREN -GLEICHAUF -DUNNING -TED -BADER -MYLISP -NOINIT -FINDEXED -INIT -EVAL -SUBDIRECTORIES -COPYRIGHTED -FTP -LANG -COMP -MEG -MEGABYTES -UNCOMPRESS -CD -OS -USERNAME -SLISP -RT -LIB -SETENV -SAMP -SETPATH -LOGIN -MISC -USR -MODMISC -TXT -DOC -EXECUTABLES -PERQ -UNTAGGED -BENCHMARKING -WINDOWING -INTRO -DOCS -EDU -AFS -VSPACE -IFINFO -DIR -SETFILENAME -TABLEOFCONTENTS -PAGENUMBERING -CLEARPAGE -MAKETITLE -ARPASUPPORT -CITATIONINFO -TRNUMBER -IFTEX -SUNOS -SPARC -DECSTATIONS -THEABSTRACT -DEF -KY -CP -NEWINDEX -ALWAYSREFILL -PAGESTYLE -CMULISP -TITLEPAGE -ELISP -LATEXINFO -DOCUMENTSTYLE diff --git a/docs/cmu-user/cmu-user.tex b/docs/cmu-user/cmu-user.tex deleted file mode 100644 index cb2a86881567072f500b2f1cdd575a7c2f1c295f..0000000000000000000000000000000000000000 --- a/docs/cmu-user/cmu-user.tex +++ /dev/null @@ -1,11506 +0,0 @@ -\documentstyle[latexinfo,elisp,cmu-titlepage,cmulisp]{report} % -*-latexinfo-*- -\pagestyle{headings} - -\begin{document} -\alwaysrefill -\newindex{cp} -\newindex{ky} - -\def\theabstract{ -CMU Common Lisp is an implementation of that Common Lisp is currently -supported on MIPS-processor DECstations, Sparc-based workstations from -Sun and the IBM RT PC, and other ports are planned. All architectures -are supported under Mach, a Berkeley Unix 4.3 binary compatible -operating system. The Sparc is also supported under SunOS. The largest -single part of this document describes the Python compiler and the -programming styles and techniques that the compiler encourages. The -rest of the document describes extensions and the implementation -dependent choices made in developing this implementation of Common Lisp. -We have added several extensions, including a source level debugger, an -interface to Unix system calls, a foreign function call interface, -support for interprocess communication and remote procedure call, and -other features that provide a good environment for developing Lisp code. -} - -\begin{iftex} -\pagestyle{empty} -\title{CMU Common Lisp User's Manual} - -\author{Robert A. MacLachlan, \var{Editor}} -\date{July 1992} -\trnumber{CMU-CS-92-161} -\citationinfo{ -\begin{center} -Supersedes Technical Reports CMU-CS-87-156 and CMU-CS-91-108. -\end{center} -} -\arpasupport{strategic} -\abstract{\theabstract} -\keywords{lisp, Common Lisp, manual, compiler, - programming language implementation, programming environment} - -\maketitle - -\clearpage -\pagestyle{headings} -\pagenumbering{roman} -\tableofcontents - -\clearpage -\pagenumbering{arabic} -\end{iftex} - -\setfilename{cmu-user.info} -\node Top, Introduction, (dir), (dir) - -\begin{ifinfo} -\vspace{1.3in} -\begin{center} -CMU Common Lisp User's Manual -Robert A. MacLachlan, \var{Editor} - -School of Computer Science -Carnegie Mellon University -Pittsburgh, PA 15213 -\end{center} - -\theabstract - -\end{ifinfo} - - -\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/intro.ms} - - - -\hide{ -*- Dictionary: cmu-user -*- } -\begin{menu} -* Introduction:: -* Design Choices and Extensions:: -* The Debugger:: -* The Compiler:: -* Advanced Compiler Use and Efficiency Hints:: -* UNIX Interface:: -* Event Dispatching with SERVE-EVENT:: -* Alien Objects:: -* Interprocess Communication under LISP:: -* Debugger Programmer's Interface:: -* Function Index:: -* Variable Index:: -* Type Index:: -* Concept Index:: - - --- The Detailed Node Listing --- - -Introduction - -* Support:: -* Local Distribution of CMU Common Lisp:: -* Net Distribution of CMU Common Lisp:: -* Source Availability:: -* Command Line Options:: -* Credits:: - -Design Choices and Extensions - -* Data Types:: -* Default Interrupts for Lisp:: -* Packages:: -* The Editor:: -* Garbage Collection:: -* Describe:: -* The Inspector:: -* Load:: -* The Reader:: -* Running Programs from Lisp:: -* Saving a Core Image:: -* Search Lists:: -* Time Parsing and Formatting:: -* Lisp Library:: - -Data Types - -* Symbols:: -* Integers:: -* Floats:: -* Characters:: -* Array Initialization:: - -Floats - -* IEEE Special Values:: -* Negative Zero:: -* Denormalized Floats:: -* Floating Point Exceptions:: -* Floating Point Rounding Mode:: -* Accessing the Floating Point Modes:: - -The Inspector - -* The Windowing Inspector:: -* The TTY Inspector:: - -Running Programs from Lisp - -* Process Accessors:: - -Search Lists - -* Search List Example:: - -The Debugger - -* Debugger Introduction:: -* The Command Loop:: -* Stack Frames:: -* Variable Access:: -* Source Location Printing:: -* Compiler Policy Control:: -* Exiting Commands:: -* Information Commands:: -* Breakpoint Commands:: -* Function Tracing:: -* Specials:: - -Stack Frames - -* Stack Motion:: -* How Arguments are Printed:: -* Function Names:: -* Funny Frames:: -* Debug Tail Recursion:: -* Unknown Locations and Interrupts:: - -Variable Access - -* Variable Value Availability:: -* Note On Lexical Variable Access:: - -Source Location Printing - -* How the Source is Found:: -* Source Location Availability:: - -Breakpoint Commands - -* Breakpoint Example:: - -Function Tracing - -* Encapsulation Functions:: - -The Compiler - -* Compiler Introduction:: -* Calling the Compiler:: -* Compilation Units:: -* Interpreting Error Messages:: -* Types in Python:: -* Getting Existing Programs to Run:: -* Compiler Policy:: -* Open Coding and Inline Expansion:: - -Compilation Units - -* Undefined Warnings:: -* Context Declarations:: -* Context Declaration Example:: - -Interpreting Error Messages - -* The Parts of the Error Message:: -* The Original and Actual Source:: -* The Processing Path:: -* Error Severity:: -* Errors During Macroexpansion:: -* Read Errors:: -* Error Message Parameterization:: - -Types in Python - -* Compile Time Type Errors:: -* Precise Type Checking:: -* Weakened Type Checking:: - -Compiler Policy - -* The Optimize Declaration:: -* The Optimize-Interface Declaration:: - -Advanced Compiler Use and Efficiency Hints - -* Advanced Compiler Introduction:: -* More About Types in Python:: -* Type Inference:: -* Source Optimization:: -* Tail Recursion:: -* Local Call:: -* Block Compilation:: -* Inline Expansion:: -* Object Representation:: -* Numbers:: -* General Efficiency Hints:: -* Efficiency Notes:: -* Profiling:: - -Advanced Compiler Introduction - -* Types:: -* Optimization:: -* Function Call:: -* Representation of Objects:: -* Writing Efficient Code:: - -More About Types in Python - -* More Types Meaningful:: -* Canonicalization:: -* Member Types:: -* Union Types:: -* The Empty Type:: -* Function Types:: -* The Values Declaration:: -* Structure Types:: -* The Freeze-Type Declaration:: -* Type Restrictions:: -* Type Style Recommendations:: - -Type Inference - -* Variable Type Inference:: -* Local Function Type Inference:: -* Global Function Type Inference:: -* Operation Specific Type Inference:: -* Dynamic Type Inference:: -* Type Check Optimization:: - -Source Optimization - -* Let Optimization:: -* Constant Folding:: -* Unused Expression Elimination:: -* Control Optimization:: -* Unreachable Code Deletion:: -* Multiple Values Optimization:: -* Source to Source Transformation:: -* Style Recommendations:: - -Tail Recursion - -* Tail Recursion Exceptions:: - -Local Call - -* Self-Recursive Calls:: -* Let Calls:: -* Closures:: -* Local Tail Recursion:: -* Return Values:: - -Block Compilation - -* Block Compilation Semantics:: -* Block Compilation Declarations:: -* Compiler Arguments:: -* Practical Difficulties:: - -Inline Expansion - -* Inline Expansion Recording:: -* Semi-Inline Expansion:: -* The Maybe-Inline Declaration:: - -Object Representation - -* Think Before You Use a List:: -* Structures:: -* Arrays:: -* Vectors:: -* Bit-Vectors:: -* Hashtables:: - -Numbers - -* Descriptors:: -* Non-Descriptor Representations:: -* Variables:: -* Generic Arithmetic:: -* Fixnums:: -* Word Integers:: -* Floating Point Efficiency:: -* Specialized Arrays:: -* Interactions With Local Call:: -* Representation of Characters:: - -General Efficiency Hints - -* Compile Your Code:: -* Avoid Unnecessary Consing:: -* Complex Argument Syntax:: -* Mapping and Iteration:: -* Trace Files and Disassembly:: - -Efficiency Notes - -* Type Uncertainty:: -* Efficiency Notes and Type Checking:: -* Representation Efficiency Notes:: -* Verbosity Control:: - -Profiling - -* Profile Interface:: -* Profiling Techniques:: -* Nested or Recursive Calls:: -* Clock resolution:: -* Profiling overhead:: -* Additional Timing Utilities:: -* A Note on Timing:: -* Benchmarking Techniques:: - -UNIX Interface - -* Reading the Command Line:: -* Lisp Equivalents for C Routines:: -* Type Translations:: -* System Area Pointers:: -* Unix System Calls:: -* File Descriptor Streams:: -* Making Sense of Mach Return Codes:: -* Unix Interrupts:: - -Unix Interrupts - -* Changing Interrupt Handlers:: -* Examples of Signal Handlers:: - -Event Dispatching with SERVE-EVENT - -* Object Sets:: -* The SERVE-EVENT Function:: -* Using SERVE-EVENT with Unix File Descriptors:: -* Using SERVE-EVENT with the CLX Interface to X:: -* A SERVE-EVENT Example:: - -Using SERVE-EVENT with the CLX Interface to X - -* Without Object Sets:: -* With Object Sets:: - -A SERVE-EVENT Example - -* Without Object Sets Example:: -* With Object Sets Example:: - -Alien Objects - -* Introduction to Aliens:: -* Alien Types:: -* Alien Operations:: -* Alien Variables:: -* Alien Data Structure Example:: -* Loading Unix Object Files:: -* Alien Function Calls:: -* Step-by-Step Alien Example:: - -Alien Types - -* Defining Alien Types:: -* Alien Types and Lisp Types:: -* Alien Type Specifiers:: -* The C-Call Package:: - -Alien Operations - -* Alien Access Operations:: -* Alien Coercion Operations:: -* Alien Dynamic Allocation:: - -Alien Variables - -* Local Alien Variables:: -* External Alien Variables:: - -Alien Function Calls - -* alien-funcall:: The alien-funcall Primitive -* def-alien-routine:: The def-alien-routine Macro -* def-alien-routine Example:: -* Calling Lisp from C:: - -Interprocess Communication under LISP - -* The REMOTE Package:: -* The WIRE Package:: -* Out-Of-Band Data:: - -The REMOTE Package - -* Connecting Servers and Clients:: -* Remote Evaluations:: -* Remote Objects:: -* Host Addresses:: - -The WIRE Package - -* Untagged Data:: -* Tagged Data:: -* Making Your Own Wires:: - -Debugger Programmer's Interface - -* DI Exceptional Conditions:: -* Debug-variables:: -* Frames:: -* Debug-functions:: -* Debug-blocks:: -* Breakpoints:: -* Code-locations:: -* Debug-sources:: -* Source Translation Utilities:: - -DI Exceptional Conditions - -* Debug-conditions:: -* Debug-errors:: -\end{menu} - -\node Introduction, Design Choices and Extensions, Top, Top -\chapter{Introduction} - -CMU Common Lisp is a public-domain implementation of Common Lisp -developed in the Computer Science Department of Carnegie Mellon -University. CMU Common Lisp is currently supported on MIPS-processor -DECstations, Sparc-based workstations from Sun and the IBM RT PC, and -other ports are planned. Currently, it runs under CMU's Mach operating -system, OSF/1 or SunOS. This document describes the implementation -based on the Python compiler. Previous versions of CMU Common Lisp ran -on the IBM RT PC and (when known as Spice Lisp) on the Perq workstation. -See \code{man cmucl} (\file{man/man1/cmucl.1}) for other general -information. - -\cmucl{} sources and executables are freely available via anonymous FTP; this -software is ``as is'', and has no warranty of any kind. CMU and the -authors assume no responsibility for the consequences of any use of this -software. See \file{doc/release-notes.txt} for a description of the -state of the release you have. - -\begin{menu} -* Support:: -* Local Distribution of CMU Common Lisp:: -* Net Distribution of CMU Common Lisp:: -* Source Availability:: -* Command Line Options:: -* Credits:: -\end{menu} - -\node Support, Local Distribution of CMU Common Lisp, Introduction, Introduction -\section{Support} - -The CMU Common Lisp project's goal is to develop a high quality public -domain system, so we want your bug reports, bug fixes and enhancements. -However, staff limitations prevent us from providing extensive support -to people outside of CMU. We are looking for university and industrial -affiliates to help us with porting and maintenance for hardware and -software that is not widely used at CMU. - -This manual contains only implementation-specific information about \cmucl. -Users will also need a separate manual describing the \clisp{} standard. -\clisp{} was initially defined in \i{Common Lisp: The Language}, by Guy L. -Steele Jr. \clisp{} is now undergoing standardization by the X3J13 committee -of ANSI. The X3J13 spec is not yet completed, but a number of clarifications -and modification have been approved. We intend that \cmucl{} will eventually -adhere to the X3J13 spec, and we have already implemented many of the changes -approved by X3J13. - -Until the X3J13 standard is completed, the second edition of \cltl2{} is -probably the best available manual for the language and for our -implementation of it. This book has no official role in the -standardization process, but it does include many of the changes adopted -since the first edition was completed. - -In addition to the language itself, this document describes a number of useful -library modules that run in \cmucl. \hemlock, an Emacs-like text editor, is -included as an integral part of the \cmucl{} environment. Two documents -describe \hemlock{}: the \i{Hemlock User's Manual}, and the \i{Hemlock Command -Implementor's Manual}. - -\node Local Distribution of CMU Common Lisp, Net Distribution of CMU Common Lisp, Support, Introduction -\section{Local Distribution of CMU Common Lisp} - -At CMU, you can get Common Lisp by running \code{modmisc}: -\begin{example} - /usr/cs/etc/modmisc - cs.misc.cmucl -\end{example} - -This establishes \file{/usr/misc/.cmucl} as a symbolic link to the release area. -In your \file{.login}, add CMU CL to your path: -\begin{example} -setpath -i /usr/misc/.cmucl -\end{example} -Then run \samp{lisp}. Note that the first time you run Lisp, it -will take AFS several minutes to copy the image into its local cache. -Subsequent starts will be much faster. - -Or, you can run directly out of the AFS release area (which may be -necessary on SunOS machines). Put this in your \file{.login} shell -script: -\begin{example} -setenv CMUCLLIB "/afs/cs/misc/cmucl/@sys/beta/lib" -setpath -i /afs/cs/misc/cmucl/@sys/beta -\end{example} - -After setting your path, `\code{man cmucl}' will give an introduction -to CMU CL and \samp{man lisp} will describe command line options. -For SunOS installation notes, see the \file{README} file in the SunOS -release area. - -See \file{/usr/misc/.cmucl/doc} for release notes and documentation. -Hardcopy documentation is available in the document room. -Documentation supplements may be available for recent additions: see -the \file{README} file. - -Send bug reports and questions to \samp{cmucl-bugs@cs.cmu.edu}. If -you send a bug report to \samp{gripe} or \samp{help}, they will just -forward it to this mailing list. - -\node Net Distribution of CMU Common Lisp, Source Availability, Local Distribution of CMU Common Lisp, Introduction -\section{Net Distribution of CMU Common Lisp} - -Externally, CMU Common Lisp is only available via anonymous FTP. We -don't have the manpower to make tapes. These are our distribution -machines: -\begin{example} -lisp-rt1.slisp.cs.cmu.edu (128.2.217.9) -lisp-rt2.slisp.cs.cmu.edu (128.2.217.10) -\end{example} - -Log in with the user \samp{anonymous} and \samp{username@host} as password -(i.e. your EMAIL address.) When you log in, the current directory should be -set to the \cmucl{} release area. If you have any trouble with FTP access, -please send mail to \samp{slisp@cs.cmu.edu}. - -The release area holds compressed tar files with names of the form: -\begin{example} -\var{version}-\var{machine}_\var{os}.tar.Z -\end{example} -FTP compressed tar archives in binary mode. To extract, \samp{cd} to the -directory that is to be the root of the tree, then type: -\begin{example} -uncompress <file.tar.Z | tar xf - . -\end{example} -The resulting tree is about 23 megabytes. For installation directions, see the -section ``site initialization'' in README file at the root of the tree. - -If poor network connections make it difficult to transfer a 10 meg file, -the release is also available split into five parts, with the suffix -\file{.0} to \file{.4}. To extract from multiple files, use: -\begin{example} -cat file.tar.Z.* | uncompress | tar xf - . -\end{example} - -The release area also contains source distributions and other binary -distributions. A listing of the current contents of the release area is -in \file{FILES}. Major release announcements will be made to -\code{comp.lang.lisp} until there is enough volume to warrant a -\code{comp.lang.lisp.cmu}. - -\node Source Availability, Command Line Options, Net Distribution of CMU Common Lisp, Introduction -\section{Source Availability} - -Lisp and documentation sources are available via anonymous FTP ftp to any CMU -CS machine. All CMU written code is public domain, but CMU CL also makes use -of two imported packages: PCL and CLX. Although these packages are -copyrighted, they may be freely distributed without any licensing agreement or -fee. See the \file{README} file in the binary distribution for up-to-date source -pointers. - -The release area contains a source distribution, which is an image of all the -\file{.lisp} source files used to build a particular system \var{version}: -\begin{example} -\var{version}-source.tar.Z (3.6 meg) -\end{example} - -All of our files (including the release area) are actually in the AFS -file system. On the release machines, the FTP server's home is the -release directory: \file{/afs/cs.cmu.edu/project/clisp/release}. The -actual working source areas are in other subdirectories of \file{clisp}, -and you can directly ``cd'' to those directories if you know the name. -Due to the way anonymous FTP access control is done, it is important to -``cd'' to the source directory with a single command, and then do a -``get'' operation. - -\node Command Line Options, Credits, Source Availability, Introduction -\section{Command Line Options} - -The command line syntax and environment is described in the lisp(1) man page in -the man/man1 directory of the distribution. See also cmucl(1). -Currently Lisp accepts the following switches: -\begin{description} - -\item[\code{-core}] requires an argument that should be the name of a -core file. Rather than using the default core file -(\file{/usr/misc/.lisp/lib/lisp.core}), the specified core file is -loaded. - -\item[\code{-edit}] specifies to enter Hemlock. A file to edit may be -specified by placing the name of the file between the program name -(usually \file{lisp}) and the first switch. - -\item[\code{-eval}] -accepts one argument which should be a Lisp form to evaluate during -the start up sequence. The value of the form will not be printed unless it is -wrapped in a form that does output. - -\item[\code{-hinit}] -accepts an argument that should be the name of -the hemlock init file to load the first time the function -\findexed{ed} is invoked. The default is to load -\file{hemlock-init.\var{object-type}}, or if that does not -exist, \file{hemlock-init.lisp} from the user's home directory. If -the file is not in the user's home directory, the full path must be -specified. - -\item[\code{-init}] accepts an argument that should be the name of an -init file to load during the normal start up sequence. The default is -to load \file{init.\var{object-type}} or, if that does not exist, -\file{init.lisp} from the user's home directory. If the file is not in -the user's home directory, the full path must be specified. - -\item[\code{-noinit}] -accepts no arguments and specifies that an init file should not -be loaded during the normal start up sequence. Also, this switch -suppresses the loading of a hemlock init file when Hemlock is started up -with the \code{-edit} switch. - -\item[\code{-load}] -accepts an argument which should be the name of a file to load -into Lisp before entering Lisp's read-eval-print loop. - -\item[\code{-slave}] specifies that Lisp should start up as a \i{slave} -Lisp and try to connect to an editor Lisp. The name of the editor to -connect to must be specified \dash{} to find the editor's name, use the -\hemlock{} \w{"\code{Accept Slave Connections}"} command. The name for -the editor Lisp is of the form: -\begin{example} -\var{machine-name}\code{:}\var{socket} -\end{example} -where \var{machine-name} is the internet host name for the machine and -\var{socket} is the decimal number of the socket to connect to. -\end{description} -For more details on the use of the \code{-edit} and \code{-slave} -switches, see the \i{Hemlock User's Manual}. - -Arguments to the above switches can be specified in one of two ways: -\w{\var{switch}\code{=}\var{value}} or -\w{\var{switch}<\var{space}>\var{value}}. For example, to start up the saved -core file mylisp.core use either of the following two commands: -\begin{example} -\code{lisp -core=mylisp.core -lisp -core mylisp.core} -\end{example} - -\node Credits, , Command Line Options, Introduction -\section{Credits} - -Since 1981 many people have contributed to the development of CMU Common -Lisp. The currently active members are: -\begin{display} -David Axmark -Miles Bader -Ted Dunning -Scott Fahlman * (fearless leader) -Mike Garland + -Paul Gleichauf * -Sean Hallgren + -Simon Leinen -William Lott * -Robert A. Maclachlan * -Tim Moore -\end{display} -\noindent -Many people are voluntarily working on improving CMU Common Lisp. ``*'' -means a full-time CMU employee, and ``+'' means a part-time student -employee. A partial listing of significant past contributors follows: -\begin{display} -Rick Busdiecker -Bill Chiles * -Chris Hoover + -John Kolojejchick -Todd Kaufmann + -Dave McDonald * -Skef Wholey * -\end{display} - -\vspace{2 em} -\researchcredit - - -\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/design.ms} - -\hide{ -*- Dictionary: cmu-user -*- } -\node Design Choices and Extensions, The Debugger, Introduction, Top -\chapter{Design Choices and Extensions} - -Several design choices in Common Lisp are left to the individual -implementation, and some essential parts of the programming environment -are left undefined. This chapter discusses the most important design -choices and extensions. - -\begin{menu} -* Data Types:: -* Default Interrupts for Lisp:: -* Packages:: -* The Editor:: -* Garbage Collection:: -* Describe:: -* The Inspector:: -* Load:: -* The Reader:: -* Running Programs from Lisp:: -* Saving a Core Image:: -* Search Lists:: -* Time Parsing and Formatting:: -* Lisp Library:: -\end{menu} - -\node Data Types, Default Interrupts for Lisp, Design Choices and Extensions, Design Choices and Extensions -\section{Data Types} - -\begin{menu} -* Symbols:: -* Integers:: -* Floats:: -* Characters:: -* Array Initialization:: -\end{menu} - -\node Symbols, Integers, Data Types, Data Types -\subsection{Symbols} - -As in \cltl, all symbols and package names are printed in lower case, as -a user is likely to type them. Internally, they are normally stored -upper case only. - -\node Integers, Floats, Symbols, Data Types -\subsection{Integers} - -The \tindexed{fixnum} type is equivalent to \code{(signed-byte 30)}. -Integers outside this range are represented as a \tindexed{bignum} or a word -integer (\pxlref{word-integers}.) Almost all integers that appear in -programs can be represented as a \code{fixnum}, so integer number -consing is rare. - -\node Floats, Characters, Integers, Data Types -\subsection{Floats} -\label{ieee-float} - -\cmucl{} supports two floating point formats: \tindexed{single-float} and -\tindexed{double-float}. These are implemented with IEEE single and -double float arithmetic, respectively. \code{short-float} is a -synonym for \code{single-float}, and \code{long-float} is a synonym -for \code{double-float}. The initial value of -\vindexed{read-default-float-format} is \code{single-float}. - -Both \code{single-float} and \code{double-float} are represented with a pointer -descriptor, so float operations can cause number consing. Number consing is -greatly reduced if programs are written to allow the use of non-descriptor -representations (\pxlref{numeric-types}.) - - -\begin{menu} -* IEEE Special Values:: -* Negative Zero:: -* Denormalized Floats:: -* Floating Point Exceptions:: -* Floating Point Rounding Mode:: -* Accessing the Floating Point Modes:: -\end{menu} - -\node IEEE Special Values, Negative Zero, Floats, Floats -\subsubsection{IEEE Special Values} - -\cmucl{} supports the IEEE infinity and NaN special values. These non-numeric -values will only be generated when trapping is disabled for some floating point -exception (\pxlref{float-traps}), so users of the default -configuration need not concern themselves with special values. - -\defconst{short-float-positive-infinity}[extensions] -\defconstx{short-float-negative-infinity}[extensions] -\defconstx{single-float-positive-infinity}[extensions] -\defconstx{single-float-negative-infinity}[extensions] -\defconstx{double-float-positive-infinity}[extensions] -\defconstx{double-float-negative-infinity}[extensions] -\defconstx{long-float-positive-infinity}[extensions] -\defconstx{long-float-negative-infinity}[extensions] -The values of these constants are the IEEE positive and negative infinity -objects for each float format. -\enddefconst - -\defun{float-infinity-p}[extensions]{\args{\var{x}}} -This function returns true if \var{x} is an IEEE float infinity (of either sign.) -\var{x} must be a float. -\enddefun - -\defun{float-nan-p}[extensions]{\args{\var{x}}} -\defunx{float-trapping-nan-p}[extensions]{\args{\var{x}}} -\code{float-nan-p} returns true if \var{x} is an IEEE NaN (Not A Number) object. -\code{float-trapping-nan-p} returns true only if \var{x} is a trapping NaN. With -either function, \var{x} must be a float. -\enddefun - -\node Negative Zero, Denormalized Floats, IEEE Special Values, Floats -\subsubsection{Negative Zero} - -The IEEE float format provides for distinct positive and negative -zeros. To test the sign on zero (or any other float), use the -\clisp{} \findexed{float-sign} function. Negative zero prints as -\code{-0.0f0} or \code{-0.0d0}. - -\node Denormalized Floats, Floating Point Exceptions, Negative Zero, Floats -\subsubsection{Denormalized Floats} - -\cmucl{} supports IEEE denormalized floats. Denormalized floats provide a -mechanism for gradual underflow. The \clisp{} -\findexed{float-precision} function returns the actual precision of a -denormalized float, which will be less than \findexed{float-digits}. Note -that in order to generate (or even print) denormalized floats, -trapping must be disabled for the underflow exception -(\pxlref{float-traps}.) The \clisp{} -\w{\code{least-positive-}\var{format}-\code{float}} constants are -denormalized. - -\defun{float-normalized-p}[extensions]{\args{\var{x}}} -This function returns true if \var{x} is a denormalized float. \var{x} must be a -float. -\enddefun - -\node Floating Point Exceptions, Floating Point Rounding Mode, Denormalized Floats, Floats -\subsubsection{Floating Point Exceptions} -\label{float-traps} - -The IEEE floating point standard defines several exceptions that occur when the -result of a floating point operation is unclear or undesirable. Exceptions can -be ignored, in which case some default action is taken, such as returning a -special value. When trapping is enabled for an exception, a error is signalled -whenever that exception occurs. These are the possible floating point -exceptions: -\begin{description} - -\item[\kwd{underflow}] This exception occurs when the result of an -operation is too small to be represented as a normalized float in its -format. If trapping is enabled, the -\tindexed{floating-point-underflow} condition is signalled. -Otherwise, the operation results in a denormalized float or zero. - -\item[\kwd{overflow}] This exception occurs when the result of an -operation is too large to be represented as a float in its format. -If trapping is enabled, the \tindexed{floating-point-overflow} -exception is signalled. Otherwise, the operation results in the -appropriate infinity. - -\item[\kwd{inexact}] -This exception occurs when the result of a floating point -operation is not exact, i.e. the result was rounded. If trapping is enabled, -the \code{extensions:floating-point-inexact} condition is signalled. Otherwise, -the rounded result is returned. - -\item[\kwd{invalid}] -This exception occurs when the result of an operation is -ill-defined, such as \code{\w{(/ 0.0 0.0)}}. If trapping is enabled, the -\code{extensions:floating-point-invalid} condition is signalled. Otherwise, a -quiet NaN is returned. - -\item[\kwd{divide-by-zero}] -This exception occurs when a float is divided by zero. -If trapping is enabled, the \tindexed{divide-by-zero} condition is signalled. -Otherwise, the appropriate infinity is returned. -\end{description} - -\node Floating Point Rounding Mode, Accessing the Floating Point Modes, Floating Point Exceptions, Floats -\subsubsection{Floating Point Rounding Mode} -\label{float-rounding-modes} - -IEEE floating point specifies four possible rounding modes: -\begin{description} - -\item[\kwd{nearest}] In this mode, the inexact results are rounded to -the nearer of the two possible result values. If the neither -possibility is nearer, then the even alternative is chosen. This -form of rounding is also called "round to even", and is the form of -rounding specified for the \clisp{} \findexed{round} function. - -\item[\kwd{positive-infinity}] This mode rounds inexact results to -the possible value closer to positive infinity. This is analogous to -the \clisp{} \findexed{ceiling} function. - -\item[\kwd{negative-infinity}] This mode rounds inexact results to -the possible value closer to negative infinity. This is analogous to -the \clisp{} \findexed{floor} function. - -\item[\kwd{zero}] -This mode rounds inexact results to the possible value closer to -zero. This is analogous to the \clisp{} \findexed{truncate} function. -\end{description} - -\paragraph{Warning:} - -Although the rounding mode can be changed with -\code{set-floating-point-modes}, use of any value other than the -default (\kwd{nearest}) can cause unusual behavior, since it will -affect rounding done by \llisp{} system code as well as rounding in -user code. In particular, the unary \code{round} function will stop -doing round-to-nearest on floats, and instead do the selected form of -rounding. - -\node Accessing the Floating Point Modes, , Floating Point Rounding Mode, Floats -\subsubsection{Accessing the Floating Point Modes} - -These functions can be used to modify or read the floating point modes: - -\defun{set-floating-point-modes}[extensions]{ - \keys{:traps :rounding-mode} - \morekeys{:fast-mode :accrued-exceptions} - \yetmorekeys{:current-exceptions}} -\defunx{get-floating-point-modes}[extensions]{} -The keyword arguments to \code{set-floating-point-modes} set various modes -controlling how floating point arithmetic is done: -\begin{description} - -\item[\kwd{traps}] -A list of the exception conditions that should cause traps. -Possible exceptions are \kwd{underflow}, \kwd{overflow}, \kwd{inexact}, -\kwd{invalid} and \kwd{divide-by-zero}. Initially all traps except -\kwd{inexact} are enabled. \xlref{float-traps}. - -\item[\kwd{rounding-mode}] The rounding mode to use when the result is -not exact. Possible values are \kwd{nearest}, \kwd{positive-infinity}, -\kwd{negative-infinity} and \kwd{zero}. Initially, the rounding mode is -\kwd{nearest}. See the warning in section \ref{float-rounding-modes} -about use of other rounding modes. - -\item[\kwd{current-exceptions}, \kwd{accrued-exceptions}] -Lists of exception keywords used to set the -exception flags. The \var{current-exceptions} are the exceptions for the -previous operation, so setting it is not very useful. The -\var{accrued-exceptions} are a cumulative record of the exceptions that occurred -since the last time these flags were cleared. Specifying \code{()} will clear any -accrued exceptions. - -\item[\kwd{fast-mode}] -Set the hardware's "fast mode" flag, if any. When set, IEEE -conformance or debuggability may be impaired. Some machines may not have this -feature, in which case the value is always \false. No currently supported -machines have a fast mode. -\end{description} -If a keyword argument is not supplied, then the associated state is not -changed. - -\code{get-floating-point-modes} returns a list representing the state of the -floating point modes. The list is in the same format as the keyword arguments -to \code{set-floating-point-modes}, so \code{apply} could be used with -\code{set-floating-point-modes} to restore the modes in effect at the time of the -call to \code{get-floating-point-modes}. -\enddefun - - -\node Characters, Array Initialization, Floats, Data Types -\subsection{Characters} - -\cmucl{} implements characters according to \i{Common Lisp: the Language II}. -The main difference from the first version is that character bits and -font have been eliminated, and the names of the types have been -changed. \tindexed{base-character} is the new equivalent of the old -\tindexed{string-char}. In this implementation, all characters are base -characters (there are no extended characters.) Character codes range -between \code{0} and \code{255}, using the ASCII encoding. - - -\node Array Initialization, , Characters, Data Types -\subsection{Array Initialization} - -If no \code{:initial-value} is specified, arrays are initialized to zero. - - -\node Default Interrupts for Lisp, Packages, Data Types, Design Choices and Extensions -\section{Default Interrupts for Lisp} - -CMU Common Lisp has several interrupt handlers defined when it starts up, -as follows: -\begin{description} - -\item[\code{SIGINT} (\ctrl{c})] -causes Lisp to enter a break loop. This puts you into the debugger -which allows you to look at the current state of the computation. If you -proceed from the break loop, the computation will proceed from where it was -interrupted. - -\item[\code{SIGQUIT} (\ctrl{\\})] -causes Lisp to do a throw to the top-level. This causes the current -computation to be aborted, and control returned to the top-level -read-eval-print loop. - -\item[\code{SIGTSTP} (\ctrl{z})] -causes Lisp to suspend execution and return to the Unix shell. If -control is returned to Lisp, the computation will proceed from where it was -interrupted. - -\item[\code{SIGILL}, \code{SIGBUS}, \code{SIGSEGV}, and \code{SIGFPE}] -cause Lisp to signal an error. -\end{description} -For keyboard interrupt signals, the standard interrupt character is in -parentheses. Your \file{.login} may set up different interrupt -characters. When a signal is generated, there may be some delay before -it is processed since Lisp cannot be interrupted safely in an arbitrary -place. The computation will continue until a safe point is reached and -then the interrupt will be processed. \xlref{signal-handlers} to define -your own signal handlers. - -\node Packages, The Editor, Default Interrupts for Lisp, Design Choices and Extensions -\section{Packages} - -When CMU Common Lisp is first started up, the default package is the -\code{user} package. The \code{user} package uses the -\code{common-lisp}, \code{extensions}, and -\code{pcl} packages. The symbols exported from these three packages can be -referenced without package qualifiers. This section describes packages which -have exported interfaces that may concern users. The numerous internal -packages which implement parts of the system are not described here. Package -nicknames are in parenthesis after the full name. -\begin{description} -\item[\code{alien}, \code{c-call}] Export the features of the Alien foreign -data structure facility (\pxlref{aliens}.) - -\item[\code{pcl}] -This package contains PCL (Portable CommonLoops), which is a portable -implementation of CLOS (the Common Lisp Object System.) This implements -most (but not all) of the features in the CLOS chapter of \cltl2. - -\item[\code{debug}] -The \code{debug} package contains the command-line oriented -debugger. It exports utility various functions and switches. - -\item[\code{debug-internals}] The \code{debug-internals} package exports the -primitives used to write debuggers. \xlref{debug-internals}. - -\item[\code{extensions (ext)}] -The \code{extensions} packages exports local extensions -to Common Lisp that are documented in this manual. Examples include the -\code{save-lisp} function and time parsing. - -\item[\code{hemlock (ed)}] -The \code{hemlock} package contains all the code to implement -Hemlock commands. The \code{hemlock} package currently exports no symbols. - -\item[\code{hemlock-internals (hi)}] -The \code{hemlock-internals} package contains code -that implements low level primitives and exports those symbols used to -write Hemlock commands. - -\item[\code{keyword}] -The \code{keyword} package contains keywords (e.g., \kwd{start}). -All symbols in the \code{keyword} package are exported and evaluate to -themselves (i.e., the value of the symbol is the symbol itself). - -\item[\code{profile}] The \code{profile} package exports a simple run-time profiling -facility (\pxlref{profiling}). - -\item[\code{common-lisp (cl lisp)}] -The \code{common-lisp} package exports all the symbols defined by \i{Common -Lisp: the Language} and only those symbols. Strictly portable Lisp code -will depend only on the symbols exported from the \code{lisp} package. - -\item[\code{unix}, \code{mach}] -These packages export system call interfaces to generic BSD Unix and Mach -(\pxlref{unix-interface}). - -\item[\code{system (sys)}] -The \code{system} package contains functions and information necessary for system -interfacing. This package is used by the \code{lisp} package and exports several -symbols that are necessary to interface to system code. - -\item[\code{common-lisp-user (user cl-user)}] -The \code{common-lisp-user} package is the default package and is where a user's -code and data is placed unless otherwise specified. This package exports no -symbols. - -\item[\code{xlib}] -The \code{xlib} package contains the Common Lisp X interface (CLX) -to the X11 protocol. This is mostly Lisp code with a couple of functions -that are defined in C to connect to the server. - -\item[\code{wire}] The \code{wire} package exports a remote procedure call facility -(\pxlref{remote}). -\end{description} - - -\node The Editor, Garbage Collection, Packages, Design Choices and Extensions -\section{The Editor} - -The \code{ed} function invokes the Hemlock editor which is described in \i{Hemlock -User's Manual} and \i{Hemlock Command Implementor's Manual}. Most users at CMU -prefer to use Hemlock's slave \Llisp{} mechanism which provides an interactive -buffer for the \code{read-eval-print} loop and editor commands for evaluating and -compiling text from a buffer into the slave \Llisp. Since the editor runs in -the \Llisp, using slaves keeps users from trashing their editor by developing -in the same \Llisp{} with \Hemlock. - - -\node Garbage Collection, Describe, The Editor, Design Choices and Extensions -\section{Garbage Collection} - -CMU Common Lisp uses a stop-and-copy garbage collector that compacts the items -in dynamic space every time it runs. Most users cause the system to garbage -collect (GC) frequently, long before space is exhausted. With 16 or 24 -megabytes of memory, causing GC's more frequently on less garbage allows the -system to GC without much (if any) paging. - -\hide{ -With the default value for the following variable, you can expect a GC to take -about one minute of elapsed time on a 6 megabyte machine running X as well as -Lisp. On machines with 8 megabytes or more of memory a GC should run without -much (if any) paging. GC's run more frequently but tend to take only about 5 -seconds. -} - -The following functions invoke the garbage collector or control whether -automatic garbage collection is in effect: - -\defun{gc}[extensions]{} -This function runs the garbage collector. If \code{ext:*gc-verbose*} is non-\nil, -then it invokes \code{ext:*gc-notify-before*} before GC'ing and -\code{ext:*gc-notify-after*} afterwards. -\enddefun - -\defun{gc-off}[extensions]{} -This function inhibits automatic garbage collection. After calling it, the -system will not GC unless you call \code{ext:gc} or \code{ext:gc-on}. -\enddefun - -\defun{gc-on}[extensions]{} -This function reinstates automatic garbage collection. If the system -would have GC'ed while automatic GC was inhibited, then this will call -\code{ext:gc}. -\enddefun - - -The following variables control the behavior of the garbage collector: - -\defvar{bytes-consed-between-gcs}[extensions] -CMU Common Lisp automatically GC's whenever the amount of memory allocated to -dynamic objects exceeds the value of an internal variable. After each GC, the -system sets this internal variable to the amount of dynamic space in use at -that point plus the value of the variable \code{ext:*bytes-consed-between-gcs*}. -The default value is 2000000. -\enddefvar - -\defvar{gc-verbose}[extensions] -This variable controls whether \code{ext:gc} invokes the functions in -\code{ext:*gc-notify-before*} and \code{ext:*gc-notify-after*}. If -\code{*gc-verbose*} is \nil, \code{ext:gc} foregoes printing any -messages. The default value is \code{T}. -\enddefvar - -\defvar{gc-notify-before}[extensions] -This variable's value is a function that should notify the user that the system -is about to GC. It takes one argument, the amount of dynamic space in use -before the GC measured in bytes. The default value of this variable is a -function that prints a message similar to the following: -\begin{display} -\b{[GC threshold exceeded with 2,107,124 bytes in use. Commencing GC.]} -\end{display} -\enddefvar - -\defvar{gc-notify-after}[extensions] -This variable's value is a function that should notify the user when a GC -finishes. The function must take three arguments, the amount of dynamic spaced -retained by the GC, the amount of dynamic space freed, and the new threshold -which is the minimum amount of space in use before the next GC will occur. All -values are byte quantities. The default value of this variable is a function -that prints a message similar to the following: -\begin{display} -\b{[GC completed with 25,680 bytes retained and 2,096,808 bytes freed.]} -\b{[GC will next occur when at least 2,025,680 bytes are in use.]} -\end{display} -\enddefvar - -Note that a garbage collection will not happen at exactly the new threshold -printed by the default \code{ext:*gc-notify-after*} function. The system -periodically checks whether this threshold has been exceeded, and only then -does a garbage collection. - -\defvar{gc-inhibit-hook}[extensions] -This variable's value is either a function of one argument or \nil. When the -system has triggered an automatic GC, if this variable is a function, then the -system calls the function with the amount of dynamic space currently in use -(measured in bytes). If the function returns \nil, then the GC occurs; -otherwise, the system inhibits automatic GC as if you had called -\code{ext:gc-off}. The writer of this hook is responsible for knowing when -automatic GC has been turned off and for calling or providing a way to call -\code{ext:gc-on}. The default value of this variable is \nil. -\enddefvar - -\defvar{before-gc-hooks}[extensions] -\defvarx{after-gc-hooks}[extensions] -These variables' values are lists of functions to call before or after any GC -occurs. The system provides these purely for side-effect, and the functions -take no arguments. -\enddefvar - - -\node Describe, The Inspector, Garbage Collection, Design Choices and Extensions -\section{Describe} - -In addition to the basic function described below, there are a number of -switches and other things that can be used to control \code{describe}'s -behavior. - -\defun{describe}{ \args{\var{object} \&optional{} \var{stream}}} -The \code{describe} function prints useful information about \var{object} -on \var{stream}, which defaults to \code{*standard-output*}. For any -object, \code{describe} will print out the type. Then it prints other -information based on the type of \var{object}. The types which are -presently handled are: - -\begin{description} - -\item[\tindexed{hash-table}] -\code{describe} prints the number of entries currently -in the hash table and the number of buckets currently allocated. - -\item[\tindexed{function}] -\code{describe} prints a list of the function's name (if any) and -its formal parameters. If the name has function documentation, then it will be -printed. If the function is compiled, then the file where it is defined will -be printed as well. - -\item[\tindexed{fixnum}] -\code{describe} prints whether the integer is prime or not. - -\item[\tindexed{symbol}] -The symbol's value, properties, and documentation are printed. If -the symbol has a function definition, then the function is described. -\end{description} -If there is anything interesting to be said about some component of -the object, describe will invoke itself recursively to describe that -object. The level of recursion is indicated by indenting output. -\enddefun - -\defvar{describe-level}[extensions] -The maximum level of recursive description allowed. Initially two. -\enddefvar - -\defvar{describe-indentation}[extensions] -The number of spaces to indent for each level of recursive -description, initially three. -\enddefvar - -\defvar{describe-print-level}[extensions] -\defvarx{describe-print-length}[extensions] -The values of \code{*print-level*} and \code{*print-length*} during -description. Initially two and five. -\enddefvar - -\node The Inspector, Load, Describe, Design Choices and Extensions -\section{The Inspector} - -\cmucl{} has both a graphical inspector that uses X windows and a simple -terminal-based inspector. - -\defun{inspect}{ \args{\&optional{} \var{object}}} -\code{Inspect} calls the inspector on the optional argument \var{object}. If -\var{object} is unsupplied, \code{inspect} immediately returns \false. -Otherwise, the behavior of inspect depends on whether Lisp is running -under X. When \code{inspect} is eventually exited, it returns some -selected Lisp object. -\enddefun - -\begin{menu} -* The Windowing Inspector:: -* The TTY Inspector:: -\end{menu} - -\node The Windowing Inspector, The TTY Inspector, The Inspector, The Inspector -\subsection{The Windowing Inspector} - -If X is available, \code{inspect} creates an X window and displays -\var{object} in the window. While \code{inspect} is running and the -cursor is in the inspector's X window, mouse clicks and keyboard input -have the following meaning: -\begin{description} - -\item[Left] -When the left mouse button is clicked over a component object, that -object will be inspected in the current inspector window. - -\item[Middle] -When the middle mouse button is clicked over a component object, -\code{inspect} is exited returning the component as the result. All the new -inspector windows are deleted. - -\item[Shift Middle] -When the shift key is depressed and the middle mouse button is -clicked over a component object, \code{inspect} exits and returns the component -as the result. All the inspector windows are left displayed on the screen. - -\item[Right] -When the right mouse button is clicked over a component object, -that object will be inspected in a new inspector window. - -\item[d, D] -When either d or D is typed, the current window is -deleted. If there are no more windows, then \code{inspect} exits and returns the -original \var{object}. - -\item[h, H, ?] -When any of h, H, or ? are typed while in an inspector window, a -new window with help information is displayed. - -\item[m, M] -When either m or M is typed, a component object may be modified. The -cursor changes to an arrow with an M beside it. Clicking any mouse button -while the mouse is over a component will select that component as the -destination for modification. If m was typed, the source object is also -selected by the mouse which is indicated by an S beside the arrow in the -cursor. If M was typed, the source object will be prompted for on the -*query-io* stream. The source object replaces the destination object. -While choosing the destination or source with the mouse, the operation can -be aborted by type q or Q. - -\item[q, Q] -When either q or Q is typed, \code{inspect} exits and -returns the original \var{object}. All new inspector windows are deleted. - -\item[p, P] -When either p or P is typed, \code{inspect} exits and -returns the original \var{object}. All the inspector windows are left on the -screen. - -\item[r, R] -When either r or R is typed, the current inspector display is -recomputed. This is necessary to maintain a consistent display for an -object that may have changed since the display was originally computed. - -\item[u, U] -When either u or U is typed, the object of which the current object -is a component is displayed. This is the inverse operation to clicking the -left mouse button over a component object. If the window is currently -displaying the top level object, nothing changes. -\end{description} -When the cursor is over a component object, the object is highlighted with a -surrounding box. - - -\node The TTY Inspector, , The Windowing Inspector, The Inspector -\subsection{The TTY Inspector} - -If X is unavailable, a terminal inspector is invoked. The TTY inspector -is a crude interface to \code{describe} which allows objects to be -traversed and maintains a history. This inspector prints information -about and object and a numbered list of the components of the object. -The command-line based interface is a normal -\code{read}--\code{eval}--\code{print} loop, but an integer \var{n} -descends into the \var{n}'th component of the current object, and -symbols with these special names are interpreted as commands: -\begin{description} -\item[U] Move back to the enclosing object. As you descend into the -components of an object, a stack of all the objects previously seen is -kept. This command pops you up one level of this stack. - -\item[Q, E] Return the current object from \code{inspect}. - -\item[R] Recompute object display, and print again. Useful if the -object may have changed. - -\item[D] Display again without recomputing. - -\item[H, ?] Show help message. -\end{description} - -\node Load, The Reader, The Inspector, Design Choices and Extensions -\section{Load} - -\defun{load}{\var{filename} \keys{:verbose :print :if-does-not-exist} - \morekeys{:if-source-newer :contents}} -As in standard Common Lisp, this function loads a file containing source or -object code into the running Lisp. Several CMU extensions have been made to -\code{load} to conveniently support a variety of program file organizations. -\var{filename} may be a wildcard pathname such as -\file{*.lisp}, in which case all matching files are loaded. - -If \var{filename} has a \code{pathname-type} (or extension), then that exact -file is loaded. If the file has no extension, then this tells \code{load} to -use a heuristic to load the ``right'' file. The -\code{*load-source-types*} and \code{*load-object-types*} variables below are -used to determine the default source and object file types. If only the source -or the object file exists (but not both), then that file is quietly loaded. -Similarly, if both the source and object file exist, and the object file is -newer than the source file, then the object file is loaded. -The value of the \var{if-source-newer} argument is used to determine what -action to take when both the source and object files exist, but the object file -is out of date: -\begin{description} -\item[:load-object] -The object file is loaded even though the source file is -newer. - -\item[:load-source] -The source file is loaded instead of the older object file. - -\item[:compile] -The source file is compiled and then the new object file is -loaded. - -\item[:query] -The user is asked a yes or no question to determine whether the -source or object file is loaded. -\end{description} -This argument defaults to the value of \code{ext:*load-if-source-newer*} -(initially \code{:load-object}.) - -The \var{contents} argument can be used to override the heuristic (based on the -file extension) that normally determines whether to load the file as a source -file or an object file. If non-null, this argument must be either -\code{:source} or \code{:binary}, which forces loading in source and binary -mode, respectively. You really shouldn't ever need to use this argument. -\enddefun - -\defvar{load-source-types}[extensions] -\defvarx{load-object-types}[extensions] -These variables are lists of possible \code{pathname-type} values for source -and object files to be passed to \code{load}. These variables are only used -when the file passed to \code{load} has no type; in this case, the possible -source and object types are used to default the type in order to determine the -names of the source and object files. -\enddefvar - -\defvar{load-if-source-newer}[extensions] -This variable determines the default value of the \var{if-source-newer} -argument to \code{load}. Its initial value is \code{:load-object}. -\enddefvar - -\node The Reader, Running Programs from Lisp, Load, Design Choices and Extensions -\section{The Reader} - -\defvar{ignore-extra-close-parentheses}[extensions] -If this variable is \true{} (the default), then the reader merely prints a -warning when an extra close parenthesis is detected (instead of signalling an -error.) -\enddefvar - - - -\node Running Programs from Lisp, Saving a Core Image, The Reader, Design Choices and Extensions -\section{Running Programs from Lisp} - -It is possible to run programs from Lisp by using the following function. - -\defun{run-program}[extensions]{ - \args{\var{program} \var{args}} - \keys{:env :wait :pty :input} - \morekeys{:if-input-does-not-exist} - \yetmorekeys{:output ...}} - -\code{Run-program} runs \var{program} in a child process. -\var{Program} should be a pathname or string naming the program. -\var{Args} should be a list of strings which this passes to -\var{program} as normal Unix parameters. For no arguments, specify -\var{args} as \nil. The value returned is either a process structure or -\nil. The process interface follows the description of -\code{run-program}. If \code{run-program} fails to fork the child -process, it returns \nil. - -Except for sharing file descriptors as explained in keyword argument -descriptions, \code{run-program} closes all file descriptors in the -child process before running the program. When you are done using a -process, call \code{process-close} to reclaim system resources. You -only need to do this when you supply \kwd{stream} for one of -\kwd{input}, \kwd{output}, or \kwd{error}, or you supply -\kwd{pty} non-\nil. You can call \code{process-close} regardless of -whether you must to reclaim resources without penalty if you feel safer. - -\code{run-program} accepts the following keyword arguments: -\begin{description} - -\item[\kwd{env}] -This is an a-list mapping keywords and simple-strings. The default -is \code{ext:*environment-list*}. If \kwd{env} is specified, \code{run-program} uses -the value given and does not combine the environment passed to Lisp with the -one specified. - -\item[\kwd{wait}] -If non-\nil{} (the default), wait until the child process terminates. -If \nil, continue running Lisp while the child process runs. - -\item[\kwd{pty}] -This should be one of \true, \nil, or a stream. If specified -non-\nil, the subprocess executes under a Unix \i{PTY}. If specified as a -stream, the system collects all output to this pty and writes it to this -stream. If specified as \true, the \code{process-pty} slot contains a stream from -which you can read the program's output and to which you can write input for -the program. The default is \nil. - -\item[\kwd{input}] -This specifies how the program gets its input. If specified as a -string, it is the name of a file that contains input for the child process. -\code{run-program} opens the file as standard input. If specified as \nil{} (the -default), then standard input is the file \file{/dev/null}. If specified as -\true, the program uses the current standard input. This may cause some -confusion if \kwd{wait} is \nil{} since two processes may use the terminal at the -same time. If specified as \kwd{stream}, then the \code{process-input} slot -contains an output stream. Anything written to this stream goes to the program -as input. \i{:Input} may also be an input stream that already contains all the -input for the process. In this case \code{run-program} reads all the input from -this stream before returning, so this cannot be used to interact with the -process. - -\item[\kwd{if-input-does-not-exist}] -This specifies what to do if the input file does -not exist. The following values are valid: \nil{} (the default) causes -\code{run-program} to return \nil{} without doing anything; \kwd{create} creates the -named file; and \kwd{error} signals an error. - -\item[\kwd{output}] -This specifies what happens with the program's output. If -specified as a pathname, it is the name of a file that contains output the -program writes to its standard output. If specified as \nil{} (the default), all -output goes to \file{/dev/null}. If specified as \true, the program writes to -the Lisp process's standard output. This may cause confusion if \kwd{wait} is -\nil{} since two processes may write to the terminal at the same time. If -specified as \kwd{stream}, then the \code{process-output} slot contains an input -stream from which you can read the program's output. - -\item[\kwd{if-output-exists}] -This specifies what to do if the output file already -exists. The following values are valid: \nil{} causes \code{run-program} to return -\nil{} without doing anything; \kwd{error} (the default) signals an error; -\kwd{supersede} overwrites the current file; and \kwd{append} appends all output -to the file. - -\item[\kwd{error}] -This is similar to \kwd{output}, except the file becomes the -program's standard error. Additionally, \kwd{error} can be \kwd{output} in which -case the program's error output is routed to the same place specified for -\kwd{output}. If specified as \kwd{stream}, the \code{process-error} contains a -stream similar to the \code{process-output} slot when specifying the \kwd{output} -argument. - -\item[\kwd{if-error-exists}] -This specifies what to do if the error output file -already exists. It accepts the same values as \kwd{if-output-exists}. - -\item[\kwd{status-hook}] -This specifies a function to call whenever the process -changes status. This is especially useful when specifying \kwd{wait} as \nil. -The function takes the process as a required argument. - -\item[\kwd{before-execve}] -This specifies a function to run in the child process -before it becomes the program to run. This is useful for actions such as -authenticating the child process without modifying the parent Lisp process. -\end{description} - -\enddefun - - -\begin{menu} -* Process Accessors:: -\end{menu} - -\node Process Accessors, , Running Programs from Lisp, Running Programs from Lisp -\subsection{Process Accessors} - -The following functions interface the process returned by \code{run-program}: - -\defun{process-p}[extensions]{\args{\var{thing}}} -This function returns \true{} if \var{thing} is a process. Otherwise it returns -\nil{} -\enddefun - -\defun{process-pid}[extensions]{\args{\var{process}}} -This function returns the process ID, an integer, for the \var{process}. -\enddefun - -\defun{process-status}[extensions]{\args{\var{process}}} -This function returns the current status of \var{process}, which is one of -\code{:running}, \code{:stopped}, \code{:exited}, or \code{:signaled}. -\enddefun - -\defun{process-exit-code}[extensions]{\args{\var{process}}} -This function returns either the exit code for \var{process}, if it is -\code{:exited}, or the termination signal \var{process} if it is \code{:signaled}. The -result is undefined for processes that are still alive. -\enddefun - -\defun{process-core-dumped}[extensions]{\args{\var{process}}} -This function returns \true{} if someone used a Unix signal to terminate the -\var{process} and caused it to dump a Unix core image. -\enddefun - -\defun{process-pty}[extensions]{\args{\var{process}}} -This function returns either the two-way stream connected to -\var{process}'s Unix -\i{PTY} connection or \nil{} if there is none. -\enddefun - -\defun{process-input}[extensions]{\args{\var{process}}} -\defunx{process-output}[extensions]{\args{\var{process}}} -\defunx{process-error}[extensions]{\args{\var{process}}} -If the corresponding stream was created, these functions return the -input, output or error file descriptor. \nil{} is returned if there is -no stream. -\enddefun - -\defun{process-status-hook}[extensions]{\args{\var{process}}} -This function returns the current function to call whenever \var{process}'s -status changes. This function takes the \var{process} as a required argument. -\code{process-status-hook} is \code{setf}'able. -\enddefun - -\defun{process-plist}[extensions]{\args{\var{process}}} -This function returns annotations supplied by users, and it is \code{setf}'able. -This is available solely for users to associate information with \var{process} -without having to build a-lists or hash tables of process structures. -\enddefun - -\defun{process-wait}[extensions]{ - \args{\var{process} \&optional{} \var{check-for-stopped}}} - This function waits for \var{process} to finish. If \var{check-for-stopped} is -non-\nil, this also returns when \var{process} stops. -\enddefun - -\defun{process-kill}[extensions]{ - \args{\i{process signal} \&optional{} \var{whom}}} - This function sends the Unix \var{signal} to \var{process}. \var{Signal} should be -the number of the signal or a keyword with the Unix name (for example, -\kwd{sigsegv}). \var{Whom} should be one of the following: -\begin{description} - -\item[\kwd{pid}] -This is the default, and it indicates sending the signal to -\var{process} only. - -\item[\kwd{process-group}] -This indicates sending the signal to \var{process}'s group. - -\item[\kwd{pty-process-group}] -This indicates sending the signal to the process group -currently in the foreground on the Unix \i{PTY} connected to \var{process}. This -last option is useful if the running program is a shell, and you wish to signal -the program running under the shell, not the shell itself. If \code{process-pty} -of \var{process} is \nil, using this option is an error. -\end{description} -\enddefun - -\defun{process-alive-p}[extensions]{\args{\var{process}}} -This function returns \true{} if \var{process}'s status is either \code{:running} or -\code{:stopped}. -\enddefun - -\defun{process-close}[extensions]{\args{\var{process}}} -This function closes all the streams associated with \var{process}. When you are -done using a process, call this to reclaim system resources. -\enddefun - - -\node Saving a Core Image, Search Lists, Running Programs from Lisp, Design Choices and Extensions -\section{Saving a Core Image} - -A mechanism has been provided to save a running Lisp core image and to -later restore it. This is convenient if you don't want to load several files -into a Lisp when you first start it up. The main problem is the large -size of each saved Lisp image, typically at least 20 megabytes. - -\defun{save-lisp}[extensions]{ - \args{\var{file}} - \keys{:purify :root-structures :init-function} - \morekeys{:load-init-file :print-herald} - \yetmorekeys{:process-command-line}} -The \code{save-lisp} function saves the state of the currently running Lisp -core image in \var{file}. The keyword arguments have the following meaning: -\begin{description} - -\item[\kwd{purify}] -If non-NIL (the default), the core image is purified before it is -saved. This means moving accessible Lisp objects from dynamic space into -read-only and static space. This reduces the amount of work the garbage -collector must do when the resulting core image is being run. Also, if -more than one Lisp is running on the same machine, this maximizes the -amount of memory that can be shared between the two processes. Objects in -read-only and static space can never be reclaimed, even if all pointers to -them are dropped. - -\item[\kwd{root-structures}] -This should be a list of the main entry points for -the resulting core image. The purification process tries to localize -symbols, functions, etc., in the core image so that paging performance -is improved. The default value is NIL which means that Lisp objects will -still be localized but probably not as optimally as they could be. This -argument has no meaning if \kwd{purify} is NIL. - -\item[\kwd{init-function}] -This is a function which is called when the saved core is -resumed. The default function simply aborts to the top-level read-eval-print -loop. If the function returns, it will be the value of \code{save-lisp}. - -\item[\kwd{load-init-file}] -If non-NIL, then load an init file; either the one -specified on the command line or \w{"\file{init.}\var{fasl-type}"}, or, if -\w{"\file{init.}\var{fasl-type}"} does not exist, \code{init.lisp} from the user's -home directory. If the init file is found, it is loaded into the resumed core -file before the read-eval-print loop is entered. - -\item[\kwd{print-herald}] -If non-NIL, then print out the standard Lisp herald when -starting. - -\item[\kwd{process-command-line}] -If non-NIL, processes the command line switches -and performs the appropriate actions. -\end{description} -\enddefun - -To resume a saved file, type: -\begin{example} -lisp -core file -\end{example} - - -\node Search Lists, Time Parsing and Formatting, Saving a Core Image, Design Choices and Extensions -\section{Search Lists} - -Search lists are an extension to Common Lisp pathnames. Search lists are used -for two purposes: -\begin{itemize} -\item They provide a convenient shorthand for commonly used directory names, -and - -\item They allow the abstract (directory structure independent) specification -of file locations in program pathname constants (similar to logical pathnames.) -\end{itemize} -Each search list has an associated list of directories (represented as -pathnames with no name or type component.) The namestring for any relative -pathname may be prefixed with ``\var{slist}\code{:}'', indicating that the -pathname is relative to the search list \var{slist} (instead of to the current -working directory.) Once qualified with a search list, the pathname is no -longer considered to be relative. - -When a search list qualified pathname is passed to a file-system operation such -as \code{open}, \code{load} or \code{truename}, each directory in the search -list is successively used as the root of the pathname until the file is -located. When a file is written to a search list directory, the file is always -written to the first directory in the list. - -\defun{search-list}[extensions]{\var{name}} -This function returns the list of directories associated with the search list -\var{name}. If \var{name} is not a defined search list, then an error is -signalled. When set with \code{setf}, the list of directories is changed to -the new value. If the new value is just a namestring or pathname, then it is -interpreted as a one-element list. Note that (unlike Unix pathnames), search -list names are case-insensitive. -\enddefun - -\defun{search-list-defined-p}[extensions]{\var{name}} -\defunx{clear-search-list}[extensions]{\var{name}} -\code{search-list-defined-p} returns \true{} if \var{name} is a defined search -list name, \false{} otherwise. \code{clear-search-list} make the search list -\var{name} undefined. -\enddefun - -\defmac{enumerate-search-list}[extensions]{ - (\var{var} \var{pathname} \mopt{result}) - \mstar{form}} - -This macro provides an interface to search list resolution. The body -\var{forms} are executed with \var{var} bound to each successive possible -expansion for \var{name}. If \var{name} does not contain a search-list, then -the body is executed exactly once. Everything is wrapped in a block named -\nil, so \code{return} can be used to terminate early. The \var{result} form -(default \nil) is evaluated to determine the result of the iteration. -\enddefmac - -\begin{menu} -* Search List Example:: -\end{menu} - -\node Search List Example, , Search Lists, Search Lists -\subsection{Search List Example} - -The search list \code{code:} can be defined as follows: -\begin{example} -(setf (ext:search-list "code:") '("/usr/lisp/code/")) -\end{example} -It is now possible to use \code{code:} as an abbreviation for the directory -\file{/usr/lisp/code/} in all file operations. For example, you can now specify -\code{code:eval.lisp} to refer to the file \file{/usr/lisp/code/eval.lisp}. - -To obtain the value of a search-list name, use the function search-list -as follows: -\begin{example} -(ext:search-list \var{name}) -\end{example} -Where \var{name} is the name of a search list as described above. For example, -calling \code{ext:search-list} on \code{code:} as follows: -\begin{example} -(ext:search-list "code:") -\end{example} -returns the list \code{("/usr/lisp/code/")}. - - -\node Time Parsing and Formatting, Lisp Library, Search Lists, Design Choices and Extensions -\section{Time Parsing and Formatting} - -\cindex{time parsing} \cindex{time formatting} -Functions are provided to allow parsing strings containing time information -and printing time in various formats are available. - -\defun{parse-time}[extensions]{ - \args{\var{time-string}} - \keys{:error-on-mismatch :default-seconds} - \morekeys{:default-minutes :default-hours} - \yetmorekeys{:default-day ...}} -\code{parse-time} accepts a string containing a time (e.g., -\w{"\code{Jan 12, 1952}"}) -and returns the universal time if it is successful. If it is unsuccessful -and the keyword argument \kwd{error-on-mismatch} is non-\FALSE, it signals an -error. Otherwise it returns \FALSE. The other keyword arguments have the -following meaning: -\begin{description} - -\item[\kwd{default-seconds}] -specifies the default value for the seconds value if -one is not provided by \var{time-string}. The default value is 0. - -\item[\kwd{default-minutes}] -specifies the default value for the minutes value if -one is not provided by \var{time-string}. The default value is 0. - -\item[\kwd{default-hours}] -specifies the default value for the hours value if -one is not provided by \var{time-string}. The default value is 0. - -\item[\kwd{default-day}] -specifies the default value for the day value if one is -not provided by \var{time-string}. The default value is the current day. - -\item[\kwd{default-month}] -specifies the default value for the month value if one -is not provided by \var{time-string}. The default value is the current -month. - -\item[\kwd{default-year}] -specifies the default value for the year value if one is -not provided by \var{time-string}. The default value is the current year. - -\item[\kwd{default-zone}] -specifies the default value for the time zone value if -one is not provided by \var{time-string}. The default value is the current -time zone. - -\item[\kwd{default-weekday}] -specifies the default value for the day of the week -if one is not provided by \var{time-string}. The default value is the -current day of the week. -\end{description} -Any of the above keywords can be given the value \kwd{current} which means -to use the current value as determined by a call to the operating system. -\enddefun - -\defun{format-universal-time}[extensions]{ - \args{\i{dest universal-time}} - \keys{:timezone} - \morekeys{:style :date-first} - \yetmorekeys{:print-seconds ...}} - -\defunx{format-decoded-time}[extensions]{ - \args{\i{dest seconds minutes hours day month year} \&key{} ...}} - -\code{format-universal-time} formats the time specified by \var{universal-time}. -\code{format-decoded-time} formats the time specified by \var{seconds}, -\var{minutes}, \var{hours}, \var{day}, \var{month}, and \var{year}. -\var{Dest} is any destination accepted by the \code{format} function. -The keyword arguments have the following meaning: -\begin{description} - -\item[\kwd{timezone}] -is an integer specifying the hours west of Greenwich. -\i{:Timezone} defaults to the current time zone. - -\item[\kwd{style}] -specifies the style to use in formatting the time. The legal -values are: -\begin{description} - -\item[\kwd{short}] -specifies to use a numeric date. - -\item[\kwd{long}] -specifies to format months and weekdays as words instead of -numbers. - -\item[\kwd{abbreviated}] -is similar to long except the words are abbreviated. - -\item[\kwd{government}] -is similar to abbreviated, except the date is of the form -"day month year" instead of "month day, year". -\end{description} - -\item[\kwd{date-first}] -if non-\false{} (default) will place the date first. -Otherwise, the time is placed first. - -\item[\kwd{print-seconds}] -if non-\false{} (default) will format the seconds as part of -the time. Otherwise, the seconds will be omitted. - -\item[\kwd{print-meridian}] -if non-\false{} (default) will format "AM" or "PM" as part of -the time. Otherwise, the "AM" or "PM" will be omitted. - -\item[\kwd{print-timezone}] -if non-\false{} (default) will format the time zone as part of -the time. Otherwise, the time zone will be omitted. - -\item[\kwd{print-seconds}] -if non-\false{} (default) will format the seconds as part of -the time. Otherwise, the seconds will be omitted. - -\item[\kwd{print-weekday}] -if non-\false{} (default) will format the weekday as part of -date. Otherwise, the weekday will be omitted. -\end{description} -\enddefun - - -\node Lisp Library, , Time Parsing and Formatting, Design Choices and Extensions -\section{Lisp Library} -\label{lisp-lib} - -The CMU Common Lisp project maintains a collection of useful or interesting -programs written by users of our system. The library is in -\file{lib/contrib/}. Two files there that users should read are: -\begin{description} - -\item[CATALOG.TXT] -This file contains a page for each entry in the library. It -contains information such as the author, portability or dependency issues, how -to load the entry, etc. - -\item[READ-ME.TXT] -This file describes the library's organization and all the -possible pieces of information an entry's catalog description could contain. -\end{description} - -Hemlock has a command \F{Library Entry} that displays a list of the current -library entries in an editor buffer. There are mode specific commands that -display catalog descriptions and load entries. This is a simple and convenient -way to browse the library. - - -\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/debug.ms} - - - -\node The Debugger, The Compiler, Design Choices and Extensions, Top -\chapter{The Debugger} \hide{-*- Dictionary: cmu-user -*-} -\begin{center} -\b{By Robert MacLachlan} -\end{center} -\cindex{debugger} -\label{debugger} - -\begin{menu} -* Debugger Introduction:: -* The Command Loop:: -* Stack Frames:: -* Variable Access:: -* Source Location Printing:: -* Compiler Policy Control:: -* Exiting Commands:: -* Information Commands:: -* Breakpoint Commands:: -* Function Tracing:: -* Specials:: -\end{menu} - -\node Debugger Introduction, The Command Loop, The Debugger, The Debugger -\section{Debugger Introduction} - -The \cmucl{} debugger is unique in its level of support for source-level -debugging of compiled code. Although some other debuggers allow access of -variables by name, this seems to be the first \llisp{} debugger that: -\begin{itemize} - -\item -Tells you when a variable doesn't have a value because it hasn't been -initialized yet or has already been deallocated, or - -\item -Can display the precise source location corresponding to a code -location in the debugged program. -\end{itemize} -These features allow the debugging of compiled code to be made almost -indistinguishable from interpreted code debugging. - -The debugger is an interactive command loop that allows a user to examine -the function call stack. The debugger is invoked when: -\begin{itemize} - -\item -A \tindexed{serious-condition} is signalled, and it is not handled, or - -\item -\findexed{error} is called, and the condition it signals is not handled, or - -\item -The debugger is explicitly invoked with the \clisp{} \findexed{break} -or \findexed{debug} functions. -\end{itemize} -When you enter the debugger, it looks something like this: -\begin{example} -Error in function CAR. -Wrong type argument, 3, should have been of type LIST. - -Restarts: - 0: Return to Top-Level. - -Debug (type H for help) - -(CAR 3) -0] -\end{example} -The first group of lines describe what the error was that put us in the -debugger. In this case \code{car} was called on \code{3}. After \code{Restarts:} -is a list of all the ways that we can restart execution after this error. In -this case, the only option is to return to top-level. After printing its -banner, the debugger prints the current frame and the debugger prompt. - - -\node The Command Loop, Stack Frames, Debugger Introduction, The Debugger -\section{The Command Loop} - -The debugger is an interactive read-eval-print loop much like the normal -top-level, but some symbols are interpreted as debugger commands instead -of being evaluated. A debugger command starts with the symbol name of -the command, possibly followed by some arguments on the same line. Some -commands prompt for additional input. Debugger commands can be -abbreviated by any unambiguous prefix: \code{help} can be typed as -\code{h}, \code{he}, etc. For convenience, some commands have -ambiguous one-letter abbreviations: \code{f} for \code{frame}. - -The package is not significant in debugger commands; any symbol with the -name of a debugger command will work. If you want to show the value of -a variable that happens also to be the name of a debugger command, you -can use the \code{list-locals} command or the \code{debug:var} -function, or you can wrap the variable in a \code{progn} to hide it from -the command loop. - -The debugger prompt is "\var{frame}\code{]}", where \var{frame} is the number -of the current frame. Frames are numbered starting from zero at the top (most -recent call), increasing down to the bottom. The current frame is the frame -that commands refer to. The current frame also provides the lexical -environment for evaluation of non-command forms. - -\cpsubindex{evaluation}{debugger} The debugger evaluates forms in the lexical -environment of the functions being debugged. The debugger can only -access variables. You can't \code{go} or \code{return-from} into a -function, and you can't call local functions. Special variable -references are evaluated with their current value (the innermost binding -around the debugger invocation) \dash{} you don't get the value that the -special had in the current frame. \xlref{debug-vars} for more -information on debugger variable access. - - -\node Stack Frames, Variable Access, The Command Loop, The Debugger -\section{Stack Frames} -\cindex{stack frames} \cpsubindex{frames}{stack} - -A stack frame is the run-time representation of a call to a function; -the frame stores the state that a function needs to remember what it is -doing. Frames have: -\begin{itemize} - -\item -Variables (\pxlref{debug-vars}), which are the values being operated -on, and - -\item -Arguments to the call (which are really just particularly interesting -variables), and - -\item -A current location (\pxlref{source-locations}), which is the place in -the program where the function was running when it stopped to call another -function, or because of an interrupt or error. -\end{itemize} - - - -\begin{menu} -* Stack Motion:: -* How Arguments are Printed:: -* Function Names:: -* Funny Frames:: -* Debug Tail Recursion:: -* Unknown Locations and Interrupts:: -\end{menu} - -\node Stack Motion, How Arguments are Printed, Stack Frames, Stack Frames -\subsection{Stack Motion} - -These commands move to a new stack frame and print the name of the function -and the values of its arguments in the style of a Lisp function call: -\begin{description} - -\item[\code{up}] -Move up to the next higher frame. More recent function calls are considered -to be higher on the stack. - -\item[\code{down}] -Move down to the next lower frame. - -\item[\code{top}] -Move to the highest frame. - -\item[\code{bottom}] -Move to the lowest frame. - -\item[\code{frame} [\var{n}]] -Move to the frame with the specified number. Prompts for the number if not -supplied. - -\begin{ignore} -\key{S} [\var{function-name} [\var{n}]] - -\item -Search down the stack for function. Prompts for the function name if not -supplied. Searches an optional number of times, but doesn't prompt for -this number; enter it following the function. - -\item[\key{R} [\var{function-name} [\var{n}]]] -Search up the stack for function. Prompts for the function name if not -supplied. Searches an optional number of times, but doesn't prompt for -this number; enter it following the function. -\end{ignore} -\end{description} - -\node How Arguments are Printed, Function Names, Stack Motion, Stack Frames -\subsection{How Arguments are Printed} - -A frame is printed to look like a function call, but with the actual argument -values in the argument positions. So the frame for this call in the source: -\begin{lisp} -(myfun (+ 3 4) 'a) -\end{lisp} -would look like this: -\begin{example} -(MYFUN 7 A) -\end{example} -All keyword and optional arguments are displayed with their actual -values; if the corresponding argument was not supplied, the value will -be the default. So this call: -\begin{lisp} -(subseq "foo" 1) -\end{lisp} -would look like this: -\begin{example} -(SUBSEQ "foo" 1 3) -\end{example} -And this call: -\begin{lisp} -(string-upcase "test case") -\end{lisp} -would look like this: -\begin{example} -(STRING-UPCASE "test case" :START 0 :END NIL) -\end{example} - -The arguments to a function call are displayed by accessing the argument -variables. Although those variables are initialized to the actual argument -values, they can be set inside the function; in this case the new value will be -displayed. - -\code{&rest} arguments are handled somewhat differently. The value of -the rest argument variable is displayed as the spread-out arguments to -the call, so: -\begin{lisp} -(format t "~A is a ~A." "This" 'test) -\end{lisp} -would look like this: -\begin{example} -(FORMAT T "~A is a ~A." "This" 'TEST) -\end{example} -Rest arguments cause an exception to the normal display of keyword -arguments in functions that have both \code{&rest} and \code{&key} -arguments. In this case, the keyword argument variables are not -displayed at all; the rest arg is displayed instead. So for these -functions, only the keywords actually supplied will be shown, and the -values displayed will be the argument values, not values of the -(possibly modified) variables. - -If the variable for an argument is never referenced by the function, it will be -deleted. The variable value is then unavailable, so the debugger prints -\code{<unused-arg>} instead of the value. Similarly, if for any of a number of -reasons (described in more detail in section \ref{debug-vars}) the value of the -variable is unavailable or not known to be available, then -\code{<unavailable-arg>} will be printed instead of the argument value. - -Printing of argument values is controlled by \code{*debug-print-level*} and -\varref{debug-print-length}. - - -\node Function Names, Funny Frames, How Arguments are Printed, Stack Frames -\subsection{Function Names} -\cpsubindex{function}{names} -\cpsubindex{names}{function} - -If a function is defined by \code{defun}, \code{labels}, or \code{flet}, then the -debugger will print the actual function name after the open parenthesis, like: -\begin{example} -(STRING-UPCASE "test case" :START 0 :END NIL) -((SETF AREF) #\back a "for" 1) -\end{example} -Otherwise, the function name is a string, and will be printed in quotes: -\begin{example} -("DEFUN MYFUN" BAR) -("DEFMACRO DO" (DO ((I 0 (1+ I))) ((= I 13))) NIL) -("SETQ *GC-NOTIFY-BEFORE*") -\end{example} -This string name is derived from the \w{\code{def}\var{mumble}} form that encloses -or expanded into the lambda, or the outermost enclosing form if there is no -\w{\code{def}\var{mumble}}. - - -\node Funny Frames, Debug Tail Recursion, Function Names, Stack Frames -\subsection{Funny Frames} -\cindex{external entry points} -\cpsubindex{entry points}{external} -\cpsubindex{block compilation}{debugger implications} -\cpsubindex{external}{stack frame kind} -\cpsubindex{optional}{stack frame kind} -\cpsubindex{cleanup}{stack frame kind} - -Sometimes the evaluator introduces new functions that are used to implement a -user function, but are not directly specified in the source. The main place -this is done is for checking argument type and syntax. Usually these functions -do their thing and then go away, and thus are not seen on the stack in the -debugger. But when you get some sort of error during lambda-list processing, -you end up in the debugger on one of these funny frames. - -These funny frames are flagged by printing "\code{[}\var{keyword}\code{]}" after the -parentheses. For example, this call: -\begin{lisp} -(car 'a 'b) -\end{lisp} -will look like this: -\begin{example} -(CAR 2 A) [:EXTERNAL] -\end{example} -And this call: -\begin{lisp} -(string-upcase "test case" :end) -\end{lisp} -would look like this: -\begin{example} -("DEFUN STRING-UPCASE" "test case" 335544424 1) [:OPTIONAL] -\end{example} - -As you can see, these frames have only a vague resemblance to the original -call. Fortunately, the error message displayed when you enter the debugger -will usually tell you what problem is (in these cases, too many arguments -and odd keyword arguments.) Also, if you go down the stack to the frame for -the calling function, you can display the original source (\pxlref{source-locations}.) - -With recursive or block compiled functions (\pxlref{block-compilation}), an \code{:EXTERNAL} frame may appear before the frame -representing the first call to the recursive function or entry to the compiled -block. This is a consequence of the way the compiler does block compilation: -there is nothing odd with your program. You will also see \code{:CLEANUP} frames -during the execution of \code{unwind-protect} cleanup code. Note that inline -expansion and open-coding affect what frames are present in the debugger, see -sections \ref{debugger-policy} and \ref{open-coding}. - - -\node Debug Tail Recursion, Unknown Locations and Interrupts, Funny Frames, Stack Frames -\subsection{Debug Tail Recursion} -\label{debug-tail-recursion} -\cindex{tail recursion} -\cpsubindex{recursion}{tail} - -Both the compiler and the interpreter are "properly tail recursive." If a -function call is in a tail-recursive position, the stack frame will be -deallocated \i{at the time of the call}, rather than after the call returns. -Consider this backtrace: -\begin{example} -(BAR ...) -(FOO ...) -\end{example} -Because of tail recursion, it is not necessarily the case that -\code{FOO} directly called \code{BAR}. It may be that \code{FOO} called -some other function \code{FOO2} which then called \code{BAR} -tail-recursively, as in this example: -\begin{example} -(defun foo () - ... - (foo2 ...) - ...) - -(defun foo2 (...) - ... - (bar ...)) - -(defun bar (...) - ...) -\end{example} - -Usually the elimination of tail-recursive frames makes debugging more -pleasant, since theses frames are mostly uninformative. If there is any -doubt about how one function called another, it can usually be -eliminated by finding the source location in the calling frame (section -\ref{source-locations}.) - -For a more thorough discussion of tail recursion, \pxlref{tail-recursion}. - - -\node Unknown Locations and Interrupts, , Debug Tail Recursion, Stack Frames -\subsection{Unknown Locations and Interrupts} -\label{unknown-locations} -\cindex{unknown code locations} -\cpsubindex{locations}{unknown} -\cindex{interrupts} -\cpsubindex{errors}{run-time} - -The debugger operates using special debugging information attached to -the compiled code. This debug information tells the debugger what it -needs to know about the locations in the code where the debugger can be -invoked. If the debugger somehow encounters a location not described in -the debug information, then it is said to be \var{unknown}. If the code -location for a frame is unknown, then some variables may be -inaccessible, and the source location cannot be precisely displayed. - -There are three reasons why a code location could be unknown: -\begin{itemize} - -\item -There is inadequate debug information due to the value of the \code{debug} -optimization quality. \xlref{debugger-policy}. - -\item -The debugger was entered because of an interrupt such as \code{^C}. - -\item -A hardware error such as "\code{bus error}" occurred in code that was -compiled unsafely due to the value of the \code{safety} optimization -quality. \xlref{optimize-declaration}. -\end{itemize} - -In the last two cases, the values of argument variables are accessible, -but may be incorrect. \xlref{debug-var-validity} for more details on -when variable values are accessible. - -It is possible for an interrupt to happen when a function call or return is in -progress. The debugger may then flame out with some obscure error or insist -that the bottom of the stack has been reached, when the real problem is that -the current stack frame can't be located. If this happens, return from the -interrupt and try again. - -When running interpreted code, all locations should be known. However, -an interrupt might catch some subfunction of the interpreter at an -unknown location. In this case, you should be able to go up the stack a -frame or two and reach an interpreted frame which can be debugged. - - -\node Variable Access, Source Location Printing, Stack Frames, The Debugger -\section{Variable Access} -\label{debug-vars} -\cpsubindex{variables}{debugger access} -\cindex{debug variables} - -There are three ways to access the current frame's local variables in the -debugger. The simplest is to type the variable's name into the debugger's -read-eval-print loop. The debugger will evaluate the variable reference as -though it had appeared inside that frame. - -The debugger doesn't really understand lexical scoping; it has just one -namespace for all the variables in a function. If a symbol is the name of -multiple variables in the same function, then the reference appears ambiguous, -even though lexical scoping specifies which value is visible at any given -source location. If the scopes of the two variables are not nested, then the -debugger can resolve the ambiguity by observing that only one variable is -accessible. - -When there are ambiguous variables, the evaluator assigns each one a -small integer identifier. The \code{debug:var} function and the -\code{list-locals} command use this identifier to distinguish between -ambiguous variables: -\begin{description} - -\item[\code{list-locals} \mopt{\var{prefix}}]\hfill\\ -This command prints the name and value of all variables in the current -frame whose name has the specified \var{prefix}. \var{prefix} may be a -string or a symbol. If no \var{prefix} is given, then all available -variables are printed. If a variable has a potentially ambiguous name, -then the name is printed with a "\code{#}\var{identifier}" suffix, where -\var{identifier} is the small integer used to make the name unique. -\end{description} - -\defun{var}[debug]{\args{\var{name} \&optional{} \var{identifier}}} -This function returns the value of the variable in the current frame with the -specified \var{name}. If supplied, \var{identifier} determines which value to -return when there are ambiguous variables. - -When \var{name} is a symbol, it is interpreted as the symbol name of the -variable, i.e. the package is significant. If \var{name} is an -uninterned symbol (gensym), then return the value of the uninterned -variable with the same name. If \var{name} is a string, -\code{debug:var} interprets it as the prefix of a variable name, and -must unambiguously complete to the name of a valid variable. - -This function is useful mainly for accessing the value of uninterned or -ambiguous variables, since most variables can be evaluated directly. -\enddefun - - -\begin{menu} -* Variable Value Availability:: -* Note On Lexical Variable Access:: -\end{menu} - -\node Variable Value Availability, Note On Lexical Variable Access, Variable Access, Variable Access -\subsection{Variable Value Availability} -\label{debug-var-validity} -\cindex{availability of debug variables} -\cindex{validity of debug variables} -\cindex{debug optimization quality} - -The value of a variable may be unavailable to the debugger in portions of the -program where \clisp{} says that the variable is defined. If a variable value is -not available, the debugger will not let you read or write that variable. With -one exception, the debugger will never display an incorrect value for a -variable. Rather than displaying incorrect values, the debugger tells you the -value is unavailable. - -The one exception is this: if you interrupt (e.g., with \code{^C}) or if there is -an unexpected hardware error such as "\code{bus error}" (which should only happen -in unsafe code), then the values displayed for arguments to the interrupted -frame might be incorrect.\footnote{Since the location of an interrupt or hardware -error will always be an unknown location (\pxlref{unknown-locations}), -non-argument variable values will never be available in the interrupted frame.} -This exception applies only to the interrupted frame: any frame farther down -the stack will be fine. - -The value of a variable may be unavailable for these reasons: -\begin{itemize} - -\item -The value of the \code{debug} optimization quality may have omitted debug -information needed to determine whether the variable is available. -Unless a variable is an argument, its value will only be available when -\code{debug} is at least \code{2}. - -\item -The compiler did lifetime analysis and determined that the value was no longer -needed, even though its scope had not been exited. Lifetime analysis is -inhibited when the \code{debug} optimization quality is \code{3}. - -\item -The variable's name is an uninterned symbol (gensym). To save space, the -compiler only dumps debug information about uninterned variables when the -\code{debug} optimization quality is \code{3}. - -\item -The frame's location is unknown (\pxlref{unknown-locations}) because -the debugger was entered due to an interrupt or unexpected hardware error. -Under these conditions the values of arguments will be available, but might be -incorrect. This is the exception above. - -\item -The variable was optimized out of existence. Variables with no reads are -always optimized away, even in the interpreter. The degree to which the -compiler deletes variables will depend on the value of the \code{compile-speed} -optimization quality, but most source-level optimizations are done under all -compilation policies. -\end{itemize} - - -Since it is especially useful to be able to get the arguments to a function, -argument variables are treated specially when the \code{speed} optimization -quality is less than \code{3} and the \code{debug} quality is at least \code{1}. -With this compilation policy, the values of argument variables are almost -always available everywhere in the function, even at unknown locations. For -non-argument variables, \code{debug} must be at least \code{2} for values to be -available, and even then, values are only available at known locations. - - -\node Note On Lexical Variable Access, , Variable Value Availability, Variable Access -\subsection{Note On Lexical Variable Access} -\cpsubindex{evaluation}{debugger} - -When the debugger command loop establishes variable bindings for available -variables, these variable bindings have lexical scope and dynamic -extent.\footnote{The variable bindings are actually created using the \clisp{} -\code{symbol-macro-let} special form.} You can close over them, but such closures -can't be used as upward funargs. - -You can also set local variables using \code{setq}, but if the variable was closed -over in the original source and never set, then setting the variable in the -debugger may not change the value in all the functions the variable is defined -in. Another risk of setting variables is that you may assign a value of a type -that the compiler proved the variable could never take on. This may result in -bad things happening. - - -\node Source Location Printing, Compiler Policy Control, Variable Access, The Debugger -\section{Source Location Printing} -\label{source-locations} -\cpsubindex{source location printing}{debugger} - -One of CMU \clisp{}'s unique capabilities is source level debugging of compiled -code. These commands display the source location for the current frame: -\begin{description} - -\item[\code{source} \mopt{\var{context}}]\hfill\\ -This command displays the file that the current frame's function was defined -from (if it was defined from a file), and then the source form responsible for -generating the code that the current frame was executing. If \var{context} is -specified, then it is an integer specifying the number of enclosing levels of -list structure to print. - -\item[\code{vsource} \mopt{\var{context}}]\hfill\\ -This command is identical to \code{source}, except that it uses the -global values of \code{*print-level*} and \code{*print-length*} instead -of the debugger printing control variables \code{*debug-print-level*} -and \code{*debug-print-length*}. -\end{description} - -The source form for a location in the code is the innermost list present -in the original source that encloses the form responsible for generating -that code. If the actual source form is not a list, then some enclosing -list will be printed. For example, if the source form was a reference -to the variable \code{*some-random-special*}, then the innermost -enclosing evaluated form will be printed. Here are some possible -enclosing forms: -\begin{example} -(let ((a *some-random-special*)) - ...) - -(+ *some-random-special* ...) -\end{example} - -If the code at a location was generated from the expansion of a macro or a -source-level compiler optimization, then the form in the original source that -expanded into that code will be printed. Suppose the file -\file{/usr/me/mystuff.lisp} looked like this: -\begin{example} -(defmacro mymac () - '(myfun)) - -(defun foo () - (mymac) - ...) -\end{example} -If \code{foo} has called \code{myfun}, and is waiting for it to return, then the -\code{source} command would print: -\begin{example} -; File: /usr/me/mystuff.lisp - -(MYMAC) -\end{example} -Note that the macro use was printed, not the actual function call form, -\code{(myfun)}. - -If enclosing source is printed by giving an argument to \code{source} or -\code{vsource}, then the actual source form is marked by wrapping it in a list -whose first element is \code{#:***HERE***}. In the previous example, -\w{\code{source 1}} would print: -\begin{example} -; File: /usr/me/mystuff.lisp - -(DEFUN FOO () - (#:***HERE*** - (MYMAC)) - ...) -\end{example} - - -\begin{menu} -* How the Source is Found:: -* Source Location Availability:: -\end{menu} - -\node How the Source is Found, Source Location Availability, Source Location Printing, Source Location Printing -\subsection{How the Source is Found} - -If the code was defined from \llisp{} by \code{compile} or -\code{eval}, then the source can always be reliably located. If the -code was defined from a \code{fasl} file created by -\findexed{compile-file}, then the debugger gets the source forms it -prints by reading them from the original source file. This is a -potential problem, since the source file might have moved or changed -since the time it was compiled. - -The source file is opened using the \code{truename} of the source file -pathname originally given to the compiler. This is an absolute pathname -with all logical names and symbolic links expanded. If the file can't -be located using this name, then the debugger gives up and signals an -error. - -If the source file can be found, but has been modified since the time it was -compiled, the debugger prints this warning: -\begin{example} -; File has been modified since compilation: -; \var{filename} -; Using form offset instead of character position. -\end{example} -where \var{filename} is the name of the source file. It then proceeds using a -robust but not foolproof heuristic for locating the source. This heuristic -works if: -\begin{itemize} - -\item -No top-level forms before the top-level form containing the source have been -added or deleted, and - -\item -The top-level form containing the source has not been modified much. (More -precisely, none of the list forms beginning before the source form have been -added or deleted.) -\end{itemize} - -If the heuristic doesn't work, the displayed source will be wrong, but will -probably be near the actual source. If the "shape" of the top-level form in -the source file is too different from the original form, then an error will be -signalled. When the heuristic is used, the the source location commands are -noticeably slowed. - -Source location printing can also be confused if (after the source was -compiled) a read-macro you used in the code was redefined to expand into -something different, or if a read-macro ever returns the same \code{eq} -list twice. If you don't define read macros and don't use \code{##} in -perverted ways, you don't need to worry about this. - - -\node Source Location Availability, , How the Source is Found, Source Location Printing -\subsection{Source Location Availability} - -\cindex{debug optimization quality} -Source location information is only available when the \code{debug} -optimization quality is at least \code{2}. If source location information is -unavailable, the source commands will give an error message. - -If source location information is available, but the source location is -unknown because of an interrupt or unexpected hardware error -(\pxlref{unknown-locations}), then the command will print: -\begin{example} -Unknown location: using block start. -\end{example} -and then proceed to print the source location for the start of the \i{basic -block} enclosing the code location. \cpsubindex{block}{basic} -\cpsubindex{block}{start location} -It's a bit complicated to explain exactly what a basic block is, but -here are some properties of the block start location: -\begin{itemize} - -\item -The block start location may be the same as the true location. - -\item -The block start location will never be later in the the program's flow of -control than the true location. - -\item -No conditional control structures (such as \code{if}, \code{cond}, \code{or}) will -intervene between the block start and the true location (but note that some -conditionals present in the original source could be optimized away.) Function -calls \i{do not} end basic blocks. - -\item -The head of a loop will be the start of a block. - -\item -The programming language concept of "block structure" and the \clisp{} \code{block} -special form are totally unrelated to the compiler's basic block. -\end{itemize} - -In other words, the true location lies between the printed location and the -next conditional (but watch out because the compiler may have changed the -program on you.) - - -\node Compiler Policy Control, Exiting Commands, Source Location Printing, The Debugger -\section{Compiler Policy Control} -\label{debugger-policy} -\cpsubindex{policy}{debugger} -\cindex{debug optimization quality} -\cindex{optimize declaration} - -The compilation policy specified by \code{optimize} declarations affects the -behavior seen in the debugger. The \code{debug} quality directly affects the -debugger by controlling the amount of debugger information dumped. Other -optimization qualities have indirect but observable effects due to changes in -the way compilation is done. - -Unlike the other optimization qualities (which are compared in relative value -to evaluate tradeoffs), the \code{debug} optimization quality is directly -translated to a level of debug information. This absolute interpretation -allows the user to count on a particular amount of debug information being -available even when the values of the other qualities are changed during -compilation. These are the levels of debug information that correspond to the -values of the \code{debug} quality: -\begin{description} - -\item[\code{0}] -Only the function name and enough information to allow the stack to -be parsed. - -\item[\code{\w{> 0}}] -Any level greater than \code{0} gives level \code{0} plus all -argument variables. Values will only be accessible if the argument -variable is never set and -\code{speed} is not \code{3}. \cmucl{} allows any real value for optimization -qualities. It may be useful to specify \code{0.5} to get backtrace argument -display without argument documentation. - -\item[\code{1}] Level \code{1} provides argument documentation -(printed arglists) and derived argument/result type information. -This makes \findexed{describe} more informative, and allows the -compiler to do compile-time argument count and type checking for any -calls compiled at run-time. - -\item[\code{2}] -Level \code{1} plus all interned local variables, source location -information, and lifetime information that tells the debugger when arguments -are available (even when \code{speed} is \code{3} or the argument is set.) This is -the default. - -\item[\code{3}] -Level \code{2} plus all uninterned variables. In addition, lifetime -analysis is disabled (even when \code{speed} is \code{3}), ensuring that all variable -values are available at any known location within the scope of the binding. -This has a speed penalty in addition to the obvious space penalty. -\end{description} - -As you can see, if the \code{speed} quality is \code{3}, debugger performance is -degraded. This effect comes from the elimination of argument variable -special-casing (\pxlref{debug-var-validity}.) Some degree of -speed/debuggability tradeoff is unavoidable, but the effect is not too drastic -when \code{debug} is at least \code{2}. - -\cindex{inline expansion} -\cindex{semi-inline expansion} -In addition to \code{inline} and \code{notinline} declarations, the relative values -of the \code{speed} and \code{space} qualities also change whether functions are -inline expanded (\pxlref{inline-expansion}.) If a function is inline -expanded, then there will be no frame to represent the call, and the arguments -will be treated like any other local variable. Functions may also be -"semi-inline", in which case there is a frame to represent the call, but the -call is to an optimized local version of the function, not to the original -function. - - -\node Exiting Commands, Information Commands, Compiler Policy Control, The Debugger -\section{Exiting Commands} - -These commands get you out of the debugger. - -\begin{description} - -\item[\code{quit}] -Throw to top level. - -\item[\code{restart} \mopt{\var{n}}]\hfill\\ -Invokes the \var{n}th restart case as displayed by the \code{error} -command. If \var{n} is not specified, the available restart cases are -reported. - -\item[\code{go}] -Calls \code{continue} on the condition given to \code{debug}. If there is no -restart case named \var{continue}, then an error is signaled. - -\item[\code{abort}] -Calls \code{abort} on the condition given to \code{debug}. This is -useful for popping debug command loop levels or aborting to top level, -as the case may be. - -\begin{ignore} -(\code{debug:debug-return} \var{expression} \mopt{\var{frame}}) - -\item -From the current or specified frame, return the result of evaluating -expression. If multiple values are expected, then this function should be -called for multiple values. -\end{ignore} -\end{description} - - -\node Information Commands, Breakpoint Commands, Exiting Commands, The Debugger -\section{Information Commands} - -Most of these commands print information about the current frame or -function, but a few show general information. - -\begin{description} - -\item[\code{help}, \code{?}] -Displays a synopsis of debugger commands. - -\item[\code{describe}] -Calls \code{describe} on the current function, displays number of local -variables, and indicates whether the function is compiled or interpreted. - -\item[\code{print}] -Displays the current function call as it would be displayed by moving to -this frame. - -\item[\code{vprint} (or \code{pp}) \mopt{\var{verbosity}}]\hfill\\ -Displays the current function call using \code{*print-level*} and -\code{*print-length*} instead of \code{*debug-print-level*} and -\code{*debug-print-length*}. \var{verbosity} is a small integer -(default 2) that controls other dimensions of verbosity. - -\item[\code{error}] -Prints the condition given to \code{invoke-debugger} and the active -proceed cases. - -\item[\code{backtrace} \mopt{\var{n}}]\hfill\\ -Displays all the frames from the current to the bottom. Only shows -\var{n} frames if specified. The printing is controlled by -\code{*debug-print-level*} and \code{*debug-print-length*}. - -\begin{ignore} -(\code{debug:debug-function} \mopt{\var{n}}) - -\item -Returns the function from the current or specified frame. - -\item[(\code{debug:function-name} \mopt{\var{n}])] -Returns the function name from the current or specified frame. - -\item[(\code{debug:pc} \mopt{\var{frame}})] -Returns the index of the instruction for the function in the current or -specified frame. This is useful in conjunction with \code{disassemble}. -The pc returned points to the instruction after the one that was fatal. -\end{ignore} -\end{description} - - -\node Breakpoint Commands, Function Tracing, Information Commands, The Debugger -\section{Breakpoint Commands} - -\cmucl{} supports setting of breakpoints inside compiled functions and -stepping of compiled code. Breakpoints can only be set at at known -locations (\pxlref{unknown-locations}), so these commands are largely -useless unless the \code{debug} optimize quality is at least \code{2} -(\pxlref{debugger-policy}). These commands manipulate breakpoints: -\begin{description} -\item[\code{breakpoint} \var{location} \mstar{\var{option} \var{value}}] -\hfill\\ -Set a breakpoint in some function. \var{location} may be an integer -code location number (as displayed by \code{list-locations}) or a -keyword. The keyword can be used to indicate setting a breakpoint at -the function start (\code{:start}, \code{:s}) or function end -(\code{:end}, \code{:e}). The \code{breakpoint} command has -\code{:condition}, \code{:break}, \code{:print} and \code{:function} -options which work similarly to the \code{trace} options. - -\item[\code{list-locations} (or \code{ll}) \mopt{\var{function}}]\hfill\\ -List all the code locations in the current frame's function, or in -\var{function} if it is supplied. The display format is the code -location number, a colon and then the source form for that location: -\begin{example} -3: (1- N) -\end{example} -If consecutive locations have the same source, then a numeric range like -\code{3-5:} will be printed. For example, a default function call has a -known location both immediately before and after the call, which would -result in two code locations with the same source. The listed function -becomes the new default function for breakpoint setting (via the -\code{breakpoint}) command. - -\item[\code{list-breakpoints} (or \code{lb})]\hfill\\ -List all currently active breakpoints with their breakpoint number. - -\item[\code{delete-breakpoint} (or \code{db}) \mopt{\var{number}}]\hfill\\ -Delete a breakpoint specified by its breakpoint number. If no number is -specified, delete all breakpoints. - -\item[\code{step}]\hfill\\ -Step to the next possible breakpoint location in the current function. -This always steps over function calls, instead of stepping into them -\end{description} - -\begin{menu} -* Breakpoint Example:: -\end{menu} - -\node Breakpoint Example, , Breakpoint Commands, Breakpoint Commands -\subsection{Breakpoint Example} - -Consider this definition of the factorial function: -\begin{lisp} -(defun ! (n) - (if (zerop n) - 1 - (* n (! (1- n))))) -\end{lisp} -This debugger session demonstrates the use of breakpoints: -\begin{example} -common-lisp-user> (break) ; Invoke debugger - -Break - -Restarts: - 0: [CONTINUE] Return from BREAK. - 1: [ABORT ] Return to Top-Level. - -Debug (type H for help) - -(INTERACTIVE-EVAL (BREAK)) -0] ll #'! -0: #'(LAMBDA (N) (BLOCK ! (IF # 1 #))) -1: (ZEROP N) -2: (* N (! (1- N))) -3: (1- N) -4: (! (1- N)) -5: (* N (! (1- N))) -6: #'(LAMBDA (N) (BLOCK ! (IF # 1 #))) -0] br 2 -(* N (! (1- N))) -1: 2 in ! -Added. -0] q - -common-lisp-user> (! 10) ; Call the function - -*Breakpoint hit* - -Restarts: - 0: [CONTINUE] Return from BREAK. - 1: [ABORT ] Return to Top-Level. - -Debug (type H for help) - -(! 10) ; We are now in first call (arg 10) before the multiply -Source: (* N (! (1- N))) -3] st - -*Step* - -(! 10) ; We have finished evaluation of (1- n) -Source: (1- N) -3] st - -*Breakpoint hit* - -Restarts: - 0: [CONTINUE] Return from BREAK. - 1: [ABORT ] Return to Top-Level. - -Debug (type H for help) - -(! 9) ; We hit the breakpoint in the recursive call -Source: (* N (! (1- N))) -3] -\end{example} - - - - -\node Function Tracing, Specials, Breakpoint Commands, The Debugger -\section{Function Tracing} -\cindex{tracing} -\cpsubindex{function}{tracing} - -The tracer causes selected functions to print their arguments and -their results whenever they are called. Options allow conditional -printing of the trace information and conditional breakpoints on -function entry or exit. - -\defmac{trace}{\mstar{option global-value} \mstar{name \mstar{option value}}} -\code{trace} is a debugging tool that prints information when specified -functions are called. In its simplest form: -\begin{example} -(trace \var{name-1} \var{name-2} ...) -\end{example} -\code{trace} causes a printout on \vindexed{trace-output} each time that one -of the named functions is entered or returns (the \var{names} are not -evaluated.) Trace output is indented according to the number of pending -traced calls, and this trace depth is printed at the beginning of each -line of output. Printing verbosity of arguments and return values is -controlled by \vindexed{debug-print-level} and \vindexed{debug-print-length}. - -If no \var{names} or \var{options} are are given, \code{trace} returns the -list of all currently traced functions, \code{*traced-function-list*}. - -Trace options can cause the normal printout to be suppressed, or cause -extra information to be printed. Each option is a pair of an option -keyword and a value form. Options may be interspersed with function -names. Options only affect tracing of the function whose name they -appear immediately after. Global options are specified before the first -name, and affect all functions traced by a given use of \code{trace}. -If an already traced function is traced again, any new options replace the -old options. The following options are defined: -\begin{description} -\item[\code{:condition} \var{form}, -\code{:condition-after} \var{form}, -\code{:condition-all} \var{form}]\hfill\\ -If \code{:condition} is specified, then \code{trace} does nothing unless -\var{form} evaluates to true at the time of the call. \code{:condition-after} -is similar, but suppresses the initial printout, and is tested when the -function returns. \code{:condition-all} tries both before and after. - -\item[\code{:wherein} \var{names}]\hfill\\ -If specified, \var{names} is a function name or list of names. \code{trace} -does nothing unless a call to one of those functions encloses the call -to this function (i.e. it would appear in a backtrace.) Anonymous -functions have string names like \code{"DEFUN FOO"}. - -\item[\code{:break} \var{form}, -\code{:break-after} \var{form}, -\code{:break-all} \var{form}]\hfill\\ -If specified, and \var{form} evaluates to true, then the debugger is -invoked at the start of the function, at the end of the function, or -both, according to the respective option. - -\item[\code{:print} \var{form}, -\code{:print-after} \var{form}, -\code{:print-all} \var{form}]\hfill\\ -In addition to the usual printout, the result of evaluating \var{form} is -printed at the start of the function, at the end of the function, or -both, according to the respective option. Multiple print options cause -multiple values to be printed. - -\item[\code{:function} \var{function-form}]\hfill\\ -This is a not really an option, but rather another way of specifying -what function to trace. The \var{function-form} is evaluated immediately, -and the resulting function is traced. - -\item[\code{:encapsulate \mgroup{:default | t | nil}}]\hfill\\ -In \cmucl, tracing can be done either by temporarily redefining the -function name (encapsulation), or using breakpoints. When breakpoints -are used, the function object itself is destructively modified to cause -the tracing action. The advantage of using breakpoints is that tracing -works even when the function is anonymously called via \code{funcall}. - -When \code{:encapsulate} is true, tracing is done via encapsulation. -\code{:default} is the default, and means to use encapsulation for -interpreted functions and funcallable instances, breakpoints otherwise. -When encapsulation is used, forms are {\it not} evaluated in the -function's lexical environment, but \code{debug:arg} can still be used. -\end{description} - -\code{:condition}, \code{:break} and \code{:print} forms are evaluated -in the lexical environment of the called function; \code{debug:var} and -\code{debug:arg} can be used. The \code{-after} and \code{-all} forms -are evaluated in the null environment. -\enddefmac - -\defmac{untrace}{ \args{\&rest{} \var{function-names}}} -This macro turns off tracing for the specified functions, and removes -their names from \code{*traced-function-list*}. If no -\var{function-names} are given, then all currently traced functions are -untraced. -\enddefmac - -\defvar{traced-function-list}[extensions] -A list of function names maintained and used by \code{trace}, -\code{untrace}, and \code{untrace-all}. This list should contain the names -of all functions currently being traced. -\enddefvar - -\defvar{max-trace-indentation}[extensions] -The maximum number of spaces which should be used to indent trace -printout. This variable is initially set to 40. -\enddefvar - -\begin{menu} -* Encapsulation Functions:: -\end{menu} - -\node Encapsulation Functions, , Function Tracing, Function Tracing -\subsection{Encapsulation Functions} -\cindex{encapsulation} -\cindex{advising} - -The encapsulation functions provide a mechanism for intercepting the -arguments and results of a function. \code{encapsulate} changes the -function definition of a symbol, and saves it so that it can be -restored later. The new definition normally calls the original -definition. The \clisp{} \findexed{fdefinition} function always returns -the original definition, stripping off any encapsulation. - -The original definition of the symbol can be restored at any time by -the \code{unencapsulate} function. \code{encapsulate} and \code{unencapsulate} -allow a symbol to be multiply encapsulated in such a way that different -encapsulations can be completely transparent to each other. - -Each encapsulation has a type which may be an arbitrary lisp object. -If a symbol has several encapsulations of different types, then any -one of them can be removed without affecting more recent ones. -A symbol may have more than one encapsulation of the same type, but -only the most recent one can be undone. - -\defun{encapsulate}[extensions]{\args{\i{symbol type body}}} -Saves the current definition of \var{symbol}, and replaces it with a -function which returns the result of evaluating the form, \var{body}. -\var{Type} is an arbitrary lisp object which is the type of -encapsulation. - -When the new function is called, the following variables are bound for the -evaluation of \var{body}: -\begin{description} - -\item[\code{extensions:argument-list}] -A list of the arguments to the function. - -\item[\code{extensions:basic-definition}] -The unencapsulated definition of the -function. -\end{description} -The unencapsulated definition may be called with the original -arguments by including the form -\begin{lisp} -(apply extensions:basic-definition extensions:argument-list) -\end{lisp} - -\code{encapsulate} always returns \var{symbol}. -\enddefun - -\defun{unencapsulate}[extensions]{\args{\i{symbol type}}} Undoes -\var{symbol}'s most recent encapsulation of type \var{type}. -\var{Type} is compared with \code{eq}. Encapsulations of other types -are left in place. -\enddefun - -\defun{encapsulated-p}[extensions]{\args{\i{symbol type}}} -Returns \code{t} if \var{symbol} has an encapsulation of type \var{type}. -Returns \nil{} otherwise. \var{Type} is compared with \code{eq}. -\enddefun - - -\begin{ignore} -section{The Single Stepper} - -\defmac{step}{ \args{\var{form}}} -Evaluates form with single stepping enabled or if \var{form} is \code{T}, -enables stepping until explicitly disabled. Stepping can be -disabled by quitting to the lisp top level, or by evaluating the form -\w{\code{(step ())}}. - -While stepping is enabled, every call to eval will prompt the user for -a single character command. The prompt is the form which is about to -be \code{eval}ed. It is printed with \code{*print-level*} and -\code{*print-length*} bound to \code{*step-print-level*} and -\code{*step-print-length*}. All interaction is done through the stream -\code{*query-io*}. Because of this, the stepper can not be used in Hemlock -eval mode. When connected to a slave Lisp, the stepper can be used -from Hemlock. - -The commands are: -\begin{description} - -\item[\key{n} (next)] -Evaluate the expression with stepping still enabled. - -\item[\key{s} (skip)] -Evaluate the expression with stepping disabled. - -\item[\key{q} (quit)] -Evaluate the expression, but disable all further -stepping inside the current call to \code{step}. - -\item[\key{p} (print)] -Print current form. (does not use -\code{*step-print-level*} or \code{*step-print-length*}.) - -\item[\key{b} (break)] -Enter break loop, and then prompt for the command -again when the break loop returns. - -\item[\key{e} (eval)] -Prompt for and evaluate an arbitrary expression. -The expression is evaluated with stepping disabled. - -\item[\key{?} (help)] -Prints a brief list of the commands. - -\item[\key{r} (return)] -Prompt for an arbitrary value to return as result -of the current call to eval. - -\item[\key{g}] -Throw to top level. -\end{description} -\enddefmac - -\defvar{step-print-level}[extensions] -\defvarx{step-print-length}[extensions] -\code{*print-level*} and \code{*print-length*} are bound to these values while -printing the current form. \code{*Step-print-level*} and -\code{*step-print-length*} are initially bound to 4 and 5, respectively. -\enddefvar - -\defvar{max-step-indentation}[extensions] -Step indents the prompts to highlight the nesting of the evaluation. -This variable contains the maximum number of spaces to use for -indenting. Initially set to 40. -\enddefvar - -\end{ignore} - - -\node Specials, , Function Tracing, The Debugger -\section{Specials} -These are the special variables that control the debugger action. - -\defvar{debug-print-level}[extensions] -\defvarx{debug-print-length}[extensions] - -\code{*print-level*} and \code{*print-length*} are bound to these values -during the execution of some debug commands. When evaluating -arbitrary expressions in the debugger, the normal values of -\code{*print-level*} and \code{*print-length*} are in effect. These -variables are initially set to 3 and 5, respectively. -\enddefvar - - -\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/compiler.ms} - - -\node The Compiler, Advanced Compiler Use and Efficiency Hints, The Debugger, Top -\chapter{The Compiler} \hide{ -*- Dictionary: cmu-user -*-} - -\begin{menu} -* Compiler Introduction:: -* Calling the Compiler:: -* Compilation Units:: -* Interpreting Error Messages:: -* Types in Python:: -* Getting Existing Programs to Run:: -* Compiler Policy:: -* Open Coding and Inline Expansion:: -\end{menu} - -\node Compiler Introduction, Calling the Compiler, The Compiler, The Compiler -\section{Compiler Introduction} - -This chapter contains information about the compiler that every \cmucl{} user -should be familiar with. Chapter \ref{advanced-compiler} goes into greater -depth, describing ways to use more advanced features. - -The \cmucl{} compiler (also known as \Python{}) has many features -that are seldom or never supported by conventional \llisp{} -compilers: -\begin{itemize} - -\item -Source level debugging of compiled code (see chapter \ref{debugger}.) - -\item -Type error compiler warnings for type errors detectable at compile time. - -\item -Compiler error messages that provide a good indication of where the error -appeared in the source. - -\item -Full run-time checking of all potential type errors, with optimization of type -checks to minimize the cost. - -\item -Scheme-like features such as proper tail recursion and extensive source-level -optimization. - -\item -Advanced tuning and optimization features such as comprehensive efficiency -notes, flow analysis, and untagged number representations (see chapter -\ref{advanced-compiler}.) -\end{itemize} - - - -\node Calling the Compiler, Compilation Units, Compiler Introduction, The Compiler -\section{Calling the Compiler} -\cindex{compiling} -Functions may be compiled using \code{compile}, \code{compile-file}, or -\code{compile-from-stream}. - -\defun{compile}{ \args{\var{name} \&optional{} \var{definition}}} -This function compiles the function whose name is \var{name}. If -\var{name} is \false, the compiled function object is returned. If -\var{definition} is supplied, it should be a lambda expression that -is to be compiled and then placed in the function cell of \var{name}. -As per the proposed X3J13 cleanup "compile-argument-problems", -\var{definition} may also be an interpreted function. - -The return values are as per the proposed X3J13 cleanup -"compiler-diagnostics". The first value is the function name or -function object. The second value is \false{} if no compiler -diagnostics were issued, and \true{} otherwise. The third value is -\false{} if no compiler diagnostics other than style warnings were -issued. A non-\false{} value indicates that there were "serious" -compiler diagnostics issued, or that other conditions of type -\tindexed{error} or \tindexed{warning} (but not -\tindexed{style-warning}) were signalled during compilation. -\enddefun - - -\defun{compile-file}{ - \args{\var{input-pathname}} - \keys{:output-file :error-file :trace-file} - \morekeys{:error-output :verbose :print :progress} - \yetmorekeys{:load :block-compile :entry-points}} -The \cmucl{} \code{compile-file} is extended through the addition of several new -keywords and an additional interpretation of \var{input-pathname}: -\begin{description} - -\item[\var{input-pathname}] If this argument is a list of input -files, rather than a single input pathname, then all the source files -are compiled into a single object file. In this case, the name of -the first file is used to determine the default output file names. -This is especially useful in combination with \var{block-compile}. - -\item[\var{output-file}] This argument specifies the name of the -output file. \true{} gives the default name, \false{} suppresses the -output file. - -\item[\var{error-file}] A listing of all the error output is directed -to this file. If there are no errors, then no error file is produced -(and any existing error file is deleted.) \true{} gives -\w{"\var{name}\code{.err}"} (the default), and \false{} suppresses -the output file. - -\item[\var{error-output}] -If \true{} (the default), then error output is sent to \code{*error-output*}. If -a stream, then output is sent to that stream instead. If \false, then error -output is suppressed. Note that this error output is in addition to (but the -same as) the output placed in the \var{error-file}. - -\item[\var{verbose}] If \true{} (the default), then the compiler -prints to error output at the start and end of compilation of each -file. See \varref{compile-verbose}. - -\item[\var{print}] -If \true{} (the default), then the compiler prints to error output -when each function is compiled. See \varref{compile-print}. - -\item[\var{progress}] If \true{} (default \false{}), then the -compiler prints to error output progress information about the phases -of compilation of each function. This is a CMU extension that is -useful mainly in large block compilations. See \varref{compile-progress}. - -\item[\var{trace-file}] If true, several of the intermediate -representations (including annotated assembly code) are dumped out to -this file. \true{} gives \w{"\var{name}\code{.trace}"}. Trace -output is off by default. \xlref{trace-files}. - -\item[\var{load}] If true, load the resulting output file. - -\item[\var{block-compile}] Controls the compile-time resolution of -function calls. By default, only self-recursive calls are resolved, -unless an \code{ext:block-start} declaration appears in the source -file. \xlref{compile-file-block}. - -\item[\var{entry-points}] If non-null, then this is a list of the -names of all functions in the file that should have global -definitions installed (because they are referenced in other files.) -\xlref{compile-file-block}. -\end{description} - -The return values are as per the proposed X3J13 cleanup -"compiler-diagnostics". The first value from \code{compile-file} is the -truename of the output file, or \false{} if the file could not be -created. The interpretation of the second and third values is -described above for \code{compile}. -\enddefun - -\defvar{compile-verbose} -\defvarx{compile-print} -\defvarx{compile-progress} -These variables determine the default values for the \kwd{verbose}, -\kwd{print} and \kwd{progress} arguments to \code{compile-file}. -\enddefvar - -\defun{compile-from-stream}[extensions]{\args{input-stream} - \keys{:error-stream} - \morekeys{:trace-stream} - \yetmorekeys{:block-compile :entry-points}} -This function is similar to \code{compile-file}, but it takes all its -arguments as streams. It reads \llisp{} code from \var{input-stream} -until end of file is reached, compiling into the current environment. -This function returns the same two values as the last two values of -\code{compile}. No output files are produced. -\enddefun - - - -\node Compilation Units, Interpreting Error Messages, Calling the Compiler, The Compiler -\section{Compilation Units} -\cpsubindex{compilation}{units} - -\cmucl{} supports the \code{with-compilation-unit} macro added to the language by -the proposed X3J13 "with-compilation-unit" compiler cleanup. This provides a -mechanism for eliminating spurious undefined warnings when there are forward -references across files, and also provides a standard way to access compiler -extensions. - -\defmac{with-compilation-unit}{ - \args{(\mstar{\var{key} \var{value}}) \mstar{\var{form}}}} - -This macro evaluates the \var{forms} in an environment that causes warnings for -undefined variables, functions and types to be delayed until all the forms have -been evaluated. Each keyword \var{value} is an evaluated form. These keyword -options are recognized: -\begin{description} - -\item[\kwd{override}] -If uses of \code{with-compilation-unit} are dynamically nested, the outermost -use will take precedence, suppressing printing of undefined warnings by inner -uses. However, when the \code{override} option is true this shadowing is -inhibited; an inner use will print summary warnings for the compilations within -the inner scope. - -\item[\kwd{optimize}] -This is a CMU extension that specifies of the "global" compilation policy for -the dynamic extent of the body. The argument should evaluate to an -\code{optimize} declare form, like: -\begin{lisp} -(optimize (speed 3) (safety 0)) -\end{lisp} -\xlref{optimize-declaration} - -\item[\kwd{optimize-interface}] -Similar to \kwd{optimize}, but specifies the compilation policy for function -interfaces (argument count and type checking) for the dynamic extent of the -body. \xlref{optimize-interface-declaration}. - -\item[\kwd{context-declarations}] -This is a CMU extension that pattern-matches on function names, automatically -splicing in any appropriate declarations at the head of the function -definition. \xlref{context-declarations}. -\end{description} -\enddefmac - -\begin{menu} -* Undefined Warnings:: -* Context Declarations:: -* Context Declaration Example:: -\end{menu} - -\node Undefined Warnings, Context Declarations, Compilation Units, Compilation Units -\subsection{Undefined Warnings} - -\cindex{undefined warnings} -Warnings about undefined variables, functions and types are delayed until the -end of the current compilation unit. The compiler entry functions -(\code{compile}, etc.) implicitly use \code{with-compilation-unit}, so undefined -warnings will be printed at the end of the compilation unless there is an -enclosing \code{with-compilation-unit}. In order the gain the benefit of this -mechanism, you should wrap a single \code{with-compilation-unit} around the calls -to \code{compile-file}, i.e.: -\begin{lisp} -(with-compilation-unit () - (compile-file "file1") - (compile-file "file2") - ...) -\end{lisp} - -Unlike for functions and types, undefined warnings for variables are not -suppressed when a definition (e.g. \code{defvar}) appears after the reference (but -in the same compilation unit.) This is because doing special declarations out -of order just doesn't work \dash{} although early references will be compiled as -special, bindings will be done lexically. - -Undefined warnings are printed with full source context (\pxlref{error-messages}), which tremendously simplifies the problem of finding -undefined references that resulted from macroexpansion. After printing -detailed information about the undefined uses of each name, -\code{with-compilation-unit} also prints summary listings of the names of all the -undefined functions, types and variables. - -\defvar{undefined-warning-limit} -This variable controls the number of undefined warnings for each distinct name -that are printed with full source context when the compilation unit ends. If -there are more undefined references than this, then they are condensed into a -single warning: -\begin{example} -Warning: \var{count} more uses of undefined function \var{name}. -\end{example} -When the value is \code{0}, then the undefined warnings are not broken down by -name at all: only the summary listing of undefined names is printed. -\enddefvar - -\node Context Declarations, Context Declaration Example, Undefined Warnings, Compilation Units -\subsection{Context Declarations} -\label{context-declarations} -\cindex{context sensitive declarations} -\cpsubindex{declarations}{context-sensitive} - -\cmucl{} has a context-sensitive declaration mechanism which is useful because it -allows flexible control of the compilation policy in large systems without -requiring changes to the source files. The primary use of this feature is to -allow the exported interfaces of a system to be compiled more safely than the -system internals. The context used is the name being defined and the kind of -definition (function, macro, etc.) - -The \kwd{context-declarations} option to \macref{with-compilation-unit} has -dynamic scope, affecting all compilation done during the evaluation of the -body. The argument to this option should evaluate to a list of lists of the -form: -\begin{example} -(\var{context-spec} \mplus{\var{declare-form}}) -\end{example} -In the indicated context, the specified declare forms are inserted at -the head of each definition. The declare forms for all contexts that -match are appended together, with earlier declarations getting -precedence over later ones. A simple example: -\begin{example} - :context-declarations - '((:external (declare (optimize (safety 2))))) -\end{example} -This will cause all functions that are named by external symbols to be -compiled with \code{safety 2}. - -The full syntax of context specs is: -\begin{description} - -\item[\kwd{internal}, \kwd{external}] -True if the symbol is internal (external) in its home package. - -\item[\kwd{uninterned}] -True if the symbol has no home package. - -\item[\code{\w{(:package \mstar{\var{package-name}})}}] -True if the symbol's home package is in any of the named packages (false if -uninterned.) - -\item[\kwd{anonymous}] -True if the function doesn't have any interesting name (not -\code{defmacro}, \code{defun}, \code{labels} or \code{flet}). - -\item[\kwd{macro}, \kwd{function}] -\kwd{macro} is a global (\code{defmacro}) macro. \kwd{function} is anything -else. - -\item[\kwd{local}, \kwd{global}] -\kwd{local} is a \code{labels} or \code{flet}. \kwd{global} is anything else. - -\item[\code{\w{(:or \mstar{\var{context-spec}})}}] -True when any supplied \var{context-spec} is true. - -\item[\code{\w{(:and \mstar{\var{context-spec}})}}] -True only when all supplied \var{context-spec}s are true. - -\item[\code{\w{(:not \mstar{\var{context-spec}})}}] -True when \var{context-spec} is false. - -\item[\code{\w{(:member \mstar{\var{name}})}}] -True when the defined name is one of these names (\code{equal} test.) - -\item[\code{\w{(:match \mstar{\var{pattern}})}}] -True when any of the patterns is a substring of the name. The name is wrapped -with \code{$}'s, so "\code{$FOO}" matches names beginning with "\code{FOO}", etc. -\end{description} - -\node Context Declaration Example, , Context Declarations, Compilation Units -\subsection{Context Declaration Example} - -Here is a more complex example of \code{with-compilation-unit} options: -\begin{example} -:optimize '(optimize (speed 2) (space 2) (inhibit-warnings 2) - (debug 1) (safety 0)) -:optimize-interface '(optimize-interface (safety 1) (debug 1)) -:context-declarations -'(((:or :external (:and (:match "%") (:match "SET"))) - (declare (optimize-interface (safety 2)))) - ((:or (:and :external :macro) - (:match "$PARSE-")) - (declare (optimize (safety 2))))) -\end{example} -The \code{optimize} and \code{extensions:optimize-interface} declarations (\pxlref{optimize-declaration}) set up the global compilation policy. The -bodies of functions are to be compiled completely unsafe (\code{safety 0}), but -argument count and weakened argument type checking is to be done when a -function is called (\code{speed 2 safety 1}). - -The first declaration specifies that all functions that are external or -whose names contain both "\code{%}" and "\code{SET}" are to be compiled -compiled with completely safe interfaces (\code{safety 2}). The reason for this -particular \kwd{match} rule is that \code{setf} inverse functions in this system -tend to have both strings in their name somewhere. We want \code{setf} inverses -to be safe because they are implicitly called by users even though their name -is not exported. - -The second declaration makes external macros or functions whose names start -with "\code{PARSE-}" have safe bodies (as well as interfaces). This is desirable -because a syntax error in a macro may cause a type error inside the body. The -\kwd{match} rule is used because macros often have auxiliary functions whose -names begin with this string. - -This particular example is used to build part of the standard \cmucl{} system. -Note however, that context declarations must be set up according to the needs -and coding conventions of a particular system; different parts of \cmucl{} are -compiled with different context declarations, and your system will probably -need its own declarations. In particular, any use of the \kwd{match} option -depends on naming conventions used in coding. - - -\node Interpreting Error Messages, Types in Python, Compilation Units, The Compiler -\section{Interpreting Error Messages} -\label{error-messages} -\cpsubindex{error messages}{compiler} -\cindex{compiler error messages} - -One of \Python{}'s unique features is the level of source location information it -provides in error messages. The error messages contain a lot of detail in a -terse format, to they may be confusing at first. Error messages will be -illustrated using this example program: -\begin{lisp} -(defmacro zoq (x) - `(roq (ploq (+ ,x 3)))) - -(defun foo (y) - (declare (symbol y)) - (zoq y)) -\end{lisp} -The main problem with this program is that it is trying to add \code{3} to a -symbol. Note also that the functions \code{roq} and \code{ploq} aren't defined -anywhere. - -\begin{menu} -* The Parts of the Error Message:: -* The Original and Actual Source:: -* The Processing Path:: -* Error Severity:: -* Errors During Macroexpansion:: -* Read Errors:: -* Error Message Parameterization:: -\end{menu} - -\node The Parts of the Error Message, The Original and Actual Source, Interpreting Error Messages, Interpreting Error Messages -\subsection{The Parts of the Error Message} - -The compiler will produce this warning: -\begin{example} -File: /usr/me/stuff.lisp - -In: DEFUN FOO - (ZOQ Y) ---> ROQ PLOQ + -==> - Y -Warning: Result is a SYMBOL, not a NUMBER. -\end{example} -In this example we see each of the six possible parts of a compiler error -message: -\begin{description} - -\item[\w{\code{File: /usr/me/stuff.lisp}}] -This is the \var{file} that the compiler read the relevant code from. The file -name is displayed because it may not be immediately obvious when there is an -error during compilation of a large system, especially when -\code{with-compilation-unit} is used to delay undefined warnings. - -\item[\w{\code{In: DEFUN FOO}}] -This is the \var{definition} or top-level form responsible for the error. It -is obtained by taking the first two elements of the enclosing form whose first -element is a symbol beginning with "\code{DEF}". If there is no enclosing -\w{\var{def}mumble}, then the outermost form is used. If there are multiple -\w{\var{def}mumbles}, then they are all printed from the out in, separated by -\code{=>}'s. In this example, the problem was in the \code{defun} for \code{foo}. - -\item[\w{\code{(ZOQ Y)}}] -This is the \i{original source} form responsible for the error. Original -source means that the form directly appeared in the original input to the -compiler, i.e. in the lambda passed to \code{compile} or the top-level form read -from the source file. In this example, the expansion of the \code{zoq} macro was -responsible for the error. - -\item[\w{\code{--> ROQ PLOQ +}} ] -This is the \i{processing path} that the compiler used to produce the -errorful code. The processing path is a representation of the evaluated forms -enclosing the actual source that the compiler encountered when processing the -original source. The path is the first element of each form, or the form -itself if the form is not a list. These forms result from the expansion of -macros or source-to-source transformation done by the compiler. In this -example, the enclosing evaluated forms are the calls to \code{roq}, \code{ploq} and -\code{+}. These calls resulted from the expansion of the \code{zoq} macro. - -\item[\code{==> Y}] -This is the \i{actual source} responsible for the error. If the actual -source appears in the explanation, then we print the next enclosing evaluated -form, instead of printing the actual source twice. (This is the form that -would otherwise have been the last form of the processing path.) In this -example, the problem is with the evaluation of the reference to the variable -\code{y}. - -\item[\w{\code{Warning: Result is a SYMBOL, not a NUMBER.}}] -This is the \var{explanation} the problem. In this example, the -problem is that \code{y} evaluates to a \code{symbol}, but is in a context where a -number is required (the argument to \code{+}). -\end{description} - -Note that each part of the error message is distinctively marked: -\begin{itemize} - -\item -\code{File:} and \code{In:} mark the file and definition, respectively. - -\item -The original source is an indented form with no prefix. - -\item -Each line of the processing path is prefixed with \code{-->}. - -\item -The actual source form is indented like the original source, but is marked by a -preceding \code{==>} line. This is like the "macroexpands to" notation used in -\cltl. - -\item -The explanation is prefixed with the error severity (\pxlref{error-severity}), either \code{Error:}, \code{Warning:}, or \code{Note:}. -\end{itemize} - - -Each part of the error message is more specific than the preceding one. If -consecutive error messages are for nearby locations, then the front part of the -error messages would be the same. In this case, the compiler omits as much of -the second message as in common with the first. For example: -\begin{example} -File: /usr/me/stuff.lisp - -In: DEFUN FOO - (ZOQ Y) ---> ROQ -==> - (PLOQ (+ Y 3)) -Warning: Undefined function: PLOQ - -==> - (ROQ (PLOQ (+ Y 3))) -Warning: Undefined function: ROQ -\end{example} -In this example, the file, definition and original source are identical for the -two messages, so the compiler omits them in the second message. If consecutive -messages are entirely identical, then the compiler prints only the first -message, followed by: -\begin{example} -[Last message occurs \var{repeats} times] -\end{example} -where \var{repeats} is the number of times the message was given. - -If the source was not from a file, then no file line is printed. If the actual -source is the same as the original source, then the processing path and actual -source will be omitted. If no forms intervene between the original source and -the actual source, then the processing path will also be omitted. - - -\node The Original and Actual Source, The Processing Path, The Parts of the Error Message, Interpreting Error Messages -\subsection{The Original and Actual Source} -\cindex{original source} -\cindex{actual source} - -The \i{original source} displayed will almost always be a list. If the actual -source for an error message is a symbol, the original source will be the -immediately enclosing evaluated list form. So even if the offending symbol -does appear in the original source, the compiler will print the enclosing list -and then print the symbol as the actual source (as though the symbol were -introduced by a macro.) - -When the \i{actual source} is displayed (and is not a symbol), it will always -be code that resulted from the expansion of a macro or a source-to-source -compiler optimization. This is code that did not appear in the original -source program; it was introduced by the compiler. - -Keep in mind that when the compiler displays a source form in an error message, -it always displays the most specific (innermost) responsible form. For -example, compiling this function: -\begin{lisp} -(defun bar (x) - (let (a) - (declare (fixnum a)) - (setq a (foo x)) - a)) -\end{lisp} -Gives this error message: -\begin{example} -In: DEFUN BAR - (LET (A) (DECLARE (FIXNUM A)) (SETQ A (FOO X)) A) -Warning: The binding of A is not a FIXNUM: - NIL -\end{example} -This error message is not saying "there's a problem somewhere in this \code{let}" -\dash{} it is saying that there is a problem with the \code{let} itself. In this -example, the problem is that \code{a}'s \false{} initial value is not a \code{fixnum}. - - -\node The Processing Path, Error Severity, The Original and Actual Source, Interpreting Error Messages -\subsection{The Processing Path} -\cindex{processing path} -\cindex{macroexpansion} -\cindex{source-to-source transformation} - -The processing path is mainly useful for debugging macros, so if you don't -write macros, you can ignore the processing path. Consider this example: -\begin{lisp} -(defun foo (n) - (dotimes (i n *undefined*))) -\end{lisp} -Compiling results in this error message: -\begin{example} -In: DEFUN FOO - (DOTIMES (I N *UNDEFINED*)) ---> DO BLOCK LET TAGBODY RETURN-FROM -==> - (PROGN *UNDEFINED*) -Warning: Undefined variable: *UNDEFINED* -\end{example} -Note that \code{do} appears in the processing path. This is because \code{dotimes} -expands into: -\begin{lisp} -(do ((i 0 (1+ i)) (#:g1 n)) - ((>= i #:g1) *undefined*) - (declare (type unsigned-byte i))) -\end{lisp} -The rest of the processing path results from the expansion of \code{do}: -\begin{lisp} -(block nil - (let ((i 0) (#:g1 n)) - (declare (type unsigned-byte i)) - (tagbody (go #:g3) - #:g2 (psetq i (1+ i)) - #:g3 (unless (>= i #:g1) (go #:g2)) - (return-from nil (progn *undefined*))))) -\end{lisp} -In this example, the compiler descended into the \code{block}, \code{let}, -\code{tagbody} and \code{return-from} to reach the \code{progn} printed as the actual -source. This is a place where the "actual source appears in explanation" rule -was applied. The innermost actual source form was the symbol \code{*undefined*} -itself, but that also appeared in the explanation, so the compiler backed out -one level. - - -\node Error Severity, Errors During Macroexpansion, The Processing Path, Interpreting Error Messages -\subsection{Error Severity} -\label{error-severity} -\cindex{severity of compiler errors} -\cindex{compiler error severity} - -There are three levels of compiler error severity: -\begin{description} - -\item[Error] -This severity is used when the compiler encounters a problem serious enough -to prevent normal processing of a form. Instead of compiling the form, the -compiler compiles a call to \code{error}. Errors are used mainly for signalling -syntax errors. If an error happens during macroexpansion, the compiler will -handle it. The compiler also handles and attempts to proceed from read errors. - -\item[Warning] -Warnings are used when the compiler can prove that something bad will happen -if a portion of the program is executed, but the compiler can proceed by -compiling code that signals an error at runtime if the problem has not been -fixed: -\begin{itemize} - -\item -Violation of type declarations, or - -\item -Function calls that have the wrong number of arguments or malformed keyword -argument lists, or - -\item -Referencing a variable declared \code{ignore}, or unrecognized declaration -specifiers. -\end{itemize} - -In the language of the \clisp{} standard, these are situations where the compiler -can determine that a situation with undefined consequences or that would cause -an error to be signalled would result at runtime. - -\item[Note] -Notes are used when there is something that seems a bit odd, but that might -reasonably appear in correct programs. -\end{description} -Note that the compiler does not fully conform to the proposed X3J13 -"compiler-diagnostics" cleanup. Errors, warnings and notes mostly correspond -to errors, warnings and style-warnings, but many things that the cleanup -considers to be style-warnings are printed as warnings rather than notes. -Also, warnings, style-warnings and most errors aren't really signalled using -the condition system. - - -\node Errors During Macroexpansion, Read Errors, Error Severity, Interpreting Error Messages -\subsection{Errors During Macroexpansion} -\cpsubindex{macroexpansion}{errors during} - -The compiler handles errors that happen during macroexpansion, turning them -into compiler errors. If you want to debug the error (to debug a macro), you -can set \code{*break-on-signals*} to \code{error}. For example, this definition: -\begin{lisp} -(defun foo (e l) - (do ((current l (cdr current)) - ((atom current) nil)) - (when (eq (car current) e) (return current)))) -\end{lisp} -gives this error: -\begin{example} -In: DEFUN FOO - (DO ((CURRENT L #) (# NIL)) (WHEN (EQ # E) (RETURN CURRENT)) ) -Error: (during macroexpansion) - -Error in function LISP::DO-DO-BODY. -DO step variable is not a symbol: (ATOM CURRENT) -\end{example} - - - -\node Read Errors, Error Message Parameterization, Errors During Macroexpansion, Interpreting Error Messages -\subsection{Read Errors} -\cpsubindex{read errors}{compiler} - -The compiler also handles errors while reading the source. For example: -\begin{example} -Error: Read error at 2: - "(,/\back foo)" -Error in function LISP::COMMA-MACRO. -Comma not inside a backquote. -\end{example} -The "\code{at 2}" refers to the character position in the source file at -which the error was signalled, which is generally immediately after the -erroneous text. The next line, "\code{(,/\back foo)}", is the line in -the source that contains the error file position. The "\code{/\back }" -indicates the error position within that line (in this example, -immediately after the offending comma.) - -When in \hemlock{} (or any other EMACS-like editor), you can go to a -character position with: -\begin{example} -M-< C-u \var{position} C-f -\end{example} -Note that if the source is from a \hemlock{} buffer, then the position -is relative to the start of the compiled region or \code{defun}, not the -file or buffer start. - -After printing a read error message, the compiler attempts to recover from the -error by backing up to the start of the enclosing top-level form and reading -again with \code{*read-suppress*} true. If the compiler can recover from the -error, then it substitutes a call to \code{cerror} for the unreadable form and -proceeds to compile the rest of the file normally. - -If there is a read error when the file position is at the end of the file -(i.e., an unexpected EOF error), then the error message looks like this: -\begin{example} -Error: Read error in form starting at 14: - "(defun test ()" -Error in function LISP::FLUSH-WHITESPACE. -EOF while reading #<Stream for file "/usr/me/test.lisp"> -\end{example} -In this case, "\code{starting at 14}" indicates the character position at which -the compiler started reading, i.e. the position before the start of the form -that was missing the closing delimiter. The line \w{"\code{(defun test ()}"} is -first line after the starting position that the compiler thinks might contain -the unmatched open delimiter. - - -\node Error Message Parameterization, , Read Errors, Interpreting Error Messages -\subsection{Error Message Parameterization} -\cpsubindex{error messages}{verbosity} -\cpsubindex{verbosity}{of error messages} - -There is some control over the verbosity of error messages. See also -\varref{undefined-warning-limit}, \code{*efficiency-note-limit*} and -\varref{efficiency-note-cost-threshold}. - -\defvar{enclosing-source-cutoff} -This variable specifies the number -of enclosing actual source forms that are printed in full, rather -than in the abbreviated processing path format. Increasing the value -from its default of \code{1} allows you to see more of the guts of -the macroexpanded source, which is useful when debugging macros. -\enddefvar - -\defvar{error-print-length} -\defvarx{error-print-level} -These variables are the print level and print length used in printing -error messages. The default values are \code{5} and \code{3}. If -null, the global values of \code{*print-level*} and -\code{*print-length*} are used. -\enddefvar - -\defmac{def-source-context}[extensions] - {name lambda-list \mstar{form}} -This macro defines how to extract an abbreviated source context from the -\var{name}d form when it appears in the compiler input. -\var{lambda-list} is a \code{defmacro} style lambda-list used to parse -the arguments. The \var{body} should return a list of subforms -that can be printed on about one line. There are predefined -methods for \code{defstruct}, \code{defmethod}, etc. If no method is -defined, then the first two subforms are returned. Note that this -facility implicitly determines the string name associated with -anonymous functions. -\enddefmac - - -\node Types in Python, Getting Existing Programs to Run, Interpreting Error Messages, The Compiler -\section{Types in Python} -\cpsubindex{types}{in python} - -A big difference between \Python{} and all other \llisp{} compilers -is the approach to type checking and amount of knowledge about types: -\begin{itemize} - -\item -\Python{} treats type declarations much differently that other Lisp -compilers do. \Python{} doesn't blindly believe type declarations; it -considers them assertions about the program that should be checked. - -\item -\Python{} also has a tremendously greater knowledge of the \clisp{} type system than -other compilers. Support is incomplete only for the \code{not}, \code{and} and -\code{satisfies} types. -\end{itemize} -See also sections \ref{advanced-type-stuff} and \ref{type-inference}. - - -\begin{menu} -* Compile Time Type Errors:: -* Precise Type Checking:: -* Weakened Type Checking:: -\end{menu} - -\node Compile Time Type Errors, Precise Type Checking, Types in Python, Types in Python -\subsection{Compile Time Type Errors} -\cindex{compile time type errors} -\cpsubindex{type checking}{at compile time} - -If the compiler can prove at compile time that some portion of the program -cannot be executed without a type error, then it will give a warning at compile -time. It is possible that the offending code would never actually be executed -at run-time due to some higher level consistency constraint unknown to the -compiler, so a type warning doesn't always indicate an incorrect program. For -example, consider this code fragment: -\begin{lisp} -(defun raz (foo) - (let ((x (case foo - (:this 13) - (:that 9) - (:the-other 42)))) - (declare (fixnum x)) - (foo x))) -\end{lisp} -Compilation produces this warning: -\begin{example} -In: DEFUN RAZ - (CASE FOO (:THIS 13) (:THAT 9) (:THE-OTHER 42)) ---> LET COND IF COND IF COND IF -==> - (COND) -Warning: This is not a FIXNUM: - NIL -\end{example} -In this case, the warning is telling you that if \code{foo} isn't any of -\code{:this}, \code{:that} or \code{:the-other}, then \code{x} will be initialized to -\false, which the \code{fixnum} declaration makes illegal. The warning will go -away if \code{ecase} is used instead of \code{case}, or if \code{:the-other} is changed -to \true. - -This sort of spurious type warning happens moderately often in the expansion -of complex macros and in inline functions. In such cases, there may be dead -code that is impossible to correctly execute. The compiler can't always prove -this code is dead (could never be executed), so it compiles the erroneous code -(which will always signal an error if it is executed) and gives a warning. - -\defun{required-argument}[extensions]{} -This function can be used as the default value for keyword arguments that must -always be supplied. Since it is known by the compiler to never return, it will -avoid any compile-time type warnings that would result from a default value -inconsistent with the declared type. When this function is called, it signals -an error indicating that a required keyword argument was not supplied. This -function is also useful for \code{defstruct} slot defaults corresponding to -required arguments. \xlref{empty-type}. - -Although this function is a CMU extension, it is relatively harmless to use it -in otherwise portable code, since you can easily define it yourself: -\begin{lisp} -(defun required-argument () - (error "A required keyword argument was not supplied.")) -\end{lisp} -\enddefun - -Type warnings are inhibited when the \code{extensions:inhibit-warnings} -optimization quality is \code{3} (\pxlref{compiler-policy}.) This can be -used in a local declaration to inhibit type warnings in a code fragment that -has spurious warnings. - - -\node Precise Type Checking, Weakened Type Checking, Compile Time Type Errors, Types in Python -\subsection{Precise Type Checking} -\label{precise-type-checks} -\cindex{precise type checking} -\cpsubindex{type checking}{precise} - -With the default compilation policy, all type assertions\footnote{There are a few -circumstances where a type declaration is discarded rather than being used as -type assertion. This doesn't affect safety much, since such discarded -declarations are also not believed to be true by the compiler.} are precisely -checked. Precise checking means that the check is done as though \code{typep} had -been called with the exact type specifier that appeared in the declaration. -\Python{} uses \var{policy} to determine whether to trust type assertions -(\pxlref{compiler-policy}). Type assertions from declarations are -indistinguishable from the type assertions on arguments to built-in functions. -In \Python, adding type declarations makes code safer. - -If a variable is declared to be \w{\code{(integer 3 17)}}, then its value must -always always be an integer between \code{3} and \code{17}. If multiple type -declarations apply to a single variable, then all the declarations must be -correct; it is as though all the types were intersected producing a single -\code{and} type specifier. - -Argument type declarations are automatically enforced. If you declare the type -of a function argument, a type check will be done when that function is called. -In a function call, the called function does the argument type checking, which -means that a more restrictive type assertion in the calling function (e.g., -from \code{the}) may be lost. - -The types of structure slots are also checked. The value of a -structure slot must always be of the type indicated in any -\code{:type} slot option.\footnote{The initial value need not be of -this type as long as the corresponding argument to the constructor is -always supplied, but this will cause a compile-time type warning -unless \code{required-argument} is used.} Because of precise type -checking, the arguments to slot accessors are checked to be the -correct type of structure. - -In traditional \llisp{} compilers, not all type assertions are checked, and type -checks are not precise. Traditional compilers blindly trust explicit type -declarations, but may check the argument type assertions for built-in -functions. Type checking is not precise, since the argument type checks will -be for the most general type legal for that argument. In many systems, type -declarations suppress what little type checking is being done, so adding type -declarations makes code unsafe. This is a problem since it discourages -writing type declarations during initial coding. In addition to being more -error prone, adding type declarations during tuning also loses all the benefits -of debugging with checked type assertions. - -To gain maximum benefit from \Python{}'s type checking, you should always declare -the types of function arguments and structure slots as precisely as possible. -This often involves the use of \code{or}, \code{member} and other list-style type -specifiers. Paradoxically, even though adding type declarations introduces -type checks, it usually reduces the overall amount of type checking. This is -especially true for structure slot type declarations. - -\Python{} uses the \code{safety} optimization quality (rather than presence or -absence of declarations) to choose one of three levels of run-time type error -checking: \pxlref{optimize-declaration}. \xlref{advanced-type-stuff} for more information about types in \Python. - - -\node Weakened Type Checking, , Precise Type Checking, Types in Python -\subsection{Weakened Type Checking} -\label{weakened-type-checks} -\cindex{weakened type checking} -\cpsubindex{type checking}{weakened} - -When the value for the \code{speed} optimization quality is greater than -\code{safety}, and \code{safety} is not \code{0}, then type checking is weakened to -reduce the speed and space penalty. In structure-intensive code this can -double the speed, yet still catch most type errors. Weakened type checks -provide a level of safety similar to that of "safe" code in other \llisp{} -compilers. - -A type check is weakened by changing the check to be for some -convenient supertype of the asserted type. For example, -\code{\w{(integer 3 17)}} is changed to \code{fixnum}, -\code{\w{(simple-vector 17)}} to \code{simple-vector}, and structure -types are changed to \code{structure}. A complex check like: -\begin{example} -(or node hunk (member :foo :bar :baz)) -\end{example} -will be omitted entirely (i.e., the check is weakened to \code{*}.) If -a precise check can be done for no extra cost, then no weakening is -done. - -Although weakened type checking is similar to type checking done by other -compilers, it is sometimes safer and sometimes less safe. Weakened checks are -done in the same places is precise checks, so all the preceding discussion -about where checking is done still applies. Weakened checking is sometimes -somewhat unsafe because although the check is weakened, the precise type is -still input into type inference. In some contexts this will result in type -inferences not justified by the weakened check, and hence deletion of some type -checks that would be done by conventional compilers. - -For example, if this code was compiled with weakened checks: -\begin{lisp} -(defstruct foo - (a nil :type simple-string)) - -(defstruct bar - (a nil :type single-float)) - -(defun myfun (x) - (declare (type bar x)) - (* (bar-a x) 3.0)) -\end{lisp} -and \code{myfun} was passed a \code{foo}, then no type error would be signalled, and -we would try to multiply a \code{simple-vector} as though it were a float (with -unpredictable results.) This is because the check for \code{bar} was weakened to -\code{structure}, yet when compiling the call to \code{bar-a}, the compiler thinks it -knows it has a \code{bar}. - -Note that normally even weakened type checks report the precise type in error -messages. For example, if \code{myfun}'s \code{bar} check is weakened to -\code{structure}, and the argument is \false{}, then the error will be: -\begin{example} -Type-error in MYFUN: - NIL is not of type BAR -\end{example} -However, there is some speed and space cost for signalling a precise error, so -the weakened type is reported if the \code{speed} optimization quality is \code{3} or -\code{debug} quality is less than \code{1}: -\begin{example} -Type-error in MYFUN: - NIL is not of type STRUCTURE -\end{example} -\xlref{optimize-declaration} for further discussion of the -\code{optimize} declaration. - - -\node Getting Existing Programs to Run, Compiler Policy, Types in Python, The Compiler -\section{Getting Existing Programs to Run} -\cpsubindex{existing programs}{to run} -\cpsubindex{types}{portability} -\cindex{compatibility with other Lisps} - -Since \Python{} does much more comprehensive type checking than other Lisp -compilers, \Python{} will detect type errors in many programs that have been -debugged using other compilers. These errors are mostly incorrect -declarations, although compile-time type errors can find actual bugs if parts -of the program have never been tested. - -Some incorrect declarations can only be detected by run-time type checking. It -is very important to initially compile programs with full type checks and then -test this version. After the checking version has been tested, then you can -consider weakening or eliminating type checks. \b{This applies even to -previously debugged programs.} \Python{} does much more type inference than -other \llisp{} compilers, so believing an incorrect declaration does much more -damage. - -The most common problem is with variables whose initial value doesn't match the -type declaration. Incorrect initial values will always be flagged by a -compile-time type error, and they are simple to fix once located. Consider -this code fragment: -\begin{example} -(prog (foo) - (declare (fixnum foo)) - (setq foo ...) - ...) -\end{example} -Here the variable \code{foo} is given an initial value of \false, but is declared -to be a \code{fixnum}. Even if it is never read, the initial value of a variable -must match the declared type. There are two ways to fix this problem. Change -the declaration: -\begin{example} -(prog (foo) - (declare (type (or fixnum null) foo)) - (setq foo ...) - ...) -\end{example} -or change the initial value: -\begin{example} -(prog ((foo 0)) - (declare (fixnum foo)) - (setq foo ...) - ...) -\end{example} -It is generally preferable to change to a legal initial value rather than to -weaken the declaration, but sometimes it is simpler to weaken the -declaration than to try to make an initial value of the appropriate type. - - -Another declaration problem occasionally encountered is incorrect declarations -on \code{defmacro} arguments. This probably usually happens when a function is -converted into a macro. Consider this macro: -\begin{lisp} -(defmacro my-1+ (x) - (declare (fixnum x)) - `(the fixnum (1+ ,x))) -\end{lisp} -Although legal and well-defined \clisp, this meaning of this definition is -almost certainly not what the writer intended. For example, this call is -illegal: -\begin{lisp} -(my-1+ (+ 4 5)) -\end{lisp} -The call is illegal because the argument to the macro is \w{\code{(+ 4 5)}}, which -is a \code{list}, not a \code{fixnum}. Because of macro semantics, it is hardly ever -useful to declare the types of macro arguments. If you really want to assert -something about the type of the result of evaluating a macro argument, then put -a \code{the} in the expansion: -\begin{lisp} -(defmacro my-1+ (x) - `(the fixnum (1+ (the fixnum ,x)))) -\end{lisp} -In this case, it would be stylistically preferable to change this macro back to -a function and declare it inline. Macros have no efficiency advantage over -inline functions when using \Python. \xlref{inline-expansion}. - - -Some more subtle problems are caused by incorrect declarations that can't be -detected at compile time. Consider this code: -\begin{example} -(do ((pos 0 (position #\back a string :start (1+ pos)))) - ((null pos)) - (declare (fixnum pos)) - ...) -\end{example} -Although \code{pos} is almost always a \code{fixnum}, it is \false{} at the end of the -loop. If this example is compiled with full type checks (the default), then -running it will signal a type error at the end of the loop. If compiled -without type checks, the program will go into an infinite loop (or perhaps -\code{position} will complain because \w{\code{(1+ nil)}} isn't a sensible start.) -Why? Because if you compile without type checks, the compiler just quietly -believes the type declaration. Since \code{pos} is always a \code{fixnum}, it is -never \nil, so \w{\code{(null pos)}} is never true, and the loop exit test is -optimized away. Such errors are sometimes flagged by unreachable code notes -(\pxlref{dead-code-notes}), but it is still important to initially compile -any system with full type checks, even if the system works fine when compiled -using other compilers. - -In this case, the fix is to weaken the type declaration to -\w{\code{(or fixnum null)}}.\footnote{Actually, this declaration is totally -unnecessary in \Python, since it already knows \code{position} returns a -non-negative \code{fixnum} or \false.} Note that there is usually little -performance penalty for weakening a declaration in this way. Any numeric -operations in the body can still assume the variable is a \code{fixnum}, since -\false{} is not a legal numeric argument. Another possible fix would be to say: -\begin{example} -(do ((pos 0 (position #\back a string :start (1+ pos)))) - ((null pos)) - (let ((pos pos)) - (declare (fixnum pos)) - ...)) -\end{example} -This would be preferable in some circumstances, since it would allow a -non-standard representation to be used for the local \code{pos} variable in the -loop body (see section \ref{ND-variables}.) - -In summary, remember that \var{all} values that a variable \var{ever} has must be -of the declared type, and that you should test using safe code initially. - - -\node Compiler Policy, Open Coding and Inline Expansion, Getting Existing Programs to Run, The Compiler -\section{Compiler Policy} -\label{compiler-policy} -\cpsubindex{policy}{compiler} -\cindex{compiler policy} - -The policy is what tells the compiler \var{how} to compile a program. This is -logically (and often textually) distinct from the program itself. Broad -control of policy is provided by the \code{optimize} declaration; other -declarations and variables control more specific aspects of compilation. - - -\begin{menu} -* The Optimize Declaration:: -* The Optimize-Interface Declaration:: -\end{menu} - -\node The Optimize Declaration, The Optimize-Interface Declaration, Compiler Policy, Compiler Policy -\subsection{The Optimize Declaration} -\label{optimize-declaration} -\cindex{optimize declaration} -\cpsubindex{declarations}{\code{optimize}} - -The \code{optimize} declaration recognizes six different \var{qualities}. The -qualities are conceptually independent aspects of program performance. In -reality, increasing one quality tends to have adverse effects on other -qualities. The compiler compares the relative values of qualities when it -needs to make a trade-off; i.e., if \code{speed} is greater than \code{safety}, then -improve speed at the cost of safety. - -The default for all qualities (except \code{debug}) is \code{1}. Whenever -qualities are equal, ties are broken according to a broad idea of what a good -default environment is supposed to be. Generally this downplays \code{speed}, -\code{compile-speed} and \code{space} in favor of \code{safety} and \code{debug}. -Novice and casual users should stick to the default policy. Advanced users -often want to improve speed and memory usage at the cost of safety and -debuggability. - -If the value for a quality is \code{0} or \code{3}, then it may have a special -interpretation. A value of \code{0} means "totally unimportant", and a \code{3} -means "ultimately important." These extreme optimization values enable -"heroic" compilation strategies that are not always desirable and sometimes -self-defeating. Specifying more than one quality as \code{3} is not desirable, -since it doesn't tell the compiler which quality is most important. - - -These are the optimization qualities: -\begin{description} - -\item[\code{speed}] -\cindex{speed optimization quality}How fast the program should is run. -\code{speed 3} enables some optimizations that hurt debuggability. - -\item[\code{compilation-speed}] -\cindex{compilation-speed optimization quality}How fast the compiler should -run. Note that increasing this above \code{safety} weakens type checking. - -\item[\code{space}] -\cindex{space optimization quality}How much space the compiled code should take -up. Inline expansion is mostly inhibited when \code{space} is greater than -\code{speed}. A value of \code{0} enables promiscuous inline expansion. Wide use of -a \code{0} value is not recommended, as it may waste so much space that run time -is slowed. \xlref{inline-expansion} for a discussion of inline -expansion. - -\item[\code{debug}] -\cindex{debug optimization quality}How debuggable the program should be. The -quality is treated differently from the other qualities: each value indicates a -particular level of debugger information; it is not compared with the other -qualities. \xlref{debugger-policy} for more details. - -\item[\code{safety}] -\cindex{safety optimization quality}How much error checking should be done. If -\code{speed}, \code{space} or \code{compilation-speed} is more important than -\code{safety}, then type checking is weakened (\pxlref{weakened-type-checks}). If \code{safety} if \code{0}, then no run time error -checking is done. In addition to suppressing type checks, \code{0} also -suppresses argument count checking, unbound-symbol checking and array bounds -checks. - -\item[\code{extensions:inhibit-warnings}] -\cindex{inhibit-warnings optimization quality}This is a CMU extension that -determines how little (or how much) diagnostic output should be printed during -compilation. This quality is compared to other qualities to determine whether -to print style notes and warnings concerning those qualities. If \code{speed} is -greater than \code{inhibit-warnings}, then notes about how to improve speed will -be printed, etc. The default value is \code{1}, so raising the value for any -standard quality above its default enables notes for that quality. If -\code{inhibit-warnings} is \code{3}, then all notes and most non-serious warnings are -inhibited. This is useful with \code{declare} to suppress warnings about -unavoidable problems. -\end{description} - -\node The Optimize-Interface Declaration, , The Optimize Declaration, Compiler Policy -\subsection{The Optimize-Interface Declaration} -\label{optimize-interface-declaration} -\cindex{optimize-interface declaration} -\cpsubindex{declarations}{\code{optimize-interface}} - -The \code{extensions:optimize-interface} declaration is identical in syntax to the -\code{optimize} declaration, but it specifies the policy used during compilation -of code the compiler automatically generates to check the number and type of -arguments supplied to a function. It is useful to specify this policy -separately, since even thoroughly debugged functions are vulnerable to being -passed the wrong arguments. The \code{optimize-interface} declaration can specify -that arguments should be checked even when the general \code{optimize} policy is -unsafe. - -Note that this argument checking is the checking of user-supplied arguments to -any functions defined within the scope of the declaration, \code{not} the checking -of arguments to \llisp{} primitives that appear in those definitions. - -The idea behind this declaration is that it allows the definition of functions -that appear fully safe to other callers, but that do no internal error -checking. Of course, it is possible that arguments may be invalid in ways -other than having incorrect type. Functions compiled unsafely must still -protect themselves against things like user-supplied array indices that are out -of bounds and improper lists. See also the \kwd{context-declarations} option -to \macref{with-compilation-unit}. - - -\node Open Coding and Inline Expansion, , Compiler Policy, The Compiler -\section{Open Coding and Inline Expansion} -\label{open-coding} -\cindex{open-coding} -\cindex{inline expansion} -\cindex{static functions} - -Since \clisp{} forbids the redefinition of standard functions\footnote{See the -proposed X3J13 "lisp-symbol-redefinition" cleanup.}, the compiler can have -special knowledge of these standard functions embedded in it. This special -knowledge is used in various ways (open coding, inline expansion, source -transformation), but the implications to the user are basically the same: -\begin{itemize} - -\item -Attempts to redefine standard functions may be frustrated, since the function -may never be called. Although it is technically illegal to redefine standard -functions, users sometimes want to implicitly redefine these functions when -they are debugging using the \code{trace} macro. Special-casing of standard -functions can be inhibited using the \code{notinline} declaration. - -\item -The compiler can have multiple alternate implementations of standard functions -that implement different trade-offs of speed, space and safety. This selection -is based on the compiler policy, \pxlref{compiler-policy}. -\end{itemize} - - -When a function call is \i{open coded}, inline code whose effect is -equivalent to the function call is substituted for that function call. -When a function call is \i{closed coded}, it is usually left as is, -although it might be turned into a call to a different function with -different arguments. As an example, if \code{nthcdr} were to be open -coded, then -\begin{lisp} -(nthcdr 4 foobar) -\end{lisp} -might turn into -\begin{lisp} -(cdr (cdr (cdr (cdr foobar)))) -\end{lisp} -or even -\begin{lisp} -(do ((i 0 (1+ i)) - (list foobar (cdr foobar))) - ((= i 4) list)) -\end{lisp} - -If \code{nth} is closed coded, then -\begin{lisp} -(nth x l) -\end{lisp} -might stay the same, or turn into something like: -\begin{lisp} -(car (nthcdr x l)) -\end{lisp} - -In general, open coding sacrifices space for speed, but some functions (such as -\code{car}) are so simple that they are always open-coded. Even when not -open-coded, a call to a standard function may be transformed into a different -function call (as in the last example) or compiled as \i{static call}. Static -function call uses a more efficient calling convention that forbids -redefinition. - -\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/efficiency.ms} - - - -\hide{ -*- Dictionary: cmu-user -*- } -\node Advanced Compiler Use and Efficiency Hints, UNIX Interface, The Compiler, Top -\chapter{Advanced Compiler Use and Efficiency Hints} -\begin{center} -\b{By Robert MacLachlan} -\end{center} -\vspace{1 cm} -\label{advanced-compiler} - -\begin{menu} -* Advanced Compiler Introduction:: -* More About Types in Python:: -* Type Inference:: -* Source Optimization:: -* Tail Recursion:: -* Local Call:: -* Block Compilation:: -* Inline Expansion:: -* Object Representation:: -* Numbers:: -* General Efficiency Hints:: -* Efficiency Notes:: -* Profiling:: -\end{menu} - -\node Advanced Compiler Introduction, More About Types in Python, Advanced Compiler Use and Efficiency Hints, Advanced Compiler Use and Efficiency Hints -\section{Advanced Compiler Introduction} - -In \cmucl, as is any language on any computer, the path to efficient code -starts with good algorithms and sensible programming techniques, but to avoid -inefficiency pitfalls, you need to know some of this implementation's quirks -and features. This chapter is mostly a fairly long and detailed overview of -what optimizations \python{} does. Although there are the usual negative -suggestions of inefficient features to avoid, the main emphasis is on -describing the things that programmers can count on being efficient. - -The optimizations described here can have the effect of speeding up existing -programs written in conventional styles, but the potential for new programming -styles that are clearer and less error-prone is at least as significant. For -this reason, several sections end with a discussion of the implications of -these optimizations for programming style. - -\begin{menu} -* Types:: -* Optimization:: -* Function Call:: -* Representation of Objects:: -* Writing Efficient Code:: -\end{menu} - -\node Types, Optimization, Advanced Compiler Introduction, Advanced Compiler Introduction -\subsection{Types} - -Python's support for types is unusual in three major ways: -\begin{itemize} - -\item -Precise type checking encourages the specific use of type declarations as a -form of run-time consistency checking. This speeds development by localizing -type errors and giving more meaningful error messages. \xlref{precise-type-checks}. \python{} produces completely safe code; optimized -type checking maintains reasonable efficiency on conventional hardware (\pxlref{type-check-optimization}.) - -\item -Comprehensive support for the \clisp{} type system makes complex type specifiers -useful. Using type specifiers such as \code{or} and \code{member} has both -efficiency and robustness advantages. \xlref{advanced-type-stuff}. - -\item -Type inference eliminates the need for some declarations, and also aids -compile-time detection of type errors. Given detailed type declarations, type -inference can often eliminate type checks and enable more efficient object -representations and code sequences. Checking all types results in -fewer type checks. See sections \ref{type-inference} and -\ref{non-descriptor}. -\end{itemize} - - -\node Optimization, Function Call, Types, Advanced Compiler Introduction -\subsection{Optimization} - -The main barrier to efficient Lisp programs is not that there is no efficient -way to code the program in Lisp, but that it is difficult to arrive at that -efficient coding. Common Lisp is a highly complex language, and usually has -many semantically equivalent "reasonable" ways to code a given problem. It is -desirable to make all of these equivalent solutions have comparable efficiency -so that programmers don't have to waste time discovering the most efficient -solution. - -Source level optimization increases the number of efficient ways to solve a -problem. This effect is much larger than the increase in the efficiency of the -"best" solution. Source level optimization transforms the original program -into a more efficient (but equivalent) program. Although the optimizer isn't -doing anything the programmer couldn't have done, this high-level optimization -is important because: -\begin{itemize} - -\item -The programmer can code simply and directly, rather than obfuscating code to -please the compiler. - -\item -When presented with a choice of similar coding alternatives, the programmer can -chose whichever happens to be most convenient, instead of worrying about which -is most efficient. -\end{itemize} - -Source level optimization eliminates the need for macros to optimize their -expansion, and also increases the effectiveness of inline expansion. -See sections \ref{source-optimization} and \ref{inline-expansion}. - -Efficient support for a safer programming style is the biggest advantage of -source level optimization. Existing tuned programs typically won't benefit -much from source optimization, since their source has already been optimized by -hand. However, even tuned programs tend to run faster under \python{} because: -\begin{itemize} - -\item -Low level optimization and register allocation provides modest speedups in any -program. - -\item -Block compilation and inline expansion can reduce function call overhead, -but may require some program restructuring. See sections -\ref{inline-expansion}, \ref{local-call} and \ref{block-compilation}. - -\item -Efficiency notes will point out important type declarations that are often -missed even in highly tuned programs. \xlref{efficiency-notes}. - -\item -Existing programs can be compiled safely without prohibitive speed penalty, -although they would be faster and safer with added declarations. \xlref{type-check-optimization}. -\end{itemize} - - -\node Function Call, Representation of Objects, Optimization, Advanced Compiler Introduction -\subsection{Function Call} - -The sort of symbolic programs generally written in \llisp{} often favor recursion -over iteration, or have inner loops so complex that they involve multiple -function calls. Such programs spend a larger fraction of their time doing -function calls than is the norm in other languages; for this reason \llisp{} -implementations strive to make the general (or full) function call as -inexpensive as possible. \python{} goes beyond this by providing two good -alternatives to full call: -\begin{itemize} - -\item -Local call resolves function references at compile time, allowing better -calling sequences and optimization across function calls. \xlref{local-call}. - -\item -Inline expansion totally eliminates call overhead and allows many context -dependent optimizations. This provides a safe and efficient implementation of -operations with function semantics, eliminating the need for error-prone macro -definitions or manual case analysis. Although most \clisp{} implementations -support inline expansion, it becomes a more powerful tool with \python{}'s source -level optimization. See sections \ref{source-optimization} and -\ref{inline-expansion}. -\end{itemize} - - -Generally, \python{} provides simple implementations for simple uses of function -call, rather than having only a single calling convention. These features -allow a more natural programming style: -\begin{itemize} - -\item -Proper tail recursion. \xlref{tail-recursion} - -\item -Relatively efficient closures. - -\item -A \code{funcall} that is as efficient as normal named call. - -\item -Calls to local functions such as from \code{labels} are optimized: -\begin{itemize} - -\item -Control transfer is a direct jump. - -\item -The closure environment is passed in registers rather than heap allocated. - -\item -Keyword arguments and multiple values are implemented more efficiently. -\end{itemize} - -\xlref{local-call}. -\end{itemize} - -\node Representation of Objects, Writing Efficient Code, Function Call, Advanced Compiler Introduction -\subsection{Representation of Objects} - -Sometimes traditional \llisp{} implementation techniques compare so poorly to the -techniques used in other languages that \llisp{} can become an impractical -language choice. Terrible inefficiencies appear in number-crunching programs, -since \llisp{} numeric operations often involve number-consing and generic -arithmetic. \python{} supports efficient natural representations for numbers -(and some other types), and allows these efficient representations to be used -in more contexts. \python{} also provides good efficiency notes that warn when a -crucial declaration is missing. - -See section \ref{non-descriptor} for more about object representations and -numeric types. Also \pxlref{efficiency-notes} about efficiency notes. - -\node Writing Efficient Code, , Representation of Objects, Advanced Compiler Introduction -\subsection{Writing Efficient Code} -\label{efficiency-overview} - -Writing efficient code that works is a complex and prolonged process. It is -important not to get so involved in the pursuit of efficiency that you lose -sight of what the original problem demands. Remember that: -\begin{itemize} - -\item -The program should be correct \dash{} it doesn't matter how quickly you get the -wrong answer. - -\item -Both the programmer and the user will make errors, so the program must be -robust \dash{} it must detect errors in a way that allows easy correction. - -\item -A small portion of the program will consume most of the resources, with the -bulk of the code being virtually irrelevant to efficiency considerations. Even -experienced programmers familiar with the problem area cannot reliably predict -where these "hot spots" will be. -\end{itemize} - - - -The best way to get efficient code that is still worth using, is to separate -coding from tuning. During coding, you should: -\begin{itemize} - -\item -Use a coding style that aids correctness and robustness without being -incompatible with efficiency. - -\item -Choose appropriate data structures that allow efficient algorithms and object -representations (\pxlref{object-representation}). Try to make -interfaces abstract enough so that you can change to a different representation -if profiling reveals a need. - -\item -Whenever you make an assumption about a function argument or global data -structure, add consistency assertions, either with type declarations or -explicit uses of \code{assert}, \code{ecase}, etc. -\end{itemize} - -During tuning, you should: -\begin{itemize} - -\item -Identify the hot spots in the program through profiling (section -\ref{profiling}.) - -\item -Identify inefficient constructs in the hot spot with efficiency notes, more -profiling, or manual inspection of the source. See sections -\ref{general-efficiency} and \ref{efficiency-notes}. - -\item -Add declarations and consider the application of optimizations. See sections -\ref{local-call}, \ref{inline-expansion} and \ref{non-descriptor}. - -\item -If all else fails, consider algorithm or data structure changes. If you did a -good job coding, changes will be easy to introduce. -\end{itemize} - - - - -\node More About Types in Python, Type Inference, Advanced Compiler Introduction, Advanced Compiler Use and Efficiency Hints -\section{More About Types in Python} -\label{advanced-type-stuff} -\cpsubindex{types}{in python} - -This section goes into more detail describing what types and declarations are -recognized by \python. The area where \python{} differs most radically from -previous \llisp{} compilers is in its support for types: -\begin{itemize} - -\item -Precise type checking helps to find bugs at run time. - -\item -Compile-time type checking helps to find bugs at compile time. - -\item -Type inference minimizes the need for generic operations, and also increases -the efficiency of run time type checking and the effectiveness of compile time -type checking. - -\item -Support for detailed types provides a wealth of opportunity for -operation-specific type inference and optimization. -\end{itemize} - - - -\begin{menu} -* More Types Meaningful:: -* Canonicalization:: -* Member Types:: -* Union Types:: -* The Empty Type:: -* Function Types:: -* The Values Declaration:: -* Structure Types:: -* The Freeze-Type Declaration:: -* Type Restrictions:: -* Type Style Recommendations:: -\end{menu} - -\node More Types Meaningful, Canonicalization, More About Types in Python, More About Types in Python -\subsection{More Types Meaningful} - -\clisp{} has a very powerful type system, but conventional \llisp{} implementations -typically only recognize the small set of types special in that -implementation. In these systems, there is an unfortunate paradox: a -declaration for a relatively general type like \code{fixnum} will be recognized by -the compiler, but a highly specific declaration such as \code{\w{(integer 3 17)}} -is totally ignored. - -This is obviously a problem, since the user has to know how to specify the type -of an object in the way the compiler wants it. A very minimal (but rarely -satisfied) criterion for type system support is that it be no worse to make a -specific declaration than to make a general one. \python{} goes beyond this by -exploiting a number of advantages obtained from detailed type information. - -Using more restrictive types in declarations allows the compiler to do better -type inference and more compile-time type checking. Also, when type -declarations are considered to be consistency assertions that should be -verified (conditional on policy), then complex types are useful for making more -detailed assertions. - -Python "understands" the list-style \code{or}, \code{member}, \code{function}, array and -number type specifiers. Understanding means that: -\begin{itemize} - -\item -If the type contains more information than is used in a particular context, -then the extra information is simply ignored, rather than derailing type -inference. - -\item -In many contexts, the extra information from these type specifier is used to -good effect. In particular, type checking in \code{Python} is \var{precise}, so -these complex types can be used in declarations to make interesting assertions -about functions and data structures (\pxlref{precise-type-checks}.) -More specific declarations also aid type inference and reduce the cost for -type checking. -\end{itemize} - -For related information, \pxlref{numeric-types} for numeric types, and -section \ref{array-types} for array types. - - -\node Canonicalization, Member Types, More Types Meaningful, More About Types in Python -\subsection{Canonicalization} -\cpsubindex{types}{equivalence} -\cindex{canonicalization of types} -\cindex{equivalence of types} - -When given a type specifier, \python{} will often rewrite it into a different -(but equivalent) type. This is the mechanism that \python{} uses for detecting -type equivalence. For example, in \python{}'s canonical representation, these -types are equivalent: -\begin{example} -(or list (member :end)) \equiv{} (or cons (member nil :end)) -\end{example} -This has two implications for the user: -\begin{itemize} - -\item -The standard symbol type specifiers for \code{atom}, \code{null}, -\code{fixnum}, etc., are in no way magical. The \tindexed{null} type -is actually defined to be \code{\w{(member nil)}}, \tindexed{list} is -\code{\w{(or cons null)}}, and \tindexed{fixnum} is -\code{\w{(signed-byte 30)}}. - -\item -When the compiler prints out a type, it may not look like the type specifier -that originally appeared in the program. This is generally not a problem, but -it must be taken into consideration when reading compiler error messages. -\end{itemize} - - -\node Member Types, Union Types, Canonicalization, More About Types in Python -\subsection{Member Types} -\cindex{member types} - -The \tindexed{member} type specifier can be used to represent -"symbolic" values, analogous to the enumerated types of Pascal. For -example, the second value of \code{find-symbol} has this type: -\begin{lisp} -(member :internal :external :inherited nil) -\end{lisp} -Member types are very useful for expressing consistency constraints on data -structures, for example: -\begin{lisp} -(defstruct ice-cream - (flavor :vanilla :type (member :vanilla :chocolate :strawberry))) -\end{lisp} -Member types are also useful in type inference, as the number of members can -sometimes be pared down to one, in which case the value is a known constant. - -\node Union Types, The Empty Type, Member Types, More About Types in Python -\subsection{Union Types} -\cindex{union (\code{or}) types} -\cindex{or (union) types} - -The \tindexed{or} (union) type specifier is understood, and is -meaningfully applied in many contexts. The use of \code{or} allows -assertions to be made about types in dynamically typed programs. For -example: -\begin{lisp} -(defstruct box - (next nil :type (or box null)) - (top :removed :type (or box-top (member :removed)))) -\end{lisp} -The type assertion on the \code{top} slot ensures that an error will be signalled -when there is an attempt to store an illegal value (such as \code{:rmoved}.) -Although somewhat weak, these union type assertions provide a useful input into -type inference, allowing the cost of type checking to be reduced. For example, -this loop is safely compiled with no type checks: -\begin{lisp} -(defun find-box-with-top (box) - (declare (type (or box null) box)) - (do ((current box (box-next current))) - ((null current)) - (unless (eq (box-top current) :removed) - (return current)))) -\end{lisp} - -Union types are also useful in type inference for representing types that are -partially constrained. For example, the result of this expression: -\begin{lisp} -(if foo - (logior x y) - (list x y)) -\end{lisp} -can be expressed as \code{\w{(or integer cons)}}. - -\node The Empty Type, Function Types, Union Types, More About Types in Python -\subsection{The Empty Type} -\label{empty-type} -\cindex{NIL type} -\cpsubindex{empty type}{the} -\cpsubindex{errors}{result type of} - -The type \false{} is also called the empty type, since no object is -of type \false{}. The union of no types, \code{(or)}, is also empty. -\python{}'s interpretation of an expression whose type is \false{} is -that the expression never yields any value, but rather fails to -terminate, or is thrown out of. For example, the type of a call to -\code{error} or a use of \code{return} is \false{}. When the type of -an expression is empty, compile-time type warnings about its value -are suppressed; presumably somebody else is signalling an error. If -a function is declared to have return type \false{}, but does in fact -return, then (in safe compilation policies) a -\code{"NIL Function returned"} error will be signalled. See also the function -\funref{required-argument}. - -\node Function Types, The Values Declaration, The Empty Type, More About Types in Python -\subsection{Function Types} -\label{function-types} -\cpsubindex{function}{types} -\cpsubindex{types}{function} - -\findexed{function} types are understood in the restrictive sense, specifying: -\begin{itemize} - -\item -The argument syntax that the function must be called with. This is -information about what argument counts are acceptable, and which -keyword arguments are recognized. In \python, warnings about -argument syntax are a consequence of function type checking. - -\item -The types of the argument values that the caller must pass. If the compiler -can prove that some argument to a call is of a type disallowed by the called -function's type, then it will give a compile-time type warning. In addition to -being used for compile-time type checking, these type assertions are also used -as output type assertions in code generation. For example, if \code{foo} is -declared to have a \code{fixnum} argument, then the \code{1+} in \w{\code{(foo (1+ x))}} -is compiled with knowledge that the result must be a fixnum. - -\item -The types the values that will be bound to argument variables in the function's -definition. Declaring a function's type with \code{ftype} implicitly declares the -types of the arguments in the definition. \python{} checks for consistency -between the definition and the \code{ftype} declaration. Because of precise type -checking, an error will be signalled when a function is called with an argument -of the wrong type. - -\item -The type of return value(s) that the caller can expect. This information is a -useful input to type inference. For example, if a function is declared to -return a \code{fixnum}, then when a call to that function appears in an -expression, the expression will be compiled with knowledge that the call will -return a \code{fixnum}. - -\item -The type of return value(s) that the definition must return. The result type -in an \code{ftype} declaration is treated like an implicit \code{the} wrapped around -the body of the definition. If the definition returns a value of the wrong -type, an error will be signalled. If the compiler can prove that the function -returns the wrong type, then it will give a compile-time warning. -\end{itemize} - -This is consistent with the new interpretation of function types and the -\code{ftype} declaration in the proposed X3J13 -"function-type-argument-type-semantics" cleanup. Note also, that if you don't -explicitly declare the type of a function using a global \code{ftype} declaration, -then \python{} will compute a function type from the definition, providing a -degree of inter-routine type inference, \pxlref{function-type-inference}. - -\node The Values Declaration, Structure Types, Function Types, More About Types in Python -\subsection{The Values Declaration} -\cindex{values declaration} - -\cmucl{} supports the \code{values} declaration as an extension to \clisp. The -syntax is \w{\code{(values \i{type1} \i{type2} ... \var{typen})}}. -This declaration is semantically equivalent to a \code{the} form -wrapped around the body of the special form in which the -\code{values} declaration appears. The advantage of \code{values} -over \findexed{the} is purely syntactic \dash{} it doesn't introduce -more indentation. For example: -\begin{example} -(defun foo (x) - (declare (values single-float)) - (ecase x - (:this ...) - (:that ...) - (:the-other ...))) -\end{example} -is equivalent to: -\begin{example} -(defun foo (x) - (the single-float - (ecase x - (:this ...) - (:that ...) - (:the-other ...)))) -\end{example} -and -\begin{example} -(defun floor (number &optional (divisor 1)) - (declare (values integer real)) - ...) -\end{example} -is equivalent to: -\begin{example} -(defun floor (number &optional (divisor 1)) - (the (values integer real) - ...)) -\end{example} -In addition to being recognized by \code{lambda} (and hence by \code{defun}), the -\code{values} declaration is recognized by all the other special forms with bodies -and declarations: \code{let}, \code{let*}, \code{labels} and \code{flet}. Macros with -declarations usually splice the declarations into one of the above forms, so -they will accept this declaration too, but the exact effect of a \code{values} -declaration will depend on the macro. - -If you declare the types of all arguments to a function, and also declare the -return value types with \code{values}, you have described the type of the -function. \python{} will use this argument and result type information to derive -a function type that will then be applied to calls of the function (\pxlref{function-types}.) This provides a way to declare the types of functions -that is much less syntactically awkward than using the \code{ftype} declaration -with a \code{function} type specifier. - -Although the \code{values} declaration is non-standard, it is relatively harmless -to use it in otherwise portable code, since any warning in non-CMU -implementations can be suppressed with the standard \code{declaration} -proclamation. - -\node Structure Types, The Freeze-Type Declaration, The Values Declaration, More About Types in Python -\subsection{Structure Types} -\label{structure-types} -\cindex{structure types} -\cindex{defstruct types} -\cpsubindex{types}{structure} - -Because of precise type checking, structure types are much better supported by -Python than by conventional compilers: -\begin{itemize} - -\item -The structure argument to structure accessors is precisely checked \dash{} if you -call \code{foo-a} on a \code{bar}, an error will be signalled. - -\item -The types of slot values are precisely checked \dash{} if you pass the wrong type -argument to a constructor or a slot setter, then an error will be signalled. -\end{itemize} -This error checking is tremendously useful for detecting bugs in programs that -manipulate complex data structures. - -An additional advantage of checking structure types and enforcing slot types -is that the compiler can safely believe slot type declarations. \python{} -effectively moves the type checking from the slot access to the slot setter or -constructor call. This is more efficient since caller of the setter or -constructor often knows the type of the value, entirely eliminating the need to -check the value's type. Consider this example: -\begin{lisp} -(defstruct coordinate - (x nil :type single-float) - (y nil :type single-float)) - -(defun make-it () - (make-coordinate :x 1.0 :y 1.0)) - -(defun use-it (it) - (declare (type coordinate it)) - (sqrt (expt (coordinate-x it) 2) (expt (coordinate-y it) 2))) -\end{lisp} -\code{make-it} and \code{use-it} are compiled with no checking on the types of the -float slots, yet \code{use-it} can use \code{single-float} arithmetic with perfect -safety. Note that \code{make-coordinate} must still check the values of \code{x} and -\code{y} unless the call is block compiled or inline expanded (\pxlref{local-call}.) But even without this advantage, it is almost always more -efficient to check slot values on structure initialization, since slots are -usually written once and read many times. - -\node The Freeze-Type Declaration, Type Restrictions, Structure Types, More About Types in Python -\subsection{The Freeze-Type Declaration} -\cindex{freeze-type declaration} -\label{freeze-type} - -The \code{extensions:freeze-type} declaration is a CMU extension that enables more -efficient compilation of user-defined types by asserting that the definition is -not going to change. This declaration may only be used globally (with -\code{declaim} or \code{proclaim}). Currently \code{freeze-type} only affects structure -type testing done by \code{typep}, \code{typecase}, etc. Here is an example: -\begin{lisp} -(declaim (freeze-type foo bar)) -\end{lisp} -This asserts that the types \code{foo} and \code{bar} and their subtypes are not -going to change. This allows more efficient type testing, since the compiler -can open-code a test for all possible subtypes, rather than having to examine -the type hierarchy at run-time. - -\node Type Restrictions, Type Style Recommendations, The Freeze-Type Declaration, More About Types in Python -\subsection{Type Restrictions} -\cpsubindex{types}{restrictions on} - -Avoid use of the \code{and}, \code{not} and \code{satisfies} types in declarations, -since type inference has problems with them. When these types do appear in a -declaration, they are still checked precisely, but the type information is of -limited use to the compiler. \code{and} types are effective as long as the -intersection can be canonicalized to a type that doesn't use \code{and}. For -example: -\begin{example} -(and fixnum unsigned-byte) -\end{example} -is fine, since it is the same as: -\begin{example} -(integer 0 \var{most-positive-fixnum}) -\end{example} -but this type: -\begin{example} -(and symbol (not (member :end))) -\end{example} -will not be fully understood by type interference since the \code{and} can't be -removed by canonicalization. - -Using any of these type specifiers in a type test with \code{typep} or -\code{typecase} is fine, since as tests, these types can be translated into the -\code{and} macro, the \code{not} function or a call to the satisfies predicate. - -\node Type Style Recommendations, , Type Restrictions, More About Types in Python -\subsection{Type Style Recommendations} -\cindex{style recommendations} - -Python provides good support for some currently unconventional ways of using -the \clisp{} type system. With \python, it is desirable to make declarations as -precise as possible, but type inference also makes some declarations -unnecessary. Here are some general guidelines for maximum robustness and -efficiency: -\begin{itemize} - -\item -Declare the types of all function arguments and structure slots as precisely as -possible (while avoiding \code{not}, \code{and} and \code{satisfies}). Put these -declarations in during initial coding so that type assertions can find bugs for -you during debugging. - -\item -Use the \tindexed{member} type specifier where there are a small number of possible -symbol values, for example: \w{\code{(member :red :blue :green)}}. - -\item -Use the \tindexed{or} type specifier in situations where the type is -not certain, but there are only a few possibilities, for example: -\w{\code{(or list vector)}}. - -\item -Declare integer types with the tightest bounds that you can, such as -\code{\w{(integer 3 7)}}. - -\item -Define \findexed{deftype} or \findexed{defstruct} types before they -are used. Definition after use is legal (producing no "undefined -type" warnings), but type tests and structure operations will be -compiled much less efficiently. - -\item -In addition to declaring the array element type and simpleness, also declare -the dimensions if they are fixed, for example: -\begin{example} -(simple-array single-float (1024 1024)) -\end{example} -This bounds information allows array indexing for multi-dimensional arrays to -be compiled much more efficiently, and may also allow array bounds checking to -be done at compile time. \xlref{array-types}. - -\item -Avoid use of the \findexed{the} declaration within expressions. Not -only does it clutter the code, but it is also almost worthless under -safe policies. If the need for an output type assertion is revealed -by efficiency notes during tuning, then you can consider \code{the}, but -it is preferable to constrain the argument types more, allowing the -compiler to prove the desired result type. - -\item -Don't bother declaring the type of \findexed{let} or other -non-argument variables unless the type is non-obvious. If you -declare function return types and structure slot types, then the type -of a variable is often obvious both to the programmer and to the -compiler. An important case where the type isn't obvious, and a -declaration is appropriate, is when the value for a variable is -pulled out of untyped structure (e.g., the result of \code{car}), or -comes from some weakly typed function, such as \code{read}. - -\item -Declarations are sometimes necessary for integer loop variables, since the -compiler can't always prove that the value is of a good integer type. These -declarations are best added during tuning, when an efficiency note indicates -the need. -\end{itemize} - - - -\node Type Inference, Source Optimization, More About Types in Python, Advanced Compiler Use and Efficiency Hints -\section{Type Inference} -\label{type-inference} -\cindex{type inference} -\cindex{inference of types} -\cindex{derivation of types} - -Type inference is the process by which the compiler tries to figure out the -types of expressions and variables, given an inevitable lack of complete type -information. Although \python{} does much more type inference than most \llisp{} -compilers, remember that the more precise and comprehensive type declarations -are, the more type inference will be able to do. - -\begin{menu} -* Variable Type Inference:: -* Local Function Type Inference:: -* Global Function Type Inference:: -* Operation Specific Type Inference:: -* Dynamic Type Inference:: -* Type Check Optimization:: -\end{menu} - -\node Variable Type Inference, Local Function Type Inference, Type Inference, Type Inference -\subsection{Variable Type Inference} -\label{variable-type-inference} - -The type of a variable is the union of the types of all the -definitions. In the degenerate case of a let, the type of the -variable is the type of the initial value. This inferred type is -intersected with any declared type, and is then propagated to all the -variable's references. The types of \findexed{multiple-value-bind} -variables are similarly inferred from the types of the individual -values of the values form. - -If multiple type declarations apply to a single variable, then all the -declarations must be correct; it is as though all the types were intersected -producing a single \tindexed{and} type specifier. In this example: -\begin{example} -(defmacro my-dotimes ((var count) &body body) - `(do ((,var 0 (1+ ,var))) - ((>= ,var ,count)) - (declare (type (integer 0 *) ,var)) - ,@body)) - -(my-dotimes (i ...) - (declare (fixnum i)) - ...) -\end{example} -the two declarations for \code{i} are intersected, so \code{i} is known to be a -non-negative fixnum. - -In practice, this type inference is limited to lets and local functions, since -the compiler can't analyze all the calls to a global function. But type -inference works well enough on local variables so that it is often unnecessary -to declare the type of local variables. This is especially likely when -function result types and structure slot types are declared. The main areas -where type inference breaks down are: -\begin{itemize} - -\item -When the initial value of a variable is a untyped expression, such as -\code{\w{(car x)}}, and - -\item -When the type of one of the variable's definitions is a function of the -variable's current value, as in: \code{(setq x (1+ x))} -\end{itemize} - - -\node Local Function Type Inference, Global Function Type Inference, Variable Type Inference, Type Inference -\subsection{Local Function Type Inference} -\cpsubindex{local call}{type inference} - -The types of arguments to local functions are inferred in the same was as any -other local variable; the type is the union of the argument types across -all the calls to the function, intersected with the declared type. If there -are any assignments to the argument variables, the type of the assigned value -is unioned in as well. - -The result type of a local function is computed in a special way that takes -tail recursion (\pxlref{tail-recursion}) into consideration. The -result type is the union of all possible return values that aren't -tail-recursive calls. For example, \python{} will infer that the result type of -this function is \code{integer}: -\begin{lisp} -(defun ! (n res) - (declare (integer n res)) - (if (zerop n) - res - (! (1- n) (* n res)))) -\end{lisp} -Although this is a rather obvious result, it becomes somewhat less trivial in -the presence of mutual tail recursion of multiple functions. Local function -result type inference interacts with the mechanisms for ensuring proper tail -recursion mentioned in section \ref{local-call-return}. - -\node Global Function Type Inference, Operation Specific Type Inference, Local Function Type Inference, Type Inference -\subsection{Global Function Type Inference} -\label{function-type-inference} -\cpsubindex{function}{type inference} - -As described in section \ref{function-types}, a global function type -(\tindexed{ftype}) declaration places implicit type assertions on the call arguments, -and also guarantees the type of the return value. So wherever a call to a -declared function appears, there is no doubt as to the types of the arguments -and return value. Furthermore, \python{} will infer a function type from the -function's definition if there is no \code{ftype} declaration. Any type -declarations on the argument variables are used as the argument types in the -derived function type, and the compiler's best guess for the result type of the -function is used as the result type in the derived function type. - -This method of deriving function types from the definition implicitly assumes -that functions won't be redefined at run-time. Consider this example: -\begin{lisp} -(defun foo-p (x) - (let ((res (and (consp x) (eq (car x) 'foo)))) - (format t "It is ~:[not ~;~]foo." res))) - -(defun frob (it) - (if (foo-p it) - (setf (cadr it) 'yow!) - (1+ it))) -\end{lisp} - -Presumably, the programmer really meant to return \code{res} from \code{foo-p}, but -he seems to have forgotten. When he tries to call do -\code{\w{(frob (list 'foo nil))}}, \code{frob} will flame out when it tries to add to -a \code{cons}. Realizing his error, he fixes \code{foo-p} and recompiles it. But -when he retries his test case, he is baffled because the error is still there. -What happened in this example is that \python{} proved that the result of -\code{foo-p} is \code{null}, and then proceeded to optimize away the \code{setf} in -\code{frob}. - -Fortunately, in this example, the error is detected at compile time due to -notes about unreachable code (\pxlref{dead-code-notes}.) Still, some -users may not want to worry about this sort of problem during incremental -development, so there is a variable to control deriving function types. - -\defvar{derive-function-types}[extensions] -If true (the default), argument and result type information derived from -compilation of \code{defun}s is used when compiling calls to that function. If -false, only information from \code{ftype} proclamations will be used. -\enddefvar - -\node Operation Specific Type Inference, Dynamic Type Inference, Global Function Type Inference, Type Inference -\subsection{Operation Specific Type Inference} -\label{operation-type-inference} -\cindex{operation specific type inference} -\cindex{arithmetic type inference} -\cpsubindex{numeric}{type inference} - -Many of the standard \clisp{} functions have special type inference procedures -that determine the result type as a function of the argument types. For -example, the result type of \code{aref} is the array element type. Here are some -other examples of type inferences: -\begin{lisp} -(logand x #xFF) \result{} (unsigned-byte 8) - -(+ (the (integer 0 12) x) (the (integer 0 1) y)) \result{} (integer 0 13) - -(ash (the (unsigned-byte 16) x) -8) \result{} (unsigned-byte 8) -\end{lisp} - -\node Dynamic Type Inference, Type Check Optimization, Operation Specific Type Inference, Type Inference -\subsection{Dynamic Type Inference} -\label{constraint-propagation} -\cindex{dynamic type inference} -\cindex{conditional type inference} -\cpsubindex{type inference}{dynamic} - -Python uses flow analysis to infer types in dynamically typed programs. For -example: -\begin{example} -(ecase x - (list (length x)) - ...) -\end{example} -Here, the compiler knows the argument to \code{length} is a list, -because the call to \code{length} is only done when \code{x} is a list. -The most significant efficiency effect of inference from assertions is -usually in type check optimization. - - -Dynamic type inference has two inputs: explicit conditionals and -implicit or explicit type assertions. Flow analysis propagates these -constraints on variable type to any code that can be executed only -after passing though the constraint. Explicit type constraints come -from \findexed{if}s where the test is either a lexical variable or a -function of lexical variables and constants, where the function is -either a type predicate, a numeric comparison or \code{eq}. - -If there is an \code{eq} (or \code{eql}) test, then the compiler will actually -substitute one argument for the other in the true branch. For example: -\begin{lisp} -(when (eq x :yow!) (return x)) -\end{lisp} -becomes: -\begin{lisp} -(when (eq x :yow!) (return :yow!)) -\end{lisp} -This substitution is done when one argument is a constant, or one argument has -better type information than the other. This transformation reveals -opportunities for constant folding or type-specific optimizations. If the test -is against a constant, then the compiler can prove that the variable is not -that constant value in the false branch, or \w{\code{(not (member :yow!))}} -in the example above. This can eliminate redundant tests, for example: -\begin{example} -(if (eq x nil) - ... - (if x a b)) -\end{example} -is transformed to this: -\begin{example} -(if (eq x nil) - ... - a) -\end{example} -Variables appearing as \code{if} tests are interpreted as -\code{\w{(not (eq \var{var} nil))}} tests. The compiler also converts \code{=} into -\code{eql} where possible. It is difficult to do inference directly on \code{=} -since it does implicit coercions. - -When there is an explicit \code{<} or \code{>} test on integer variables, the -compiler makes inferences about the ranges the variables can assume in the true -and false branches. This is mainly useful when it proves that the values are -small enough in magnitude to allow open-coding of arithmetic operations. For -example, in many uses of \code{dotimes} with a \code{fixnum} repeat count, the -compiler proves that fixnum arithmetic can be used. - -Implicit type assertions are quite common, especially if you declare function -argument types. Dynamic inference from implicit type assertions sometimes -helps to disambiguate programs to a useful degree, but is most noticeable when -it detects a dynamic type error. For example: -\begin{lisp} -(defun foo (x) - (+ (car x) x)) -\end{lisp} -results in this warning: -\begin{example} -In: DEFUN FOO - (+ (CAR X) X) -==> - X -Warning: Result is a LIST, not a NUMBER. -\end{example} - -Note that \llisp{}'s dynamic type checking semantics make dynamic type -inference useful even in programs that aren't really dynamically typed, for -example: -\begin{lisp} -(+ (car x) (length x)) -\end{lisp} -Here, \code{x} presumably always holds a list, but in the absence of a declaration -the compiler cannot assume \code{x} is a list simply because list-specific -operations are sometimes done on it. The compiler must consider the program to -be dynamically typed until it proves otherwise. Dynamic type inference proves -that the argument to \code{length} is always a list because the call to \code{length} -is only done after the list-specific \code{car} operation. - - -\node Type Check Optimization, , Dynamic Type Inference, Type Inference -\subsection{Type Check Optimization} -\label{type-check-optimization} -\cpsubindex{type checking}{optimization} -\cpsubindex{optimization}{type check} - -Python backs up its support for precise type checking by minimizing the cost of -run-time type checking. This is done both through type inference and though -optimizations of type checking itself. - -Type inference often allows the compiler to prove that a value is of the -correct type, and thus no type check is necessary. For example: -\begin{lisp} -(defstruct foo a b c) -(defstruct link - (foo (required-argument) :type foo) - (next nil :type (or link null))) - -(foo-a (link-foo x)) -\end{lisp} -Here, there is no need to check that the result of \code{link-foo} is a \code{foo}, -since it always is. Even when some type checks are necessary, type inference -can often reduce the number: -\begin{example} -(defun test (x) - (let ((a (foo-a x)) - (b (foo-b x)) - (c (foo-c x))) - ...)) -\end{example} -In this example, only one \w{\code{(foo-p x)}} check is needed. This applies to a -lesser degree in list operations, such as: -\begin{lisp} -(if (eql (car x) 3) (cdr x) y) -\end{lisp} -Here, we only have to check that \code{x} is a list once. - -Since \python{} recognizes explicit type tests, code that explicitly protects -itself against type errors has little introduced overhead due to implicit type -checking. For example, this loop compiles with no implicit checks checks for -\code{car} and \code{cdr}: -\begin{lisp} -(defun memq (e l) - (do ((current l (cdr current))) - ((atom current) nil) - (when (eq (car current) e) (return current)))) -\end{lisp} - -\cindex{complemented type checks} -Python reduces the cost of checks that must be done through an optimization -called \var{complementing}. A complemented check for \var{type} is simply a check -that the value is not of the type \w{\code{(not \var{type})}}. This is only -interesting when something is known about the actual type, in which case we can -test for the complement of \w{\code{(and \var{known-type} (not \var{type}))}}, or the -difference between the known type and the assertion. An example: -\begin{lisp} -(link-foo (link-next x)) -\end{lisp} -Here, we change the type check for \code{link-foo} from a test for \code{foo} to a -test for: -\begin{lisp} -(not (and (or foo null) (not foo))) -\end{lisp} -or more simply \w{\code{(not null)}}. This is probably the most important use of -complementing, since the situation is fairly common, and a \code{null} test is -much cheaper than a structure type test. - -Here is a more complicated example that illustrates the combination of -complementing with dynamic type inference: -\begin{lisp} -(defun find-a (a x) - (declare (type (or link null) x)) - (do ((current x (link-next current))) - ((null current) nil) - (let ((foo (link-foo current))) - (when (eq (foo-a foo) a) (return foo))))) -\end{lisp} -This loop can be compiled with no type checks. The \code{link} test for -\code{link-foo} and \code{link-next} is complemented to \w{\code{(not null)}}, and then -deleted because of the explicit \code{null} test. As before, no check is -necessary for \code{foo-a}, since the \code{link-foo} is always a \code{foo}. This sort -of situation shows how precise type checking combined with precise declarations -can actually result in reduced type checking. - - -\node Source Optimization, Tail Recursion, Type Inference, Advanced Compiler Use and Efficiency Hints -\section{Source Optimization} -\label{source-optimization} -\cindex{optimization} - -This section describes source-level transformations that \python{} does on -programs in an attempt to make them more efficient. Although source-level -optimizations can make existing programs more efficient, the biggest advantage -of this sort of optimization is that it makes it easier to write efficient -programs. If a clean, straightforward implementation is can be transformed -into an efficient one, then there is no need for tricky and dangerous hand -optimization. - -\begin{menu} -* Let Optimization:: -* Constant Folding:: -* Unused Expression Elimination:: -* Control Optimization:: -* Unreachable Code Deletion:: -* Multiple Values Optimization:: -* Source to Source Transformation:: -* Style Recommendations:: -\end{menu} - -\node Let Optimization, Constant Folding, Source Optimization, Source Optimization -\subsection{Let Optimization} -\label{let-optimization} - -\cindex{let optimization} \cpsubindex{optimization}{let} -The primary optimization of let variables is to delete them when they are -unnecessary. Whenever the value of a let variable is a constant, a constant -variable or a constant (local or non-notinline) function, the variable is -deleted, and references to the variable are replaced with references to the -constant expression. This is useful primarily in the expansion of macros or -inline functions, where argument values are often constant in any given call, -but are in general non-constant expressions that must be bound to preserve -order of evaluation. Let variable optimization eliminates the need for macros -to carefully avoid spurious bindings, and also makes inline functions just as -efficient as macros. - -A particularly interesting class of constant is a local function. Substituting -for lexical variables that are bound to a function can substantially improve -the efficiency of functional programming styles, for example: -\begin{lisp} -(let ((a #'(lambda (x) (zow x)))) - (funcall a 3)) -\end{lisp} -effectively transforms to: -\begin{lisp} -(zow 3) -\end{lisp} -This transformation is done even when the function is a closure, as in: -\begin{lisp} -(let ((a (let ((y (zug))) - #'(lambda (x) (zow x y))))) - (funcall a 3)) -\end{lisp} -becoming: -\begin{lisp} -(zow 3 (zug)) -\end{lisp} - -A constant variable is a lexical variable that is never assigned to, always -keeping its initial value. Whenever possible, avoid setting lexical variables -\dash{} instead bind a new variable to the new value. Except for loop variables, -it is almost always possible to avoid setting lexical variables. This form: -\begin{example} -(let ((x (f x))) - ...) -\end{example} -is \var{more} efficient than this form: -\begin{example} -(setq x (f x)) -... -\end{example} -Setting variables makes the program more difficult to understand, both to the -compiler and to the programmer. \python{} compiles assignments at least as -efficiently as any other \llisp{} compiler, but most let optimizations are only -done on constant variables. - -Constant variables with only a single use are also optimized away, even when -the initial value is not constant.\footnote{The source transformation in this -example doesn't represent the preservation of evaluation order implicit in the -compiler's internal representation. Where necessary, the back end will -reintroduce temporaries to preserve the semantics.} For example, this -expansion of \code{incf}: -\begin{lisp} -(let ((#:g3 (+ x 1))) - (setq x #:G3)) -\end{lisp} -becomes: -\begin{lisp} -(setq x (+ x 1)) -\end{lisp} -The type semantics of this transformation are more important than the -elimination of the variable itself. Consider what happens when \code{x} is -declared to be a \code{fixnum}; after the transformation, the compiler can compile -the addition knowing that the result is a \code{fixnum}, whereas before the -transformation the addition would have to allow for fixnum overflow. - -Another variable optimization deletes any variable that is never read. This -causes the initial value and any assigned values to be unused, allowing those -expressions to be deleted if they have no side-effects. - -Note that a let is actually a degenerate case of local call (\pxlref{let-calls}), and that let optimization can be done on calls that weren't -created by a let. Also, local call allows an applicative style of iteration -that is totally assignment free. - -\node Constant Folding, Unused Expression Elimination, Let Optimization, Source Optimization -\subsection{Constant Folding} -\cindex{constant folding} -\cpsubindex{folding}{constant} - -Constant folding is an optimization that replaces a call of constant arguments -with the constant result of that call. Constant folding is done on all -standard functions for which it is legal. Inline expansion allows folding of -any constant parts of the definition, and can be done even on functions that -have side-effects. - -It is convenient to rely on constant folding when programming, as in this -example: -\begin{example} -(defconstant limit 42) - -(defun foo () - (... (1- limit) ...)) -\end{example} -Constant folding is also helpful when writing macros or inline functions, since -it usually eliminates the need to write a macro that special-cases constant -arguments. - -\cindex{constant-function declaration} -Constant folding of a user defined function is enabled by the -\code{extensions:constant-function} proclamation. In this example: -\begin{example} -(declaim (ext:constant-function myfun)) -(defun myexp (x y) - (declare (single-float x y)) - (exp (* (log x) y))) - - ... (myexp 3.0 1.3) ... -\end{example} -The call to \code{myexp} is constant-folded to \code{4.1711674}. - - -\node Unused Expression Elimination, Control Optimization, Constant Folding, Source Optimization -\subsection{Unused Expression Elimination} -\cindex{unused expression elimination} -\cindex{dead code elimination} - -If the value of any expression is not used, and the expression has no -side-effects, then it is deleted. As with constant folding, this optimization -applies most often when cleaning up after inline expansion and other -optimizations. Any function declared an \code{extensions:constant-function} is -also subject to unused expression elimination. - -Note that \python{} will eliminate parts of unused expressions known to be -side-effect free, even if there are other unknown parts. For example: -\begin{lisp} -(let ((a (list (foo) (bar)))) - (if t - (zow) - (raz a))) -\end{lisp} -becomes: -\begin{lisp} -(progn (foo) (bar)) -(zow) -\end{lisp} - - -\node Control Optimization, Unreachable Code Deletion, Unused Expression Elimination, Source Optimization -\subsection{Control Optimization} -\cindex{control optimization} -\cpsubindex{optimization}{control} - -The most important optimization of control is recognizing when an -\findexed{if} test is known at compile time, then deleting the -\code{if}, the test expression, and the unreachable branch of the -\code{if}. This can be considered a special case of constant folding, -although the test doesn't have to be truly constant as long as it is -definitely not \false. Note also, that type inference propagates the -result of an \code{if} test to the true and false branches, -\pxlref{constraint-propagation}. - -A related \code{if} optimization is this transformation:\footnote{Note that the code -for \code{x} and \code{y} isn't actually replicated.} -\begin{lisp} -(if (if a b c) x y) -\end{lisp} -into: -\begin{lisp} -(if a - (if b x y) - (if c x y)) -\end{lisp} -The opportunity for this sort of optimization usually results from a -conditional macro. For example: -\begin{lisp} -(if (not a) x y) -\end{lisp} -is actually implemented as this: -\begin{lisp} -(if (if a nil t) x y) -\end{lisp} -which is transformed to this: -\begin{lisp} -(if a - (if nil x y) - (if t x y)) -\end{lisp} -which is then optimized to this: -\begin{lisp} -(if a y x) -\end{lisp} -Note that due to \python{}'s internal representations, the \code{if}\dash{}\code{if} -situation will be recognized even if other forms are wrapped around the inner -\code{if}, like: -\begin{example} -(if (let ((g ...)) - (loop - ... - (return (not g)) - ...)) - x y) -\end{example} - -In \python, all the \clisp{} macros really are macros, written in terms of -\code{if}, \code{block} and \code{tagbody}, so user-defined control macros can be just -as efficient as the standard ones. \python{} emits basic blocks using a heuristic -that minimizes the number of unconditional branches. The code in a \code{tagbody} -will not be emitted in the order it appeared in the source, so there is no -point in arranging the code to make control drop through to the target. - -\node Unreachable Code Deletion, Multiple Values Optimization, Control Optimization, Source Optimization -\subsection{Unreachable Code Deletion} -\label{dead-code-notes} -\cindex{unreachable code deletion} -\cindex{dead code elimination} - -Python will delete code whenever it can prove that the code can never be -executed. Code becomes unreachable when: -\begin{itemize} - -\item -An \code{if} is optimized away, or - -\item -There is an explicit unconditional control transfer such as \code{go} or -\code{return-from}, or - -\item -The last reference to a local function is deleted (or there never was any -reference.) -\end{itemize} - - -When code that appeared in the original source is deleted, the compiler prints -a note to indicate a possible problem (or at least unnecessary code.) For -example: -\begin{lisp} -(defun foo () - (if t - (write-line "True.") - (write-line "False."))) -\end{lisp} -will result in this note: -\begin{example} -In: DEFUN FOO - (WRITE-LINE "False.") -Note: Deleting unreachable code. -\end{example} - -It is important to pay attention to unreachable code notes, since they often -indicate a subtle type error. For example: -\begin{example} -(defstruct foo a b) - -(defun lose (x) - (let ((a (foo-a x)) - (b (if x (foo-b x) :none))) - ...)) -\end{example} -results in this note: -\begin{example} -In: DEFUN LOSE - (IF X (FOO-B X) :NONE) -==> - :NONE -Note: Deleting unreachable code. -\end{example} -The \kwd{none} is unreachable, because type inference knows that the argument -to \code{foo-a} must be a \code{foo}, and thus can't be \false. Presumably the -programmer forgot that \code{x} could be \false{} when he wrote the binding for -\code{a}. - -Here is an example with an incorrect declaration: -\begin{lisp} -(defun count-a (string) - (do ((pos 0 (position #\back a string :start (1+ pos))) - (count 0 (1+ count))) - ((null pos) count) - (declare (fixnum pos)))) -\end{lisp} -This time our note is: -\begin{example} -In: DEFUN COUNT-A - (DO ((POS 0 #) (COUNT 0 #)) - ((NULL POS) COUNT) - (DECLARE (FIXNUM POS))) ---> BLOCK LET TAGBODY RETURN-FROM PROGN -==> - COUNT -Note: Deleting unreachable code. -\end{example} -The problem here is that \code{pos} can never be null since it is declared a -\code{fixnum}. - -It takes some experience with unreachable code notes to be able to tell what -they are trying to say. In non-obvious cases, the best thing to do is to call -the function in a way that should cause the unreachable code to be executed. -Either you will get a type error, or you will find that there truly is no way -for the code to be executed. - -Not all unreachable code results in a note: -\begin{itemize} - -\item -A note is only given when the unreachable code textually appears in the -original source. This prevents spurious notes due to the optimization of -macros and inline functions, but sometimes also foregoes a note that would have -been useful. - -\item -Since accurate source information is not available for non-list forms, there is -an element of heuristic in determining whether or not to give a note about an -atom. Spurious notes may be given when a macro or inline function defines a -variable that is also present in the calling function. Notes about \false{} and -\true{} are never given, since it is too easy to confuse these constants in -expanded code with ones in the original source. - -\item -Notes are only given about code unreachable due to control flow. There is no -note when an expression is deleted because its value is unused, since this is a -common consequence of other optimizations. -\end{itemize} - - -Somewhat spurious unreachable code notes can also result when a macro inserts -multiple copies of its arguments in different contexts, for example: -\begin{lisp} -(defmacro t-and-f (var form) - `(if ,var ,form ,form)) - -(defun foo (x) - (t-and-f x (if x "True." "False."))) -\end{lisp} -results in these notes: -\begin{example} -In: DEFUN FOO - (IF X "True." "False.") -==> - "False." -Note: Deleting unreachable code. - -==> - "True." -Note: Deleting unreachable code. -\end{example} -It seems like it has deleted both branches of the \code{if}, but it has really -deleted one branch in one copy, and the other branch in the other copy. Note -that these messages are only spurious in not satisfying the intent of the rule -that notes are only given when the deleted code appears in the original source; -there is always \var{some} code being deleted when a unreachable code note is -printed. - - -\node Multiple Values Optimization, Source to Source Transformation, Unreachable Code Deletion, Source Optimization -\subsection{Multiple Values Optimization} -\cindex{multiple value optimization} -\cpsubindex{optimization}{multiple value} - -Within a function, \python{} implements uses of multiple values particularly -efficiently. Multiple values can be kept in arbitrary registers, so using -multiple values doesn't imply stack manipulation and representation -conversion. For example, this code: -\begin{example} -(let ((a (if x (foo x) u)) - (b (if x (bar x) v))) - ...) -\end{example} -is actually more efficient written this way: -\begin{example} -(multiple-value-bind - (a b) - (if x - (values (foo x) (bar x)) - (values u v)) - ...) -\end{example} - -Also, \pxlref{local-call-return} for information on how local call -provides efficient support for multiple function return values. - - -\node Source to Source Transformation, Style Recommendations, Multiple Values Optimization, Source Optimization -\subsection{Source to Source Transformation} -\cindex{source-to-source transformation} -\cpsubindex{transformation}{source-to-source} - -The compiler implements a number of operation-specific optimizations as -source-to-source transformations. You will often see unfamiliar code in error -messages, for example: -\begin{lisp} -(defun my-zerop () (zerop x)) -\end{lisp} -gives this warning: -\begin{example} -In: DEFUN MY-ZEROP - (ZEROP X) -==> - (= X 0) -Warning: Undefined variable: X -\end{example} -The original \code{zerop} has been transformed into a call to \code{=}. This -transformation is indicated with the same \code{==>} used to mark macro and -function inline expansion. Although it can be confusing, display of the -transformed source is important, since warnings are given with respect to the -transformed source. This a more obscure example: -\begin{lisp} -(defun foo (x) (logand 1 x)) -\end{lisp} -gives this efficiency note: -\begin{example} -In: DEFUN FOO - (LOGAND 1 X) -==> - (LOGAND C::Y C::X) -Note: Forced to do static-function Two-arg-and (cost 53). - Unable to do inline fixnum arithmetic (cost 1) because: - The first argument is a INTEGER, not a FIXNUM. - etc. -\end{example} -Here, the compiler commuted the call to \code{logand}, introducing temporaries. -The note complains that the \var{first} argument is not a \code{fixnum}, when in the -original call, it was the second argument. To make things more confusing, the -compiler introduced temporaries called \code{c::x} and \code{c::y} that are bound to -\code{y} and \code{1}, respectively. - -You will also notice source-to-source optimizations when efficiency notes are -enabled (\pxlref{efficiency-notes}.) When the compiler is unable to -do a transformation that might be possible if there was more information, then -an efficiency note is printed. For example, \code{my-zerop} above will also give -this efficiency note: -\begin{example} -In: DEFUN FOO - (ZEROP X) -==> - (= X 0) -Note: Unable to optimize because: - Operands might not be the same type, so can't open code. -\end{example} - -\node Style Recommendations, , Source to Source Transformation, Source Optimization -\subsection{Style Recommendations} -\cindex{style recommendations} - -Source level optimization makes possible a clearer and more relaxed programming -style: -\begin{itemize} - -\item -Don't use macros purely to avoid function call. If you want an inline -function, write it as a function and declare it inline. It's clearer, less -error-prone, and works just as well. - -\item -Don't write macros that try to "optimize" their expansion in trivial ways such -as avoiding binding variables for simple expressions. The compiler does -these optimizations too, and is less likely to make a mistake. - -\item -Make use of local functions (i.e., \code{labels} or \code{flet}) and tail-recursion -in places where it is clearer. Local function call is faster than full call. - -\item -Avoid setting local variables when possible. Binding a new \code{let} variable is -at least as efficient as setting an existing variable, and is easier to -understand, both for the compiler and the programmer. - -\item -Instead of writing similar code over and over again so that it can be hand -customized for each use, define a macro or inline function, and let the -compiler do the work. -\end{itemize} - - - -\node Tail Recursion, Local Call, Source Optimization, Advanced Compiler Use and Efficiency Hints -\section{Tail Recursion} -\label{tail-recursion} -\cindex{tail recursion} -\cindex{recursion} - -A call is tail-recursive if nothing has to be done after the the call returns, -i.e. when the call returns, the returned value is immediately returned from the -calling function. In this example, the recursive call to \code{myfun} is -tail-recursive: -\begin{lisp} -(defun myfun (x) - (if (oddp (random x)) - (isqrt x) - (myfun (1- x)))) -\end{lisp} - -Tail recursion is interesting because it is form of recursion that can be -implemented much more efficiently than general recursion. In general, a -recursive call requires the compiler to allocate storage on the stack at -run-time for every call that has not yet returned. This memory consumption -makes recursion unacceptably inefficient for representing repetitive algorithms -having large or unbounded size. Tail recursion is the special case of -recursion that is semantically equivalent to the iteration constructs normally -used to represent repetition in programs. Because tail recursion is equivalent -to iteration, tail-recursive programs can be compiled as efficiently as -iterative programs. - -So why would you want to write a program recursively when you can write it -using a loop? Well, the main answer is that recursion is a more general -mechanism, so it can express some solutions simply that are awkward to write as -a loop. Some programmers also feel that recursion is a stylistically -preferable way to write loops because it avoids assigning variables. -For example, instead of writing: -\begin{lisp} -(defun fun1 (x) - something-that-uses-x) - -(defun fun2 (y) - something-that-uses-y) - -(do ((x something (fun2 (fun1 x)))) - (nil)) -\end{lisp} -You can write: -\begin{lisp} -(defun fun1 (x) - (fun2 something-that-uses-x)) - -(defun fun2 (y) - (fun1 something-that-uses-y)) - -(fun1 something) -\end{lisp} -The tail-recursive definition is actually more efficient, in addition to being -(arguably) clearer. As the number of functions and the complexity of their -call graph increases, the simplicity of using recursion becomes compelling. -Consider the advantages of writing a large finite-state machine with separate -tail-recursive functions instead of using a single huge \code{prog}. - -It helps to understand how to use tail recursion if you think of a -tail-recursive call as a \code{psetq} that assigns the argument values to the -called function's variables, followed by a \code{go} to the start of the called -function. This makes clear an inherent efficiency advantage of tail-recursive -call: in addition to not having to allocate a stack frame, there is no need to -prepare for the call to return (e.g., by computing a return PC.) - -Is there any disadvantage to tail recursion? Other than an increase in -efficiency, the only way you can tell that a call has been compiled -tail-recursively is if you use the debugger. Since a tail-recursive call has -no stack frame, there is no way the debugger can print out the stack frame -representing the call. The effect is that backtrace will not show some calls -that would have been displayed in a non-tail-recursive implementation. In -practice, this is not as bad as it sounds \dash{} in fact it isn't really clearly -worse, just different. \xlref{debug-tail-recursion} for information -about the debugger implications of tail recursion. - -In order to ensure that tail-recursion is preserved in arbitrarily complex -calling patterns across separately compiled functions, the compiler must -compile any call in a tail-recursive position as a tail-recursive call. This -is done regardless of whether the program actually exhibits any sort of -recursive calling pattern. In this example, the call to \code{fun2} will always -be compiled as a tail-recursive call: -\begin{lisp} -(defun fun1 (x) - (fun2 x)) -\end{lisp} -So tail recursion doesn't necessarily have anything to do with recursion -as it is normally thought of. \xlref{local-tail-recursion} for more -discussion of using tail recursion to implement loops. - -\begin{menu} -* Tail Recursion Exceptions:: -\end{menu} - -\node Tail Recursion Exceptions, , Tail Recursion, Tail Recursion -\subsection{Tail Recursion Exceptions} - -Although \python{} is claimed to be "properly" tail-recursive, some might dispute -this, since there are situations where tail recursion is inhibited: -\begin{itemize} - -\item -When the call is enclosed by a special binding, or - -\item -When the call is enclosed by a \code{catch} or \code{unwind-protect}, or - -\item -When the call is enclosed by a \code{block} or \code{tagbody} and the block name or -\code{go} tag has been closed over. -\end{itemize} -These dynamic extent binding forms inhibit tail recursion because they -allocate stack space to represent the binding. Shallow-binding -implementations of dynamic scoping also require cleanup code to be -evaluated when the scope is exited. - - -\node Local Call, Block Compilation, Tail Recursion, Advanced Compiler Use and Efficiency Hints -\section{Local Call} -\label{local-call} -\cindex{local call} -\cpsubindex{call}{local} -\cpsubindex{function call}{local} - -Python supports two kinds of function call: full call and local call. Full -call is the standard calling convention; its late binding and generality make -\llisp{} what it is, but create unavoidable overheads. When the compiler can -compile the calling function and the called function simultaneously, it can use -local call to avoid some of the overhead of full call. Local call is really a -collection of compilation strategies. If some aspect of call overhead is not -needed in a particular local call, then it can be omitted. In some cases, -local call can be totally free. Local call provides two main advantages to the -user: -\begin{itemize} - -\item -Local call makes the use of the lexical function binding forms -\findexed{flet} and \findexed{labels} much more efficient. A local -call is always faster than a full call, and in many cases is much faster. - -\item -Local call is a natural approach to \i{block compilation}, a compilation -technique that resolves function references at compile time. Block compilation -speeds function call, but increases compilation times and prevents function -redefinition. -\end{itemize} - - -\begin{menu} -* Self-Recursive Calls:: -* Let Calls:: -* Closures:: -* Local Tail Recursion:: -* Return Values:: -\end{menu} - -\node Self-Recursive Calls, Let Calls, Local Call, Local Call -\subsection{Self-Recursive Calls} -\cpsubindex{recursion}{self} - -Local call is used when a function defined by \code{defun} calls itself. For -example: -\begin{lisp} -(defun fact (n) - (if (zerop n) - 1 - (* n (fact (1- n))))) -\end{lisp} -This use of local call speeds recursion, but can also complicate debugging, -since \findexed{trace} will only show the first call to \code{fact}, and not the -recursive calls. This is because the recursive calls directly jump to the -start of the function, and don't indirect through the \code{symbol-function}. -Self-recursive local call is inhibited when the \kwd{block-compile} argument to -\code{compile-file} is \false{} (\pxlref{compile-file-block}.) - -\node Let Calls, Closures, Self-Recursive Calls, Local Call -\subsection{Let Calls} -\label{let-calls} -Because local call avoids unnecessary call overheads, the compiler internally -uses local call to implement some macros and special forms that are not -normally thought of as involving a function call. For example, this \code{let}: -\begin{example} -(let ((a (foo)) - (b (bar))) - ...) -\end{example} -is internally represented as though it was macroexpanded into: -\begin{example} -(funcall #'(lambda (a b) - ...) - (foo) - (bar)) -\end{example} -This implementation is acceptable because the simple cases of local call -(equivalent to a \code{let}) result in good code. This doesn't make \code{let} any -more efficient, but does make local calls that are semantically the same as \code{let} -much more efficient than full calls. For example, these definitions are all -the same as far as the compiler is concerned: -\begin{example} -(defun foo () - ...some other stuff... - (let ((a something)) - ...some stuff...)) - -(defun foo () - (flet ((localfun (a) - ...some stuff...)) - ...some other stuff... - (localfun something))) - -(defun foo () - (let ((funvar #'(lambda (a) - ...some stuff...))) - ...some other stuff... - (funcall funvar something))) -\end{example} - -Although local call is most efficient when the function is called only once, a -call doesn't have to be equivalent to a \code{let} to be more efficient than full -call. All local calls avoid the overhead of argument count checking and -keyword argument parsing, and there are a number of other advantages that apply -in many common situations. \xlref{let-optimization} for a -discussion of the optimizations done on let calls. - -\node Closures, Local Tail Recursion, Let Calls, Local Call -\subsection{Closures} -\cindex{closures} - -Local call allows for much more efficient use of closures, since the closure -environment doesn't need to be allocated on the heap, or even stored in memory -at all. In this example, there is no penalty for \code{localfun} referencing -\code{a} and \code{b}: -\begin{lisp} -(defun foo (a b) - (flet ((localfun (x) - (1+ (* a b x)))) - (if (= a b) - (localfun (- x)) - (localfun x)))) -\end{lisp} -In local call, the compiler effectively passes closed-over values as extra -arguments, so there is no need for you to "optimize" local function use by -explicitly passing in lexically visible values. Closures may also be subject -to let optimization (\pxlref{let-optimization}.) - -Note: indirect value cells are currently always allocated on the heap when a -variable is both assigned to (with \code{setq} or \code{setf}) and closed over, -regardless of whether the closure is a local function or not. This is another -reason to avoid setting variables when you don't have to. - -\node Local Tail Recursion, Return Values, Closures, Local Call -\subsection{Local Tail Recursion} -\label{local-tail-recursion} -\cindex{tail recursion} -\cpsubindex{recursion}{tail} - -Tail-recursive local calls are particularly efficient, since they are in effect -an assignment plus a control transfer. Scheme programmers write loops with -tail-recursive local calls, instead of using the imperative \code{go} and -\code{setq}. This has not caught on in the \clisp{} community, since conventional -\llisp{} compilers don't implement local call. In \python, users can choose to -write loops such as: -\begin{lisp} -(defun ! (n) - (labels ((loop (n total) - (if (zerop n) - total - (loop (1- n) (* n total))))) - (loop n 1))) -\end{lisp} - -\defmac{iterate}[extensions]{\args - {\var{name} (\mstar{(\var{var} \var{initial-value})}) \mstar{\var{declaration}} \mstar{\var{form}}}} -This macro provides syntactic sugar for using \findexed{labels} to do iteration. It -creates a local function \var{name} with the specified \var{var}s as its arguments -and the \var{declaration}s and \var{form}s as its body. This function is then -called with the \var{initial-values}, and the result of the call is return from -the macro. - -Here is our factorial example rewritten using \code{iterate}: -\begin{lisp} -(defun ! (n) - (iterate loop - ((n n) - (total 1)) - (if (zerop n) - total - (loop (1- n) (* n total))))) -\end{lisp} -The main advantage of using \code{iterate} over \code{do} is that \code{iterate} -naturally allows stepping to be done differently depending on conditionals in -the body of the loop. \code{iterate} can also be used to implement algorithms -that aren't really iterative by simply doing a non-tail call. For example, -the standard recursive definition of factorial can be written like this: -\begin{lisp} -(iterate fact - ((n n)) - (if (zerop n) - 1 - (* n (fact (1- n))))) -\end{lisp} -\enddefmac - -\node Return Values, , Local Tail Recursion, Local Call -\subsection{Return Values} -\label{local-call-return} -\cpsubindex{return values}{local call} -\cpsubindex{local call}{return values} - -One of the more subtle costs of full call comes from allowing arbitrary numbers -of return values. This overhead can be avoided in local calls to functions -that always return the same number of values. For efficiency reasons (as well -as stylistic ones), you should write functions so that they always return the -same number of values. This may require passing extra \false{} arguments to -\code{values} in some cases, but the result is more efficient, not less so. - -When efficiency notes are enabled (\pxlref{efficiency-notes}), and the -compiler wants to use known values return, but can't prove that the function -always returns the same number of values, then it will print a note like this: -\begin{example} -In: DEFUN GRUE - (DEFUN GRUE (X) (DECLARE (FIXNUM X)) (COND (# #) (# NIL) (T #))) -Note: Return type not fixed values, so can't use known return convention: - (VALUES (OR (INTEGER -536870912 -1) NULL) &REST T) -\end{example} - -In order to implement proper tail recursion in the presence of known values -return (\pxlref{tail-recursion}), the compiler sometimes must prove that -multiple functions all return the same number of values. When this can't be -proven, the compiler will print a note like this: -\begin{example} -In: DEFUN BLUE - (DEFUN BLUE (X) (DECLARE (FIXNUM X)) (COND (# #) (# #) (# #) (T #))) -Note: Return value count mismatch prevents known return from - these functions: - BLUE - SNOO -\end{example} -\xlref{number-local-call} for the interaction between local call -and the representation of numeric types. - - -\node Block Compilation, Inline Expansion, Local Call, Advanced Compiler Use and Efficiency Hints -\section{Block Compilation} -\label{block-compilation} -\cindex{block compilation} -\cpsubindex{compilation}{block} - -Block compilation allows calls to global functions defined by -\findexed{defun} to be compiled as local calls. The function call -can be in a different top-level form than the \code{defun}, or even in a -different file. - -In addition, block compilation allows the declaration of the \i{entry points} -to the block compiled portion. An entry point is any function that may be -called from outside of the block compilation. If a function is not an entry -point, then it can be compiled more efficiently, since all calls are known at -compile time. In particular, if a function is only called in one place, then -it will be let converted. This effectively inline expands the function, but -without the code duplication that results from defining the function normally -and then declaring it inline. - -The main advantage of block compilation is that it it preserves efficiency in -programs even when (for readability and syntactic convenience) they are broken -up into many small functions. There is absolutely no overhead for calling a -non-entry point function that is defined purely for modularity (i.e. called -only in one place.) - -Block compilation also allows the use of non-descriptor arguments and return -values in non-trivial programs (\pxlref{number-local-call}). - -\begin{menu} -* Block Compilation Semantics:: -* Block Compilation Declarations:: -* Compiler Arguments:: -* Practical Difficulties:: -\end{menu} - -\node Block Compilation Semantics, Block Compilation Declarations, Block Compilation, Block Compilation -\subsection{Block Compilation Semantics} - -The effect of block compilation can be envisioned as the compiler turning all -the \code{defun}s in the block compilation into a single \code{labels} form: -\begin{example} -(declaim (start-block fun1 fun3)) - -(defun fun1 () - ...) - -(defun fun2 () - ... - (fun1) - ...) - -(defun fun3 (x) - (if x - (fun1) - (fun2))) - -(declaim (end-block)) -\end{example} -becomes: -\begin{example} -(labels ((fun1 () - ...) - (fun2 () - ... - (fun1) - ...) - (fun3 (x) - (if x - (fun1) - (fun2)))) - (setf (fdefinition 'fun1) #'fun1) - (setf (fdefinition 'fun3) #'fun3)) -\end{example} -Calls between the block compiled functions are local calls, so changing the -global definition of \code{fun1} will have no effect on what \code{fun2} does; -\code{fun2} will keep calling the old \code{fun1}. - -The entry points \code{fun1} and \code{fun3} are still installed in the -\code{symbol-function} as the global definitions of the functions, so a full call -to an entry point works just as before. However, \code{fun2} is not an entry -point, so it is not globally defined. In addition, \code{fun2} is only called in -one place, so it will be let converted. - - -\node Block Compilation Declarations, Compiler Arguments, Block Compilation Semantics, Block Compilation -\subsection{Block Compilation Declarations} -\cpsubindex{declarations}{block compilation} -\cindex{start-block declaration} -\cindex{end-block declaration} - -The \code{extensions:start-block} and \code{extensions:end-block} declarations allow -fine-grained control of block compilation. These declarations are only legal -as a global declarations (\code{declaim} or \code{proclaim}). - -\noindent -\vspace{1 em} -The \code{start-block} declaration has this syntax: -\begin{example} -(start-block \mstar{\var{entry-point-name}}) -\end{example} -When processed by the compiler, this declaration marks the start of -block compilation, and specifies the entry points to that block. If no -entry points are specified, then \var{all} functions are made into entry -points. If already block compiling, then the compiler ends the current -block and starts a new one. - -\noindent -\vspace{1 em} -The \code{end-block} declaration has no arguments: -\begin{lisp} -(end-block) -\end{lisp} -The \code{end-block} declaration ends a block compilation unit without -starting a new one. This is useful mainly when only a portion of a file -is worth block compiling. - -\node Compiler Arguments, Practical Difficulties, Block Compilation Declarations, Block Compilation -\subsection{Compiler Arguments} -\label{compile-file-block} -\cpsubindex{compile-file}{block compilation arguments} - -The \kwd{block-compile} and \kwd{entry-points} arguments to -\code{extensions:compile-from-stream} and \funref{compile-file} provide overall -control of block compilation, and allow block compilation without requiring -modification of the program source. - -There are three possible values of the \kwd{block-compile} argument: -\begin{description} - -\item[\false{}] -Do no compile-time resolution of global function names, not even for -self-recursive calls. This inhibits any \code{start-block} declarations appearing -in the file, allowing all functions to be incrementally redefined. - -\item[\true{}] -Start compiling in block compilation mode. This is mainly useful for block -compiling small files that contain no \code{start-block} declarations. See also -the \kwd{entry-points} argument. - -\item[\kwd{specified}] -Start compiling in form-at-a-time mode, but exploit \code{start-block} -declarations and compile self-recursive calls as local calls. Normally -\kwd{specified} is the default for this argument (see -\varref{block-compile-default}.) -\end{description} - -The \kwd{entry-points} argument can be used in conjunction with -\w{\kwd{block-compile} \true{}} to specify the entry-points to a block-compiled -file. If not specified or \nil, all global functions will be compiled as entry -points. When \kwd{block-compile} is not \true, this argument is ignored. - -\defvar{block-compile-default} -This variable determines the default value for the \kwd{block-compile} argument -to \code{compile-file} and \code{compile-from-stream}. The initial value of this -variable is \kwd{specified}, but \false{} is sometimes useful for totally -inhibiting block compilation. -\enddefvar - -\node Practical Difficulties, , Compiler Arguments, Block Compilation -\subsection{Practical Difficulties} - -The main problem with block compilation is that the compiler uses -large amounts of memory when it is block compiling. This places an -upper limit on the amount of code that can be block compiled as a -unit. To make best use of block compilation, it is necessary to -locate the parts of the program containing many internal calls, and -then add the appropriate \code{start-block} declarations. When writing -new code, it is a good idea to put in block compilation declarations -from the very beginning, since writing block declarations correctly -requires accurate knowledge of the program's function call structure. -If you want to initially develop code with full incremental -redefinition, you can compile with \varref{block-compile-default} set to -\false. - -Note if a \code{defun} appears in a non-null lexical environment, then -calls to it cannot be block compiled. - -Unless files are very small, it is probably impractical to block compile -multiple files as a unit by specifying a list of files to \code{compile-file}. -Semi-inline expansion (\pxlref{semi-inline}) provides another way to -extend block compilation across file boundaries. - - -\node Inline Expansion, Object Representation, Block Compilation, Advanced Compiler Use and Efficiency Hints -\section{Inline Expansion} -\label{inline-expansion} -\cindex{inline expansion} -\cpsubindex{expansion}{inline} -\cpsubindex{call}{inline} -\cpsubindex{function call}{inline} -\cpsubindex{optimization}{function call} - -Python can expand almost any function inline, including functions -with keyword arguments. The only restrictions are that keyword -argument keywords in the call must be constant, and that global -function definitions (\code{defun}) must be done in a null lexical -environment (not nested in a \code{let} or other binding form.) Local -functions (\code{flet}) can be inline expanded in any environment. -Combined with \python{}'s source-level optimization, inline expansion -can be used for things that formerly required macros for efficient -implementation. In \python, macros don't have any efficiency -advantage, so they need only be used where a macro's syntactic -flexibility is required. - -Inline expansion is a compiler optimization technique that reduces -the overhead of a function call by simply not doing the call: -instead, the compiler effectively rewrites the program to appear as -though the definition of the called function was inserted at each -call site. In \llisp, this is straightforwardly expressed by -inserting the \code{lambda} corresponding to the original definition: -\begin{lisp} -(proclaim '(inline my-1+)) -(defun my-1+ (x) (+ x 1)) - -(my-1+ someval) \result{} ((lambda (x) (+ x 1)) someval) -\end{lisp} - -When the function expanded inline is large, the program after inline expansion -may be substantially larger than the original program. If the program becomes -too large, inline expansion hurts speed rather than helping it, since hardware -resources such as physical memory and cache will be exhausted. Inline -expansion is called for: -\begin{itemize} - -\item -When profiling has shown that a relatively simple function is called -so often that a large amount of time is being wasted in the calling -of that function (as opposed to running in that function.) If a -function is complex, it will take a long time to run relative the -time spent in call, so the speed advantage of inline expansion is -diminished at the same time the space cost of inline expansion is -increased. Of course, if a function is rarely called, then the -overhead of calling it is also insignificant. - -\item -With functions so simple that they take less space to inline expand than would -be taken to call the function (such as \code{my-1+} above.) It would require -intimate knowledge of the compiler to be certain when inline expansion would -reduce space, but it is generally safe to inline expand functions whose -definition is a single function call, or a few calls to simple \clisp{} -functions. -\end{itemize} - - -In addition to this speed/space tradeoff from inline expansion's avoidance of -the call, inline expansion can also reveal opportunities for optimization. -\python{}'s extensive source-level optimization can make use of context -information from the caller to tremendously simplify the code resulting from -the inline expansion of a function. - -The main form of caller context is local information about the actual argument -values: what the argument types are and whether the arguments are constant. -Knowledge about argument types can eliminate run-time type tests (e.g., for -generic arithmetic.) Constant arguments in a call provide opportunities for -constant folding optimization after inline expansion. - -A hidden way that constant arguments are often supplied to functions is through -the defaulting of unsupplied optional or keyword arguments. There can be a -huge efficiency advantage to inline expanding functions that have complex -keyword-based interfaces, such as this definition of the \code{member} function: -\begin{lisp} -(proclaim '(inline member)) -(defun member (item list &key - (key #'identity) - (test #'eql testp) - (test-not nil notp)) - (do ((list list (cdr list))) - ((null list) nil) - (let ((car (car list))) - (if (cond (testp - (funcall test item (funcall key car))) - (notp - (not (funcall test-not item (funcall key car)))) - (t - (funcall test item (funcall key car)))) - (return list))))) - -\end{lisp} -After inline expansion, this call is simplified to the obvious code: -\begin{lisp} -(member a l :key #'foo-a :test #'char=) \result{} - -(do ((list list (cdr list))) - ((null list) nil) - (let ((car (car list))) - (if (char= item (foo-a car)) - (return list)))) -\end{lisp} -In this example, there could easily be more than an order of magnitude -improvement in speed. In addition to eliminating the original call to -\code{member}, inline expansion also allows the calls to \code{char=} and \code{foo-a} -to be open-coded. We go from a loop with three tests and two calls to a loop -with one test and no calls. - -\xlref{source-optimization} for more discussion of source level -optimization. - -\begin{menu} -* Inline Expansion Recording:: -* Semi-Inline Expansion:: -* The Maybe-Inline Declaration:: -\end{menu} - -\node Inline Expansion Recording, Semi-Inline Expansion, Inline Expansion, Inline Expansion -\subsection{Inline Expansion Recording} -\cindex{recording of inline expansions} - -Inline expansion requires that the source for the inline expanded function to -be available when calls to the function are compiled. The compiler doesn't -remember the inline expansion for every function, since that would take an -excessive about of space. Instead, the programmer must tell the compiler to -record the inline expansion before the definition of the inline expanded -function is compiled. This is done by globally declaring the function inline -before the function is defined, by using the \code{inline} and -\code{extensions:maybe-inline} (\pxlref{maybe-inline-declaration}) -declarations. - -In addition to recording the inline expansion of inline functions at the time -the function is compiled, \code{compile-file} also puts the inline expansion in -the output file. When the output file is loaded, the inline expansion is made -available for subsequent compilations; there is no need to compile the -definition again to record the inline expansion. - -If a function is declared inline, but no expansion is recorded, then the -compiler will give an efficiency note like: -\begin{example} -Note: MYFUN is declared inline, but has no expansion. -\end{example} -When you get this note, check that the \code{inline} declaration and the -definition appear before the calls that are to be inline expanded. This note -will also be given if the inline expansion for a \code{defun} could not be -recorded because the \code{defun} was in a non-null lexical environment. - -\node Semi-Inline Expansion, The Maybe-Inline Declaration, Inline Expansion Recording, Inline Expansion -\subsection{Semi-Inline Expansion} -\label{semi-inline} - -Python supports \var{semi-inline} functions. Semi-inline expansion shares a -single copy of a function across all the calls in a component by converting the -inline expansion into a local function (\pxlref{local-call}.) This -takes up less space when there are multiple calls, but also provides less -opportunity for context dependent optimization. When there is only one call, -the result is identical to normal inline expansion. Semi-inline expansion is -done when the \code{space} optimization quality is \code{0}, and the function has -been declared \code{extensions:maybe-inline}. - -This mechanism of inline expansion combined with local call also allows -recursive functions to be inline expanded. If a recursive function is declared -\code{inline}, calls will actually be compiled semi-inline. Although recursive -functions are often so complex that there is little advantage to semi-inline -expansion, it can still be useful in the same sort of cases where normal inline -expansion is especially advantageous, i.e. functions where the calling context -can help a lot. - -\node The Maybe-Inline Declaration, , Semi-Inline Expansion, Inline Expansion -\subsection{The Maybe-Inline Declaration} -\label{maybe-inline-declaration} -\cindex{maybe-inline declaration} - -The \code{extensions:maybe-inline} declaration is a \cmucl{} extension. It is -similar to \code{inline}, but indicates that inline expansion may sometimes be -desirable, rather than saying that inline expansion should almost always be -done. When used in a global declaration, \code{extensions:maybe-inline} causes -the expansion for the named functions to be recorded, but the functions aren't -actually inline expanded unless \code{space} is \code{0} or the function is -eventually (perhaps locally) declared \code{inline}. - -Use of the \code{extensions:maybe-inline} declaration followed by the \code{defun} is -preferable to the standard idiom of: -\begin{lisp} -(proclaim '(inline myfun)) -(defun myfun () ...) -(proclaim '(notinline myfun)) - -;;; \i{Any calls to \code{myfun} here are not inline expanded.} - -(defun somefun () - (declare (inline myfun)) - ;; - ;; \i{Calls to \code{myfun} here are inline expanded.} - ...) -\end{lisp} -The problem with using \code{notinline} in this way is that in \clisp{} it does more -than just suppress inline expansion, it also forbids the compiler to use any -knowledge of \code{myfun} until a later \code{inline} declaration overrides the -\code{notinline}. This prevents compiler warnings about incorrect calls to the -function, and also prevents block compilation. - -The \code{extensions:maybe-inline} declaration is used like this: -\begin{lisp} -(proclaim '(extensions:maybe-inline myfun)) -(defun myfun () ...) - -;;; \i{Any calls to \code{myfun} here are not inline expanded.} - -(defun somefun () - (declare (inline myfun)) - ;; - ;; \i{Calls to \code{myfun} here are inline expanded.} - ...) - -(defun someotherfun () - (declare (optimize (space 0))) - ;; - ;; \i{Calls to \code{myfun} here are expanded semi-inline.} - ...) -\end{lisp} -In this example, the use of \code{extensions:maybe-inline} causes the expansion to -be recorded when the \code{defun} for \code{somefun} is compiled, and doesn't waste -space through doing inline expansion by default. Unlike \code{notinline}, this -declaration still allows the compiler to assume that the known definition -really is the one that will be called when giving compiler warnings, and also -allows the compiler to do semi-inline expansion when the policy is appropriate. - -When the goal is merely to control whether inline expansion is done by default, -it is preferable to use \code{extensions:maybe-inline} rather than \code{notinline}. -The \code{notinline} declaration should be reserved for those special occasions -when a function may be redefined at run-time, so the compiler must be told that -the obvious definition of a function is not necessarily the one that will be in -effect at the time of the call. - - -\node Object Representation, Numbers, Inline Expansion, Advanced Compiler Use and Efficiency Hints -\section{Object Representation} -\label{object-representation} -\cindex{object representation} -\cpsubindex{representation}{object} -\cpsubindex{efficiency}{of objects} - -A somewhat subtle aspect of writing efficient \clisp{} programs is choosing the -correct data structures so that the underlying objects can be implemented -efficiently. This is partly because of the need for multiple representations -for a given value (\pxlref{non-descriptor}), but is also due to -the sheer number of object types that \clisp{} has built in. The number of -possible representations complicates the choice of a good representation -because semantically similar objects may vary in their efficiency depending on -how the program operates on them. - -\begin{menu} -* Think Before You Use a List:: -* Structures:: -* Arrays:: -* Vectors:: -* Bit-Vectors:: -* Hashtables:: -\end{menu} - -\node Think Before You Use a List, Structures, Object Representation, Object Representation -\subsection{Think Before You Use a List} -\cpsubindex{lists}{efficiency of} - -Although Lisp's creator seemed to think that it was for LISt Processing, the -astute observer may have noticed that the chapter on list manipulation makes up -less that three percent of \i{Common Lisp: the Language II}. The language has -grown since Lisp 1.5 \dash{} new data types supersede lists for many purposes. - -\node Structures, Arrays, Think Before You Use a List, Object Representation -\subsection{Structures} -\cpsubindex{structure types}{efficiency of} -One of the best ways of building complex data structures is to define -appropriate structure types using \findexed{defstruct}. In \python, access of -structure slots is always at least as fast as list or vector access, and is -usually faster. In comparison to a list representation of a tuple, structures -also have a space advantage. - -Even if structures weren't more efficient than other representations, structure -use would still be attractive because programs that use structures in -appropriate ways are much more maintainable and robust than programs written -using only lists. For example: -\begin{lisp} -(rplaca (caddr (cadddr x)) (caddr y)) -\end{lisp} -could have been written using structures in this way: -\begin{lisp} -(setf (beverage-flavor (astronaut-beverage x)) (beverage-flavor y)) -\end{lisp} -The second version is more maintainable because it is easier to understand what -it is doing. It is more robust because structures accesses are type checked. -An \code{astronaut} will never be confused with a \code{beverage}, and the result of -\code{beverage-flavor} is always a flavor. See sections \ref{structure-types} and -\ref{freeze-type} for more information about structure types. \xlref{type-inference} for a number of examples that make clear the advantages of -structure typing. - -Note that the structure definition should be compiled before any uses of its -accessors or type predicate so that these function calls can be efficiently -open-coded. - -\node Arrays, Vectors, Structures, Object Representation -\subsection{Arrays} -\label{array-types} -\cpsubindex{arrays}{efficiency of} - -Arrays are often the most efficient representation for collections of objects -because: -\begin{itemize} - -\item -Array representations are often the most compact. An array is always more -compact than a list containing the same number of elements. - -\item -Arrays allow fast constant-time access. - -\item -Arrays are easily destructively modified, which can reduce consing. - -\item -Array element types can be specialized, which reduces both overall size and -consing (\pxlref{specialized-array-types}.) -\end{itemize} - - -Access of arrays that are not of type \code{simple-array} is less efficient, so -declarations are appropriate when an array is of a simple type like -\code{simple-string} or \code{simple-bit-vector}. Arrays are almost always simple, -but the compiler may not be able to prove simpleness at every use. The only -way to get a non-simple array is to use the \kwd{displaced-to}, -\kwd{fill-pointer} or \code{adjustable} arguments to \code{make-array}. If you don't -use these hairy options, then arrays can always be declared to be simple. - -Because of the many specialized array types and the possibility of non-simple -arrays, array access is much like generic arithmetic (\pxlref{generic-arithmetic}). In order for array accesses to be efficiently -compiled, the element type and simpleness of the array must be known at compile -time. If there is inadequate information, the compiler is forced to call a -generic array access routine. You can detect inefficient array accesses by -enabling efficiency notes, \pxlref{efficiency-notes}. - -\node Vectors, Bit-Vectors, Arrays, Object Representation -\subsection{Vectors} -\cpsubindex{vectors}{efficiency of} - -Vectors (one dimensional arrays) are particularly useful, since in addition to -their obvious array-like applications, they are also well suited to -representing sequences. In comparison to a list representation, vectors are -faster to access and take up between two and sixty-four times less space -(depending on the element type.) As with arbitrary arrays, the compiler needs -to know that vectors are not complex, so you should use \code{simple-string} in -preference to \code{string}, etc. - -The only advantage that lists have over vectors for representing sequences is -that it is easy to change the length of a list, add to it and remove items from -it. Likely signs of archaic, slow lisp code are \code{nth} and \code{nthcdr}. If -you are using these functions you should probably be using a vector. - -\node Bit-Vectors, Hashtables, Vectors, Object Representation -\subsection{Bit-Vectors} -\cpsubindex{bit-vectors}{efficiency of} - -Another thing that lists have been used for is set manipulation. In -applications where there is a known, reasonably small universe of items -bit-vectors can be used to improve performance. This is much less convenient -than using lists, because instead of symbols, each element in the universe must -be assigned a numeric index into the bit vector. Using a bit-vector will -nearly always be faster, and can be tremendously faster if the number of -elements in the set is not small. The logical operations on -\code{simple-bit-vector}s are efficient, since they operate on a word at a time. - - -\node Hashtables, , Bit-Vectors, Object Representation -\subsection{Hashtables} -\cpsubindex{hash-tables}{efficiency of} - -Hashtables are an efficient and general mechanism for maintaining associations -such as the association between an object and its name. Although hashtables -are usually the best way to maintain associations, efficiency and style -considerations sometimes favor the use of an association list (a-list). - -\code{assoc} is fairly fast when the \var{test} argument is \code{eq} or \code{eql} and -there are only a few elements, but the time goes up in proportion with the -number of elements. In contrast, the hash-table lookup has a somewhat higher -overhead, but the speed is largely unaffected by the number of entries in the -table. For an \code{equal} hash-table or alist, hash-tables have an even greater -advantage, since the test is more expensive. Whatever you do, be sure to use -the most restrictive test function possible. - -The style argument observes that although hash-tables and alists -overlap in function, they do not do all things equally well. -\begin{itemize} - -\item -Alists are good for maintaining scoped environments. They were originally -invented to implement scoping in the Lisp interpreter, and are still used for -this in \python. With an alist one can non-destructively change an association -simply by consing a new element on the front. This is something that cannot be -done with hash-tables. - -\item -Hashtables are good for maintaining a global association. -The value associated with an entry can easily be changed with -\code{setf}. With an alist, one has to go through contortions, either -\code{rplacd}'ing the cons if the entry exists, or pushing a new one if -it doesn't. The side-effecting nature of hash-table operations is an -advantage here. -\end{itemize} - - -Historically, symbol property lists were often used for global name -associations. Property lists provide an awkward and error-prone combination of -name association and record structure. If you must use the property list, -please store all the related values in a single structure under a single -property, rather than using many properties. This makes access more efficient, -and also adds a modicum of typing and abstraction. \xlref{advanced-type-stuff} for information on types in \cmucl. - - -\node Numbers, General Efficiency Hints, Object Representation, Advanced Compiler Use and Efficiency Hints -\section{Numbers} -\label{numeric-types} -\cpsubindex{numeric}{types} -\cpsubindex{types}{numeric} - -Numbers are interesting because numbers are one of the few \llisp{} data types -that have direct support in conventional hardware. If a number can be -represented in the way that the hardware expects it, then there is a big -efficiency advantage. - -Using hardware representations is problematical in \llisp{} due to dynamic typing -(where the type of a value may be unknown at compile time.) It is possible to -compile code for statically typed portions of a \llisp{} program with efficiency -comparable to that obtained in statically typed languages such as C, but not -all \llisp{} implementations succeed. There are two main barriers to efficient -numerical code in \llisp{}: -\begin{itemize} - -\item -The compiler must prove that the numerical expression is in fact statically -typed, and - -\item -The compiler must be able to somehow reconcile the conflicting demands of the -hardware mandated number representation with the \llisp{} requirements of dynamic -typing and garbage-collecting dynamic storage allocation. -\end{itemize} - -Because of its type inference (\pxlref{type-inference}) and efficiency -notes (\pxlref{efficiency-notes}), \python{} is better than conventional -\llisp{} compilers at ensuring that numerical expressions are statically typed. -Python also goes somewhat farther than existing compilers in the area of -allowing native machine number representations in the presence of garbage -collection. - -\begin{menu} -* Descriptors:: -* Non-Descriptor Representations:: -* Variables:: -* Generic Arithmetic:: -* Fixnums:: -* Word Integers:: -* Floating Point Efficiency:: -* Specialized Arrays:: -* Interactions With Local Call:: -* Representation of Characters:: -\end{menu} - -\node Descriptors, Non-Descriptor Representations, Numbers, Numbers -\subsection{Descriptors} -\cpsubindex{descriptors}{object} -\cindex{object representation} -\cpsubindex{representation}{object} -\cpsubindex{consing}{overhead of} - -\llisp{}'s dynamic typing requires that it be possible to represent any value -with a fixed length object, known as a \var{descriptor}. This fixed-length -requirement is implicit in features such as: -\begin{itemize} - -\item -Data types (like \code{simple-vector}) that can contain any type of object, and -that can be destructively modified to contain different objects (of possibly -different types.) - -\item -Functions that can be called with any type of argument, and that can be -redefined at run time. -\end{itemize} - -In order to save space, a descriptor is invariably represented as a single -word. Objects that can be directly represented in the descriptor itself are -said to be \var{immediate}. Descriptors for objects larger than one word are in -reality pointers to the memory actually containing the object. - -Representing objects using pointers has two major disadvantages: -\begin{itemize} - -\item -The memory pointed to must be allocated on the heap, so it must eventually be -freed by the garbage collector. Excessive heap allocation of objects (or -"consing") is inefficient in several ways. \xlref{consing}. - -\item -Representing an object in memory requires the compiler to emit additional -instructions to read the actual value in from memory, and then to write the -value back after operating on it. -\end{itemize} - -The introduction of garbage collection makes things even worse, since the -garbage collector must be able to determine whether a descriptor is an -immediate object or a pointer. This requires that a few bits in each -descriptor be dedicated to the garbage collector. The loss of a few bits -doesn't seem like much, but it has a major efficiency implication \dash{} objects -whose natural machine representation is a full word (integers and -single-floats) cannot have an immediate representation. So the compiler is -forced to use an unnatural immediate representation (such as \code{fixnum}) or a -natural pointer representation (with the attendant consing overhead.) - - -\node Non-Descriptor Representations, Variables, Descriptors, Numbers -\subsection{Non-Descriptor Representations} -\label{non-descriptor} -\cindex{non-descriptor representations} -\cindex{stack numbers} - -From the discussion above, we can see that the standard descriptor -representation has many problems, the worst being number consing. -\llisp{} compilers try to avoid these descriptor efficiency problems by using -\var{non-descriptor} representations. A compiler that uses non-descriptor -representations can compile this function so that it does no number consing: -\begin{lisp} -(defun multby (vec n) - (declare (type (simple-array single-float (*)) vec) - (single-float n)) - (dotimes (i (length vec)) - (setf (aref vec i) - (* n (aref vec i))))) -\end{lisp} -If a descriptor representation were used, each iteration of the loop might -cons two floats and do three times as many memory references. - -As its negative definition suggests, the range of possible non-descriptor -representations is large. The performance improvement from non-descriptor -representation depends upon both the number of types that have non-descriptor -representations and the number of contexts in which the compiler is forced to -use a descriptor representation. - -Many \llisp{} compilers support non-descriptor representations for float types -such as \code{single-float} and \code{double-float} (section \ref{float-efficiency}.) -\python{} adds support for full word integers (\pxlref{word-integers}), -characters (\pxlref{characters}) and system-area pointers (unconstrained -pointers, \pxlref{system-area-pointers}.) Many \llisp{} compilers -support non-descriptor representations for variables (section -\ref{ND-variables}) and array elements (section \ref{specialized-array-types}.) -\python{} adds support for non-descriptor arguments and return values in local -call (\pxlref{number-local-call}). -\node Variables, Generic Arithmetic, Non-Descriptor Representations, Numbers -\subsection{Variables} -\label{ND-variables} -\cpsubindex{variables}{non-descriptor} -\cpsubindex{type declarations}{variable} -\cpsubindex{efficiency}{of numeric variables} - -In order to use a non-descriptor representation for a variable or expression -intermediate value, the compiler must be able to prove that the value is always -of a particular type having a non-descriptor representation. Type inference -(\pxlref{type-inference}) often needs some help from user-supplied -declarations. The best kind of type declaration is a variable type declaration -placed at the binding point: -\begin{lisp} -(let ((x (car l))) - (declare (single-float x)) - ...) -\end{lisp} -Use of \code{the}, or of variable declarations not at the binding form is -insufficient to allow non-descriptor representation of the variable \dash{} with -these declarations it is not certain that all values of the variable are of the -right type. It is sometimes useful to introduce a gratuitous binding that -allows the compiler to change to a non-descriptor representation, like: -\begin{lisp} -(etypecase x - ((signed-byte 32) - (let ((x x)) - (declare (type (signed-byte 32) x)) - ...)) - ...) -\end{lisp} -The declaration on the inner \code{x} is necessary here due to a phase ordering -problem. Although the compiler will eventually prove that the outer \code{x} is -a \w{\code{(signed-byte 32)}} within that \code{etypecase} branch, the inner \code{x} -would have been optimized away by that time. Declaring the type makes let -optimization more cautious. - -Note that storing a value into a global (or \code{special}) variable always forces -a descriptor representation. Wherever possible, you should operate only on -local variables, binding any referenced globals to local variables at the -beginning of the function, and doing any global assignments at the end. - -Efficiency notes signal use of inefficient representations, so programmer's -needn't continuously worry about the details of representation selection (\pxlref{representation-eff-note}.) - -\node Generic Arithmetic, Fixnums, Variables, Numbers -\subsection{Generic Arithmetic} -\label{generic-arithmetic} -\cindex{generic arithmetic} -\cpsubindex{arithmetic}{generic} -\cpsubindex{numeric}{operation efficiency} - -In \clisp, arithmetic operations are \var{generic}.\footnote{As Steele notes in CLTL -II, this is a generic conception of generic, and is not to be confused with the -CLOS concept of a generic function.} The \code{+} function can be passed -\code{fixnum}s, \code{bignum}s, \code{ratio}s, and various kinds of \code{float}s and -\code{complex}es, in any combination. In addition to the inherent complexity of -\code{bignum} and \code{ratio} operations, there is also a lot of overhead in just -figuring out which operation to do and what contagion and canonicalization -rules apply. The complexity of generic arithmetic is so great that it is -inconceivable to open code it. Instead, the compiler does a function call to a -generic arithmetic routine, consuming many instructions before the actual -computation even starts. - -This is ridiculous, since even \llisp{} programs do a lot of arithmetic, and the -hardware is capable of doing operations on small integers and floats with a -single instruction. To get acceptable efficiency, the compiler special-cases -uses of generic arithmetic that are directly implemented in the hardware. In -order to open code arithmetic, several constraints must be met: -\begin{itemize} - -\item -All the arguments must be known to be a good type of number. - -\item -The result must be known to be a good type of number. - -\item -Any intermediate values such as the result of \w{\code{(+ a b)}} in the call -\w{\code{(+ a b c)}} must be known to be a good type of number. - -\item -All the above numbers with good types must be of the \var{same} good type. Don't -try to mix integers and floats or different float formats. -\end{itemize} - -The "good types" are \w{\code{(signed-byte 32)}}, \w{\code{(unsigned-byte 32)}}, -\code{single-float} and \code{double-float}. See sections \ref{fixnums}, -\ref{word-integers} and \ref{float-efficiency} for more discussion of good -numeric types. - -\code{float} is not a good type, since it might mean either \code{single-float} or -\code{double-float}. \code{integer} is not a good type, since it might mean -\code{bignum}. \code{rational} is not a good type, since it might mean \code{ratio}. -Note however that these types are still useful in declarations, since -type inference may be able to strengthen a weak declaration into a good one, -when it would be at a loss if there was no declaration at all (\pxlref{type-inference}). The \code{integer} and \code{unsigned-byte} (or non-negative -integer) types are especially useful in this regard, since they can often be -strengthened to a good integer type. - -Arithmetic with \code{complex} numbers is inefficient in comparison to float and -integer arithmetic. Complex numbers are always represented with a pointer -descriptor (causing consing overhead), and complex arithmetic is always closed -coded using the general generic arithmetic functions. But arithmetic with -complex types such as: -\begin{lisp} -(complex float) -(complex fixnum) -\end{lisp} -is still faster than \code{bignum} or \code{ratio} arithmetic, since the -implementation is much simpler. - -Note: don't use \code{/} to divide integers unless you want the overhead of -rational arithmetic. Use \code{truncate} even when you know that the arguments -divide evenly. - -You don't need to remember all the rules for how to get open-coded arithmetic, -since efficiency notes will tell you when and where there is a problem \dash{} -\pxlref{efficiency-notes}. - - -\node Fixnums, Word Integers, Generic Arithmetic, Numbers -\subsection{Fixnums} -\label{fixnums} -\cindex{fixnums} -\cindex{bignums} - -A fixnum is a "FIXed precision NUMber". In modern \llisp{} implementations, -fixnums can be represented with an immediate descriptor, so operating on -fixnums requires no consing or memory references. Clever choice of -representations also allows some arithmetic operations to be done on fixnums -using hardware supported word-integer instructions, somewhat reducing the -speed penalty for using an unnatural integer representation. - -It is useful to distinguish the \code{fixnum} type from the fixnum representation -of integers. In \python, there is absolutely nothing magical about the -\code{fixnum} type in comparison to other finite integer types. \code{fixnum} is -equivalent to (is defined with \code{deftype} to be) \w{\code{(signed-byte 30)}}. -\code{fixnum} is simply the largest subset of integers that \i{can be represented} -using an immediate fixnum descriptor. - -Unlike in other \clisp{} compilers, it is in no way desirable to use the -\code{fixnum} type in declarations in preference to more restrictive integer types -such as \code{bit}, \w{\code{(integer -43 7)}} and \w{\code{(unsigned-byte 8)}}. Since -Python does understand these integer types, it is preferable to use the more -restrictive type, as it allows better type inference (\pxlref{operation-type-inference}.) - -The small, efficient fixnum is contrasted with bignum, or "BIG NUMber". This -is another descriptor representation for integers, but this time a pointer -representation that allows for arbitrarily large integers. Bignum operations -are less efficient than fixnum operations, both because of the consing and -memory reference overheads of a pointer descriptor, and also because of the -inherent complexity of extended precision arithmetic. While fixnum operations -can often be done with a single instruction, bignum operations are so complex -that they are always done using generic arithmetic. - -A crucial point is that the compiler will use generic arithmetic if -it can't \var{prove} that all the arguments, intermediate values, and results are -fixnums. With bounded integer types such as \code{fixnum}, the result type proves -to be especially problematical, since these types are not closed under -common arithmetic operations such as \code{+}, \code{-}, \code{*} and \code{/}. For -example, \w{\code{(1+ (the fixnum x))}} does not necessarily evaluate to a -\code{fixnum}. Bignums were added to \llisp{} to get around this problem, but they -really just transform the correctness problem "if this add overflows, you will -get the wrong answer" to the efficiency problem "if this add \var{might} overflow -then your program will run slowly (because of generic arithmetic.)" - -There is just no getting around the fact that the hardware only directly -supports short integers. To get the most efficient open coding, the compiler -must be able to prove that the result is a good integer type. This is an -argument in favor of using more restrictive integer types: -\w{\code{(1+ (the fixnum x))}} may not always be a \code{fixnum}, but -\w{\code{(1+ (the (unsigned-byte 8) x))}} always is. -Of course, you can also assert the result type by putting in lots of \code{the} -declarations and then compiling with \code{safety} \code{0}. - -\node Word Integers, Floating Point Efficiency, Fixnums, Numbers -\subsection{Word Integers} -\label{word-integers} -\cindex{word integers} - -Python is unique in its efficient implementation of arithmetic -on full-word integers through non-descriptor representations and open coding. -Arithmetic on any subtype of these types: -\begin{lisp} -(signed-byte 32) -(unsigned-byte 32) -\end{lisp} -is reasonably efficient, although subtypes of \code{fixnum} remain somewhat more -efficient. - -If a word integer must be represented as a descriptor, then the \code{bignum} -representation is used, with its associated consing overhead. The support for -word integers in no way changes the language semantics, it just makes -arithmetic on small bignums vastly more efficient. It is fine to do arithmetic -operations with mixed \code{fixnum} and word integer operands; just declare the -most specific integer type you can, and let the compiler decide what -representation to use. - -In fact, to most users, the greatest advantage of word integer arithmetic is -that it effectively provides a few guard bits on the fixnum representation. If -there are missing assertions on intermediate values in a fixnum expression, the -intermediate results can usually be proved to fit in a word. After the whole -expression is evaluated, there will often be a fixnum assertion on the final -result, allowing creation of a fixnum result without even checking for -overflow. - -The remarks in section \ref{fixnums} about fixnum result type also apply to -word integers; you must be careful to give the compiler enough information to -prove that the result is still a word integer. This time, though, when we blow -out of word integers we land in into generic bignum arithmetic, which is much -worse than sleazing from \code{fixnum}s to word integers. Note that mixing -\w{\code{(unsigned-byte 32)}} arguments with arguments of any signed type (such as -\code{fixnum}) is a no-no, since the result might not be unsigned. - -\node Floating Point Efficiency, Specialized Arrays, Word Integers, Numbers -\subsection{Floating Point Efficiency} -\label{float-efficiency} -\cindex{floating point efficiency} - -Arithmetic on objects of type \code{single-float} and \code{double-float} is -efficiently implemented using non-descriptor representations and open coding. -As for integer arithmetic, the arguments must be known to be of the same float -type. Unlike for integer arithmetic, the results and intermediate values -usually take care of themselves due to the rules of float contagion, i.e. -\w{\code{(1+ (the single-float x))}} is always a \code{single-float}. - -Although they are not specially implemented, \code{short-float} and \code{long-float} -are also acceptable in declarations, since they are synonyms for the -\code{single-float} and \code{double-float} types, respectively. It is harmless to -use list-style float type specifiers such as \w{\code{(single-float 0.0 1.0)}}, -but Python currently makes little use of bounds on float types. - -When a float must be represented as a descriptor, a pointer representation is -used, creating consing overhead. For this reason, you should try to avoid -situations (such as full call and non-specialized data structures) that force a -descriptor representation. See sections \ref{specialized-array-types} and -\ref{number-local-call}. - -\xlref{ieee-float} for information on the extensions to support IEEE -floating point. - -\node Specialized Arrays, Interactions With Local Call, Floating Point Efficiency, Numbers -\subsection{Specialized Arrays} -\label{specialized-array-types} -\cindex{specialized array types} -\cpsubindex{array types}{specialized} -\cpsubindex{types}{specialized array} - -\clisp{} supports specialized array element types through the \kwd{element-type} -argument to \code{make-array}. When an array has a specialized element type, only -elements of that type can be stored in the array. From this restriction comes -two major efficiency advantages: -\begin{itemize} - -\item -A specialized array can save space by packing multiple elements into a single -word. For example, a \code{base-char} array can have 4 elements per word, and -a \code{bit} array can have 32. This space-efficient representation is possible -because it is not necessary to separately indicate the type of each element. - -\item -The elements in a specialized array can be given the same non-descriptor -representation as the one used in registers and on the stack, eliminating the -need for representation conversions when reading and writing array elements. -For objects with pointer descriptor representations (such as floats and word -integers) there is also a substantial consing reduction because it is not -necessary to allocate a new object every time an array element is modified. -\end{itemize} - - -These are the specialized element types currently supported: -\begin{lisp} -bit -(unsigned-byte 2) -(unsigned-byte 4) -(unsigned-byte 8) -(unsigned-byte 16) -(unsigned-byte 32) -base-character -single-float -double-float -\end{lisp} -Although a \code{simple-vector} can hold any type of object, \true{} should still be -considered a specialized array type, since arrays with element type \true{} are -specialized to hold descriptors. - -When using non-descriptor representations, it is particularly important to make -sure that array accesses are open-coded, since in addition to the generic -operation overhead, efficiency is lost when the array element is converted to a -descriptor so that it can be passed to (or from) the generic access routine. -You can detect inefficient array accesses by enabling efficiency notes, \pxlref{efficiency-notes}. \xlref{array-types}. - -\node Interactions With Local Call, Representation of Characters, Specialized Arrays, Numbers -\subsection{Interactions With Local Call} -\label{number-local-call} -\cpsubindex{local call}{numeric operands} -\cpsubindex{call}{numeric operands} -\cindex{numbers in local call} - -Local call has many advantages (\pxlref{local-call}); one relevant to -our discussion here is that local call extends the usefulness of non-descriptor -representations. If the compiler knows from the argument type that an argument -has a non-descriptor representation, then the argument will be passed in that -representation. The easiest way to ensure that the argument type is known at -compile time is to always declare the argument type in the called function, -like: -\begin{lisp} -(defun 2+f (x) - (declare (single-float x)) - (+ x 2.0)) -\end{lisp} -The advantages of passing arguments and return values in a non-descriptor -representation are the same as for non-descriptor representations in general: -reduced consing and memory access (\pxlref{non-descriptor}.) This -extends the applicative programming styles discussed in section -\ref{local-call} to numeric code. Also, if source files are kept reasonably -small, block compilation can be used to reduce number consing to a minimum. - -Note that non-descriptor return values can only be used with the known return -convention (section \ref{local-call-return}.) If the compiler can't prove that -a function always returns the same number of values, then it must use the -unknown values return convention, which requires a descriptor representation. -Pay attention to the known return efficiency notes to avoid number consing. - -\node Representation of Characters, , Interactions With Local Call, Numbers -\subsection{Representation of Characters} -\label{characters} -\cindex{characters} -\cindex{strings} - -Python also uses a non-descriptor representation for characters when -convenient. This improves the efficiency of string manipulation, but is -otherwise pretty invisible; characters have an immediate descriptor -representation, so there is not a great penalty for converting a character to a -descriptor. Nonetheless, it may sometimes be helpful to declare -character-valued variables as \code{base-character}. - - -\node General Efficiency Hints, Efficiency Notes, Numbers, Advanced Compiler Use and Efficiency Hints -\section{General Efficiency Hints} -\label{general-efficiency} -\cpsubindex{efficiency}{general hints} - -This section is a summary of various implementation costs and ways to get -around them. These hints are relatively unrelated to the use of the \python{} -compiler, and probably also apply to most other \llisp{} implementations. In -each section, there are references to related in-depth discussion. - -\begin{menu} -* Compile Your Code:: -* Avoid Unnecessary Consing:: -* Complex Argument Syntax:: -* Mapping and Iteration:: -* Trace Files and Disassembly:: -\end{menu} - -\node Compile Your Code, Avoid Unnecessary Consing, General Efficiency Hints, General Efficiency Hints -\subsection{Compile Your Code} -\cpsubindex{compilation}{why to} - -At this point, the advantages of compiling code relative to running it -interpreted probably need not be emphasized too much, but remember that -in \cmucl, compiled code typically runs hundreds of times faster than -interpreted code. Also, compiled (\code{fasl}) files load significantly faster -than source files, so it is worthwhile compiling files which are loaded many -times, even if the speed of the functions in the file is unimportant. - -Even disregarding the efficiency advantages, compiled code is as good or better -than interpreted code. Compiled code can be debugged at the source level (see -chapter \ref{debugger}), and compiled code does more error checking. For these -reasons, the interpreter should be regarded mainly as an interactive command -interpreter, rather than as a programming language implementation. - -\b{Do not} be concerned about the performance of your program until you -see its speed compiled. Some techniques that make compiled code run -faster make interpreted code run slower. - -\node Avoid Unnecessary Consing, Complex Argument Syntax, Compile Your Code, General Efficiency Hints -\subsection{Avoid Unnecessary Consing} -\cindex{consing} -\cindex{garbage collection} -\cindex{memory allocation} -\cpsubindex{efficiency}{of memory use} - -\label{consing} Consing is another name for allocation of storage, as done by -the \code{cons} function (hence its name.) \code{cons} is by no means the only -function which conses \dash{} so does \code{make-array} and many other functions. -Arithmetic and function call can also have hidden consing overheads. Consing -hurts performance in the following ways: -\begin{itemize} - -\item -Consing reduces memory access locality, increasing paging activity. - -\item -Consing takes time just like anything else. - -\item -Any space allocated eventually needs to be reclaimed, either by garbage -collection or by starting a new \code{lisp} process. -\end{itemize} - - -Consing is not undiluted evil, since programs do things other than consing, and -appropriate consing can speed up the real work. It would certainly save time -to allocate a vector of intermediate results that are reused hundreds of -times. Also, if it is necessary to copy a large data structure many times, it -may be more efficient to update the data structure non-destructively; this -somewhat increases update overhead, but makes copying trivial. - -Note that the remarks in section \ref{efficiency-overview} about the importance -of separating tuning from coding also apply to consing overhead. The majority -of consing will be done by a small portion of the program. The consing hot -spots are even less predictable than the CPU hot spots, so don't waste time and -create bugs by doing unnecessary consing optimization. During initial coding, -avoid unnecessary side-effects and cons where it is convenient. If profiling -reveals a consing problem, \var{then} go back and fix the hot spots. - -\xlref{non-descriptor} for a discussion of how to avoid number -consing in \python. - - -\node Complex Argument Syntax, Mapping and Iteration, Avoid Unnecessary Consing, General Efficiency Hints -\subsection{Complex Argument Syntax} -\cpsubindex{argument syntax}{efficiency} -\cpsubindex{efficiency}{of argument syntax} -\cindex{keyword argument efficiency} -\cindex{rest argument efficiency} - -Common Lisp has very powerful argument passing mechanisms. Unfortunately, two -of the most powerful mechanisms, rest arguments and keyword arguments, have a -significant performance penalty: -\begin{itemize} - -\item -With keyword arguments, the called function has to parse the supplied keywords -by iterating over them and checking them against the desired keywords. - -\item -With rest arguments, the function must cons a list to hold the arguments. If a -function is called many times or with many arguments, large amounts of memory -will be allocated. -\end{itemize} - -Although rest argument consing is worse than keyword parsing, neither problem -is serious unless thousands of calls are made to such a function. The use of -keyword arguments is strongly encouraged in functions with many arguments or -with interfaces that are likely to be extended, and rest arguments are often -natural in user interface functions. - -Optional arguments have some efficiency advantage over keyword arguments, but -their syntactic clumsiness and lack of extensibility has caused many \clisp{} -programmers to abandon use of optionals except in functions that have obviously -simple and immutable interfaces (such as \code{subseq}), or in functions that are -only called in a few places. When defining an interface function to be used by -other programmers or users, use of only required and keyword arguments is -recommended. - -Parsing of \code{defmacro} keyword and rest arguments is done at compile time, so -a macro can be used to provide a convenient syntax with an efficient -implementation. If the macro-expanded form contains no keyword or rest -arguments, then it is perfectly acceptable in inner loops. - -Keyword argument parsing overhead can also be avoided by use of inline -expansion (\pxlref{inline-expansion}) and block compilation (section -\ref{block-compilation}.) - -Note: the compiler open-codes most heavily used system functions which have -keyword or rest arguments, so that no run-time overhead is involved. - -\node Mapping and Iteration, Trace Files and Disassembly, Complex Argument Syntax, General Efficiency Hints -\subsection{Mapping and Iteration} -\cpsubindex{mapping}{efficiency of} - -One of the traditional \llisp{} programming styles is a highly applicative one, -involving the use of mapping functions and many lists to store intermediate -results. To compute the sum of the square-roots of a list of numbers, one -might say: -\begin{lisp} -(apply #'+ (mapcar #'sqrt list-of-numbers)) -\end{lisp} - -This programming style is clear and elegant, but unfortunately results -in slow code. There are two reasons why: -\begin{itemize} - -\item -The creation of lists of intermediate results causes much consing (see -\ref{consing}). - -\item -Each level of application requires another scan down the list. Thus, -disregarding other effects, the above code would probably take twice -as long as a straightforward iterative version. -\end{itemize} - - -An example of an iterative version of the same code: -\begin{lisp} -(do ((num list-of-numbers (cdr num)) - (sum 0 (+ (sqrt (car num)) sum))) - ((null num) sum)) -\end{lisp} - -See sections \ref{variable-type-inference} and \ref{let-optimization} for a -discussion of the interactions of iteration constructs with type inference and -variable optimization. Also, section \ref{local-tail-recursion} discusses an -applicative style of iteration. - -\node Trace Files and Disassembly, , Mapping and Iteration, General Efficiency Hints -\subsection{Trace Files and Disassembly} -\label{trace-files} -\cindex{trace files} -\cindex{assembly listing} -\cpsubindex{listing files}{trace} -\cindex{Virtual Machine (VM, or IR2) representation} -\cindex{implicit continuation representation (IR1)} -\cpsubindex{continuations}{implicit representation} - -In order to write efficient code, you need to know the relative costs of -different operations. The main reason why writing efficient \llisp{} code is -difficult is that there are so many operations, and the costs of these -operations vary in obscure context-dependent ways. Although efficiency notes -point out some problem areas, the only way to ensure generation of the best code -is to look at the assembly code output. - -The \code{disassemble} function is a convenient way to get the assembly code for a -function, but it can be very difficult to interpret, since the correspondence -with the original source code is weak. A better (but more awkward) option is -to use the \kwd{trace-file} argument to \code{compile-file} to generate a trace -file. - -A trace file is a dump of the compiler's internal representations, including -annotated assembly code. Each component in the program gets three pages in -the trace file (separated by "\code{^L}"): -\begin{itemize} - -\item -The implicit-continuation (or IR1) representation of the optimized source. -This is a dump of the flow graph representation used for "source level" -optimizations. As you will quickly notice, it is not really very close to the -source. This representation is not very useful to even sophisticated users. - -\item -The Virtual Machine (VM, or IR2) representation of the program. This dump -represents the generated code as sequences of "Virtual OPerations" (VOPs.) -This representation is intermediate between the source and the assembly code -\dash{} each VOP corresponds fairly directly to some primitive function or -construct, but a given VOP also has a fairly predictable instruction sequence. -An operation (such as \code{+}) may have multiple implementations with different -cost and applicability. The choice of a particular VOP such as \code{+/fixnum} or -\code{+/single-float} represents this choice of implementation. Once you are -familiar with it, the VM representation is probably the most useful for -determining what implementation has been used. - -\item -An assembly listing, annotated with the VOP responsible for generating the -instructions. This listing is useful for figuring out what a VOP does and how -it is implemented in a particular context, but its large size makes it more -difficult to read. -\end{itemize} - - -Note that trace file generation takes much space and time, since the trace file -is tens of times larger than the source file. To avoid huge confusing trace -files and much wasted time, it is best to separate the critical program portion -into its own file and then generate the trace file from this small file. - - -\node Efficiency Notes, Profiling, General Efficiency Hints, Advanced Compiler Use and Efficiency Hints -\section{Efficiency Notes} -\label{efficiency-notes} -\cindex{efficiency notes} -\cpsubindex{notes}{efficiency} -\cindex{tuning} - -Efficiency notes are messages that warn the user that the compiler has chosen a -relatively inefficient implementation for some operation. Usually an -efficiency note reflects the compiler's desire for more type information. If -the type of the values concerned is known to the programmer, then additional -declarations can be used to get a more efficient implementation. - -Efficiency notes are controlled by the \code{extensions:inhibit-warnings} -optimization quality (\pxlref{optimize-declaration}.) When \code{speed} -is greater than \code{extensions:inhibit-warnings}, efficiency notes are enabled. -Note that this implicitly enables efficiency notes whenever \code{speed} is -increased from its default of \code{1}. - -Consider this program with an obscure missing declaration: -\begin{lisp} -(defun eff-note (x y z) - (declare (fixnum x y z)) - (the fixnum (+ x y z))) -\end{lisp} -If compiled with \code{\w{(speed 3) (safety 0)}}, this note is given: -\begin{example} -In: DEFUN EFF-NOTE - (+ X Y Z) -==> - (+ (+ X Y) Z) -Note: Forced to do inline (signed-byte 32) arithmetic (cost 3). - Unable to do inline fixnum arithmetic (cost 2) because: - The first argument is a (INTEGER -1073741824 1073741822), - not a FIXNUM. -\end{example} -This efficiency note tells us that the result of the intermediate computation -\code{\w{(+ x y)}} is not known to be a \code{fixnum}, so the addition of the -intermediate sum to \code{z} must be done less efficiently. This can be fixed by -changing the definition of \code{eff-note}: -\begin{lisp} -(defun eff-note (x y z) - (declare (fixnum x y z)) - (the fixnum (+ (the fixnum (+ x y)) z))) -\end{lisp} - -\begin{menu} -* Type Uncertainty:: -* Efficiency Notes and Type Checking:: -* Representation Efficiency Notes:: -* Verbosity Control:: -\end{menu} - -\node Type Uncertainty, Efficiency Notes and Type Checking, Efficiency Notes, Efficiency Notes -\subsection{Type Uncertainty} -\cpsubindex{types}{uncertainty} -\cindex{uncertainty of types} - -The main cause of inefficiency is the compiler's lack of adequate information -about the types of function argument and result values. Many important -operations (such as arithmetic) have an inefficient general (generic) case, but -have efficient implementations that can usually be used if there is sufficient -argument type information. - -Type efficiency notes are given when a value's type is uncertain. There is an -important distinction between values that are \i{not known} to be of a good -type (uncertain) and values that are \i{known not} to be of a good type. -Efficiency notes are given mainly for the first case (uncertain types.) If it -is clear to the compiler that that there is not an efficient implementation for -a particular function call, then an efficiency note will only be given if the -\code{extensions:inhibit-warnings} optimization quality is \code{0} (\pxlref{optimize-declaration}.) - -In other words, the default efficiency notes only suggest that you add -declarations, not that you change the semantics of your program so that an -efficient implementation will apply. For example, compilation of this form -will not give an efficiency note: -\begin{lisp} -(elt (the list l) i) -\end{lisp} -even though a vector access is more efficient than indexing a list. - -\node Efficiency Notes and Type Checking, Representation Efficiency Notes, Type Uncertainty, Efficiency Notes -\subsection{Efficiency Notes and Type Checking} -\cpsubindex{type checking}{efficiency of} -\cpsubindex{efficiency}{of type checking} -\cpsubindex{optimization}{type check} - -It is important that the \code{eff-note} example above used -\w{\code{(safety 0)}}. When type checking is enabled, you may get apparently -spurious efficiency notes. With \w{\code{(safety 1)}}, the note has this extra -line on the end: -\begin{example} -The result is a (INTEGER -1610612736 1610612733), not a FIXNUM. -\end{example} -This seems strange, since there is a \code{the} declaration on the result of that -second addition. - -In fact, the inefficiency is real, and is a consequence of \python{}'s treating -declarations as assertions to be verified. The compiler can't assume that the -result type declaration is true \dash{} it must generate the result and then test -whether it is of the appropriate type. - -In practice, this means that when you are tuning a program to run without type -checks, you should work from the efficiency notes generated by unsafe -compilation. If you want code to run efficiently with type checking, then you -should pay attention to all the efficiency notes that you get during safe -compilation. Since user supplied output type assertions (e.g., from \code{the}) -are disregarded when selecting operation implementations for safe code, you -must somehow give the compiler information that allows it to prove that the -result truly must be of a good type. In our example, it could be done by -constraining the argument types more: -\begin{lisp} -(defun eff-note (x y z) - (declare (type (unsigned-byte 18) x y z)) - (+ x y z)) -\end{lisp} -Of course, this declaration is acceptable only if the arguments to \code{eff-note} -always \var{are} \w{\code{(unsigned-byte 18)}} integers. - -\node Representation Efficiency Notes, Verbosity Control, Efficiency Notes and Type Checking, Efficiency Notes -\subsection{Representation Efficiency Notes} -\label{representation-eff-note} -\cindex{representation efficiency notes} -\cpsubindex{efficiency notes}{for representation} -\cindex{object representation efficiency notes} -\cindex{stack numbers} -\cindex{non-descriptor representations} -\cpsubindex{descriptor representations}{forcing of} - -When operating on values that have non-descriptor representations (\pxlref{non-descriptor}), there can be a substantial time and consing penalty for -converting to and from descriptor representations. For this reason, the -compiler gives an efficiency note whenever it is forced to do a representation -coercion more expensive than \varref{efficiency-note-cost-threshold}. - -Inefficient representation coercions may be due to type uncertainty, as in this example: -\begin{lisp} -(defun set-flo (x) - (declare (single-float x)) - (prog ((var 0.0)) - (setq var (gorp)) - (setq var x) - (return var))) -\end{lisp} -which produces this efficiency note: -\begin{example} -In: DEFUN SET-FLO - (SETQ VAR X) -Note: Doing float to pointer coercion (cost 13) from X to VAR. -\end{example} -The variable \code{var} is not known to always hold values of type -\code{single-float}, so a descriptor representation must be used for its value. -In sort of situation, and adding a declaration will eliminate the inefficiency. - -Often inefficient representation conversions are not due to type uncertainty -\dash{} instead, they result from evaluating a non-descriptor expression in a -context that requires a descriptor result: -\begin{itemize} - -\item -Assignment to or initialization of any data structure other than a specialized -array (\pxlref{specialized-array-types}), or - -\item -Assignment to a \code{special} variable, or - -\item -Passing as an argument or returning as a value in any function call that is not -a local call (\pxlref{number-local-call}.) -\end{itemize} - -If such inefficient coercions appear in a "hot spot" in the program, data -structures redesign or program reorganization may be necessary to improve -efficiency. See sections \ref{block-compilation}, \ref{numeric-types} and -\ref{profiling}. - -Because representation selection is done rather late in compilation, the source -context in these efficiency notes is somewhat vague, making interpretation more -difficult. This is a fairly straightforward example: -\begin{lisp} -(defun cf+ (x y) - (declare (single-float x y)) - (cons (+ x y) t)) -\end{lisp} -which gives this efficiency note: -\begin{example} -In: DEFUN CF+ - (CONS (+ X Y) T) -Note: Doing float to pointer coercion (cost 13), for: - The first argument of CONS. -\end{example} -The source context form is almost always the form that receives the value being -coerced (as it is in the preceding example), but can also be the source form -which generates the coerced value. Compiling this example: -\begin{lisp} -(defun if-cf+ (x y) - (declare (single-float x y)) - (cons (if (grue) (+ x y) (snoc)) t)) -\end{lisp} -produces this note: -\begin{example} -In: DEFUN IF-CF+ - (+ X Y) -Note: Doing float to pointer coercion (cost 13). -\end{example} - -In either case, the note's text explanation attempts to include additional -information about what locations are the source and destination of the -coercion. Here are some example notes: -\begin{example} - (IF (GRUE) X (SNOC)) -Note: Doing float to pointer coercion (cost 13) from X. - - (SETQ VAR X) -Note: Doing float to pointer coercion (cost 13) from X to VAR. -\end{example} -Note that the return value of a function is also a place to which coercions may -have to be done: -\begin{example} - (DEFUN F+ (X Y) (DECLARE (SINGLE-FLOAT X Y)) (+ X Y)) -Note: Doing float to pointer coercion (cost 13) to "<return value>". -\end{example} -Sometimes the compiler is unable to determine a name for the source or -destination, in which case the source context is the only clue. - - -\node Verbosity Control, , Representation Efficiency Notes, Efficiency Notes -\subsection{Verbosity Control} -\cpsubindex{verbosity}{of efficiency notes} -\cpsubindex{efficiency notes}{verbosity} - -These variables control the verbosity of efficiency notes: - -\defvar{efficiency-note-cost-threshold} -Before printing some efficiency notes, the compiler compares the value of this -variable to the difference in cost between the chosen implementation and the -best potential implementation. If the difference is not greater than this -limit, then no note is printed. The units are implementation dependent; -the initial value suppresses notes about "trivial" inefficiencies. A value of -\code{1} will note any inefficiency. -\enddefvar - -\defvar{efficiency-note-limit} -When printing some efficiency notes, the compiler reports possible efficient -implementations. The initial value of \code{2} prevents excessively long -efficiency notes in the common case where there is no type information, so all -implementations are possible. -\enddefvar - - -\node Profiling, , Efficiency Notes, Advanced Compiler Use and Efficiency Hints -\section{Profiling} - -\cindex{profiling} -\cindex{timing} -\cindex{consing} -\cindex{tuning} -\label{profiling} - -The first step in improving a program's performance is to profile the activity -of the program to find where it spends its time. The best way to do this is to -use the profiling utility found in the \code{profile} package. This package -provides a macro \code{profile} that encapsulates functions with statistics -gathering code. - -\begin{menu} -* Profile Interface:: -* Profiling Techniques:: -* Nested or Recursive Calls:: -* Clock resolution:: -* Profiling overhead:: -* Additional Timing Utilities:: -* A Note on Timing:: -* Benchmarking Techniques:: -\end{menu} - -\node Profile Interface, Profiling Techniques, Profiling, Profiling -\subsection{Profile Interface} - -\defvar{timed-functions} -This variable holds a list of all functions that are currently being profiled. -\enddefvar - -\defmac{profile}{ \args{\mstar{\var{name}}}} -This macro wraps profiling code around the named functions. As in \code{trace}, -the \var{name}s are not evaluated. If a function is already profiled, then the -function is unprofiled and reprofiled (useful to notice function redefinition.) -A warning is printed for each name that is not a defined function. -\enddefmac - -\defmac{unprofile}{ \args{\mstar{\var{name}}}} -This macro removes profiling code from the named functions. If no \var{name}s -are supplied, all currently profiled functions are unprofiled. -\enddefmac - - -\defmac{report-time}{ \args{\mstar{\var{name}}}} -This macro prints a report for each \var{name}d function of the following -information: -\begin{itemize} -\item The total CPU time used in that function for all calls, - -\item the total number of bytes consed in that function for all calls, - -\item the total number of calls, - -\item the average amount of CPU time per call. -\end{itemize} -Summary totals of the CPU time, consing and calls columns are printed. An -estimate of the profiling overhead is also printed (see below). If no -\var{name}s are supplied, then the times for all currently profiled functions are -printed. -\enddefmac - -\defmac{reset-time}{ \args{\mstar{\var{name}}}} -This macro resets the profiling counters associated with the \var{name}d -functions. If no \var{name}s are supplied, then all currently profiled functions -are reset. -\enddefmac - - -\node Profiling Techniques, Nested or Recursive Calls, Profile Interface, Profiling -\subsection{Profiling Techniques} - -Start by profiling big pieces of a program, then carefully choose which -functions close to, but not in, the inner loop are to be profiled next. -Avoid profiling functions that are called by other profiled functions, since -this opens the possibility of profiling overhead being included in the reported -times. - -If the per-call time reported is less than 1/10 second, then consider the clock -resolution and profiling overhead before you believe the time. It may be that -you will need to run your program many times in order to average out to a -higher resolution. - - -\node Nested or Recursive Calls, Clock resolution, Profiling Techniques, Profiling -\subsection{Nested or Recursive Calls} - -The profiler attempts to compensate for nested or recursive calls. Time and -consing overhead will be charged to the dynamically innermost (most recent) -call to a profiled function. So profiling a subfunction of a profiled function -will cause the reported time for the outer function to decrease. However if an -inner function has a large number of calls, some of the profiling overhead may -"leak" into the reported time for the outer function. In general, be wary of -profiling short functions that are called many times. - -\node Clock resolution, Profiling overhead, Nested or Recursive Calls, Profiling -\subsection{Clock resolution} - -Unless you are very lucky, the length of your machine's clock "tick" is -probably much longer than the time it takes simple function to run. For -example, on the IBM RT, the clock resolution is 1/50 second. This means that -if a function is only called a few times, then only the first couple decimal -places are really meaningful. - -Note however, that if a function is called many times, then the statistical -averaging across all calls should result in increased resolution. For example, -on the IBM RT, if a function is called a thousand times, then a resolution of -tens of microseconds can be expected. - -\node Profiling overhead, Additional Timing Utilities, Clock resolution, Profiling -\subsection{Profiling overhead} - -The added profiling code takes time to run every time that the profiled -function is called, which can disrupt the attempt to collect timing -information. In order to avoid serious inflation of the times for functions -that take little time to run, an estimate of the overhead due to profiling is -subtracted from the times reported for each function. - -Although this correction works fairly well, it is not totally accurate, -resulting in times that become increasingly meaningless for functions with -short runtimes. This is only a concern when the estimated profiling overhead -is many times larger than reported total CPU time. - -The estimated profiling overhead is not represented in the reported total CPU -time. The sum of total CPU time and the estimated profiling overhead should be -close to the total CPU time for the entire profiling run (as determined by the -\code{time} macro.) Time unaccounted for is probably being used by functions that -you forgot to profile. - -\node Additional Timing Utilities, A Note on Timing, Profiling overhead, Profiling -\subsection{Additional Timing Utilities} - -\defmac{time}{ \args{\var{form}}} -This macro evaluates \var{form}, prints some timing and memory allocation -information to \code{*trace-output*}, and returns any values that \var{form} -returns. The timing information includes real time, user run time, and system -run time. This macro executes a form and reports the time and consing -overhead. If the \code{time} form is not compiled (e.g. it was typed at -top-level), then \code{compile} will be called on the form to give more accurate -timing information. If you really want to time interpreted speed, you can say: -\begin{lisp} -(time (eval '\var{form})) -\end{lisp} -Things that execute fairly quickly should be timed more than once, since there -may be more paging overhead in the first timing. To increase the accuracy of -very short times, you can time multiple evaluations: -\begin{lisp} -(time (dotimes (i 100) \var{form})) -\end{lisp} -\enddefmac - -\defun{get-bytes-consed}[extensions]{} -This function returns the number of bytes allocated since the first time you -called it. The first time it is called it returns zero. The above profiling -routines use this to report consing information. -\enddefun - -\defvar{gc-run-time}[extensions] -This variable accumulates the run-time consumed by garbage -collection, in the units returned by \findexed{get-internal-run-time}. -\enddefvar - -\defconst{internal-time-units-per-second} -The value of internal-time-units-per-second is 100. -\enddefconst - -\node A Note on Timing, Benchmarking Techniques, Additional Timing Utilities, Profiling -\subsection{A Note on Timing} -\cpsubindex{CPU time}{interpretation of} -\cpsubindex{run time}{interpretation of} -\cindex{interpretation of run time} - -There are two general kinds of timing information provided by the \code{time} -macro and other profiling utilities: real time and run time. Real time is -elapsed, wall clock time. It will be affected in a fairly obvious way by any -other activity on the machine. The more other processes contending for CPU -and memory, the more real time will increase. This means that real time -measurements are difficult to replicate, though this is less true on a -dedicated workstation. The advantage of real time is that it is real. It -tells you really how long the program took to run under the benchmarking -conditions. The problem is that you don't know exactly what those conditions -were. - -Run time is the amount of time that the processor supposedly spent running the -program, as opposed to waiting for I/O or running other processes. "User run -time" and "system run time" are numbers reported by the Unix kernel. They are -supposed to be a measure of how much time the processor spent running your -"user" program (which will include GC overhead, etc.), and the amount of time -that the kernel spent running "on your behalf". - -Ideally, user time should be totally unaffected by benchmarking -conditions; in reality user time does depend on other system activity, -though in rather non-obvious ways. - -System time will clearly depend on benchmarking conditions. In Lisp -benchmarking, paging activity increases system run time (but not by as much -as it increases real time, since the kernel spends some time waiting for -the disk, and this is not run time, kernel or otherwise.) - -In my experience, the biggest trap in interpreting kernel/user run time is -to look only at user time. In reality, it seems that the \var{sum} of kernel -and user time is more reproducible. The problem is that as system activity -increases, there is a spurious \var{decrease} in user run time. In effect, as -paging, etc., increases, user time leaks into system time. - -So, in practice, the only way to get truly reproducible results is to run -with the same competing activity on the system. Try to run on a machine -with nobody else logged in, and check with "ps aux" to see if there are any -system processes munching large amounts of CPU or memory. If the ratio -between real time and the sum of user and system time varies much between -runs, then you have a problem. - -\node Benchmarking Techniques, , A Note on Timing, Profiling -\subsection{Benchmarking Techniques} -\cindex{benchmarking techniques} - -Given these imperfect timing tools, how do should you do benchmarking? The -answer depends on whether you are trying to measure improvements in the -performance of a single program on the same hardware, or if you are trying to -compare the performance of different programs and/or different hardware. - -For the first use (measuring the effect of program modifications with -constant hardware), you should look at \var{both} system+user and real time to -understand what effect the change had on CPU use, and on I/O (including -paging.) If you are working on a CPU intensive program, the change in -system+user time will give you a moderately reproducible measure of -performance across a fairly wide range of system conditions. For a CPU -intensive program, you can think of system+user as "how long it would have -taken to run if I had my own machine." So in the case of comparing CPU -intensive programs, system+user time is relatively real, and reasonable to -use. - -For programs that spend a substantial amount of their time paging, you -really can't predict elapsed time under a given operating condition without -benchmarking in that condition. User or system+user time may be fairly -reproducible, but it is also relatively meaningless, since in a paging or -I/O intensive program, the program is spending its time waiting, not -running, and system time and user time are both measures of run time. -A change that reduces run time might increase real time by increasing -paging. - -Another common use for benchmarking is comparing the performance of the same -program on different hardware. You want to know which machine to run your -program on. For comparing different machines (operating systems, etc.), the -only way to compare that makes sense is to set up the machines in \var{exactly} -the way that they will \var{normally} be run, and then measure \var{real} time. If -the program will normally be run along with X, then run X. If the program will -normally be run on a dedicated workstation, then be sure nobody else is on the -benchmarking machine. If the program will normally be run on a machine with -three other Lisp jobs, then run three other Lisp jobs. If the program will -normally be run on a machine with 8meg of memory, then run with 8meg. Here, -"normal" means "normal for that machine". If you the choice of an unloaded RT -or a heavily loaded PMAX, do your benchmarking on an unloaded RT and a heavily -loaded PMAX. - -If you have a program you believe to be CPU intensive, then you might be -tempted to compare "run" times across systems, hoping to get a meaningful -result even if the benchmarking isn't done under the expected running -condition. Don't to this, for two reasons: -\begin{itemize} - -\item -The operating systems might not compute run time in the same way. - -\item -Under the real running condition, the program might not be CPU -intensive after all. -\end{itemize} - - -In the end, only real time means anything \dash{} it is the amount of time you -have to wait for the result. The only valid uses for run time are: -\begin{itemize} - -\item -To develop insight into the program. For example, if run time is much less -than elapsed time, then you are probably spending lots of time paging. - -\item -To evaluate the relative performance of CPU intensive programs in the -same environment. -\end{itemize} - - -\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/Unix.ms} - - - -\node UNIX Interface, Event Dispatching with SERVE-EVENT, Advanced Compiler Use and Efficiency Hints, Top -\chapter{UNIX Interface} -\label{unix-interface} -\begin{center} -\b{By Robert MacLachlan, Skef Wholey,} -\end{center} -\begin{center} -\b{Bill Chiles, and William Lott} -\end{center} - -CMU Common Lisp attempts to make the full power of the underlying -environment available to the Lisp programmer. This is done using -combination of hand-coded interfaces and foreign function calls to C -libraries. Although the techniques differ, the style of interface is -similar. This chapter provides an overview of the facilities -available and general rules for using them, as well as describing -specific features in detail. It is assumed that the reader has a -working familiarity with Mach, Unix and X, as well as access to the -standard system documentation. - -\begin{menu} -* Reading the Command Line:: -* Lisp Equivalents for C Routines:: -* Type Translations:: -* System Area Pointers:: -* Unix System Calls:: -* File Descriptor Streams:: -* Making Sense of Mach Return Codes:: -* Unix Interrupts:: -\end{menu} - - -\node Reading the Command Line, Useful Variables, UNIX Interface, UNIX Interface -\section{Reading the Command Line} - -The shell parses the command line with which Lisp is invoked, and -passes a data structure containing the parsed information to Lisp. -This information is then extracted from that data structure and put -into a set of Lisp data structures. - -\defvar{command-line-strings}[extensions] -\defvarx{command-line-utility-name}[extensions] -\defvarx{command-line-words}[extensions] -\defvarx{command-line-switches}[extensions] -The value of \code{*command-line-words*} is a list of strings that make up the -command line, one word per string. The first word on the command line, i.e. -the name of the program invoked (usually \code{lisp}) is stored in -\code{*command-line-utility-name*}. The value of \code{*command-line-switches*} is a -list of \code{command-line-switch} structures, with a structure for each word on -the command line starting with a hyphen. All the command line words between -the program name and the first switch are stored in \code{*command-line-words*}. -\enddefvar - -The following functions may be used to examine \code{command-line-switch} -structures. -\defun{cmd-switch-name}[extensions]{\args{\var{switch}}} -Returns the name of the switch, less the preceding hyphen and trailing equal -sign (if any). -\enddefun -\defun{cmd-switch-value}[extensions]{\args{\var{switch}}} -Returns the value designated using an embedded equal sign, if any. If the -switch has no equal sign, then this is null. -\enddefun -\defun{cmd-switch-words}[extensions]{\args{\var{switch}}} -Returns a list of the words between this switch and the next switch or the end -of the command line. -\enddefun - - -\node Useful Variables, Lisp Equivalents for C Routines, Reading the Command Line, UNIX Interface - -\section{Useful Variables} - -\defvar{stdin}[system] -\defvarx{stdout}[system] -\defvarx{stderr}[system] -Streams connected to the standard input, output and error file -descriptors. -\enddefvar - -\defvar{tty}[system] -A stream connected to \file{/dev/tty}. -\enddefvar - -\defvar{task-self}[system] -\defvarx{task-data}[system] -\defvarx{task-notify}[system] -The initial ports for the Lisp process (Mach only.) -\enddefvar - - -\node Lisp Equivalents for C Routines, Type Translations, Useful Variables, UNIX Interface -\section{Lisp Equivalents for C Routines} - -The UNIX documentation describes the system interface in terms of C -procedure headers. The corresponding Lisp function will have a somewhat -different interface, since Lisp argument passing conventions and -datatypes are different. - -The main difference in the argument passing conventions is that Lisp does not -support passing values by reference. In Lisp, all argument and results are -passed by value. Interface functions take some fixed number of arguments and -return some fixed number of values. A given "parameter" in the C -specification will appear as an argument, return value, or both, depending on -whether it is an In parameter, Out parameter, or In/Out parameter. The basic -transformation one makes to come up with the Lisp equivalent of a C routine is -to remove the Out parameters from the call, and treat them as extra return -values. In/Out parameters appear both as arguments and return values. Since -Out and In/Out parameters are only conventions in C, you must determine the -usage from the documentation. - - -Thus, the C routine declared as -\begin{example} -kern_return_t lookup(servport, portsname, portsid) - port servport; - char *portsname; - int *portsid; /* out */ - { - ... - *portsid = <expression to compute portsid field> - return(KERN_SUCCESS); - } -\end{example} -has as its Lisp equivalent something like -\begin{lisp} -(defun lookup (ServPort PortsName) - ... - (values - success - <expression to compute portsid field>)) -\end{lisp} -If there are multiple out or in-out arguments, then there are multiple -additional returns values. - -Fortunately, CMU Common Lisp programmers rarely have to worry about the -nuances of this translation process, since the names of the arguments and -return values are documented in a way so that the \code{describe} function -(and the \Hemlock{} \code{Describe Function Call} command, invoked with -\b{C-M-Shift-A}) will list this information. Since the names of arguments -and return values are usually descriptive, the information that -\code{describe} prints is usually all one needs to write a -call. Most programmers use this on-line documentation nearly -all of the time, and thereby avoid the need to handle bulky -manuals and perform the translation from barbarous tongues. - -\node Type Translations, System Area Pointers, Lisp Equivalents for C Routines, UNIX Interface -\section{Type Translations} -\cindex{aliens} -\cpsubindex{types}{alien} -\cpsubindex{types}{foreign language} - -Lisp data types have very different representations from those used by -conventional languages such as C. Since the system interfaces are -designed for conventional languages, Lisp must translate objects to and -from the Lisp representations. Many simple objects have a direct -translation: integers, characters, strings and floating point numbers -are translated to the corresponding Lisp object. A number of types, -however, are implemented differently in Lisp for reasons of clarity and -efficiency. - -Instances of enumerated types are expressed as keywords in Lisp. -Records, arrays, and pointer types are implemented with the \Alien{} -facility (see page \pageref{aliens}.) Access functions are defined -for these types which convert fields of records, elements of arrays, -or data referenced by pointers into Lisp objects (possibly another -object to be referenced with another access function). - -One should dispose of \Alien{} objects created by constructor -functions or returned from remote procedure calls when they are no -longer of any use, freeing the virtual memory associated with that -object. Since \alien{}s contain pointers to non-Lisp data, the -garbage collector cannot do this itself. If the memory -was obtained from \funref{make-alien} or from a foreign function call -to a routine that used \code{malloc}, then \funref{free-alien} should -be used. If the \alien{} was created -using MACH memory allocation (e.g. \code{vm_allocate}), then the -storage should be freed using \code{vm_deallocate}. - -\node System Area Pointers, Unix System Calls, Type Translations, UNIX Interface -\section{System Area Pointers} -\label{system-area-pointers} - -\cindex{pointers}\cpsubindex{malloc}{C function}\cpsubindex{free}{C function} -Note that in some cases an address is represented by a Lisp integer, and in -other cases it is represented by a real pointer. Pointers are usually used -when an object in the current address space is being referred to. The MACH -virtual memory manipulation calls must use integers, since in principle the -address could be in any process, and Lisp cannot abide random pointers. -Because these types are represented differently in Lisp, one must explicitly -coerce between these representations. - -System Area Pointers (SAPs) provide a mechanism that bypasses the \Alien{} type -system and accesses virtual memory directly. A SAP is a raw byte pointer into -the \code{lisp} process address space. SAPs are represented with a pointer -descriptor, so SAP creation can cause consing. However, the compiler uses -a non-descriptor representation for SAPs when possible, so the consing -overhead is generally minimal. \xlref{non-descriptor}. - -\defun{sap-int}[system]{\args{\var{sap}}} -\defunx{int-sap}[system]{\args{\var{int}}} -The function \code{sap-int} is used to generate an integer corresponding to the -system area pointer, suitable for passing to the kernel interfaces (which want -all addresses specified as integers). The function \code{int-sap} is used to do -the opposite conversion. The integer representation of a SAP is the byte -offset of the SAP from the start of the address space. -\enddefun - -\defun{sap+}[system]{\args{\var{sap} \var{offset}}} -This function adds a byte \var{offset} to \var{sap}, returning a new SAP. -\enddefun - -\defun{sap-ref-8}[system]{\args{\var{sap} \var{offset}}} -\defunx{sap-ref-16}[system]{\args{\var{sap} \var{offset}}} -\defunx{sap-ref-32}[system]{\args{\var{sap} \var{offset}}} -These functions return the 8, 16 or 32 bit unsigned integer at -\var{offset} from \var{sap}. The \var{offset} is always a byte -offset, regardless of the number of bits accessed. \code{setf} may -be used with the these functions to deposit values into virtual -memory. -\enddefun - -\defun{signed-sap-ref-8}[system]{\args{\var{sap} \var{offset}}} -\defunx{signed-sap-ref-16}[system]{\args{\var{sap} \var{offset}}} -\defunx{signed-sap-ref-32}[system]{\args{\var{sap} \var{offset}}} -These functions are the same as the above unsigned operations, except -that they sign-extend, returning a negative number if the high bit is -set. -\enddefun - -\node Unix System Calls, File Descriptor Streams, System Area Pointers, UNIX Interface -\section{Unix System Calls} - -You probably won't have much cause to use them, but all the Unix system -calls are available. The Unix system call functions are in the -\code{Unix} package. The name of the interface for a particular system -call is the name of the system call prepended with \code{unix-}. The -system usually defines the associated constants without any prefix name. -To find out how to use a particular system call, try using -\code{describe} on it. If that is unhelpful, look at the source in -\file{syscall.lisp} or consult your system maintainer. - -The Unix system calls indicate an error by returning \false{} as the -first value and the Unix error number as the second value. If the call -succeeds, then the first value will always be non-\nil, often \code{t}. - -\defun{get-unix-error-msg}[Unix]{\args{\var{error}}} -This function returns a string describing the Unix error number \var{error}. -\enddefun - -\node File Descriptor Streams, Making Sense of Mach Return Codes, Unix System Calls, UNIX Interface -\section{File Descriptor Streams} - -Many of the UNIX system calls return file descriptors. Instead of using other -UNIX system calls to perform I/O on them, you can create a stream around them. -For this purpose, fd-streams exist. - -\defun{make-fd-stream}[system]{\args{\var{descriptor}} - \keys{:input :output :element-type} - \morekeys{:buffering :name :file :original} - \yetmorekeys{:delete-original :auto-close} - \yetmorekeys{:timeout}} - -This function creates a file descriptor stream using \var{descriptor}. -If \var{input} is non-\nil, input operations are allowed. If -\var{output} is non-\nil, output operations are allowed. The default is -input only. These keywords are defined: -\begin{description} -\item[\var{element-type}] is the type of the unit of transaction for the -stream, which defaults to \code{string-char}. See the Common Lisp -description of \code{open} for valid values. - -\item[\var{buffering}] is the kind of output buffering desired for the stream. -Legal values are \kwd{none} for no buffering, \kwd{line} for buffering up to -each newline, and \kwd{full} for full buffering. - -\item[\var{name}] is a simple-string name to use for descriptive -purposes when the system prints an fd-stream. When printing fd-streams, -the system prepends the streams name with \code{Stream for }. If -\var{name} is unspecified, it defaults to a string containing \var{file} -or \var{descriptor}, in order of preference. - -\item[\var{file}, \var{original}]: \var{file} specifies the name of the -associated file when creating a file stream (must be a -\code{simple-string}). \var{original} is the \code{simple-string} name -of a backup file containing the original contents of \var{file} while -writing \var{file}. - -When you abort the stream by passing \true{} to -\code{close} as the second argument, if you supplied both \var{file} and -\var{original}, \code{close} will rename the \var{original} name to the -\var{file} name. When you \code{close} the stream normally, if you supplied -\var{original}, and \var{delete-original} is non-\nil, \code{close} -deletes \var{original}. If \var{auto-close} is true (the default), then -\var{descriptor} will be closed when the stream is garbage collected. - -\item[\var{timeout}] if non-null, then \var{timeout} is an integer -number of seconds after which an input wait should time out. If a read -does time out, then the \code{system:io-timeout} condition is signalled. -\end{description} -\enddefun - -\defun{fd-stream-p}[system]{\args{\var{object}}} -This function returns \true{} if \var{object} is an fd-stream, and \nil{} if not. -\enddefun - -\defun{fd-stream-fd}[system]{\args{\var{stream}}} -This returns the file descriptor associated with \var{stream}. -\enddefun - - -\node Making Sense of Mach Return Codes, Unix Interrupts, File Descriptor Streams, UNIX Interface -\section{Making Sense of Mach Return Codes} - -Whenever a remote procedure call returns a Unix error code (such as -\code{kern_return_t}), it is usually prudent to check that code to see if the call -was successful. To relieve the programmer of the hassle of testing this value -himself, and to centralize the information about the meaning of non-success -return codes, CMU Common Lisp provides a number of macros and functions. -See also \funref{get-unix-error-msg}. - -\defun{gr-error}[system]{ - \args{\var{function} \var{gr} \&optional{} \var{context}}} -Signals a Lisp error, printing a message indicating that the call to the -specified \var{function} failed, with the return code \var{gr}. If supplied, the -\var{context} string is printed after the \var{function} name and before the string -associated with the \var{gr}. For example: -\begin{example} -* (gr-error 'nukegarbage 3 "lost big") - -Error in function GR-ERROR: -NUKEGARBAGE lost big, no space. -Proceed cases: -0: Return to Top-Level. -Debug (type H for help) -(Signal #<Conditions:Simple-Error.5FDE0>) -0] -\end{example} -\enddefun - -\defmac{gr-call}[system]{\args{\var{function} \&rest{} \var{args}}} -\defmacx{gr-call*}[system]{\args{\var{function} \&rest{} \var{args}}} -These macros can be used to call a function and automatically check the -GeneralReturn code and signal an appropriate error in case of non-successful -return. \code{gr-call} returns \false{} if no error occurs, while \code{gr-call*} -returns the second value of the function called. -\begin{example} -* (gr-call mach:port_allocate *task-self*) -NIL -* -\end{example} -\enddefmac - -\defmac{gr-bind}[system]{ - \args{\code{(}\mstar{\var{var}}\code{)} \code{(}\var{function} \mstar{\var{arg}}\code{)} \mstar{\var{form}}}} -This macro can be used much like \code{multiple-value-bind} to bind the \var{var}s -to return values resulting from calling the \var{function} with the given -\var{arg}s. The first return value is not bound to a variable, but is checked as a -GeneralReturn code, as in \code{gr-call}. -\begin{example} -* (gr-bind (port_list port_list_cnt) - (mach:port_select *task-self*) - (format t "The port count is ~S." port_list_cnt) - port_list) -The port count is 0. -#<Alien value> -* -\end{example} -\enddefmac - -\node Unix Interrupts, , Making Sense of Mach Return Codes, UNIX Interface -\section{Unix Interrupts} - -\cindex{unix interrupts} \cindex{interrupts} -CMU Common Lisp allows access to all the Unix signals that can be generated -under Unix. It should be noted that if this capability is abused, it is -possible to completely destroy the running Lisp. The following macros and -functions allow access to the Unix interrupt system. The signal names as -specified in section 2 of the \i{Unix Programmer's Manual} are exported -from the Unix package. - -\begin{menu} -* Changing Interrupt Handlers:: -* Examples of Signal Handlers:: -\end{menu} - -\node Changing Interrupt Handlers, Examples of Signal Handlers, Unix Interrupts, Unix Interrupts -\subsection{Changing Interrupt Handlers} -\label{signal-handlers} - -\defmac{with-enabled-interrupts}[system]{ - \args{\var{specs} \&rest{} \var{body}}} - -This macro should be called with a list of signal specifications, \var{specs}. -Each element of \var{specs} should be a list of two\hide{ or three} elements: -the first should be the Unix signal for which a handler should be established, -the second should be a function to be called when the signal is -received\hide{, and -the third should be an optional character used to generate the signal from the -keyboard. This last item is only useful for the SIGINT, SIGQUIT, and SIGTSTP -signals.} One or more signal handlers can be established in this way. -\code{with-enabled-interrupts} establishes the correct signal handlers and then -executes the forms in \var{body}. The forms are executed in an unwind-protect so -that the state of the signal handlers will be restored to what it was before -the \code{with-enabled-interrupts} was entered. A signal handler function -specified as NIL will set the Unix signal handler to the default which is -normally either to ignore the signal or to cause a core dump depending on the -particular signal. -\enddefmac - -\defmac{without-interrupts}[system]{\args{\&rest{} \var{body}}} -It is sometimes necessary to execute a piece a code that can not be -interrupted. This macro the forms in \var{body} with interrupts disabled. Note -that the Unix interrupts are not actually disabled, rather they are queued -until after \var{body} has finished executing. -\enddefmac - -\defmac{with-interrupts}[system]{\args{\&rest{} \var{body}}} -When executing an interrupt handler, the system disables interrupts, as if the -handler was wrapped in in a \code{without-interrupts}. The macro -\code{with-interrupts} can be used to enable interrupts while the forms in -\var{body} are evaluated. This is useful if \var{body} is going to enter a break -loop or do some long computation that might need to be interrupted. -\enddefmac - -\defmac{without-hemlock}[system]{\args{\&rest{} \var{body}}} -For some interrupts, such as SIGTSTP (suspend the Lisp process and return -to the Unix shell) it is necessary to leave Hemlock and then return to it. -This macro executes the forms in \var{body} after exiting Hemlock. When -\var{body} has been executed, control is returned to Hemlock. -\enddefmac - -\defun{enable-interrupt}[system]{ - \args{\var{signal} \var{function}\hide{ \&optional{} \var{character}}}} - -This function establishes \var{function} as the handler for \var{signal}. -\hide{The optional \var{character} can be specified for the SIGINT, SIGQUIT, -and SIGTSTP signals and causes that character to generate the appropriate -signal from the keyboard.} Unless you want to establish a global signal -handler, you should use the macro \code{with-enabled-interrupts} to temporarily -establish a signal handler. \hide{Without \var{character},} -\code{enable-interrupt} returns the old function associated with the signal. -\hide{When \var{character} is specified for SIGINT, SIGQUIT, or SIGTSTP, it -returns the old character code.} -\enddefun - -\defun{ignore-interrupt}[system]{\args{\var{signal}}} -Ignore-interrupt sets the Unix signal mechanism to ignore \var{signal} -which means that the Lisp process will never see the signal. -Ignore-interrupt returns the old function associated with the signal or \false{} -if none is currently defined. -\enddefun - -\defun{default-interrupt}[system]{\args{\var{signal}}} -Default-interrupt can be used to tell the Unix signal mechanism to perform -the default action for \var{signal}. For details on what the default action -for a signal is, see section 2 of the \i{Unix Programmer's Manual}. In -general, it is likely to ignore the signal or to cause a core dump. -\enddefun - -\node Examples of Signal Handlers, , Changing Interrupt Handlers, Unix Interrupts -\subsection{Examples of Signal Handlers} - -The following code is the signal handler used by the Lisp system for the -SIGINT signal. -\begin{lisp} -(defun ih-sigint (signal code scp) - (declare (ignore signal code scp)) - (without-hemlock - (with-interrupts - (break "Software Interrupt" t)))) -\end{lisp} -The \code{without-hemlock} form is used to make sure that Hemlock is exited before -a break loop is entered. The \code{with-interrupts} form is used to enable -interrupts because the user may want to generate an interrupt while in the -break loop. Finally, break is called to enter a break loop, so the user -can look at the current state of the computation. If the user proceeds -from the break loop, the computation will be restarted from where it was -interrupted. - -The following function is the Lisp signal handler for the SIGTSTP signal -which suspends a process and returns to the Unix shell. -\begin{lisp} -(defun ih-sigtstp (signal code scp) - (declare (ignore signal code scp)) - (without-hemlock - (Unix:unix-kill (Unix:unix-getpid) Unix:sigstop))) -\end{lisp} -Lisp uses this interrupt handler to catch the SIGTSTP signal because it is -necessary to get out of Hemlock in a clean way before returning to the shell. - -To set up these interrupt handlers, the following is recommended: -\begin{lisp} -(with-enabled-interrupts ((Unix:SIGINT #'ih-sigint) - (Unix:SIGTSTP #'ih-sigtstp)) - <user code to execute with the above signal handlers enabled.> -) -\end{lisp} - - -\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/server.ms} - -\node Event Dispatching with SERVE-EVENT, Alien Objects, UNIX Interface, Top -\chapter{Event Dispatching with SERVE-EVENT} -\begin{center} -\b{By Bill Chiles and Robert MacLachlan} -\end{center} - -It is common to have multiple activities simultaneously operating in the same -Lisp process. Furthermore, Lisp programmers tend to expect a flexible -development environment. It must be possible to load and modify application -programs without requiring modifications to other running programs. CMU Common -Lisp achieves this by having a central scheduling mechanism based on an -event-driven, object-oriented paradigm. - -An \var{event} is some interesting happening that should cause the Lisp process -to wake up and do something. These events include X events and activity on -Unix file descriptors. The object-oriented mechanism is only available with -the first two, and it is optional with X events as described later in this -chapter. In an X event, the window ID is the object capability and the X event -type is the operation code. The Unix file descriptor input mechanism simply -consists of an association list of a handler to call when input shows up on a -particular file descriptor. - - -\begin{menu} -* Object Sets:: -* The SERVE-EVENT Function:: -* Using SERVE-EVENT with Unix File Descriptors:: -* Using SERVE-EVENT with the CLX Interface to X:: -* A SERVE-EVENT Example:: -\end{menu} - -\node Object Sets, The SERVE-EVENT Function, Event Dispatching with SERVE-EVENT, Event Dispatching with SERVE-EVENT -\section{Object Sets} -\label{object-sets} -\cindex{object sets} -An \i{object set} is a collection of objects that have the same implementation -for each operation. Externally the object is represented by the object -capability and the operation is represented by the operation code. Within -Lisp, the object is represented by an arbitrary Lisp object, and the -implementation for the operation is represented by an arbitrary Lisp function. -The object set mechanism maintains this translation from the external to the -internal representation. - -\defun{make-object-set}[system]{ - \args{\var{name} \&optional{} \var{default-handler}}} - This function makes a new object set. \var{Name} is a string used -only for purposes of identifying the object set when it is printed. -\var{Default-handler} is the function used as a handler when an -undefined operation occurs on an object in the set. You can define -operations with the \code{serve-}\var{operation} functions exported -the \code{extensions} package for X events -(\pxlref{x-serve-mumbles}). Objects are added with -\code{system:add-xwindow-object}. Initially the object set has no -objects and no defined operations. -\enddefun - -\defun{object-set-operation}[system]{ - \args{\var{object-set} \var{operation-code}}} - - This function returns the handler function that is the -implementation of the operation corresponding to \var{operation-code} -in \var{object-set}. When set with \code{setf}, the setter function -establishes the new handler. The \code{serve-}\var{operation} -functions exported from the \code{extensions} package for X events -(\pxlref{x-serve-mumbles}) call this on behalf of the user when -announcing a new operation for an object set. -\enddefun - -\defun{add-xwindow-object}[system]{ - \args{\var{window} \var{object} \var{object-set}}} -These functions add \var{port} or \var{window} to \var{object-set}. \var{Object} is -an arbitrary Lisp object that is associated with the \var{port} or \var{window} -capability. \var{Window} is a CLX window. When an event occurs, -\code{system:serve-event} passes \var{object} as an argument to the handler -function. -\enddefun - - -\node The SERVE-EVENT Function, Using SERVE-EVENT with Unix File Descriptors, Object Sets, Event Dispatching with SERVE-EVENT -\section{The SERVE-EVENT Function} - -The \code{system:serve-event} function is the standard way for an application -to wait for something to happen. For example, the Lisp system calls -\code{system:serve-event} when it wants input from X or a terminal stream. -The idea behind \code{system:serve-event} is that it knows the appropriate -action to take when any interesting event happens. If an application calls -\code{system:serve-event} when it is idle, then any other applications with -pending events can run. This allows several applications to run "at the -same time" without interference, even though there is only one thread of -control. Note that if an application is waiting for input of any kind, -then other applications will get events. - -\defun{serve-event}[system]{\args{\&optional{} \var{timeout}}} -This function waits for an event to happen and then dispatches to the -correct handler function. If specified, \var{timeout} is the number of -seconds to wait before timing out. A time out of zero seconds is legal and -causes \code{system:serve-event} to poll for any events immediately available -for processing. \code{system:serve-event} returns \true{} if it serviced at -least one event, and \nil{} otherwise. Depending on the application, when -\code{system:serve-event} returns \true, you might want to call it repeatedly -with a timeout of zero until it returns \nil. - -If input is available on any designated file descriptor, then this calls the -appropriate handler function supplied by \code{system:add-fd-handler}. - -Since events for many different applications may arrive -simultaneously, an application waiting for a specific event -must loop on \code{system:serve-event} until the desired event -happens. Since programs such as \hemlock{} call -\code{system:serve-event} for input, applications usually do -not need to call \code{system:serve-event} at all; \hemlock{} -allows other application's handlers to run when it goes into an -input wait. -\enddefun - -\defun{serve-all-events}[system]{\args{\&optional{} \var{timeout}}} -This function is similar to \code{system:serve-event}, except it serves all -the pending events rather than just one. It returns \true{} if it serviced -at least one event, and \nil{} otherwise. -\enddefun - - -\node Using SERVE-EVENT with Unix File Descriptors, Using SERVE-EVENT with the CLX Interface to X, The SERVE-EVENT Function, Event Dispatching with SERVE-EVENT -\section{Using SERVE-EVENT with Unix File Descriptors} -Object sets are not available for use with file descriptors, as there are -only two operations possible on file descriptors: input and output. -Instead, a handler for either input or output can be registered with -\code{system:serve-event} for a specific file descriptor. Whenever any input -shows up, or output is possible on this file descriptor, the function -associated with the handler for that descriptor is funcalled with the -descriptor as it's single argument. - -\defun{add-fd-handler}[system]{\args{\i{fd direction function}}} -This function installs and returns a new handler for the file descriptor -\var{fd}. \var{Direction} can be either \kwd{input} if the system should invoke -the handler when input is available or \kwd{output} if the system should invoke -the handler when output is possible. This returns a unique object representing -the handler, and this is a suitable argument for \code{system:remove-fd-handler} -\var{Function} must take one argument, the file descriptor. -\enddefun - -\defun{remove-fd-handler}[system]{\args{\var{handler}}} -This function removes \var{handler}, that \code{add-fd-handler} must have previously -returned. -\enddefun - -\defmac{with-fd-handler}[system]{ - \args{(\i{direction fd function}) \mstar{\var{form}}}} - This macro executes the supplied forms with a handler installed using \var{fd}, -\var{direction}, and \var{function}. See \code{system:add-fd-handler}. -\enddefmac - -\defun{wait-until-fd-usable}[system]{ - \args{\i{direction fd} \&optional{} \var{timeout}}} - This function waits for up to \var{timeout} seconds for \var{fd} to become usable -for \var{direction} (either \kwd{input} or \kwd{output}). If \var{timeout} is \nil{} -or unspecified, this waits forever. -\enddefun - -\defun{invalidate-descriptor}[system]{\args{\var{fd}}} -This function removes all handlers associated with \var{fd}. This should only be -used in drastic cases (such as I/O errors, but not necessarily EOF). Normally, -you should use \code{remove-fd-handler} to remove the specific handler. -\enddefun - -\begin{ignore} - -section{Using SERVE-EVENT with Matchmaker Interfaces} -\label{ipc-serve-mumbles} -Remember from section \ref{object-sets}, an object set is a collection of -objects, ports in this case, with some set of operations, message ID's, with -corresponding implementations, the same handler functions. - -Matchmaker uses the object set operations to implement servers. For each -server interface \i{XXX}, Matchmaker defines a function, \code{serve-}\i{XXX}, of -two arguments, an object set and a function. The \code{serve-}\i{XXX} function -establishes the function as the implementation of the \i{XXX} operation in the -object set. Recall from section \ref{object-sets}, \code{system:add-port-object} -associates some Lisp object with a port in an object set. When -\code{system:serve-event} notices activity on a port, it calls the function given -to \code{serve-}\i{XXX} with the object given to \code{system:add-port-object} and -the input parameters specified in the message definition. The return values -from the function are used as the output parameters for the message, if any. -\code{serve-}\i{XXX} functions are also generated for each \i{server message} and -asynchronous user interface. - -To use a Lisp server: -\begin{itemize} - -\item -Create an object set. - -\item -Define some operations on it using the \code{serve-}\i{XXX} functions. - -\item -Create an object for every port on which you receive requests. - -\item -Call \code{system:serve-event} to service an RPC request. -\end{itemize} - - -Object sets allow many servers in the same Lisp to operate without knowing -about each other. There can be multiple implementations of the same interface -with different operation handlers established in distinct object sets. This -property is especially useful when handling emergency messages. - -\end{ignore} - -\node Using SERVE-EVENT with the CLX Interface to X, A SERVE-EVENT Example, Using SERVE-EVENT with Unix File Descriptors, Event Dispatching with SERVE-EVENT -\section{Using SERVE-EVENT with the CLX Interface to X} -\label{x-serve-mumbles} -Remember from section \ref{object-sets}, an object set is a collection of -objects, CLX windows in this case, with some set of operations, event keywords, -with corresponding implementations, the same handler functions. Since X allows -multiple display connections from a given process, you can avoid using object -sets if every window in an application or display connection behaves the same. -If a particular X application on a single display connection has windows that -want to handle certain events differently, then using object sets is a -convenient way to organize this since you need some way to map the window/event -combination to the appropriate functionality. - -The following is a discussion of functions exported from the \code{extensions} -package that facilitate handling CLX events through \code{system:serve-event}. -The first two routines are useful regardless of whether you use -\code{system:serve-event}: -\defun{open-clx-display}[ext]{ - \args{\&optional{} \var{string}}} - This function parses \var{string} for an X display specification including -display and screen numbers. \var{String} defaults to the following: -\begin{verbatim} -(cdr (assoc :display ext:*environment-list* :test #'eq)) -\end{verbatim} -If any field in the display specification is missing, this signals an error. -\code{ext:open-clx-display} returns the CLX display and screen. -\enddefun - -\defun{flush-display-events}[ext]{\args{\var{display}}} -This function flushes all the events in \var{display}'s event queue including the -current event, in case the user calls this from within an event handler. -\enddefun - - -\begin{menu} -* Without Object Sets:: -* With Object Sets:: -\end{menu} - -\node Without Object Sets, With Object Sets, Using SERVE-EVENT with the CLX Interface to X, Using SERVE-EVENT with the CLX Interface to X -\subsection{Without Object Sets} -Since most applications that use CLX, can avoid the complexity of object sets, -these routines are described in a separate section. The routines described in -the next section that use the object set mechanism are based on these -interfaces. - -\defun{enable-clx-event-handling}[ext]{ - \args{\var{display} \var{handler}}} - This function causes \code{system:serve-event} to notice when there is input -on \var{display}'s connection to the X11 server. When this happens, -\code{system:serve-event} invokes \var{handler} on \var{display} in a dynamic -context with an error handler bound that flushes all events from -\var{display} and returns. By returning, the error handler declines to -handle the error, but it will have cleared all events; thus, entering the -debugger will not result in infinite errors due to streams that wait via -\code{system:serve-event} for input. Calling this repeatedly on the same -\var{display} establishes \var{handler} as a new handler, replacing any -previous one for \var{display}. \enddefun - -\defun{disable-clx-event-handling}[ext]{\args{\var{display}}} -This function undoes the effect of \code{ext:enable-clx-event-handling}. -\enddefun - -\defmac{with-clx-event-handling}[ext]{ - \args{(\var{display} \var{handler}) \mstar{form}}} - This macro evaluates each \var{form} in a context where -\code{system:serve-event} invokes \var{handler} on \var{display} whenever there is -input on \var{display}'s connection to the X server. This destroys any -previously established handler for \var{display}. -\enddefmac - - -\node With Object Sets, , Without Object Sets, Using SERVE-EVENT with the CLX Interface to X -\subsection{With Object Sets} -This section discusses the use of object sets and \code{system:serve-event} to -handle CLX events. This is necessary when a single X application has distinct -windows that want to handle the same events in different ways. Basically, you -need some way of asking for a given window which way you want to handle some -event because this event is handled differently depending on the window. -Object sets provide this feature. - -For each CLX event-key symbol-name \i{XXX} (for example, \var{key-press}), there -is a function \code{serve-}\i{XXX} of two arguments, an object set and a function. -The \code{serve-}\i{XXX} function establishes the function as the handler for the -\kwd{XXX} event in the object set. Recall from section \ref{object-sets}, -\code{system:add-xwindow-object} associates some Lisp object with a CLX window in -an object set. When \code{system:serve-event} notices activity on a window, it -calls the function given to \code{ext:enable-clx-event-handling}. If this -function is \code{ext:object-set-event-handler}, it calls the function given to -\code{serve-}\i{XXX}, passing the object given to \code{system:add-xwindow-object} -and the event's slots as well as a couple other arguments described below. - -To use object sets in this way: -\begin{itemize} - -\item -Create an object set. - -\item -Define some operations on it using the \code{serve-}\i{XXX} functions. - -\item -Add an object for every window on which you receive requests. This can be the -CLX window itself or some structure more meaningful to your application. - -\item -Call \code{system:serve-event} to service an X event. -\end{itemize} - - -\defun{object-set-event-handler}[ext]{\args{\var{display}}} -This function is a suitable argument to \code{ext:enable-clx-event-handling}. The -actual event handlers defined for particular events within a given object set -must take an argument for every slot in the appropriate event. In addition to -the event slots, \code{ext:object-set-event-handler} passes the following -arguments: -\begin{itemize} - -\item -The object, as established by \code{system:add-xwindow-object}, on which the event -occurred. - -\item -event-key, see \code{xlib:event-case}. - -\item -send-event-p, see \code{xlib:event-case}. -\end{itemize} - -Describing any \code{ext:serve-}\var{event-key-name} function, where -\var{event-key-name} is an event-key symbol-name (for example, -\code{ext:serve-key-press}), indicates exactly what all the arguments are in their -correct order. - -\begin{ignore} -\code{ext:object-set-event-handler} ignores \kwd{no-exposure} -events on pixmaps, issuing a warning if one occurs. It is only -prepared to dispatch events for windows. -\end{ignore} - -When creating an object set for use with \code{ext:object-set-event-handler}, -specify \code{ext:default-clx-event-handler} as the default handler for events in -that object set. If no default handler is specified, and the system invokes -the default default handler, it will cause an error since this function takes -arguments suitable for handling port messages. -\enddefun - - -\node A SERVE-EVENT Example, , Using SERVE-EVENT with the CLX Interface to X, Event Dispatching with SERVE-EVENT -\section{A SERVE-EVENT Example} -This section contains two examples using \code{system:serve-event}. The first -one does not use object sets, and the second, slightly more complicated one -does. - - -\begin{menu} -* Without Object Sets Example:: -* With Object Sets Example:: -\end{menu} - -\node Without Object Sets Example, With Object Sets Example, A SERVE-EVENT Example, A SERVE-EVENT Example -\subsection{Without Object Sets Example} -This example defines an input handler for a CLX display connection. It only -recognizes \kwd{key-press} events. The body of the example loops over -\code{system:serve-event} to get input. - -\begin{lisp} -(in-package "SERVER-EXAMPLE") - -(defun my-input-handler (display) - (xlib:event-case (display :timeout 0) - (:key-press (event-window code state) - (format t "KEY-PRESSED (Window = ~D) = ~S.~%" - (xlib:window-id event-window) - ;; See Hemlock Command Implementor's Manual for convenient - ;; input mapping function. - (ext:translate-character display code state)) - ;; Make XLIB:EVENT-CASE discard the event. - t))) -\end{lisp} -\begin{lisp} -(defun server-example () - "An example of using the SYSTEM:SERVE-EVENT function and object sets to - handle CLX events." - (let* ((display (ext:open-clx-display)) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (window (create-window :parent (screen-root screen) - :x 0 :y 0 :width 200 :height 200 - :background white :border black - :border-width 2 - :event-mask - (xlib:make-event-mask :key-press)))) - ;; Wrap code in UNWIND-PROTECT, so we clean up after ourselves. - (unwind-protect - (progn - ;; Enable event handling on the display. - (ext:enable-clx-event-handling display #'my-input-handler) - ;; Map the windows to the screen. - (map-window window) - ;; Make sure we send all our requests. - (display-force-output display) - ;; Call serve-event for 100,000 events or immediate timeouts. - (dotimes (i 100000) (system:serve-event))) - ;; Disable event handling on this display. - (ext:disable-clx-event-handling display) - ;; Get rid of the window. - (destroy-window window) - ;; Pick off any events the X server has already queued for our - ;; windows, so we don't choke since SYSTEM:SERVE-EVENT is no longer - ;; prepared to handle events for us. - (loop - (unless (deleting-window-drop-event *display* window) - (return))) - ;; Close the display. - (xlib:close-display display)))) - -(defun deleting-window-drop-event (display win) - "Check for any events on win. If there is one, remove it from the - event queue and return t; otherwise, return nil." - (xlib:display-finish-output display) - (let ((result nil)) - (xlib:process-event - display :timeout 0 - :handler #'(lambda (&key event-window &allow-other-keys) - (if (eq event-window win) - (setf result t) - nil))) - result)) -\end{lisp} - - -\node With Object Sets Example, , Without Object Sets Example, A SERVE-EVENT Example -\subsection{With Object Sets Example} -This example involves more work, but you get a little more for your effort. It -defines two objects, \code{input-box} and \code{slider}, and establishes a -\kwd{key-press} handler for each object, \code{key-pressed} and -\code{slider-pressed}. We have two object sets because we handle events on the -windows manifesting these objects differently, but the events come over the -same display connection. - -\begin{lisp} -(in-package "SERVER-EXAMPLE") - -(defstruct (input-box (:print-function print-input-box) - (:constructor make-input-box (display window))) - "Our program knows about input-boxes, and it doesn't care how they - are implemented." - display ; The CLX display on which my input-box is displayed. - window) ; The CLX window in which the user types. -;;; -(defun print-input-box (object stream n) - (declare (ignore n)) - (format stream "#<Input-Box ~S>" (input-box-display object))) - -(defvar *input-box-windows* - (system:make-object-set "Input Box Windows" - #'ext:default-clx-event-handler)) - -(defun key-pressed (input-box event-key event-window root child - same-screen-p x y root-x root-y modifiers time - key-code send-event-p) - "This is our :key-press event handler." - (declare (ignore event-key root child same-screen-p x y - root-x root-y time send-event-p)) - (format t "KEY-PRESSED (Window = ~D) = ~S.~%" - (xlib:window-id event-window) - ;; See Hemlock Command Implementor's Manual for convenient - ;; input mapping function. - (ext:translate-character (input-box-display input-box) - key-code modifiers))) -;;; -(ext:serve-key-press *input-box-windows* #'key-pressed) -\end{lisp} -\begin{lisp} -(defstruct (slider (:print-function print-slider) - (:include input-box) - (:constructor %make-slider - (display window window-width max))) - "Our program knows about sliders too, and these provide input values - zero to max." - bits-per-value ; bits per discrete value up to max. - max) ; End value for slider. -;;; -(defun print-slider (object stream n) - (declare (ignore n)) - (format stream "#<Slider ~S 0..~D>" - (input-box-display object) - (1- (slider-max object)))) -;;; -(defun make-slider (display window max) - (%make-slider display window - (truncate (xlib:drawable-width window) max) - max)) - -(defvar *slider-windows* - (system:make-object-set "Slider Windows" - #'ext:default-clx-event-handler)) - -(defun slider-pressed (slider event-key event-window root child - same-screen-p x y root-x root-y modifiers time - key-code send-event-p) - "This is our :key-press event handler for sliders. Probably this is - a mouse thing, but for simplicity here we take a character typed." - (declare (ignore event-key root child same-screen-p x y - root-x root-y time send-event-p)) - (format t "KEY-PRESSED (Window = ~D) = ~S --> ~D.~%" - (xlib:window-id event-window) - ;; See Hemlock Command Implementor's Manual for convenient - ;; input mapping function. - (ext:translate-character (input-box-display slider) - key-code modifiers) - (truncate x (slider-bits-per-value slider)))) -;;; -(ext:serve-key-press *slider-windows* #'slider-pressed) -\end{lisp} -\begin{lisp} -(defun server-example () - "An example of using the SYSTEM:SERVE-EVENT function and object sets to - handle CLX events." - (let* ((display (ext:open-clx-display)) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (iwindow (create-window :parent (screen-root screen) - :x 0 :y 0 :width 200 :height 200 - :background white :border black - :border-width 2 - :event-mask - (xlib:make-event-mask :key-press))) - (swindow (create-window :parent (screen-root screen) - :x 0 :y 300 :width 200 :height 50 - :background white :border black - :border-width 2 - :event-mask - (xlib:make-event-mask :key-press))) - (input-box (make-input-box display iwindow)) - (slider (make-slider display swindow 15))) - ;; Wrap code in UNWIND-PROTECT, so we clean up after ourselves. - (unwind-protect - (progn - ;; Enable event handling on the display. - (ext:enable-clx-event-handling display - #'ext:object-set-event-handler) - ;; Add the windows to the appropriate object sets. - (system:add-xwindow-object iwindow input-box - *input-box-windows*) - (system:add-xwindow-object swindow slider - *slider-windows*) - ;; Map the windows to the screen. - (map-window iwindow) - (map-window swindow) - ;; Make sure we send all our requests. - (display-force-output display) - ;; Call server for 100,000 events or immediate timeouts. - (dotimes (i 100000) (system:serve-event))) - ;; Disable event handling on this display. - (ext:disable-clx-event-handling display) - (delete-window iwindow display) - (delete-window swindow display) - ;; Close the display. - (xlib:close-display display)))) -\end{lisp} -\begin{lisp} -(defun delete-window (window display) - ;; Remove the windows from the object sets before destroying them. - (system:remove-xwindow-object window) - ;; Destroy the window. - (destroy-window window) - ;; Pick off any events the X server has already queued for our - ;; windows, so we don't choke since SYSTEM:SERVE-EVENT is no longer - ;; prepared to handle events for us. - (loop - (unless (deleting-window-drop-event display window) - (return)))) - -(defun deleting-window-drop-event (display win) - "Check for any events on win. If there is one, remove it from the - event queue and return t; otherwise, return nil." - (xlib:display-finish-output display) - (let ((result nil)) - (xlib:process-event - display :timeout 0 - :handler #'(lambda (&key event-window &allow-other-keys) - (if (eq event-window win) - (setf result t) - nil))) - result)) -\end{lisp} - -\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/alien.ms} - -\node Alien Objects, Interprocess Communication under LISP, Event Dispatching with SERVE-EVENT, Top -\chapter{Alien Objects} -\label{aliens} -\begin{center} -\b{By Robert MacLachlan and William Lott} -\end{center} -\vspace{1 cm} - -\begin{menu} -* Introduction to Aliens:: -* Alien Types:: -* Alien Operations:: -* Alien Variables:: -* Alien Data Structure Example:: -* Loading Unix Object Files:: -* Alien Function Calls:: -* Step-by-Step Alien Example:: -\end{menu} - -\node Introduction to Aliens, Alien Types, Alien Objects, Alien Objects -\section{Introduction to Aliens} - -Because of Lisp's emphasis on dynamic memory allocation and garbage -collection, Lisp implementations use unconventional memory representations -for objects. This representation mismatch creates problems when a Lisp -program must share objects with programs written in another language. There -are three different approaches to establishing communication: -\begin{itemize} -\item The burden can be placed on the foreign program (and programmer) by -requiring the use of Lisp object representations. The main difficulty with -this approach is that either the foreign program must be written with Lisp -interaction in mind, or a substantial amount of foreign ``glue'' code must be -written to perform the translation. - -\item The Lisp system can automatically convert objects back and forth -between the Lisp and foreign representations. This is convenient, but -translation becomes prohibitively slow when large or complex data structures -must be shared. - -\item The Lisp program can directly manipulate foreign objects through the -use of extensions to the Lisp language. Most Lisp systems make use of -this approach, but the language for describing types and expressing -accesses is often not powerful enough for complex objects to be easily -manipulated. -\end{itemize} -\cmucl{} relies primarily on the automatic conversion and direct manipulation -approaches: Aliens of simple scalar types are automatically converted, -while complex types are directly manipulated in their foreign -representation. Any foreign objects that can't automatically be -converted into Lisp values are represented by objects of type -\code{alien-value}. Since Lisp is a dynamically typed language, even -foreign objects must have a run-time type; this type information is -provided by encapsulating the raw pointer to the foreign data within an -\code{alien-value} object. - -The Alien type language and operations are most similar to those of the -C language, but Aliens can also be used when communicating with most -other languages that can be linked with C. - - -\node Alien Types, Alien Operations, Introduction to Aliens, Alien Objects -\section{Alien Types} - -Alien types have a description language based on nested list structure. For -example: -\begin{example} -struct foo \{ - int a; - struct foo *b[100]; -\}; -\end{example} -has the corresponding Alien type: -\begin{lisp} -(struct foo - (a int) - (b (array (* (struct foo)) 100))) -\end{lisp} - - -\begin{menu} -* Defining Alien Types:: -* Alien Types and Lisp Types:: -* Alien Type Specifiers:: -* The C-Call Package:: -\end{menu} - -\node Defining Alien Types, Alien Types and Lisp Types, Alien Types, Alien Types -\subsection{Defining Alien Types} - -Types may be either named or anonymous. With structure and union types, the -name is part of the type specifier, allowing recursively defined types such as: -\begin{lisp} -(struct foo (a (* (struct foo)))) -\end{lisp} -An anonymous structure or union type is specified by using the name \nil. The -\funref{with-alien} macro defines a local scope which ``captures'' any named -type definitions. Other types are not inherently named, but can be given -named abbreviations using \code{def-alien-type}. - -\defmac{def-alien-type}[alien]{name type} -This macro globally defines \var{name} as a shorthand for the Alien type -\var{type}. When introducing global structure and union type definitions, -\var{name} may be \nil, in which case the name to define is taken from the -type's name. -\enddefmac - - -\node Alien Types and Lisp Types, Alien Type Specifiers, Defining Alien Types, Alien Types -\subsection{Alien Types and Lisp Types} - -The Alien types form a subsystem of the \cmucl{} type system. An \code{alien} -type specifier provides a way to use any Alien type as a Lisp type -specifier. For example -\begin{lisp} -(typep foo '(alien (* int))) -\end{lisp} -can be used to determine whether \code{foo} is a pointer to an \code{int}. -\code{alien} type specifiers can be used in the same ways as ordinary type -specifiers (like \code{string}.) Alien type declarations are subject to the same -precise type checking as any other declaration (section -\xlref{precise-type-checks}.) - -Note that the Alien type system overlaps with normal Lisp type specifiers in -some cases. For example, the type specifier \code{(alien single-float)} is -identical to \code{single-float}, since Alien floats are automatically -converted to Lisp floats. When \code{type-of} is called on an Alien value -that is not automatically converted to a Lisp value, then it will return an -\code{alien} type specifier. - -\node Alien Type Specifiers, The C-Call Package, Alien Types and Lisp Types, Alien Types -\subsection{Alien Type Specifiers} - -Some Alien type names are \clisp symbols, but the names are -still exported from the \code{alien} package, so it is legal to say -\code{alien:single-float}. These are the basic Alien type specifiers: - -\deftp{Alien type}{*}{\var{type}} -A pointer to an object of the specified \var{type}. If \var{type} is \true, -then it means a pointer to anything, similar to ``\code{void *}'' in ANSI C. -Currently, the only way to detect a null pointer is: -\begin{lisp} -(zerop (sap-int (alien-sap \var{ptr}))) -\end{lisp} -\xlref{system-area-pointers} -\enddeftp - -\deftp{Alien type}{array}{\var{type} \mstar{\var{dimension}}} -An array of the specified \var{dimensions}, holding elements of type -\var{type}. Note that \code{(* int)} and \code{(array int)} are considered to -be different types when type checking is done; pointer and array types must be -explicitly coerced using \code{cast}. - -Arrays are accessed using \code{deref}, passing the indices as additional -arguments. Elements are stored in column-major order (as in C), so the first -dimension determines only the size of the memory block, and not the layout of -the higher dimensions. An array whose first dimension is variable may be -specified by using \nil{} as the first dimension. Fixed-size arrays can be -allocated as array elements, structure slots or \code{with-alien} variables. -Dynamic arrays can only be allocated using \funref{make-alien}. -\enddeftp - -\deftp{Alien type}{struct}{\var{name} - \mstar{(\var{field} \var{type} \mopt{\var{bits}})}} - -A structure type with the specified \var{name} and \var{fields}. Fields are -allocated at the same positions used by the implementation's C compiler. -\var{bits} is intended for C-like bit field support, but is currently unused. -If \var{name} is \false, then the type is anonymous. - -If a named Alien \code{struct} specifier is passed to \funref{def-alien-type} -or \funref{with-alien}, then this defines, respectively, a new global or local -Alien structure type. If no \var{fields} are specified, then the fields are -taken from the current (local or global) Alien structure type definition of -\var{name}. -\enddeftp - -\deftp{Alien type}{union}{\var{name} - \mstar{(\var{field} \var{type} \mopt{\var{bits}})}} -Similar to \code{struct}, but defines a union type. All fields are allocated at -the same offset, and the size of the union is the size of the largest field. -The programmer must determine which field is active from context. -\enddeftp - -\deftp{Alien type}{enum}{\var{name} \mstar{\var{spec}}} -An enumeration type that maps between integer values and keywords. If -\var{name} is \false, then the type is anonymous. Each \var{spec} is either -a keyword, or a list \code{(\var{keyword} \var{value})}. If \var{integer} is -not supplied, then it defaults to one greater than the value for the preceding -spec (or to zero if it is the first spec.) -\enddeftp - -\deftp{Alien type}{signed}{\mopt{\var{bits}}} -A signed integer with the specified number of bits precision. The upper limit -on integer precision is determined by the machine's word size. If no size is -specified, the maximum size will be used. -\enddeftp - -\deftp{Alien type}{integer}{\mopt{\var{bits}}} -Identical to \code{signed} --- the distinction between \code{signed} and -\code{integer} is purely stylistic. -\enddeftp - -\deftp{Alien type}{unsigned}{\mopt{\var{bits}}} -Like \code{signed}, but specifies an unsigned integer. -\enddeftp - -\deftp{Alien type}{boolean}{\mopt{\var{bits}}} -Similar to an enumeration type that maps \code{0} to \false{} and all other values -to \true. \var{bits} determines the amount of storage allocated to hold the -truth value. -\enddeftp - -\deftp{Alien type}{single-float}{} -A floating-point number in IEEE single format. -\enddeftp - -\deftp{Alien type}{double-float}{} -A floating-point number in IEEE double format. -\enddeftp - -\deftp{Alien type}{function}{\var{result-type} \mstar{\var{arg-type}}} -\label{alien-function-types} -A Alien function that takes arguments of the specified \var{arg-types} and -returns a result of type \var{result-type}. Note that the only context where -a \code{function} type is directly specified is in the argument to -\code{alien-funcall} (see section \ref{alien-funcall}.) In all other contexts, -functions are represented by function pointer types: \code{(* (function -...))}. \enddeftp - -\deftp{Alien type}{system-area-pointer}{} -A pointer which is represented in Lisp as a \code{system-area-pointer} object -(\pxlref{system-area-pointers}.) -\enddeftp - -\node The C-Call Package, , Alien Type Specifiers, Alien Types -\subsection{The C-Call Package} - -The \code{c-call} package exports these type-equivalents to the C type of the -same name: \code{char}, \code{short}, \code{int}, \code{long}, -\code{unsigned-char}, \code{unsigned-short}, \code{unsigned-int}, -\code{unsigned-long}, \code{float}, \code{double}. \code{c-call} also exports -these types: - -\deftp{Alien type}{void}{} -This type is used in function types to declare that no useful value is -returned. Evaluation of an \code{alien-funcall} form will return zero values. -\enddeftp - -\deftp{Alien type}{c-string}{} -This type is similar to \code{(* char)}, but is interpreted as a -null-terminated string, and is automatically converted into a Lisp string when -accessed. If the pointer is C \code{NULL} (or 0), then accessing gives Lisp -\false. - -Assigning a Lisp string to a \code{c-string} structure field or variable stores -the contents of the string to the memory already pointed to by that variable. -When an Alien of type \code{(* char)} is assigned to a \code{c-string}, then -the \code{c-string} pointer is assigned to. This allows \code{c-string} -pointers to be initialized. For example: -\begin{lisp} -(def-alien-type nil (struct foo (str c-string))) - -(defun make-foo (str) - (let ((my-foo (make-alien (struct foo)))) - (setf (slot my-foo 'str) (make-alien char (length str))) - (setf (slot my-foo 'str) str) - my-foo)) -\end{lisp} -Storing Lisp \false{} writes C \code{NULL} to the \code{c-string} pointer. -\enddeftp - - -\node Alien Operations, Alien Variables, Alien Types, Alien Objects -\section{Alien Operations} - -This section describes the basic operations on Alien values. - -\begin{menu} -* Alien Access Operations:: -* Alien Coercion Operations:: -* Alien Dynamic Allocation:: -\end{menu} - -\node Alien Access Operations, Alien Coercion Operations, Alien Operations, Alien Operations -\subsection{Alien Access Operations} - -\defun{deref}[alien]{\var{pointer-or-array} \&rest \var{indices}} -This function returns the value pointed to by an Alien pointer or the value of -an Alien array element. If a pointer, an optional single index can be -specified to give the equivalent of C pointer arithmetic; this index is scaled -by the size of the type pointed to. If an array, the number of indices must -be the same as the number of dimensions in the array type. \code{deref} can -be set with \code{setf} to assign a new value. -\enddefun - -\defun{slot}[alien]{\var{struct-or-union} \var{slot-name}} -This function extracts the value of slot \var{slot-name} from the an Alien -\code{struct} or \code{union}. If \var{struct-or-union} is a pointer to a -structure or union, then it is automatically dereferenced. This can be -set with \code{setf} to assign a new value. Note that \var{slot-name} -is evaluated, and need not be a compile-time constant (but only constant -slot accesses are efficiently compiled.) -\enddefun - -\node Alien Coercion Operations, Alien Dynamic Allocation, Alien Access Operations, Alien Operations -\subsection{Alien Coercion Operations} - -\defmac{addr}[alien]{\var{alien-expr}} -This macro returns a pointer to the location specified by \var{alien-expr}, -which must be either an Alien variable, a use of \code{deref}, a use of \code{slot}, -or a use of \funref{extern-alien}. -\enddefmac - -\defmac{cast}[alien]{\var{alien} \var{new-type}} -This macro converts \var{alien} to a new Alien with the specified -\var{new-type}. Both types must be an Alien pointer, array or function type. -Note that the result is not \code{eq} to the argument, but does refer to the same -data bits. -\enddefmac - -\defmac{sap-alien}[alien]{\var{sap} \var{type}} -\defunx{alien-sap}[alien]{\var{alien-value}} -\code{sap-alien} converts \var{sap} (a system area pointer -\pxlref{system-area-pointers}) to an Alien value with the specified -\var{type}. \var{type} is not evaluated. - -\code{alien-sap} returns the SAP which points to \var{alien-value}'s -data. - -The \var{type} to \code{sap-alien} and the type of the \var{alien-value} to -\code{alien-sap} must some Alien pointer, array or record type. -\enddefmac - -\node Alien Dynamic Allocation, , Alien Coercion Operations, Alien Operations -\subsection{Alien Dynamic Allocation} - -Dynamic Aliens are allocated using the \code{malloc} library, so foreign code -can call \code{free} on the result of \code{make-alien}, and Lisp code can -call \code{free-alien} on objects allocated by foreign code. - -\defmac{make-alien}[alien]{\var{type} \mopt{\var{size}}} -This macro returns a dynamically allocated Alien of the specified -\var{type} (which is not evaluated.) The allocated memory is not -initialized, and may contain arbitrary junk. If supplied, \var{size} is -an expression to evaluate to compute the size of the allocated object. -There are two major cases: -\begin{itemize} -\item When \var{type} is an array type, an array of that type is -allocated and a \var{pointer} to it is returned. Note that you must use -\code{deref} to change the result to an array before you can use -\code{deref} to read or write elements: -\begin{lisp} -(defvar *foo* (make-alien (array char 10))) - -(type-of *foo*) -\result{} (alien (* (array (signed 8) 10))) - -(setf (deref (deref foo) 0) 10) -\result{} 10 -\end{lisp} -If supplied, \var{size} is used as the first dimension for the array. - -\item When \var{type} is any other type, then then an object for that type is -allocated, and a \var{pointer} to it is returned. So \code{(make-alien int)} -returns a \code{(* int)}. If \var{size} is specified, then a block of that -many objects is allocated, with the result pointing to the first one. -\end{itemize} -\enddefmac - -\defun{free-alien}[alien]{\var{alien}} -This function frees the storage for \var{alien} (which must have been allocated -with \code{make-alien} or \code{malloc}.) -\enddefun - -See also \funref{with-alien}, which stack-allocates Aliens. - - -\node Alien Variables, Alien Data Structure Example, Alien Operations, Alien Objects -\section{Alien Variables} - -Both local (stack allocated) and external (C global) Alien variables are -supported. - -\begin{menu} -* Local Alien Variables:: -* External Alien Variables:: -\end{menu} - -\node Local Alien Variables, External Alien Variables, Alien Variables, Alien Variables -\subsection{Local Alien Variables} - -\defmac{with-alien}[alien]{\mstar{(\var{name} \var{type} - \mopt{\var{initial-value}})} - \mstar{form}} - -This macro establishes local alien variables with the specified Alien types -and names for dynamic extent of the body. The variable \var{names} are -established as symbol-macros; the bindings have lexical scope, and may be -assigned with \code{setq} or \code{setf}. This form is analogous to defining a local -variable in C: additional storage is allocated, and the initial value is -copied. - -\code{with-alien} also establishes a new scope for named structures and unions. -Any \var{type} specified for a variable may contain name structure or union -types with the slots specified. Within the lexical scope of the binding -specifiers and body, a locally defined structure type \var{foo} can be -referenced by its name using: -\begin{lisp} -(struct foo) -\end{lisp} -\enddefmac - -\node External Alien Variables, , Local Alien Variables, Alien Variables -\subsection{External Alien Variables} -\label{external-aliens} - -External Alien names are strings, and Lisp names are symbols. When an -external Alien is represented using a Lisp variable, there must be a way to -convert from one name syntax into the other. The macros \code{extern-alien}, -\code{def-alien-variable} and \funref{def-alien-routine} use this conversion -heuristic: -\begin{itemize} -\item Alien names are converted to Lisp names by uppercasing and replacing -underscores with hyphens. - -\item Conversely, Lisp names are converted to Alien names by lowercasing and -replacing hyphens with underscores. - -\item Both the Lisp symbol and Alien string names may be separately -specified by using a list of the form: -\begin{lisp} -(\var{lisp-symbol} \var{alien-string}) -\end{lisp} -\end{itemize} - -\defmac{def-alien-variable}[alien]{\var{name} \var{type}} -This macro defines \var{name} as an external Alien variable of the specified -Alien \var{type}. \var{name} and \var{type} are not evaluated. The Lisp name -of the variable (see above) becomes a global Alien variable in the Lisp -namespace. Global Alien variables are effectively ``global symbol macros''; -a reference to the variable fetches the contents of the external variable. -Similarly, setting the variable stores new contents --- the new contents must -be of the declared \var{type}. - -For example, it is often necessary to read the global C variable \code{errno} to -determine why a particular function call failed. It is possible to define -errno and make it accessible from Lisp by the following: -\begin{lisp} -(def-alien-variable "errno" int) - -;; Now it is possible to get the value of the C variable errno simply by -;; referencing that Lisp variable: -;; -(print errno) -\end{lisp} -\enddefmac - -\defmac{extern-alien}[alien]{\var{name} \var{type}} -This macro returns an Alien with the specified \var{type} which points to an -externally defined value. \var{name} is not evaluated, and may be specified -either as a string or a symbol. \var{type} is an unevaluated Alien type -specifier. -\enddefmac - - -\node Alien Data Structure Example, Loading Unix Object Files, Alien Variables, Alien Objects -\section{Alien Data Structure Example} - -Now that we have Alien types, operations and variables, we can manipulate -foreign data structures. This C declaration can be translated into the -following Alien type: -\begin{lisp} -struct foo \{ - int a; - struct foo *b[100]; -\}; - - \equiv{} - -(def-alien-type nil - (struct foo - (a int) - (b (array (* (struct foo)) 100)))) -\end{lisp} - -With this definition, the following C expression can be translated in this way: -\begin{example} -struct foo f; -f.b[7].a - - \equiv{} - -(with-alien ((f (struct foo))) - (slot (deref (slot f 'b) 7) 'a) - ;; - ;; Do something with f... - ) -\end{example} - - -Or consider this example of an external C variable and some accesses: -\begin{example} -struct c_struct \{ - short x, y; - char a, b; - int z; - c_struct *n; -\}; - -extern struct c_struct *my_struct; - -my_struct->x++; -my_struct->a = 5; -my_struct = my_struct->n; -\end{example} -which can be made be manipulated in Lisp like this: -\begin{lisp} -(def-alien-type nil - (struct c-struct - (x short) - (y short) - (a char) - (b char) - (z int) - (n (* c-struct)))) - -(def-alien-variable "my_struct" (* c-struct)) - -(incf (slot my-struct 'x)) -(setf (slot my-struct 'a) 5) -(setq my-struct (slot my-struct 'n)) -\end{lisp} - - - -\node Loading Unix Object Files, Alien Function Calls, Alien Data Structure Example, Alien Objects -\section{Loading Unix Object Files} - -Foreign object files are loaded into the running Lisp process by -\code{load-foreign}. First, it runs the linker on the files and libraries, -creating an absolute Unix object file. This object file is then loaded into -into the currently running Lisp. The external symbols defining routines and -variables are made available for future external references (e.g. by -\code{extern-alien}.) \code{load-foreign} must be run before any of the defined -symbols are referenced. - -Note that if a Lisp core image is saved (using \funref{save-lisp}), all -loaded foreign code is lost when the image is restarted. - -\defun{load-foreign}[alien]{\var{files} \&key{} libraries base-file env} - -\var{files} is a \code{simple-string} or list of \code{simple-string}s -specifying the names of the object files. \var{libraries} is a list of -\code{simple-string}s specifying libraries in a format that \code{ld}, the Unix -linker, expects. The default value for \var{libraries} is \code{("-lc")} -(i.e., the standard C library). \var{base-file} is the file to use for the -initial symbol table information. The default is the Lisp start up code: -\file{path:lisp}. \var{env} should be a list of simple strings in the format -of Unix environment variables (i.e., \code{\var{A}=\var{B}}, where \var{A} is -an environment variable and \var{B} is its value). The default value for -\var{env} is the environment information available at the time Lisp was -invoked. Unless you are certain that you want to change this, you should just -use the default. -\enddefun - - -\node Alien Function Calls, Step-by-Step Alien Example, Loading Unix Object Files, Alien Objects -\section{Alien Function Calls} - -The foreign function call interface allows a Lisp program to call functions -written in other languages. The current implementation of the foreign -function call interface assumes a C calling convention and thus routines -written in any language that adheres to this convention may be called from -Lisp. - -Lisp sets up various interrupt handling routines and other environment -information when it first starts up, and expects these to be in place at all -times. The C functions called by Lisp should either not change the -environment, especially the interrupt entry points, or should make sure -that these entry points are restored when the C function returns to Lisp. -If a C function makes changes without restoring things to the way they were -when the C function was entered, there is no telling what will happen. - -\begin{menu} -* alien-funcall:: The alien-funcall Primitive -* def-alien-routine:: The def-alien-routine Macro -* def-alien-routine Example:: -* Calling Lisp from C:: -\end{menu} - -\node alien-funcall, def-alien-routine, Alien Function Calls, Alien Function Calls -\subsection{The alien-funcall Primitive} - -\defun{alien-funcall}[alien]{\var{alien-function} \&rest \var{arguments}} -This function is the foreign function call primitive: \var{alien-function} is -called with the supplied \var{arguments} and its value is returned. The -\var{alien-function} is an arbitrary run-time expression; to call a constant -function, use \funref{extern-alien} or \code{def-alien-routine}. - -The type of \var{alien-function} must be \code{(alien (function ...))} or -\code{(alien (* (function ...)))}, \xlref{alien-function-types}. The function -type is used to determine how to call the function (as through it was declared -with a prototype.) The type need not be known at compile time, but only -known-type calls are efficiently compiled. Limitations: -\begin{itemize} -\item Structure type return values are not implemented. -\item Passing of structures by value is not implemented. -\end{itemize} -\enddefun - -Here is an example which allocates a \code{(struct foo)}, calls a foreign -function to initialize it, then returns a Lisp vector of all the -\code{(* (struct foo))} objects filled in by the foreign call: -\begin{lisp} -;; -;; Allocate a foo on the stack. -(with-alien ((f (struct foo))) - ;; - ;; Call some C function to fill in foo fields. - (alien-funcall (extern-alien "mangle_foo" (function void (* foo))) - (addr f)) - ;; - ;; Find how many foos to use by getting the A field. - (let* ((num (slot f 'a)) - (result (make-array num))) - ;; - ;; Get a pointer to the array so that we don't have to keep extracting it: - (with-alien ((a (* (array (* (struct foo)) 100)) (addr (slot f 'b)))) - ;; - ;; Loop over the first N elements and stash them in the result vector. - (dotimes (i num) - (setf (svref result i) (deref (deref a) i))) - result))) -\end{lisp} - -\node def-alien-routine, def-alien-routine Example, alien-funcall, Alien Function Calls -\subsection{The def-alien-routine Macro} - - -\defmac{def-alien-routine}[alien]{\var{name} \var{result-type} - \mstar{(\var{aname} \var{atype} \mopt{style})}} - -This macro is a convenience for automatically generating Lisp interfaces to -simple foreign functions. The primary feature is the parameter style -specification, which translates the C pass-by-reference idiom into additional -return values. - -\var{name} is usually a string external symbol, but may also be a symbol Lisp -name or a list of the Lisp name and the foreign name. If only one name is -specified, the other is automatically derived, -(\pxlref{external-aliens}.) - -\var{result-type} is the Alien type of the return value. Each remaining -subform specifies an argument to the foreign function. \var{aname} is the -symbol name of the argument to the constructed function (for documentation) -and \var{atype} is the Alien type of corresponding foreign argument. The -semantics of the actual call are the same as for \funref{alien-funcall}. -\var{style} should be one of the following: -\begin{description} -\item[:in] specifies that the argument is passed by value. This is the -default. \kwd{in} arguments have no corresponding return value from the Lisp -function. - -\item[:out] specifies a pass-by-reference output value. The type of the -argument must be a pointer to a fixed sized object (such as an integer or -pointer). \kwd{out} and \kwd{in-out} cannot be used with pointers to arrays, -records or functions. An object of the correct size is allocated, and its -address is passed to the foreign function. When the function returns, the -contents of this location are returned as one of the values of the Lisp -function. - -\item[:copy] -is similar to \kwd{in}, but the argument is copied to a pre-allocated -object and a pointer to this object is passed to the foreign routine. - -\item[:in-out] -is a combination of \kwd{copy} and \kwd{out}. The argument is copied to a -pre-allocated object and a pointer to this object is passed to the -foreign routine. On return, the contents of this location is returned as an -additional value. -\end{description} -Any efficiency-critical foreign interface function should be inline expanded by -preceding \code{def-alien-routine} with: -\begin{lisp} -(declaim (inline \var{lisp-name})) -\end{lisp} -In addition to avoiding the Lisp call overhead, this allows pointers, -word-integers and floats to be passed using non-descriptor representations, -avoiding consing (\pxlref{non-descriptor}.) -\enddefmac - -\node def-alien-routine Example, Calling Lisp from C, def-alien-routine, Alien Function Calls -\subsection{def-alien-routine Example} - -Consider the C function \code{cfoo} with the following calling convention: -\begin{example} -cfoo (a, i) - char *str; - char *a; /* update */ - int *i; /* out */ -\{ -/* Body of cfoo. */ -\} -\end{example} -which can be described by the following call to \code{def-alien-routine}: -\begin{lisp} -(def-alien-routine "cfoo" void - (str c-string) - (a char :in-out) - (i int :out)) -\end{lisp} -The Lisp function \code{cfoo} will have two arguments (\var{str} and \var{a}) -and two return values (\var{a} and \var{i}). - -\node Calling Lisp from C, , def-alien-routine Example, Alien Function Calls -\subsection{Calling Lisp from C} - -{\it There is currently a mechanism for calling Lisp functions from C, but it -is rather restricted, and is scheduled for replacement. If you need to call -Lisp functions from C, contact us and we will let you know what capabilities -are available in the system you have. } - - -\node Step-by-Step Alien Example, , Alien Function Calls, Alien Objects -\section{Step-by-Step Alien Example} - -This section presents a complete example of an interface to a somewhat -complicated C function. This example should give a fairly good idea of how to -get the effect you want for almost any kind of C function. Suppose you have -the following C function which you want to be able to call from Lisp in the -file \file{test.c}: -\begin{verbatim} -struct c_struct -{ - int x; - char *s; -}; - -struct c_struct *c_function (i, s, r, a) - int i; - char *s; - struct c_struct *r; - int a[10]; -{ - int j; - struct c_struct *r2; - - printf("i = %d\n", i); - printf("s = %s\n", s); - printf("r->x = %d\n", r->x); - printf("r->s = %s\n", r->s); - for (j = 0; j < 10; j++) printf("a[%d] = %d.\n", j, a[j]); - r2 = (struct c_struct *) malloc (sizeof(struct c_struct)); - r2->x = i + 5; - r2->s = "A C string"; - return(r2); -}; -\end{verbatim} -It is possible to call this function from Lisp using the file \file{test.lisp} -whose contents is: -\begin{lisp} -;;; -*- Package: test-c-call -*- -(in-package "TEST-C-CALL") -(use-package "ALIEN") -(use-package "C-CALL") - -;;; Define the record c-struct in Lisp. -(def-alien-type nil - (struct c-struct - (x int) - (s c-string))) - -;;; Define the Lisp function interface to the C routine. It returns a -;;; pointer to a record of type c-struct. It accepts four parameters: -;;; i, an int; s, a pointer to a string; r, a pointer to a c-struct -;;; record; and a, a pointer to the array of 10 ints. -;;; -;;; The INLINE declaration eliminates some efficiency notes about heap -;;; allocation of Alien values. -(declaim (inline c-function)) -(def-alien-routine c-function - (* (struct c-struct)) - (i int) - (s c-string) - (r (* (struct c-struct))) - (a (array int 10))) - -;;; A function which sets up the parameters to the C function and -;;; actually calls it. -(defun call-cfun () - (with-alien ((ar (array int 10)) - (c-struct (struct c-struct))) - (dotimes (i 10) ; Fill array. - (setf (deref ar i) i)) - (setf (slot c-struct 'x) 20) - (setf (slot c-struct 's) "A Lisp String") - - (with-alien ((res (* (struct c-struct)) - (c-function 5 "Another Lisp String" (addr c-struct) ar))) - (format t "Returned from C function.~%") - (multiple-value-prog1 - (values (slot res 'x) - (slot res 's)) - ;; - ;; Deallocate result \i{after} we are done using it. - (free-alien res))))) -\end{lisp} -To execute the above example, it is necessary to compile the C routine as -follows: -\begin{example} -cc -c test.c -\end{example} -In order to enable incremental loading with some linkers, you may need to say: -\begin{example} -cc -G 0 -c test.c -\end{example} -Once the C code has been compiled, you can start up Lisp and load it in: -\begin{example} -%lisp -;;; Lisp should start up with its normal prompt. - -;;; Compile the Lisp file. This step can be done separately. You don't have -;;; to recompile every time. -* (compile-file "test.lisp") - -;;; Load the foreign object file to define the necessary symbols. This must -;;; be done before loading any code that refers to these symbols. next block -;;; of comments are actually the output of LOAD-FOREIGN. Different linkers -;;; will give different warnings, but some warning about redefining the code -;;; size is typical. -* (load-foreign "test.o") - -;;; Running library:load-foreign.csh... -;;; Loading object file... -;;; Parsing symbol table... -Warning: "_gp" moved from #x00C082C0 to #x00C08460. - -Warning: "end" moved from #x00C00340 to #x00C004E0. - -;;; o.k. now load the compiled Lisp object file. -* (load "test") - -;;; Now we can call the routine that sets up the parameters and calls the C -;;; function. -* (test-c-call::call-cfun) - -;;; The C routine prints the following information to standard output. -i = 5 -s = Another Lisp string -r->x = 20 -r->s = A Lisp string -a[0] = 0. -a[1] = 1. -a[2] = 2. -a[3] = 3. -a[4] = 4. -a[5] = 5. -a[6] = 6. -a[7] = 7. -a[8] = 8. -a[9] = 9. -;;; Lisp prints out the following information. -Returned from C function. -;;; Return values from the call to test-c-call::call-cfun. -10 -"A C string" -* -\end{example} - -If any of the foreign functions do output, they should not be called from -within Hemlock. Depending on the situation, various strange behavior occurs. -Under X, the output goes to the window in which Lisp was started; on a -terminal, the output will overwrite the Hemlock screen image; in a Hemlock -slave, standard output is \file{/dev/null} by default, so any output is -discarded. - -\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/ipc.ms} - -\node Interprocess Communication under LISP, Debugger Programmer's Interface, Alien Objects, Top -\chapter{Interprocess Communication under LISP} -\begin{center} -\b{Written by William Lott and Bill Chiles} -\end{center} -\label{remote} - -CMU Common Lisp offers a facility for interprocess communication (IPC) -on top of using Unix system calls and the complications of that level -of IPC. There is a simple remote-procedure-call (RPC) package build -on top of TCP/IP sockets. - - -\begin{menu} -* The REMOTE Package:: -* The WIRE Package:: -* Out-Of-Band Data:: -\end{menu} - -\node The REMOTE Package, The WIRE Package, Interprocess Communication under LISP, Interprocess Communication under LISP -\section{The REMOTE Package} -The \code{remote} package provides simple RPC facility including -interfaces for creating servers, connecting to already existing -servers, and calling functions in other Lisp processes. The routines -for establishing a connection between two processes, -\code{create-request-server} and \code{connect-to-remote-server}, -return \var{wire} structures. A wire maintains the current state of -a connection, and all the RPC forms require a wire to indicate where -to send requests. - - -\begin{menu} -* Connecting Servers and Clients:: -* Remote Evaluations:: -* Remote Objects:: -* Host Addresses:: -\end{menu} - -\node Connecting Servers and Clients, Remote Evaluations, The REMOTE Package, The REMOTE Package -\subsection{Connecting Servers and Clients} - -Before a client can connect to a server, it must know the network address on -which the server accepts connections. Network addresses consist of a host -address or name, and a port number. Host addresses are either a string of the -form \code{VANCOUVER.SLISP.CS.CMU.EDU} or a 32 bit unsigned integer. Port -numbers are 16 bit unsigned integers. Note: \var{port} in this context has -nothing to do with Mach ports and message passing. - -When a process wants to receive connection requests (that is, become a -server), it first picks an integer to use as the port. Only one server -(Lisp or otherwise) can use a given port number on a given machine at -any particular time. This can be an iterative process to find a free -port: picking an integer and calling \code{create-request-server}. This -function signals an error if the chosen port is unusable. You will -probably want to write a loop using \code{handler-case}, catching -conditions of type error, since this function does not signal more -specific conditions. - -\defun{create-request-server}[wire]{ - \args{\var{port} \&optional{} \var{on-connect}}} - \code{create-request-server} sets up the current Lisp to accept connections on -the given port. If port is unavailable for any reason, this signals an error. -When a client connects to this port, the acceptance mechanism makes a wire -structure and invokes the \var{on-connect} function. Invoking this function has -a couple purposes, and \var{on-connect} may be \nil{} in which case the system -foregoes invoking any function at connect time. - -The \var{on-connect} function is both a hook that allows you access to the wire -created by the acceptance mechanism, and it confirms the connection. This -function takes two arguments, the wire and the host address of the connecting -process. See the section on host addresses below. When \var{on-connect} is -\nil, the request server allows all connections. When it is non-\nil, the -function returns two values, whether to accept the connection and a function -the system should call when the connection terminates. Either value may be -\nil, but when the first value is \nil, the acceptance mechanism destroys the -wire. - -\code{create-request-server} returns an object that \code{destroy-request-server} -uses to terminate a connection. -\enddefun - -\defun{destroy-request-server}[wire]{\args{\var{server}}} -\code{destroy-request-server} takes the result of \code{create-request-server} and -terminates that server. Any existing connections remain intact, but all -additional connection attempts will fail. -\enddefun - -\defun{connect-to-remote-server}[wire]{ - \args{\var{host} \var{port} \&optional{} \var{on-death}}} - \code{connect-to-remote-server} attempts to connect to a remote server at the -given \var{port} on \var{host} and returns a wire structure if it is successful. -If \var{on-death} is non-\nil, it is a function the system invokes when this -connection terminates. -\enddefun - - -\node Remote Evaluations, Remote Objects, Connecting Servers and Clients, The REMOTE Package -\subsection{Remote Evaluations} -After the server and client have connected, they each have a wire allowing -function evaluation in the other process. This RPC mechanism has three -flavors: for side-effect only, for a single value, and for multiple values. - -Only a limited number of data types can be sent across wires as arguments for -remote function calls and as return values: integers inclusively less than 32 -bits in length, symbols, lists, and \var{remote-objects} (\pxlref{remote-objs}). The system sends symbols as two strings, the package name -and the symbol name, and if the package doesn't exist remotely, the remote -process signals an error. The system ignores other slots of symbols. Lists -may be any tree of the above valid data types. To send other data types you -must represent them in terms of these supported types. For example, you could -use \code{prin1-to-string} locally, send the string, and use \code{read-from-string} -remotely. - -\defmac{remote}[wire]{\args{\i{wire \mstar{call-specs}}}} -The \code{remote} macro arranges for the process at the other end of \var{wire} to -invoke each of the functions in the \var{call-specs}. To make sure the system -sends the remote evaluation requests over the wire, you must call -\code{wire-force-output}. - -Each of \var{call-specs} looks like a function call textually, but it has some -odd constraints and semantics. The function position of the form must be the -symbolic name of a function. \code{remote} evaluates each of the argument -subforms for each of the \var{call-specs} locally in the current context, sending -these values as the arguments for the functions. - -Consider the following example: -\begin{verbatim} -(defun write-remote-string (str) - (declare (simple-string str)) - (wire:remote wire - (write-string str))) -\end{verbatim} -The value of \code{str} in the local process is passed over the wire with a -request to invoke \code{write-string} on the value. The system does not expect to -remotely evaluate \code{str} for a value in the remote process. -\enddefmac - -\defun{wire-force-output}[wire]{\args{\var{wire}}} -\code{wire-force-output} flushes all internal buffers associated with \var{wire}, -sending the remote requests. This is necessary after a call to \code{remote}. -\enddefun - -\defmac{remote-value}[wire]{\args{\i{wire call-spec}}} -The \code{remote-value} macro is similar to the \code{remote} macro. -\code{remote-value} only takes one \var{call-spec}, and it returns the value -returned by the function call in the remote process. The value must be a valid -type the system can send over a wire, and there is no need to call -\code{wire-force-output} in conjunction with this interface. - -If client unwinds past the call to \code{remote-value}, the server continues -running, but the system ignores the value the server sends back. - -If the server unwinds past the remotely requested call, instead of returning -normally, \code{remote-value} returns two values, \nil{} and \true. Otherwise this -returns the result of the remote evaluation and \nil. -\enddefmac - -\defmac{remote-value-bind}[wire]{ - \args{\i{wire (\mstar{variable}) remote-form \mstar{local-forms}}}} - \code{remote-value-bind} is similar to \code{multiple-value-bind} except the values -bound come from \var{remote-form}'s evaluation in the remote process. The -\var{local-forms} execute in an implicit \code{progn}. - -If the client unwinds past the call to \code{remote-value-bind}, the server -continues running, but the system ignores the values the server sends back. - -If the server unwinds past the remotely requested call, instead of returning -normally, the \var{local-forms} never execute, and \code{remote-value-bind} returns -\nil. -\enddefmac - - -\node Remote Objects, Host Addresses, Remote Evaluations, The REMOTE Package -\subsection{Remote Objects} -\label{remote-objs} - -The wire mechanism only directly supports a limited number of data -types for transmission as arguments for remote function calls and as -return values: integers inclusively less than 32 bits in length, -symbols, lists. Sometimes it is useful to allow remote processes to -refer to local data structures without allowing the remote process -to operate on the data. We have \var{remote-objects} to support -this without the need to represent the data structure in terms of -the above data types, to send the representation to the remote -process, to decode the representation, to later encode it again, and -to send it back along the wire. - -You can convert any Lisp object into a remote-object. When you send -a remote-object along a wire, the system simply sends a unique token -for it. In the remote process, the system looks up the token and -returns a remote-object for the token. When the remote process -needs to refer to the original Lisp object as an argument to a -remote call back or as a return value, it uses the remote-object it -has which the system converts to the unique token, sending that -along the wire to the originating process. Upon receipt in the -first process, the system converts the token back to the same -(\code{eq}) remote-object. - -\defun{make-remote-object}[wire]{\args{\var{object}}} -\code{make-remote-object} returns a remote-object that has \var{object} as its -value. The remote-object can be passed across wires just like the directly -supported wire data types. -\enddefun - -\defun{remote-object-p}[wire]{\args{\var{object}}} -The function \code{remote-object-p} returns \true{} if \var{object} -is a remote object and \nil{} otherwise. -\enddefun - -\defun{remote-object-local-p}[wire]{\args{\var{remote}}} -The -function \code{remote-object-local-p} returns \true{} if -\var{remote} refers to an object in the local process. This is can -only occur if the local process created \var{remote} with -\code{make-remote-object}. -\enddefun - -\defun{remote-object-eq}[wire]{\args{\i{obj1 obj2}}} -The function \code{remote-object-eq} returns \true{} if \i{obj1} and -\i{obj2} refer to the same (\code{eq}) lisp object, regardless of -which process created the remote-objects. -\enddefun - -\defun{remote-object-value}[wire]{\args{\var{remote}}} -This function returns the original object used to create the given remote -object. It is an error if some other process originally created the -remote-object. -\enddefun - -\defun{forget-remote-translation}[wire]{\args{\var{object}}} -This function removes the information and storage necessary to -translate remote-objects back into \var{object}, so the next -\code{gc} can reclaim the memory. You should use this when you no -longer expect to receive references to \var{object}. If some remote -process does send a reference to \var{object}, -\code{remote-object-value} signals an error. -\enddefun - - -\node Host Addresses, , Remote Objects, The REMOTE Package -\subsection{Host Addresses} -The operating system maintains a database of all the valid host -addresses. You can use this database to convert between host names -and addresses and vice-versa. - -\defun{lookup-host-entry}[ext]{\args{\var{host}}} -\code{lookup-host-entry} searches the database for the given -\var{host} and returns a host-entry structure for it. If it fails -to find \var{host} in the database, it returns \nil. \var{Host} is -either the address (as an integer) or the name (as a string) of the -desired host. -\enddefun - -\defun{host-entry-name}[ext]{\args{\var{host-entry}}} -\defunx{host-entry-aliases}[ext]{\args{\var{host-entry}}} -\defunx{host-entry-addr-list}[ext]{\args{\var{host-entry}}} -\defunx{host-entry-addr}[ext]{\args{\var{host-entry}}} -\code{host-entry-name}, \code{host-entry-aliases}, and -\code{host-entry-addr-list} each return the indicated slot from the -host-entry structure. \code{host-entry-addr} returns the primary -(first) address from the list returned by -\code{host-entry-addr-list}. -\enddefun - - -\node The WIRE Package, Out-Of-Band Data, The REMOTE Package, Interprocess Communication under LISP -\section{The WIRE Package} - -The \code{wire} package provides for sending data along wires. The -\code{remote} package sits on top of this package. All data sent -with a given output routine must be read in the remote process with -the complementary fetching routine. For example, if you send so a -string with \code{wire-output-string}, the remote process must know -to use \code{wire-get-string}. To avoid rigid data transfers and -complicated code, the interface supports sending -\var{tagged} data. With tagged data, the system sends a tag -announcing the type of the next data, and the remote system takes -care of fetching the appropriate type. - -When using interfaces at the wire level instead of the RPC level, -the remote process must read everything sent by these routines. If -the remote process leaves any input on the wire, it will later -mistake the data for an RPC request causing unknown lossage. - -\begin{menu} -* Untagged Data:: -* Tagged Data:: -* Making Your Own Wires:: -\end{menu} - -\node Untagged Data, Tagged Data, The WIRE Package, The WIRE Package -\subsection{Untagged Data} -When using these routines both ends of the wire know exactly what types are -coming and going and in what order. This data is restricted to the following -types: -\begin{itemize} - -\item -8 bit unsigned bytes. - -\item -32 bit unsigned bytes. - -\item -32 bit integers. - -\item -simple-strings less than 65535 in length. -\end{itemize} - - -\defun{wire-output-byte}[wire]{\args{\i{wire byte}}} -\defunx{wire-get-byte}[wire]{\args{\var{wire}}} -\defunx{wire-output-number}[wire]{\args{\i{wire number}}} -\defunx{wire-get-number}[wire]{\args{\var{wire} \&optional{} \var{signed}}} -\defunx{wire-output-string}[wire]{\args{\i{wire string}}} -\defunx{wire-get-string}[wire]{\args{\var{wire}}} -These functions either output or input an object of the specified data type. -When you use any of these output routines to send data across the wire, you -must use the corresponding input routine interpret the data. -\enddefun - - -\node Tagged Data, Making Your Own Wires, Untagged Data, The WIRE Package -\subsection{Tagged Data} -When using these routines, the system automatically transmits and interprets -the tags for you, so both ends can figure out what kind of data transfers -occur. Sending tagged data allows a greater variety of data types: integers -inclusively less than 32 bits in length, symbols, lists, and \var{remote-objects} -(\pxlref{remote-objs}). The system sends symbols as two strings, the -package name and the symbol name, and if the package doesn't exist remotely, -the remote process signals an error. The system ignores other slots of -symbols. Lists may be any tree of the above valid data types. To send other -data types you must represent them in terms of these supported types. For -example, you could use \code{prin1-to-string} locally, send the string, and use -\code{read-from-string} remotely. - -\defun{wire-output-object}[wire]{\args{\i{wire object} \&optional{} \var{cache-it}}} -\defunx{wire-get-object}[wire]{\args{\var{wire}}} -The function \code{wire-output-object} sends \var{object} over \var{wire} preceded by -a tag indicating its type. - -If \var{cache-it} is non-\nil, this function only sends \var{object} the first time -it gets \var{object}. Each end of the wire associates a token with \var{object}, -similar to remote-objects, allowing you to send the object more efficiently on -successive transmissions. \var{Cache-it} defaults to \true{} for symbols and \nil{} -for other types. Since the RPC level requires function names, a high-level -protocol based on a set of function calls saves time in sending the functions' -names repeatedly. - -The function \code{wire-get-object} reads the results of \code{wire-output-object} -and returns that object. -\enddefun - - -\node Making Your Own Wires, , Tagged Data, The WIRE Package -\subsection{Making Your Own Wires} -You can create wires manually in addition to the \code{remote} package's -interface creating them for you. To create a wire, you need a Unix \i{file -descriptor}. If you are unfamiliar with Unix file descriptors, see section 2 of -the Unix manual pages. - -\defun{make-wire}[wire]{\args{\var{descriptor}}} -The function \code{make-wire} creates a new wire when supplied with the file -descriptor to use for the underlying I/O operations. -\enddefun - -\defun{wire-p}[wire]{\args{\var{object}}} -This function returns \true{} if \var{object} is indeed a wire, \nil{} otherwise. -\enddefun - -\defun{wire-fd}[wire]{\args{\var{wire}}} -This function returns the file descriptor used by the \var{wire}. -\enddefun - - -\node Out-Of-Band Data, , The WIRE Package, Interprocess Communication under LISP -\section{Out-Of-Band Data} - -The TCP/IP protocol allows users to send data asynchronously, otherwise -known as \var{out-of-band} data. When using this feature, the operating -system interrupts the receiving process if this process has chosen to be -notified about out-of-band data. The receiver can grab this input -without affecting any information currently queued on the socket. -Therefore, you can use this without interfering with any current -activity due to other wire and remote interfaces. - -Unfortunately, most implementations of TCP/IP are broken, so use of -out-of-band data is limited for safety reasons. You can only reliably -send one character at a time. - -This routines in this section provide a mechanism for establishing -handlers for out-of-band characters and for sending them out-of-band. -These all take a Unix file descriptor instead of a wire, but you can -fetch a wire's file descriptor with \code{wire-fd}. - -\defun{add-oob-handler}[wire]{\args{\i{fd char handler}}} -The function \code{add-oob-handler} arranges for \var{handler} to be called -whenever \var{char} shows up as out-of-band data on the file descriptor -\var{fd}. -\enddefun - -\defun{remove-oob-handler}[wire]{\args{\i{fd char}}} -This function removes the handler for the character \var{char} on the file -descriptor \var{fd}. -\enddefun - -\defun{remove-all-oob-handlers}[wire]{\args{\var{fd}}} -This function removes all handlers for the file descriptor \var{fd}. -\enddefun - -\defun{send-character-out-of-band}[wire]{\args{\i{fd char}}} -This function Sends the character \var{char} down the file descriptor \var{fd} -out-of-band. -\enddefun - - -\hide{File:debug-int.tex} -\node Debugger Programmer's Interface, Function Index, Interprocess Communication under LISP, Top -\chapter{Debugger Programmer's Interface} -\label{debug-internals} - -The debugger programmers interface is exported from from the -\code{"DEBUG-INTERNALS"} or \code{"DI"} package. This is a CMU -extension that allows debugging tools to be written without detailed -knowledge of the compiler or run-time system. - -Some of the interface routines take a code-location as an argument. As -described in the section on code-locations, some code-locations are -unknown. When a function calls for a \var{basic-code-location}, it -takes either type, but when it specifically names the argument -\var{code-location}, the routine will signal an error if you give it an -unknown code-location. - -\begin{menu} -* DI Exceptional Conditions:: -* Debug-variables:: -* Frames:: -* Debug-functions:: -* Debug-blocks:: -* Breakpoints:: -* Code-locations:: -* Debug-sources:: -* Source Translation Utilities:: -\end{menu} - - -\node DI Exceptional Conditions, Debug-variables, Debugger Programmer's Interface, Debugger Programmer's Interface -\section{DI Exceptional Conditions} - -Some of these operations fail depending on the availability debugging -information. In the most severe case, when someone saved a Lisp image -stripping all debugging data structures, no operations are valid. In -this case, even backtracing and finding frames is impossible. Some -interfaces can simply return values indicating the lack of information, -or their return values are naturally meaningful in light missing data. -Other routines, as documented below, will signal -\code{serious-condition}s when they discover awkward situations. This -interface does not provide for programs to detect these situations other -than by calling a routine that detects them and signals a condition. -These are serious-conditions because the program using the interface -must handle them before it can correctly continue execution. These -debugging conditions are not errors since it is no fault of the -programmers that the conditions occur. - -\begin{menu} -* Debug-conditions:: -* Debug-errors:: -\end{menu} - -\node Debug-conditions, Debug-errors, DI Exceptional Conditions, DI Exceptional Conditions -\subsection{Debug-conditions} - -The debug internals interface signals conditions when it can't adhere -to its contract. These are serious-conditions because the program -using the interface must handle them before it can correctly continue -execution. These debugging conditions are not errors since it is no -fault of the programmers that the conditions occur. The interface -does not provide for programs to detect these situations other than -calling a routine that detects them and signals a condition. - - -\deftp{Condition}{debug-condition}{} - -This condition inherits from serious-condition, and all debug-conditions -inherit from this. These must be handled, but they are not programmer errors. -\enddeftp - - -\deftp{Condition}{no-debug-info}{} - -This condition indicates there is absolutely no debugging information -available. -\enddeftp - - -\deftp{Condition}{no-debug-function-returns}{} - -This condition indicates the system cannot return values from a frame since -its debug-function lacks debug information details about returning values. -\enddeftp - - -\deftp{Condition}{no-debug-blocks}{} -This condition indicates that a function was not compiled with debug-block -information, but this information is necessary necessary for some requested -operation. -\enddeftp - -\deftp{Condition}{no-debug-variables}{} -Similar to \code{no-debug-blocks}, except that variable information was -requested. -\enddeftp - -\deftp{Condition}{lambda-list-unavailable}{} -Similar to \code{no-debug-blocks}, except that lambda list information was -requested. -\enddeftp - -\deftp{Condition}{invalid-value}{} - -This condition indicates a debug-variable has \code{:invalid} or \code{:unknown} -value in a particular frame. -\enddeftp - - -\deftp{Condition}{ambiguous-variable-name}{} - -This condition indicates a user supplied debug-variable name identifies more -than one valid variable in a particular frame. -\enddeftp - - -\node Debug-errors, , Debug-conditions, DI Exceptional Conditions -\subsection{Debug-errors} - -These are programmer errors resulting from misuse of the debugging tools' -programmers' interface. You could have avoided an occurrence of one of these -by using some routine to check the use of the routine generating the error. - - -\deftp{Condition}{debug-error}{} -This condition inherits from error, and all user programming errors inherit -from this condition. -\enddeftp - - -\deftp{Condition}{unhandled-condition}{} -This error results from a signalled \code{debug-condition} occurring -without anyone handling it. -\enddeftp - - -\deftp{Condition}{unknown-code-location}{} -This error indicates the invalid use of an unknown-code-location. -\enddeftp - - -\deftp{Condition}{unknown-debug-variable}{} - -This error indicates an attempt to use a debug-variable in conjunction with an -inappropriate debug-function; for example, checking the variable's validity -using a code-location in the wrong debug-function will signal this error. -\enddeftp - - -\deftp{Condition}{frame-function-mismatch}{} - -This error indicates you called a function returned by -\code{preprocess-for-eval} -on a frame other than the one for which the function had been prepared. -\enddeftp - - - -\node Debug-variables, Frames, DI Exceptional Conditions, Debugger Programmer's Interface -\section{Debug-variables} - -Debug-variables represent the constant information about where the system -stores argument and local variable values. The system uniquely identifies with -an integer every instance of a variable with a particular name and package. To -access a value, you must supply the frame along with the debug-variable since -these are particular to a function, not every instance of a variable on the -stack. - -\defun{debug-variable-name}{debug-variable} -This function returns the name of the \var{debug-variable}. The name is the -name of the symbol used as an identifier when writing the code. -\enddefun - - -\defun{debug-variable-package}{debug-variable} -This function returns the package name of the \var{debug-variable}. This is -the package name of the symbol used as an identifier when writing the code. -\enddefun - - -\defun{debug-variable-symbol}{debug-variable} -This function returns the symbol from interning \code{debug-variable-name} in -the package named by \code{debug-variable-package}. -\enddefun - - -\defun{debug-variable-id}{debug-variable} -This function returns the integer that makes \var{debug-variable}'s name and -package name unique with respect to other \var{debug-variable}'s in the same -function. -\enddefun - - -\defun{debug-variable-validity}{debug-variable basic-code-location} -This function returns three values reflecting the validity of -\var{debug-variable}'s value at \var{basic-code-location}: -\begin{description} - \item[\code{:valid}] The value is known to be available. - \item[\code{:invalid}] The value is known to be unavailable. - \item[\code{:unknown}] The value's availability is unknown. -\end{description} -\enddefun - - -\defun{debug-variable-value}{debug-variable frame} -This function returns the value stored for \var{debug-variable} in \var{frame}. -The value may be invalid. This is \code{SETF}'able. -\enddefun - - -\defun{debug-variable-valid-value}{debug-variable frame} -This function returns the value stored for \var{debug-variable} in -\var{frame}. If the value is not \code{:valid}, then this signals an -\code{invalid-value} error. -\enddefun - - - -\node Frames, Debug-functions, Debug-variables, Debugger Programmer's Interface -\section{Frames} - -Frames describe a particular call on the stack for a particular thread. This -is the environment for name resolution, getting arguments and locals, and -returning values. The stack conceptually grows up, so the top of the stack is -the most recently called function. - -\code{top-frame}, \code{frame-down}, \code{frame-up}, and -\code{frame-debug-function} can only fail when there is absolutely no -debug information available. This can only happen when someone saved a -Lisp image specifying that the system dump all debugging data. - - -\defun{top-frame}{} -This function never returns the frame for itself, always the frame before -calling \code{top-frame}. -\enddefun - - -\defun{frame-down}{frame} -This returns the frame immediately below \var{frame} on the stack. When -\var{frame} is the bottom of the stack, this returns \nil. -\enddefun - - -\defun{frame-up}{frame} -This returns the frame immediately above \var{frame} on the stack. When -\var{frame} is the top of the stack, this returns \nil. -\enddefun - - -\defun{frame-debug-function}{frame} -This function returns the debug-function for the function whose call -\var{frame} represents. -\enddefun - - -\defun{frame-code-location}{frame} -This function returns the code-location where \var{frame}'s debug-function will -continue running when program execution returns to \var{frame}. If someone -interrupted this frame, the result could be an unknown code-location. -\enddefun - - -\defun{frame-catches}{frame} -This function returns an a-list for all active catches in \var{frame} mapping -catch tags to the code-locations at which the catch re-enters. -\enddefun - - -\defun{eval-in-frame}{frame form} -This evaluates \var{form} in \var{frame}'s environment. This can signal -several different debug-conditions since its success relies on a variety of -inexact debug information: \code{invalid-value}, -\code{ambiguous-variable-name}, \code{frame-function-mismatch}. See -also \funref{preprocess-for-eval}. -\enddefun - - -\defun{return-from-frame}{frame values} -This returns the elements in the list \var{values} as multiple values from -\var{frame} as if the function \var{frame} represents returned these values. -This signals a \code{no-debug-function-returns} condition when \var{frame}'s -debug-function lacks information on returning values. - -\i{Not Yet Implemented} -\enddefun - - -\node Debug-functions, Debug-blocks, Frames, Debugger Programmer's Interface -\section {Debug-functions} - -Debug-functions represent the static information about a function determined at -compile time --- argument and variable storage, their lifetime information, -etc. The debug-function also contains all the debug-blocks representing -basic-blocks of code, and these contains information about specific -code-locations in a debug-function. - -\defmac{do-debug-function-blocks} - {(block-var debug-function \mopt{result-form}) \mstar{form}} - -This executes the forms in a context with \var{block-var} bound to each -debug-block in \var{debug-function} successively. \var{Result-form} is -an optional form to execute for a return value, and -\code{do-debug-function-blocks} returns \nil if there is no -\var{result-form}. This signals a \code{no-debug-blocks} condition when the -\var{debug-function} lacks debug-block information. -\enddefmac - - -\defun{debug-function-lambda-list}{debug-function} -This function returns a list representing the lambda-list for -\var{debug-function}. The list has the following structure: -\begin{example} - (required-var1 required-var2 - ... - (:optional var3 suppliedp-var4) - (:optional var5) - ... - (:rest var6) (:rest var7) - ... - (:keyword keyword-symbol var8 suppliedp-var9) - (:keyword keyword-symbol var10) - ... - ) -\end{example} -Each \code{var}\var{n} is a debug-variable; however, the symbol -\code{:deleted} appears instead whenever the argument remains unreferenced -throughout \var{debug-function}. - -If there is no lambda-list information, this signals a -\code{lambda-list-unavailable} condition. -\enddefun - - -\defmac{do-debug-function-variables} - {(var debug-function \mopt{result}) \mstar{form}} -This macro executes each \var{form} in a context with \var{var} bound to each -debug-variable in \var{debug-function}. This returns the value of executing -\var{result} (defaults to \nil). This may iterate over only some of -\var{debug-function}'s variables or none depending on debug policy; for example, -possibly the compilation only preserved argument information. -\enddefmac - - -\defun{debug-variable-info-available}{debug-function} -This function returns whether there is any variable information for -\var{debug-function}. This is useful for distinguishing whether there were no -locals in a function or whether there was no variable information. For -example, if \code{do-debug-function-variables} executes its forms zero times, -then you can use this function to determine the reason. -\enddefun - - -\defun{debug-function-symbol-variables}{debug-function symbol} -This function returns a list of debug-variables in \var{debug-function} having -the same name and package as \var{symbol}. If \var{symbol} is uninterned, then -this returns a list of debug-variables without package names and with the same -name as \var{symbol}. The result of this function is limited to the -availability of variable information in \var{debug-function}; for example, -possibly \var{debug-function} only knows about its arguments. -\enddefun - - -\defun{ambiguous-debug-variables}{debug-function name-prefix-string} -This function returns a list of debug-variables in \var{debug-function} whose -names contain \var{name-prefix-string} as an initial substring. The result of -this function is limited to the availability of variable information in -\var{debug-function}; for example, possibly \var{debug-function} only knows -about its arguments. -\enddefun - - -\defun{preprocess-for-eval}{form basic-code-location} -This function returns a function of one argument that evaluates \var{form} in -the lexical context of \var{basic-code-location}. This allows efficient -repeated evaluation of \var{form} at a certain place in a function which could -be useful for conditional breaking. This signals a \code{no-debug-variables} -condition when the code-location's debug-function has no debug-variable -information available. The returned function takes a frame as an -argument. See also \funref{eval-in-frame}. -\enddefun - - -\defun{function-debug-function}{function} -This function returns a debug-function that represents debug information for -\var{function}. -\enddefun - - -\defun{debug-function-kind}{debug-function} -This function returns the kind of function \var{debug-function} represents. -The value is one of the following: -\begin{description} -\item[\code{:optional}] -This kind of function is an entry point to an ordinary function. It handles -optional defaulting, parsing keywords, etc. -\item[\code{:external}] -This kind of function is an entry point to an ordinary function. It checks -argument values and count and calls the defined function. -\item[\code{:top-level}] -This kind of function executes one or more random top-level forms -from a file. -\item[\code{:cleanup}] -This kind of function represents the cleanup forms in an \code{unwind-protect}. -\item[\nil] -This kind of function is not one of the above; that is, it is not specially -marked in any way. -\end{description} -\enddefun - - -\defun{debug-function-function}{debug-function} -This function returns the Common Lisp function associated with the -\var{debug-function}. This returns \nil if the function is unavailable or is -non-existent as a user callable function object. -\enddefun - - -\defun{debug-function-name}{debug-function} -This function returns the name of the function represented by -\var{debug-function}. This may be a string or a cons; do not assume it is a symbol. -\enddefun - - - -\node Debug-blocks, Breakpoints, Debug-functions, Debugger Programmer's Interface -\section{Debug-blocks} - -Debug-blocks contain information pertinent to a specific range of code in a -debug-function. - -\defmac{do-debug-block-locations} - {(code-var debug-block \mopt{result}) \mstar{form}} -This macro executes each \var{form} in a context with \var{code-var} bound to -each code-location in \var{debug-block}. This returns the value of executing -\var{result} (defaults to \nil). -\enddefmac - - -\defun{debug-block-successors}{debug-block} -This function returns the list of possible code-locations where execution may -continue when the basic-block represented by \var{debug-block} completes its -execution. -\enddefun - - -\defun{debug-block-elsewhere-p}{debug-block} -This function returns whether \var{debug-block} represents elsewhere code. -This is code the compiler has moved out of a function's code sequence for -optimization reasons. Code-locations in these blocks are unsuitable for -stepping tools, and the first code-location has nothing to do with a normal -starting location for the block. -\enddefun - - - -\node Breakpoints, Code-locations, Debug-blocks, Debugger Programmer's Interface -\section{Breakpoints} - -A breakpoint represents a function the system calls with the current frame when -execution passes a certain code-location. A break point is active or inactive -independent of its existence. They also have an extra slot for users to tag -the breakpoint with information. - -\defun{make-breakpoint}{hook-function what - \keys{:kind :info :function-end-cookie}} -This function creates and returns a breakpoint. When program execution -encounters the breakpoint, the system calls \var{hook-function}. -\var{Hook-function} takes the current frame for the function in which the -program is running and the breakpoint object. - -\var{what} and \var{kind} determine where in a function the system invokes -\var{hook-function}. \var{what} is either a code-location or a -debug-function. \var{kind} is one of \code{:code-location}, -\code{:function-start}, or \code{:function-end}. Since the starts and ends of -functions may not have code-locations representing them, designate these places -by supplying \var{what} as a debug-function and \var{kind} indicating the -\code{:function-start} or \code{:function-end}. When \var{what} is a -debug-function and \var{kind} is \code{:function-end}, then hook-function must -take two additional arguments, a list of values returned by the function and a -function-end-cookie. - -\var{info} is information supplied by and used by the user. - -\var{function-end-cookie} is a function. To implement function-end -breakpoints, the system uses starter breakpoints to establish the function-end -breakpoint for each invocation of the function. Upon each entry, the system -creates a unique cookie to identify the invocation, and when the user supplies -a function for this argument, the system invokes it on the cookie. The system -later invokes the function-end breakpoint hook on the same cookie. The user -may save the cookie when passed to the function-end-cookie function for -later comparison in the hook function. - -This signals an error if \var{what} is an unknown code-location. -\enddefun - - -\defun{activate-breakpoint}{breakpoint} -This function causes the system to invoke the \var{breakpoint}'s hook-function -until the next call to \code{deactivate-breakpoint} or \code{delete-breakpoint}. -The system invokes breakpoint hook functions in the opposite order that you -activate them. -\enddefun - - -\defun{deactivate-breakpoint}{breakpoint} -This function stops the system from invoking the \var{breakpoint}'s -hook-function. -\enddefun - - -\defun{breakpoint-active-p}{breakpoint} -This returns whether \var{breakpoint} is currently active. -\enddefun - - -\defun{breakpoint-hook-function}{breakpoint} -This function returns the \var{breakpoint}'s function the system calls when -execution encounters \var{breakpoint}, and it is active. This is -\code{SETF}'able. -\enddefun - - -\defun{breakpoint-info}{breakpoint} -This function returns \var{breakpoint}'s information supplied by the user. -This is \code{SETF}'able. -\enddefun - - -\defun{breakpoint-kind}{breakpoint} -This function returns the \var{breakpoint}'s kind specification. -\enddefun - - -\defun{breakpoint-what}{breakpoint} -This function returns the \var{breakpoint}'s what specification. -\enddefun - - -\defun{delete-breakpoint}{breakpoint} -This function frees system storage and removes computational overhead -associated with \var{breakpoint}. After calling this, \var{breakpoint} is -useless and can never become active again. -\enddefun - - - -\node Code-locations, Debug-sources, Breakpoints, Debugger Programmer's Interface -\section{Code-locations} - -Code-locations represent places in functions where the system has correct -information about the function's environment and where interesting operations -can occur --- asking for a local variable's value, setting breakpoints, -evaluating forms within the function's environment, etc. - -Sometimes the interface returns unknown code-locations. These represent places -in functions, but there is no debug information associated with them. Some -operations accept these since they may succeed even with missing debug data. -These operations' argument is named \var{basic-code-location} indicating they -take known and unknown code-locations. If an operation names its argument -\var{code-location}, and you supply an unknown one, it will signal an error. -For example, \code{frame-code-location} may return an unknown code-location if -someone interrupted Lisp in the given frame. The system knows where execution -will continue, but this place in the code may not be a place for which the -compiler dumped debug information. - -\defun{code-location-debug-function}{basic-code-location} -This function returns the debug-function representing information about the -function corresponding to the code-location. -\enddefun - - -\defun{code-location-debug-block}{basic-code-location} -This function returns the debug-block containing code-location if it is -available. Some debug policies inhibit debug-block information, and if none is -available, then this signals a \code{no-debug-blocks} condition. -\enddefun - - -\defun{code-location-top-level-form-offset}{code-location} -This function returns the number of top-level forms before the one containing -\var{code-location} as seen by the compiler in some compilation unit. A -compilation unit is not necessarily a single file, see the section on -debug-sources. -\enddefun - - -\defun{code-location-form-number}{code-location} -This function returns the number of the form corresponding to -\var{code-location}. The form number is derived by walking the subforms of a -top-level form in depth-first order. While walking the top-level form, count -one in depth-first order for each subform that is a cons. See -\funref{form-number-translations}. -\enddefun - - -\defun{code-location-debug-source}{code-location} -This function returns \var{code-location}'s debug-source. -\enddefun - - -\defun{code-location-unknown-p}{basic-code-location} -This function returns whether \var{basic-code-location} is unknown. It returns -\nil when the code-location is known. -\enddefun - - -\defun{code-location=}{code-location1 code-location2} -This function returns whether the two code-locations are the same. -\enddefun - - - -\node Debug-sources, Source Translation Utilities, Code-locations, Debugger Programmer's Interface -\section{Debug-sources} - -Debug-sources represent how to get back the source for some code. The source -is either a file (\code{compile-file} or \code{load}), a lambda-expression -(\code{compile}, \code{defun}, \code{defmacro}), or a stream (something -particular to CMU Common Lisp, \code{compile-from-stream}). - -When compiling a source, the compiler counts each top-level form it processes, -but when the compiler handles multiple files as one block compilation, the -top-level form count continues past file boundaries. Therefore -\code{code-location-top-level-form-offset} returns an offset that does not -always start at zero for the code-location's debug-source. The offset into a -particular source is \code{code-location-top-level-form-offset} minus -\code{debug-source-root-number}. - -Inside a top-level form, a code-location's form number indicates the subform -corresponding to the code-location. - -\defun{debug-source-from}{debug-source} -This function returns an indication of the type of source. The following -are the possible values: -\begin{description} -\item[\code{:file}] -from a file (obtained by \code{compile-file} if compiled). -\item[\code{:lisp}] -from Lisp (obtained by \code{compile} if compiled). -\item[\code{:stream}] -from a non-file stream (CMU Common Lisp supports \code{compile-from-stream}). -\end{description} -\enddefun - - -\defun{debug-source-name}{debug-source} -This function returns the actual source in some sense represented by -debug-source, which is related to \code{debug-source-from}: -\begin{description} -\item[\code{:file}] -the pathname of the file. -\item[\code{:lisp}] -a lambda-expression. -\item[\code{:stream}] -some descriptive string that's otherwise useless. -\end{description} -\enddefun - - -\defun{debug-source-created}{debug-source} -This function returns the universal time someone created the source. This -may be \nil if it is unavailable. -\enddefun - - -\defun{debug-source-compiled}{debug-source} -This function returns the time someone compiled the source. This is \nil -if the source is uncompiled. -\enddefun - - -\defun{debug-source-root-number}{debug-source} -This returns the number of top-level forms processed by the compiler before -compiling this source. If this source is uncompiled, this is zero. This may -be zero even if the source is compiled since the first form in the first file -compiled in one compilation, for example, must have a root number of zero --- -the compiler saw no other top-level forms before it. -\enddefun - - -\node Source Translation Utilities, , Debug-sources, Debugger Programmer's Interface -\section{Source Translation Utilities} - -These two functions provide a mechanism for converting the rather -obscure (but highly compact) representation of source locations into an -actual source form: - -\defun{debug-source-start-positions}{debug-source} -This function returns the file position of each top-level form as an array if -\var{debug-source} is from a \code{:file}. If \code{debug-source-from} is -\code{:lisp} or \code{:stream}, this returns \nil. -\enddefun - - -\defun{form-number-translations}{form tlf-number} -This function returns a table mapping form numbers (see -\code{code-location-form-number}) to source-paths. A source-path indicates a -descent into the top-level-form \var{form}, going directly to the subform -corresponding to a form number. \var{Tlf-number} is the top-level-form number -of \var{form}. -\enddefun - - -\defun{source-path-context}{form path context} -This function returns the subform of \var{form} indicated by the source-path. -\var{Form} is a top-level form, and \var{path} is a source-path into it. -\var{Context} is the number of enclosing forms to return instead of directly -returning the source-path form. When \var{context} is non-zero, the -form returned contains a marker, \code{\#:****HERE****}, immediately -before the form indicated by \var{path}. -\enddefun - - - -\twocolumn -\node Function Index, Variable Index, Debugger Programmer's Interface, Top -\unnumbered{Function Index} -\cindex{Function Index} - -\printindex{fn} - -\twocolumn -\node Variable Index, Type Index, Function Index, Top -\unnumbered{Variable Index} -\cindex{Variable Index} - -\printindex{vr} - -\twocolumn -\node Type Index, Concept Index, Variable Index, Top -\unnumbered{Type Index} -\cindex{Type Index} - -\printindex{tp} - -\onecolumn -\node Concept Index, , Type Index, Top -\unnumbered{Concept Index} -\cindex{Concept Index} - -\printindex{cp} -\end{document} diff --git a/docs/database/cmulisp-fmt.el b/docs/database/cmulisp-fmt.el deleted file mode 100644 index c15ce5c44c986dabd3eb3951b28dcc67bb232018..0000000000000000000000000000000000000000 --- a/docs/database/cmulisp-fmt.el +++ /dev/null @@ -1,146 +0,0 @@ -(load "clisp-fmt") -(load "funref-fmt") - -(put 'defvar 'latexinfo-deffn-formatting-property - 'latexinfo-format-specialized-defvar) - -(put 'defvarx 'latexinfo-deffn-formatting-property - 'latexinfo-format-specialized-defvar) - -(defun latexinfo-format-specialized-defvar (parsed-args) - ;; Specialized variable-like entity: - ;; \defvar{name} In Info, `Variable: Name' - ;; Use cdr of command-type to determine category: - (let ((category (car (cdr command-type))) - (name (car parsed-args)) - (args (cdr parsed-args))) - (if (not (looking-at "\n")) (insert "\n")) - (insert " -- " category ": " "*" name "*") - (while args - (insert " " - (if (= ?& (aref (car args) 0)) - (car args) - (upcase (car args))) - "\n") - (setq args (cdr args))))) - - - -(put 'python 'latexinfo-format 'latexinfo-format-python) -(defun latexinfo-format-python () - (latexinfo-parse-noarg) - (insert "Python")) - -(put 'Python 'latexinfo-format 'latexinfo-format-Python) -(defun latexinfo-format-Python () - (latexinfo-parse-noarg) - (insert "Python")) - -(put 'hemlock 'latexinfo-format 'latexinfo-format-hemlock) -(defun latexinfo-format-hemlock () - (latexinfo-parse-noarg) - (insert "hemlock")) - -(put 'Hemlock 'latexinfo-format 'latexinfo-format-Hemlock) -(defun latexinfo-format-Hemlock () - (latexinfo-parse-noarg) - (insert "Hemlock")) - -(put 'clisp 'latexinfo-format 'latexinfo-format-clisp) -(defun latexinfo-format-clisp () - (latexinfo-parse-noarg) - (insert "Common Lisp")) - -(put 'cmucl 'latexinfo-format 'latexinfo-format-cmucl) -(defun latexinfo-format-cmucl () - (latexinfo-parse-noarg) - (insert "CMU Common Lisp")) - -(put 'cmulisp 'latexinfo-format 'latexinfo-format-cmulisp) -(defun latexinfo-format-clisp () - (latexinfo-parse-noarg) - (insert "CMU Common Lisp")) - -(put 'alien 'latexinfo-format 'latexinfo-format-alien) -(defun latexinfo-format-alien () - (latexinfo-parse-noarg) - (insert "alien")) - -(put 'Alien 'latexinfo-format 'latexinfo-format-Alien) -(defun latexinfo-format-Alien () - (latexinfo-parse-noarg) - (insert "Alien")) - -(put 'Aliens 'latexinfo-format 'latexinfo-format-Aliens) -(defun latexinfo-format-Aliens () - (latexinfo-parse-noarg) - (insert "Aliens")) - -(put 'aliens 'latexinfo-format 'latexinfo-format-aliens) -(defun latexinfo-format-aliens () - (latexinfo-parse-noarg) - (insert "aliens")) - -(put 'Llisp 'latexinfo-format 'latexinfo-format-llisp) -(put 'llisp 'latexinfo-format 'latexinfo-format-llisp) -(defun latexinfo-format-llisp () - (latexinfo-parse-noarg) - (insert "Common Lisp")) - -(put 'cltl 'latexinfo-format 'latexinfo-format-cltl) -(defun latexinfo-format-cltl () - (latexinfo-parse-noarg) - (insert "\i{Common Lisp: The Language}")) - -(put 'hinge 'latexinfo-format 'latexinfo-format-hinge) -(defun latexinfo-format-hinge () - (latexinfo-parse-noarg) - ) - -(put 'hfill 'latexinfo-format 'latexinfo-format-hfill) -(defun latexinfo-format-hfill () - (latexinfo-parse-noarg)) - -(put 'hide 'latexinfo-format 'latexinfo-parse-required-argument) -(put 'ux 'latexinfo-format 'latexinfo-parse-required-argument) - -(put 'dash 'latexinfo-format 'latexinfo-format-dash) -(defun latexinfo-format-dash () - (latexinfo-parse-noarg) - (insert "--")) - -(put 'kwd 'latexinfo-format 'latexinfo-format-kwd) -(defun latexinfo-format-kwd () - (insert ":" (latexinfo-parse-arg-discard) ) - (goto-char latexinfo-command-start)) - -(put 'multiple 'latexinfo-format 'latexinfo-format-noop) -(put 'F 'latexinfo-format 'latexinfo-format-noop) - -(put 'keys 'latexinfo-format 'latexinfo-format-keys) -(defun latexinfo-format-keys () - (insert "&keys " (latexinfo-parse-required-argument)) - (goto-char latexinfo-command-start)) - -(put 'args 'latexinfo-format 'latexinfo-format-args) -(defun latexinfo-format-args () - (insert (latexinfo-parse-required-argument)) - (goto-char latexinfo-command-start)) - -(put 'morekeys 'latexinfo-format 'latexinfo-format-morekeys) -(put 'yetmorekeys 'latexinfo-format 'latexinfo-format-morekeys) -(defun latexinfo-format-morekeys () - (insert " " (latexinfo-parse-required-argument)) - (goto-char latexinfo-command-start)) - - -(put 'findexed 'latexinfo-format 'latexinfo-format-noop) -(put 'vindexed 'latexinfo-format 'latexinfo-format-noop) -(put 'tindexed 'latexinfo-format 'latexinfo-format-noop) -(put 'conindexed 'latexinfo-format 'latexinfo-format-noop) -(put 'vrindex 'latexinfo-format 'latexinfo-format-noop) -(put 'cpindex 'latexinfo-format 'latexinfo-format-noop) -(put 'fnindex 'latexinfo-format 'latexinfo-format-noop) -(put 'pgindex 'latexinfo-format 'latexinfo-format-noop) -(put 'tpindex 'latexinfo-format 'latexinfo-format-noop) -(put 'kyindex 'latexinfo-format 'latexinfo-format-noop) diff --git a/docs/database/cmulisp.sty b/docs/database/cmulisp.sty deleted file mode 100644 index 093591227eb6f166aef069bb9b8bf35cd341b993..0000000000000000000000000000000000000000 --- a/docs/database/cmulisp.sty +++ /dev/null @@ -1,119 +0,0 @@ -\input{clisp.sty} -\input{funref.sty} - -\def\researchcredit{ -This research was sponsored by the Defense Advanced -Research Projects Agency, Information Science and Technology Office, -under the title \i{Research on Parallel Computing} issued by DARPA/CMO -under Contract MDA972-90-C-0035 ARPA Order No. 7330. - -The views and conclusions contained in this document are those of the -authors and should not be interpreted as representing the official -policies, either expressed or implied, of the Defense Advanced Research -Projects Agency or the U.S. government. -} - -% Now stop making all imbedded control L's <Form Feed> act like \newpage -\catcode`^^L = \active -\def^^L{} - -% Was @comment[garbage...] -\long\def\hide#1{} - -% See if we can squelch some of the noise in the default cross-reference -% format. -\def\xrefX [#1,#2,#3,#4,#5,#6]{section \ref{#1}, page\tie \pageref{#1}} - -% Wrap *'s around DEFVAR variables, but not in the vindex. -\def\defvar{\defun@vspace\defvarx} -\def\defvarx{\@defvrstar{Variable}} - -\def\@defvrstar#1#2{\outer\def\defun@type{#1}\outer\def\defun@name{*#2*}% -\vrindexbold{#2}\label{VR:#2}% -\@ifnextchar[{\@defvarpackage}{\@defvarnopackage} -} - -%%% Hemlock Function -\def\F#1{\code{#1}} - -%% Keywords -\def\kwd#1{\code{:#1}} - - -% Indexing (was fvpindex) - -\let\indexfont=\tt - -\def\findexed#1{\findex{#1}{\indexfont #1}} -\def\vindexed#1{\vindex{#1}{\indexfont *#1*}} -\def\conindexed#1{\vindex{#1}{\indexfont #1}} -\def\tindexed#1{\tindex{#1}{\indexfont #1}} - -\newindex{vr} -\newindex{fn} -\newindex{tp} - - -% Cross-referencing (was funref) - -% Add support for referencing functions. This assumes clisp.sty -% and must be loaded after clisp.sty -\def\@defn#1#2{\outer\def\defun@type{#1}\outer\def\defun@name{#2}% -\fnindexbold{#2}\label{FN:#2}% -\@ifnextchar[{\@defunpackage}{\@defunnopackage} -} - -\def\@defvr#1#2{\outer\def\defun@type{#1}\outer\def\defun@name{#2}% -\vrindexbold{#2}\label{VR:#2}% -\@ifnextchar[{\@defvarpackage}{\@defvarnopackage} -} - -\def\@defmc#1#2{\outer\def\defun@type{#1}\outer\def\defun@name{#2}% -\fnindexbold{#2}\label{FN:#2}% -\@ifnextchar[{\@defmacpackage}{\@defmacnopackage} -} - -\let\xlref=\xref % the same indexes in LaTeX, but not in info -\let\pxlref=\pxref % the same indexes in LaTeX, but not in info - -% These are now supported. -\def\funref#1{\findexed{#1} (page\tie\pageref{FN:#1})} -\def\specref#1{\findexed{#1} (page\tie\pageref{FN:#1})} -\def\macref#1{\findexed{#1} (page\tie\pageref{FN:#1})} -\def\varref#1{\vindexed{#1} (page\tie\pageref{VR:#1})} -\def\conref#1{\conindexed{#1} (page\tie\pageref{VR:#1})} - - -% Abbreviations.. - -\def\clisp{{Common Lisp}} - -\def\dash{---} -\def\alien{{Alien}} -\def\aliens{{Aliens}} -\def\Aliens{{Aliens}} -\def\Alien{{Alien}} -\def\Hemlock{{Hemlock}} -\def\hemlock{{Hemlock}} -\def\python{{Python}} -\def\Python{{Python}} -\def\cmucl{{CMU Common Lisp}} -\def\llisp{{Common Lisp}} -\def\Llisp{{Common Lisp}} -\def\cltl{{\i{Common Lisp: The Language}}} - - -% Formatting, from cmu-proc.sty: - - \oddsidemargin -10pt \evensidemargin -10pt - \topmargin -40pt \headheight 12pt \headsep 25pt - \footheight 12pt \footskip 30pt - -\textheight 9.25in \textwidth 6.75in \columnsep .375in \columnseprule 0pt - - -\def\@oddhead{}\def\@evenhead{} -\def\@oddfoot{} -\def\@evenfoot{\@oddfoot} - -\sloppy diff --git a/docs/database/dbolio.lib b/docs/database/dbolio.lib deleted file mode 100644 index 2ee721a1c062eaa2222b5e8220d28849e95140e4..0000000000000000000000000000000000000000 --- a/docs/database/dbolio.lib +++ /dev/null @@ -1,324 +0,0 @@ -@Marker(Library, DBOLIO, Press, Dover, Postscript) - - -@Modify(Chapter,TitleForm -{@Begin(Hd1A, Below 0.8 in)@Skip(0.8 in)@*Chapter @Parm(Numbered)@*@Skip(0.3 in)@*@Parm(Title)@End(Hd1A)}, - ContentsForm -{@Begin(Tc1)@Rfstr(@Parm(Page))@Parm(Referenced)@.@ @Parm(Title)@End(Tc1)}, - Numbered [@1],IncrementedBy Use,Referenced [@1],Announced) -@Modify(Appendix,TitleEnv HD1,ContentsEnv tc1,Numbered [@A.], - ContentsForm "@Tc1(Appendix @Parm(Referenced)@.@ @Rfstr(@Parm(Page))@parm(Title))", - TitleForm "@Hd1(@=Appendix @Parm(Referenced)@*@=@Parm(Title))", - IncrementedBy,Referenced [@A],Announced) @Comment{Alias Chapter} -@Define(F, Facecode F) -@Define(Sail, Facecode U) -@Define(Arrow, Facecode N) -@Commandstring(Minussign = "") -@Commandstring(Centerdot = "@Begin(W, script +0.4 quad).@End(W)") -@Commandstring(Tilde = "@Begin(W, script +0.4 quad)~@End(W)") -@Commandstring(Underscore = "_") -@Commandstring(Bq = "@;`") -@Form(Complex = "@f[#C(@Parm(R) @Parm(I))]") -@Textform(Altmode = "<altmode>") -@Define(DenseDescription = Description, Spread .3) -@Define(Defenvironment = Text, Need 4, Nofill, Justification Off, Break, - Above 2, Below 2, Spread 0.5) -@Define(Defbody = Text, Leftmargin +.6in, Indent 0, Spread 0.5, Break) -@Define(Undefbody = Text, Nofill, Justification Off, Leftmargin -.6in, - Above 0, Below 0, Group, Break) -@Define(Lispenvironment = Verbatim, Group, Leftmargin +.3in, Above .5, Below .5) -@Commandstring(Nopara = "@Begin(Text, Continue Force)@End(Text)") -@Commandstring(Optional = "@f[&optional]") -@Commandstring(Rest = "@f[&rest]") -@Commandstring(Key = "@f[&key]") -@Commandstring(allowotherkeys = "@f[&allow-other-keys]") -@Commandstring(Aux = "@f[&aux]") -@Commandstring(Body = "@f[&body]") -@Commandstring(Whole = "@f[&whole]") -@Commandstring(Special = "@f[&special]") -@Commandstring(Local = "@f[&local]") -@Textform(Mopt = "@r{[}@Parm(Text)@r{]}") -@Textform(Mgroup = "@r[{]@Parm(Text)@r[}]") -@Textform(Mstar = "@r[{]@Parm(Text)@r[}*]") -@Textform(Mplus = "@r[{]@Parm(Text)@r[}@+[+]]") -@Commandstring(Mor = "@r[|]") -@Commandstring(Lisp = "@Begin(Lispenvironment)@~") -@Commandstring(Endlisp = "@End(Lispenvironment)") -@Commandstring(Lispx = "@Begin(Text, Indent 0, Above .5)For example:@End(Text)@Lisp") -@Comment{ - @Commandstring(EQ = "@Arrow[J]") - @Commandstring(EV = "@Arrow[A]") - @Commandstring(EX = "@Arrow[G]") -} - @Commandstring(EQ = "@f[<=>]") - @Commandstring(EV = "@f[=>]") - @Commandstring(EX = "@f[==>]") -@Commandstring(lbracket = "@f{[}") -@Commandstring(rbracket = "@f{]}") -@Commandstring(lbrace = "@f[{]") -@Commandstring(rbrace = "@f[}]") -@define(subi = i) -@define(subr = r) -@define(superi = i) -@define(supersail = sail) -@define(superg = g) -@commandstring(superminussign = "@minussign@;") -@commandstring(supercenterdot = "@centerdot@;") -@Commandstring(false = "@f[nil]") -@Commandstring(nil = "@f[nil]") -@Commandstring(empty = "@f[()]") -@Commandstring(true = "@f[t]") -@Commandstring(xlisp = "@r[L@c[isp]]") -@Commandstring(clisp = "@r[C@c[ommon]] @xlisp") -@Commandstring(lmlisp = "@PossiblyIndexedRef(K <ZetaLisp>, - E <@r[Z@c[eta]@xlisp]>, F <@r[Z@c[eta]@xlisp]>)") -@Commandstring(newlisp = "@PossiblyIndexedRef(K <NIL>, - E <@r[N@c[il]]>, F <@r[N@c[il] (New Implementation of @xlisp]>)") -@Commandstring(slisp = "@PossiblyIndexedRef(K <Spice LISP>, - E <@r[S@c[pice]] @xlisp>, F <@r[S@c[pice]] @xlisp>)") -@Commandstring(lisp15 = "@PossiblyIndexedRef(K <Lisp 1.5>, - E <@xlisp @r[1.5]>, F <@xlisp @r[1.5]>)") -@Commandstring(maclisp = "@PossiblyIndexedRef(K <MacLISP>, - E <@r[M@c[ac]]@xlisp>, F <@r[M@c[ac]]@xlisp>)") -@Commandstring(franzlisp = "@PossiblyIndexedRef(K <Franz LISP>, - E <@r[F@c[ranz]] @xlisp>, F <@r[F@c[ranz]] @xlisp>)") -@Commandstring(interlisp = "@PossiblyIndexedRef(K <InterLISP>, - E <@r[I@c[nter]]@xlisp>, F <@r[I@c[nter]]@xlisp>)") -@Commandstring(stdlisp = "@PossiblyIndexedRef(K <Standard LISP>, - E <@r[S@c[tandard]] @xlisp>, F <@r[S@c[tandard]] @xlisp>)") -@Commandstring(psl = "@PossiblyIndexedRef(K <Portable Standard LISP>, - E <@r[P@c[ortable] S@c[tandard]] @xlisp>, F <@r[P@c[ortable] S@c[tandard]] @xlisp>)") -@Commandstring(s1lisp = "@PossiblyIndexedRef(K <S-1 Lisp>, - E <@r[S-1] @xlisp>, F <@r[S-1] @xlisp>)") -@Commandstring(scheme = "@PossiblyIndexedRef(K <scheme>, - E <@r[S@c[cheme]]>, F <@r[S@c[cheme]]>)") -@Commandstring(fortran = "@PossiblyIndexedRef(K <Fortran>, - E <@c[fortran]>, F <@c[fortran]>)") -@Commandstring(algol = "@PossiblyIndexedRef(K <Algol>, - E <@c[algol]>, F <@c[algol]>)") -@Commandstring(pascal = "@PossiblyIndexedRef(K <Pascal>, - E <@c[pascal]>, F <@c[pascal]>)") -@Commandstring(ada = "@PossiblyIndexedRef(K <ADA>, - E <@c[ada]>, F <@c[ada]>)") -@Commandstring(apl = "@PossiblyIndexedRef(K <APL>, - E <@c[apl]>, F <@c[apl]>)") -@Commandstring(pl1 = "@PossiblyIndexedRef(K <PL/I>, - E <@c[pl/i]>, F <@c[pl/i]>)") -@Commandstring(clanguage = "@PossiblyIndexedRef(K <C>, - E <@c[c]>, F <@c[c] language>)") -@Define(Smallitemize=Itemize, Spread 0.5, Above 0.5, Below 0.5) - -@Marker(Library, DBOLIO, File) - - -@Style(Justification Off) -@Style(Linewidth 7.2 Inches) -@Style(Indentation 0) -@Modify(Chapter,TitleForm -{@Begin(Hd1A, Below 0.8 in)@Skip(0.8 in)@*Chapter @Parm(Numbered)@*@Skip(0.3 in)@*@Parm(Title)@End(Hd1A)}, - ContentsForm -{@Begin(Tc1)@Rfstr(@Parm(Page))@Parm(Referenced)@.@ @Parm(Title)@End(Tc1)}, - Numbered [@1],IncrementedBy Use,Referenced [@1],Announced) -@Modify(Appendix,TitleEnv HD1,ContentsEnv tc1,Numbered [@A.], - ContentsForm "@Tc1(Appendix @Parm(Referenced)@.@ @Rfstr(@Parm(Page))@parm(Title))", - TitleForm "@Hd1(@=Appendix @Parm(Referenced)@*@=@Parm(Title))", - IncrementedBy,Referenced [@A],Announced) @Comment{Alias Chapter} -@Define(F, Capitalized) -@Define(A, Initialize "[APL]") -@Define(Sail = R) -@Define(B = R) -@Commandstring(Minussign = "-") -@Commandstring(Tilde = "~") -@Commandstring(Centerdot = ".") -@Commandstring(Underscore = "_") -@Commandstring(Bq = "@;`") -@Form(Complex = "@f[#C(@Parm(R) @Parm(I))]") -@Textform(Altmode = "$") -@Define(DenseDescription = Description, Spread 0) -@Define(Defenvironment = Text, Need 4, Nofill, Justification Off, Break, - Leftmargin +12, Indent -12, Above 2, Below 2, Spread 0.5) -@Define(Defbody = Text, Leftmargin -6in, Indent 0, Spread 0.5, Break) -@Define(Undefbody = Text, Justification Off, Leftmargin +6, Indent -12, - Above 0, Below 0, Group, Break) -@Define(Lispenvironment = Verbatim, Group, Leftmargin +.5in, Above 1, Below 1) -@Commandstring(Nopara = "@Begin(Text, Continue Force)@End(Text)") -@Commandstring(Optional = "@f[&optional]") -@Commandstring(Rest = "@f[&rest]") -@Commandstring(Key = "@f[&key]") -@Commandstring(allowotherkeys = "@f[&allow-other-keys]") -@Commandstring(Aux = "@f[&aux]") -@Commandstring(Body = "@f[&body]") -@Commandstring(Whole = "@f[&whole]") -@Commandstring(Special = "@f[&special]") -@Commandstring(Local = "@f[&local]") -@Textform(Mopt = "@r{[}@Parm(Text)@r{]}") -@Textform(Mgroup = "@r[{]@Parm(Text)@r[}]") -@Textform(Mstar = "@r[{]@Parm(Text)@r[}*]") -@Textform(Mplus = "@r[{]@Parm(Text)@r[}@+[+]]") -@Commandstring(Mor = "@r[|]") -@Commandstring(Lisp = "@Begin(Lispenvironment)@~") -@Commandstring(Endlisp = "@End(Lispenvironment)") -@Commandstring(Lispx = "@Begin(Text, Indent 0, Above 0)For example:@End(Text)@Lisp") -@Commandstring(EQ = "==") -@Commandstring(EV = "->") -@Commandstring(EX = "<=>") -@Commandstring(lbracket = "@f{[}") -@Commandstring(rbracket = "@f{]}") -@Commandstring(lbrace = "@f[{]") -@Commandstring(rbrace = "@f[}]") -@define(subi = i) -@define(subr = r) -@define(superi = i) -@define(supersail = sail) -@define(superg = g) -@commandstring(superminussign = "@minussign@;") -@commandstring(supercenterdot = "@centerdot@;") -@Commandstring(false = "@f[nil]") -@Commandstring(nil = "@f[nil]") -@Commandstring(empty = "@f[()]") -@Commandstring(true = "@f[t]") -@Commandstring(xlisp = "@r[L@c[isp]]") -@Commandstring(clisp = "@r[C@c[ommon]] @xlisp") -@Commandstring(lmlisp = "@PossiblyIndexedRef(K <ZetaLisp>, - E <@r[Z@c[eta]@xlisp]>, F <@r[Z@c[eta]@xlisp]>)") -@Commandstring(newlisp = "@PossiblyIndexedRef(K <NIL>, - E <@r[N@c[il]]>, F <@r[N@c[il] (New Implementation of @xlisp]>)") -@Commandstring(slisp = "@PossiblyIndexedRef(K <Spice LISP>, - E <@r[S@c[pice]] @xlisp>, F <@r[S@c[pice]] @xlisp>)") -@Commandstring(lisp15 = "@PossiblyIndexedRef(K <Lisp 1.5>, - E <@xlisp @r[1.5]>, F <@xlisp @r[1.5]>)") -@Commandstring(maclisp = "@PossiblyIndexedRef(K <MacLISP>, - E <@r[M@c[ac]]@xlisp>, F <@r[M@c[ac]]@xlisp>)") -@Commandstring(franzlisp = "@PossiblyIndexedRef(K <Franz LISP>, - E <@r[F@c[ranz]] @xlisp>, F <@r[F@c[ranz]] @xlisp>)") -@Commandstring(interlisp = "@PossiblyIndexedRef(K <InterLISP>, - E <@r[I@c[nter]]@xlisp>, F <@r[I@c[nter]]@xlisp>)") -@Commandstring(stdlisp = "@PossiblyIndexedRef(K <Standard LISP>, - E <@r[S@c[tandard]] @xlisp>, F <@r[S@c[tandard]] @xlisp>)") -@Commandstring(psl = "@PossiblyIndexedRef(K <Portable Standard LISP>, - E <@r[P@c[ortable] S@c[tandard]] @xlisp>, F <@r[P@c[ortable] S@c[tandard]] @xlisp>)") -@Commandstring(s1lisp = "@PossiblyIndexedRef(K <S-1 Lisp>, - E <@r[S-1] @xlisp>, F <@r[S-1] @xlisp>)") -@Commandstring(scheme = "@PossiblyIndexedRef(K <scheme>, - E <@c[scheme]>, F <@c[scheme]>)") -@Commandstring(fortran = "@PossiblyIndexedRef(K <Fortran>, - E <@c[fortran]>, F <@c[fortran]>)") -@Commandstring(algol = "@PossiblyIndexedRef(K <Algol>, - E <@c[algol]>, F <@c[algol]>)") -@Commandstring(pascal = "@PossiblyIndexedRef(K <Pascal>, - E <@c[pascal]>, F <@c[pascal]>)") -@Commandstring(ada = "@PossiblyIndexedRef(K <ADA>, - E <@c[ada]>, F <@c[ada]>)") -@Commandstring(apl = "@PossiblyIndexedRef(K <APL>, - E <@c[apl]>, F <@c[apl]>)") -@Commandstring(pl1 = "@PossiblyIndexedRef(K <PL/I>, - E <@c[pl/i]>, F <@c[pl/i]>)") -@Commandstring(clanguage = "@PossiblyIndexedRef(K <C>, - E <@c[c]>, F <@c[c] language>)") -@Define(Smallitemize=Itemize, Spread 0, Above 0, Below 0) - -@Marker(Library, DBOLIO) - - -@Modify(Chapter,TitleForm -{@Begin(Hd1A, Below 0.8 in)@Skip(0.8 in)@*Chapter @Parm(Numbered)@*@Skip(0.3 in)@*@Parm(Title)@End(Hd1A)}, - ContentsForm -{@Begin(Tc1)@Rfstr(@Parm(Page))@Parm(Referenced)@.@ @Parm(Title)@End(Tc1)}, - Numbered [@1],IncrementedBy Use,Referenced [@1],Announced) -@Modify(Appendix,TitleEnv HD1,ContentsEnv tc1,Numbered [@A.], - ContentsForm "@Tc1(Appendix @Parm(Referenced)@.@ @Rfstr(@Parm(Page))@parm(Title))", - TitleForm "@Hd1(@=Appendix @Parm(Referenced)@*@=@Parm(Title))", - IncrementedBy,Referenced [@A],Announced) @Comment{Alias Chapter} -@Define(F, Capitalized) -@Define(A, Initialize "[APL]") -@Define(Sail = R) -@Define(B = R) -@Commandstring(Minussign = "-") -@Commandstring(Tilde = "~") -@Commandstring(Centerdot = ".") -@Commandstring(Underscore = "_") -@Commandstring(Bq = "@;`") -@Form(Complex = "@f[#C(@Parm(R) @Parm(I))]") -@Textform(Altmode = "<altmode>") -@Define(DenseDescription = Description, Spread 0) -@Define(Defenvironment = Text, Need 4, Nofill, Justification Off, Break, - Leftmargin +12, Indent -12, Above 2, Below 2, Spread 0.5) -@Define(Defbody = Text, Leftmargin -6, Indent 0, Spread 0.5, Break) -@Define(Undefbody = Text, Justification Off, Leftmargin +6, Indent -12, - Above 0, Below 0, Group, Break) -@Define(Lispenvironment = Verbatim, Group, Leftmargin +4, Above 1, Below 1) -@Commandstring(Nopara = "@Begin(Text, Continue Force)@End(Text)") -@Commandstring(Optional = "@f[&optional]") -@Commandstring(Rest = "@f[&rest]") -@Commandstring(Key = "@f[&key]") -@Commandstring(allowotherkeys = "@f[&allow-other-keys]") -@Commandstring(Aux = "@f[&aux]") -@Commandstring(Body = "@f[&body]") -@Commandstring(Whole = "@f[&whole]") -@Commandstring(Special = "@f[&special]") -@Commandstring(Local = "@f[&local]") -@Textform(Mopt = "@r{[}@Parm(Text)@r{]}") -@Textform(Mgroup = "@r[{]@Parm(Text)@r[}]") -@Textform(Mstar = "@r[{]@Parm(Text)@r[}*]") -@Textform(Mplus = "@r[{]@Parm(Text)@r[}@+[+]]") -@Commandstring(Mor = "@r[|]") -@Commandstring(Lisp = "@Begin(Lispenvironment)@~") -@Commandstring(Endlisp = "@End(Lispenvironment)") -@Commandstring(Lispx = "@Begin(Text, Indent 0, Above 0)For example:@End(Text)@Lisp") -@Commandstring(EQ = "==") -@Commandstring(EV = "->") -@Commandstring(EX = "<=>") -@Commandstring(lbracket = "@f{[}") -@Commandstring(rbracket = "@f{]}") -@Commandstring(lbrace = "@f[{]") -@Commandstring(rbrace = "@f[}]") -@define(subi = i) -@define(subr = r) -@define(superi = i) -@define(supersail = sail) -@define(superg = g) -@commandstring(superminussign = "@minussign@;") -@commandstring(supercenterdot = "@centerdot@;") -@Commandstring(false = "@f[nil]") -@Commandstring(nil = "@f[nil]") -@Commandstring(empty = "@f[()]") -@Commandstring(true = "@f[t]") -@Commandstring(xlisp = "@r[L@c[isp]]") -@Commandstring(clisp = "@r[C@c[ommon]] @xlisp") -@Commandstring(lmlisp = "@PossiblyIndexedRef(K <ZetaLisp>, - E <@r[Z@c[eta]@xlisp]>, F <@r[Z@c[eta]@xlisp]>)") -@Commandstring(newlisp = "@PossiblyIndexedRef(K <NIL>, - E <@r[N@c[il]]>, F <@r[N@c[il] (New Implementation of @xlisp)]>)") -@Commandstring(slisp = "@PossiblyIndexedRef(K <Spice LISP>, - E <@r[S@c[pice]] @xlisp>, F <@r[S@c[pice]] @xlisp>)") -@Commandstring(lisp15 = "@PossiblyIndexedRef(K <Lisp 1.5>, - E <@xlisp @r[1.5]>, F <@xlisp @r[1.5]>)") -@Commandstring(maclisp = "@PossiblyIndexedRef(K <MacLISP>, - E <@r[M@c[ac]]@xlisp>, F <@r[M@c[ac]]@xlisp>)") -@Commandstring(franzlisp = "@PossiblyIndexedRef(K <Franz LISP>, - E <@r[F@c[ranz]] @xlisp>, F <@r[F@c[ranz]] @xlisp>)") -@Commandstring(interlisp = "@PossiblyIndexedRef(K <InterLISP>, - E <@r[I@c[nter]]@xlisp>, F <@r[I@c[nter]]@xlisp>)") -@Commandstring(stdlisp = "@PossiblyIndexedRef(K <Standard LISP>, - E <@r[S@c[tandard]] @xlisp>, F <@r[S@c[tandard]] @xlisp>)") -@Commandstring(psl = "@PossiblyIndexedRef(K <Portable Standard LISP>, - E <@r[P@c[ortable] S@c[tandard]] @xlisp>, F <@r[P@c[ortable] S@c[tandard]] @xlisp>)") -@Commandstring(s1lisp = "@PossiblyIndexedRef(K <S-1 Lisp>, - E <@r[S-1] @xlisp>, F <@r[S-1] @xlisp>)") -@Commandstring(scheme = "@PossiblyIndexedRef(K <scheme>, - E <@c[scheme]>, F <@c[scheme]>)") -@Commandstring(fortran = "@PossiblyIndexedRef(K <Fortran>, - E <@c[fortran]>, F <@c[fortran]>)") -@Commandstring(algol = "@PossiblyIndexedRef(K <Algol>, - E <@c[algol]>, F <@c[algol]>)") -@Commandstring(pascal = "@PossiblyIndexedRef(K <Pascal>, - E <@c[pascal]>, F <@c[pascal]>)") -@Commandstring(ada = "@PossiblyIndexedRef(K <ADA>, - E <@c[ada]>, F <@c[ada]>)") -@Commandstring(apl = "@PossiblyIndexedRef(K <APL>, - E <@c[apl]>, F <@c[apl]>)") -@Commandstring(pl1 = "@PossiblyIndexedRef(K <PL/I>, - E <@c[pl/i]>, F <@c[pl/i]>)") -@Commandstring(clanguage = "@PossiblyIndexedRef(K <C>, - E <@c[c]>, F <@c[c] language>)") -@Define(Smallitemize=Itemize, Spread 0, Above 0, Below 0) diff --git a/docs/database/hem.lib b/docs/database/hem.lib deleted file mode 100644 index 794efa037d3a95ea32dc4d73caa1e542326d2672..0000000000000000000000000000000000000000 --- a/docs/database/hem.lib +++ /dev/null @@ -1,71 +0,0 @@ -@marker(library, Hem, Press, Dover, Postscript) - -@Form(Defhvar = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @hid[@Parm(Var)]@imbed(val, def <@ @ (initial value @f[@parm(val)])>)@>[@i[@Hemlock Variable]]@\@~ - @Send(FunList {@hid[@Parm(Var)] @>[@i[@Hemlock Variable]]@\})@~ - @HVxindex@Parmquote(Var)@~ - @Imbed(Nolabel, undef '@Imbed(Varlabel, - def <@Label{@Parm(Varlabel)-hvar}>, - undef <@Label{@Parm(Var)-hvar}>)')@~ - @Begin(Defbody)@Tabclear ") - -@Form(Defhvar1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @hid[@Parm(Var)]@imbed(val, def <@ @ (initial value @f[@parm(val)])>)@>[@i[@hemlock Variable]]@\@~ - @Send(FunList {@hid[@Parm(Var)] @>[@i[@hemlock Variable]]@\})@~ - @HVxindex@Parmquote(Var)@~ - @Imbed(Nolabel, undef '@Imbed(Varlabel, - def <@Label{@Parm(Varlabel)-hvar}>, - undef <@Label{@Parm(Var)-hvar}>)')@~ - @End(Undefbody)") - -@Commandstring(Enddefhvar = "@End(Defbody)@End(Defenvironment)") -@Textform(HVxindex = "@Xindex(T {Hemlock variable}, X {@Parm(Text)}, P {@hid[@Parm(Text)]})@'") -@Textform(HVindexref = "@Xindexref(T {Hemlock variable}, X {@Parm(Text)}, P {@hid[@Parm(Text)]})@'") -@Textform(HVarref = '@hid[@Parm(Text)] @~ - @r[(page @Pageref(@Parm(Text)-hvar))]@HVindexref@Parmquote(Text)') - - -@Form(Defcom = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @hid[@Parm(Com)]@imbed(bind, def <@ @ (bound to @bf[@parm(bind)])>)@~ - @imbed(Stuff, def <@ @ (@Parm(Stuff))>)@>[@i[Command]]@\@~ - @Send(FunList {@hid[@Parm(Com)] @>[@i[Command]]@\})@~ - @HCxindex@Parmquote(Com)@~ - @Imbed(Nolabel, undef '@Imbed(Comlabel, - def <@Label{@Parm(Comlabel)-com}>, - undef <@Label{@Parm(Com)-com}>)')@~ - @Begin(Defbody)@Tabclear ") - - -@Form(Defcom1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @hid[@Parm(Com)]@imbed(bind, def <@ @ (bound to @bf[@parm(bind)])>)@~ - @imbed(Stuff, def <@ @ (@Parm(Stuff))>)@>[@i[Command]]@\@~ - @Send(FunList {@hid[@Parm(Com)] @>[@i[Command]]@\})@~ - @HCxindex@Parmquote(Com)@~ - @Imbed(Nolabel, undef '@Imbed(Comlabel, - def <@Label{@Parm(Comlabel)-com}>, - undef <@Label{@Parm(Com)-com}>)')@~ - @End(Undefbody)") - - -@Commandstring(Enddefcom = "@End(Defbody)@End(Defenvironment)") -@Textform(HCxindex = "@Xindex(T {Command}, X {@Parm(Text)}, P {@hid[@Parm(Text)]})@'") -@Textform(HCindexref = "@Xindexref(T {Command}, X {@Parm(Text)}, P {@hid[@Parm(Text)]})@'") -@Textform(Comref = '@hid[@Parm(Text) ]@~ - @r[(page @Pageref(@Parm(Text)-com))]@HCindexref@Parmquote(Text)') - - -@String(IndexFuns "Yes") -@string(supresskeyindex "Yes") - -@specialfont(f1 = helvetica) -@commandstring(Hemlock = "@f1(Hemlock)") -@textform(hid = '@w{@f1{@parm(Text)}}') -@commandstring[emacs = "@f1<Emacs>"] - -@specialfont(f2 = "SouvenirDemi") -@textform<binding = "@f2[@w(@parm{text})]"> -@textform<bf = "@f2[@w(@parm{text})]"> - -@commandstring[llisp = "L@c(isp)"] - -@commandstring[windows = "X windows"] diff --git a/docs/database/outtir.lib b/docs/database/outtir.lib deleted file mode 100644 index 428d1a416142c743844dab57252b9c1f6ef5769b..0000000000000000000000000000000000000000 --- a/docs/database/outtir.lib +++ /dev/null @@ -1,329 +0,0 @@ -@Comment{Version of BOLIO.LIB that provides a single unified index -instead of separate indexes for functions, variables, constants, -keywords, and concepts.} - -@Marker(Library, Uttir, Press, Dover, Postscript) - -@Libraryfile(DBolio) - - -@Comment{Constraints on the definition of IndexEnvironment: - Indent = - LeftMargin - (Linewidth + Leftmargin + Columnmargin) * Columns - Columnmargin - = global line width -} -@Define(IndexEnvironment, Boxed, Columns 2, Columnmargin 0.5in, - Linewidth 2.7in, Leftmargin +0.3in, Indent -0.3in) - -@Define(KeySpreadEnvironment, Facecode F) -@Textform(SpreadKeys = "@KeySpreadEnvironment<@SpreadKeysLoop@Parm(Text)[]>") -@Textform(SpreadKeysLoop = - "@String(SpreadKeysTemp = @Parmquote(Text))@Case(SpreadKeysTemp, - null <>, else < :@Parm(Text)@SpreadKeysLoop>)") - -@Form(IndexKeys = "@Textform(IndexKeysLoop = - '@String(IndexKeysTemp = @Quote{@Parmquote(Text)})@Case(IndexKeysTemp, - null <>, else [@Kindex2(P = @Quote{@Parmquote(Text)}, - S = {for@f( @Parm(Fun))})@IndexKeysLoop])')@IndexKeysLoop@Parm(Keys)[]@~") - -@Counter(UnNumberedIndex,TitleEnv HD1A,ContentsEnv tc1,Announced,Alias Chapter) - -@Textform(IndexHeadings = "@UnnumberedIndex@Parmquote(Text) -@String(ChapterTitle = @Parmquote(Text)) -@Pageheading(Immediate, Left = <>, Right = <>) -@Pagefooting(Immediate, Center = <@Value(Page)>) -@Pageheading(Odd, Left = <@c[@Value(ChapterTitle)]>, Right = <@Value(Page)>) -@Pageheading(Even, Left = <@Value(Page)>, Right = <@c[@Value(ReportTitle)]>) -@Pagefooting(Center = <>) -") - -@Textform(Incompatibility = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4) - @b[Compatibility note:] @Index(@b[Compatibility note]) - @Parm(Text) @End(Quotation)") -@Textform(Implementation = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4) - @b[Implementation note:] @Index(@b[Implementation note]) - @Parm(Text) @End(Quotation)") -@Textform(Rationale = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4) - @b[Rationale:] @Index(@b[Rationale]) @Parm(Text) @End(Quotation)") -@Comment{ -@Textform(Query = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4) - @f[???] @b[Query:] @Index(@b[Query]) @Parm(Text) @End(Quotation)") -} - -@Textform(Kwd = "@f[:@Parm(Text)]") -@Textform(KeywordList = " - @Begin(Description) - @Textform(Keyword = '@Begin(Multiple)@~ -@f[:@Quote<@Parm(Text)> ]@\@Kindex2(P = @Quote<@Parmquote(Text)>, - S = {for@f[ @Parm(Text)]})@~ - @Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~') - @Textform(FirstKeyword = '@Begin(Multiple)@~ -@f[:@Quote<@Parm(Text)> @r[or] ]@Kindex2(P = @Quote<@Parmquote(Text)>, - S = {for@f[ @Parm(Text)]})@~ - @Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~') - @Textform(NextKeyword = '@~ -@f[:@Quote<@Parm(Text)> @r[or] ]@Kindex2(P = @Quote<@Parmquote(Text)>, - S = {for@f[ @Parm(Text)]})@~ - @Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~') - @Textform(LastKeyword = '@~ -@f[:@Quote<@Parm(Text)> ]@\@Kindex2(P = @Quote<@Parmquote(Text)>, - S = {for@f[ @Parm(Text)]})@~ - @Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~') - @Textform(SubKeywordList = ' - @Begin(Description) - @Textform(SubKeyword = <@Begin(Multiple)@~ -@f[:@Quote{@Quote[@Parm(Text)]} ]@\@Kindex2(P = @Quote{@Quote[@Parmquote(Text)]}, - S = {for@f[ @Quote[@Parm(Text)] ]option @~ - to@f[ @Parm(Text)]})@~ - @Label{@Parm(Text)-@Quote[@Parm(Text)]-@Quote{@Quote[@Parm(Text)]}-kwd}@~>)') -") -@Textform(PseudoKeyword = "@Begin(Multiple)@Parm(Text) @\@~") -@Commandstring(Endkeyword = "@End(Multiple)") -@Commandstring(Endkeywordlist = "@End(Description)") -@Textform(PseudoSubKeyword = "@Begin(Multiple)@Parm(Text) @\@~") -@Commandstring(EndSubKeyword = "@End(Multiple)") -@Commandstring(EndSubKeywordlist = "@End(Description)") -@Textform(RandomKeywordList = " - @Begin(Description) - @Index2(P = {Keywords}, S = {for@f[ ]@Parm(Text)}) - @Textform(RandomKeyword = '@Begin(Multiple) -@f[:@Quote<@Parm(Text)> ]@\@Kindex2(P = @Quote<@Parmquote(Text)>, - S = {for@f[ ]@Parm(Text)})@~') -") -@Textform(PseudoRandomKeyword = "@Begin(Multiple)@Parm(Text) @\@~") -@Commandstring(Endrandomkeyword = "@End(Multiple)") -@Commandstring(Endrandomkeywordlist = "@End(Description)") - -@Form(Defvar = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\@~ - @Send(FunList {@f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\})@~ - @Imbed(Nostar, undef<@Vindex@Parmquote(Var)>, def<@Vxindex@Parmquote(Var)>)@~ - @Imbed(Nolabel, undef '@Imbed(Varlabel, - def <@Label{@Parm(Varlabel)-var}>, - undef <@Label{@Parm(Var)-var}>)')@~ - @Begin(Defbody)@Tabclear ") -@Form(Defvar1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\@~ - @Send(FunList {@f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\})@~ - @Imbed(Nostar, undef<@Vindex@Parmquote(Var)>, def<@Vxindex@Parmquote(Var)>)@~ - @Imbed(Nolabel, undef '@Imbed(Varlabel, - def <@Label{@Parm(Varlabel)-var}>, - undef <@Label{@Parm(Var)-var}>)')@~ - @End(Undefbody)") -@Commandstring(Enddefvar = "@End(Defbody)@End(Defenvironment)") - -@Form(Defcon = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @f[@Parm(Var)] @>[@i[Constant]]@\@~ - @Send(FunList {@f[@Parm(Var)] @>[@i[Constant]]@\})@~ - @Conindex@Parmquote(Var)@~ - @Imbed(Nolabel, undef '@Imbed(Varlabel, - def <@Label{@Parm(Varlabel)-con}>, - undef <@Label{@Parm(Var)-con}>)')@~ - @Begin(Defbody)@Tabclear ") -@Form(Defcon1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @f[@Parm(Var)] @>[@i[Constant]]@\@~ - @Send(FunList {@f[@Parm(Var)] @>[@i[Constant]]@\})@~ - @Conindex@Parmquote(Var)@~ - @Imbed(Nolabel, undef '@Imbed(Varlabel, - def <@Label{@Parm(Varlabel)-con}>, - undef <@Label{@Parm(Var)-con}>)')@~ - @End(Undefbody)") -@Commandstring(Enddefcon = "@End(Defbody)@End(Defenvironment)") - -@Form(Defun = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\ -@Imbed(MoreKeys, def <@/@Spreadkeys(@Parm(MoreKeys)) ->)@~ -@Imbed(YetMoreKeys, def <@/@Spreadkeys(@Parm(YetMoreKeys)) ->)@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, - def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\@Imbed(MoreKeys, - def < -@/@f[@Spreadkeys(@Parm(MoreKeys))]>)@Imbed(YetMoreKeys, - def < -@/@f[@Spreadkeys(@Parm(YetMoreKeys))]>)})@~ - @Findex@Parmquote(Fun)@~ - @Imbed(SuppressKeyIndex, undef < - @Imbed(Keys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(Keys))')@~ - @Imbed(MoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(MoreKeys))')@~ - @Imbed(YetMoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(YetMoreKeys))')>)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def <@Label{@Parm(Funlabel)-fun}>, - undef <@Label{@Parm(Fun)-fun}>)')@~ - @Begin(Defbody)@Tabclear ") -@Form(Defun1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\ -@Imbed(MoreKeys, def <@/@Spreadkeys(@Parm(MoreKeys)) ->)@~ -@Imbed(YetMoreKeys, def <@/@Spreadkeys(@Parm(YetMoreKeys)) ->)@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, - def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\@Imbed(MoreKeys, - def < -@/@f[@Spreadkeys(@Parm(MoreKeys))]>)@Imbed(YetMoreKeys, - def < -@/@f[@Spreadkeys(@Parm(YetMoreKeys))]>)})@~ - @Findex@Parmquote(Fun)@~ - @Imbed(SuppressKeyIndex, undef < - @Imbed(Keys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(Keys))')@~ - @Imbed(MoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(MoreKeys))')@~ - @Imbed(YetMoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(YetMoreKeys))')>)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def [@Label{@Parm(Funlabel)-fun}], - undef [@Label{@Parm(Fun)-fun}])')@~ - @End(Undefbody)") -@Commandstring(Enddefun = "@End(Defbody)@End(Defenvironment)") - -@Form(Defmac = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\})@~ - @Mindex@Parmquote(Fun)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def <@Label{@Parm(Funlabel)-mac}>, - undef <@Label{@Parm(Fun)-mac}>)')@~ - @Begin(Defbody)@Tabclear ") -@Form(Defmac1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\})@~ - @Mindex@Parmquote(Fun)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def <@Label{@Parm(Funlabel)-mac}>, - undef <@Label{@Parm(Fun)-mac}>)')@~ - @End(Undefbody)") -@Commandstring(Enddefmac = "@End(Defbody)@End(Defenvironment)") - -@Form(Defspec = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\})@~ - @Sindex@Parmquote(Fun)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def <@Label{@Parm(Funlabel)-spec}>, - undef <@Label{@Parm(Fun)-spec}>)')@~ - @Begin(Defbody)@Tabclear ") -@Form(Defspec1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\})@~ - @Sindex@Parmquote(Fun)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def <@Label{@Parm(Funlabel)-spec}>, - undef <@Label{@Parm(Fun)-spec}>)')@~ - @End(Undefbody)") -@Commandstring(Enddefspec = "@End(Defbody)@End(Defenvironment)") - -@Textform(Xindent = "@hsp(2.0em)") -@Textform(Xsepr = "@hsp(0.5em)") -@Textform(Def = "@Index@Parmquote(Text)@i@Parmquote(Text)") -@Textform(Index = "@Indexentry{Key {@Parm(Text) !1}, - Entry {@r[@Parm(Text)]@Xsepr()}, Number {@r[@Parmvalue(Page)]}}@'") -@Form(PossiblyIndexedRef = "@Indexentry{Key {@Parm(K) !1}, - Entry {@r[@Parm(F)]@Xsepr()}, Number {@r[@Parmvalue(Page)]}}@Parm(E)") -@Textform(Index1 = "@Indexentry{Key {@Parm(Text) !1}, - Entry {@r[@Parm(Text)]@Xsepr()}}@'") -@Form(Index2 = "@Index1@Parmquote(P)@Indexentry{Key {@Parm(P) !2 @Parm(S)}, - Entry {@Xindent()@r[@Parm(S)]@Xsepr()}, Number {@Parmvalue(Page)}}@'") -@Form(Seealso = "@Index1@Parmquote(P)@Indexentry{Key {@Parm(P) !3 @Parm(S)}, - Entry {@Xindent()@Xindent()@r[See also:]}, Number @Parmquote(S)}@'") -@Form(Xindex = "@Indexentry{Key {@Parm(X) @Parm(T) 1}, - Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()}, - Number {@b[@Parmvalue(Page)]}}@'") -@Form(Xindexref = "@Indexentry{Key {@Parm(X) @Parm(T) 1}, - Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()}, - Number {@Parmvalue(Page)}}@'") -@Form(Xindex1 = "@Indexentry{Key {@Parm(X) @Parm(T) 1}, - Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()}}@'") -@Form(Xindex2 = "@Xindex1(X @Parmquote(X), T @Parmquote(T), - P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~ - @Indexentry{Key {@Parm(X) @Parm(T) 2 @Parm(S)}, - Entry {@Xindent()@Parm(S)@Xsepr()}, - Number {@b[@Parmvalue(Page)]}}@'") -@Form(Xindexref2 = "@Xindex1(X @Parmquote(X), T @Parmquote(T), - P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~ - @Indexentry{Key {@Parm(X) @Parm(T) 2 @Parm(S)}, - Entry {@Xindent()@Parm(S)@Xsepr()}, - Number {@Parmvalue(Page)}}@'") -@Form(Xseealso = "@Xindex1(X @Parmquote(X), T @Parmquote(T), - P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~ - @Indexentry{Key {@Parm(X) @Parm(T) 3 @Parm(S)}, - Entry {@Xindent()@Xindent()@r[See also:]}, - Number @Parmquote(S)}}@'") - -@Textform(Cindex = "@Index@Parmquote(Text)@'") - -@Textform(Findex = "@Case(IndexFuns, Yes '@Xindex(T {function}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Textform(Findexref = "@Case(IndexFuns, Yes '@Xindexref(T {function}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Form(Findex2 = "@Case(IndexFuns, Yes '@Xindex2(T {function}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") -@Form(Fseealso = "@Case(IndexFuns, Yes '@Xseealso(T {function}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") - -@Textform(Mindex = "@Case(IndexFuns, Yes '@Xindex(T {macro}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Textform(Mindexref = "@Case(IndexFuns, Yes '@Xindexref(T {macro}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Form(Mindex2 = "@Case(IndexFuns, Yes '@Xindex2(T {macro}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") -@Form(Mseealso = "@Case(IndexFuns, Yes '@Xseealso(T {macro}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") - -@Textform(Sindex = "@Case(IndexFuns, Yes '@Xindex(T {special form}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Textform(Sindexref = "@Case(IndexFuns, Yes '@Xindexref(T {special form}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Form(Sindex2 = "@Case(IndexFuns, Yes '@Xindex2(T {special form}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") -@Form(Sseealso = "@Case(IndexFuns, Yes '@Xseealso(T {special form}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") - -@Textform(Vindex = "@Xindex(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[*]}, R{@f[*]})@'") -@Textform(Vxindex = "@Xindex(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Textform(Vindexref = "@Xindexref(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[*]}, R{@f[*]})@'") -@Form(Vindex2 = "@Xindex2(T {variable}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[*]}, R{@f[*]})@'") -@Form(Vseealso = "@Xseealso(T {variable}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[*]}, R{@f[*]})@'") - -@Textform(Conindex = "@Xindex(T {constant}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Textform(Conindexref = "@Xindexref(T {constant}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Form(Conindex2 = "@Xindex2(T {constant}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") -@Form(Conseealso = "@Xseealso(T {constant}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") - -@Textform(Kindex = "@Xindex(T {keyword}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[:]})@'") -@Textform(Kindexref = "@Xindexref(T {keyword}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[:]})@'") -@Form(Kindex2 = "@Xindex2(T {keyword}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[:]})@'") -@Form(Kindexref2 = "@Xindexref2(T {keyword}, X {@Parm(K)}, P {@f[@Parm(K)]}, S @Parmquote(S), Q {@f[:]})@'") -@Form(Kseealso = "@Xseealso(T {keyword}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[:]})@'") - -@Textform(Declindex = "@Xindex(T {declaration}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Textform(Declindexref = "@Xindexref(T {declaration}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Form(Declindex2 = "@Xindex2(T {declaration}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") -@Form(Declseealso = "@Xseealso(T {declaration}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") - -@Textform(Typeindex = "@Xindex(T {type specifier}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Textform(Typeindexref = "@Xindexref(T {type specifier}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Form(Typeindex2 = "@Xindex2(T {type specifier}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") -@Form(Typeseealso = "@Xseealso(T {type specifier}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") - -@Textform(Funref = "@f[@Parm(Text) ]@~ - @r[(page @Pageref(@Parm(Text)-fun))]@Findexref@Parmquote(Text)@;") -@Textform(Funreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-fun))]@Findexref@Parmquote(Text)@;") -@Form(Xfunref = "@f[@Parm(X) ]@~ - @r[(page @Pageref(@Parm(L)-fun))]@Findexref@Parmquote(X)@;") -@Textform(Macref = "@f[@Parm(Text) ]@~ - @r[(page @Pageref(@Parm(Text)-mac))]@Mindexref@Parmquote(Text)@;") -@Textform(Macreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-mac))]@Mindexref@Parmquote(Text)@;") -@Form(Xmacref = "@f[@Parm(X) ]@~ - @r[(page @Pageref(@Parm(L)-mac))]@Mindexref@Parmquote(X)@;") -@Textform(Specref = "@f[@Parm(Text) ]@~ - @r[(page @Pageref(@Parm(Text)-spec))]@Sindexref@Parmquote(Text)@;") -@Textform(Specreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-spec))]@Sindexref@Parmquote(Text)@;") -@Form(XSpecref = "@f[@Parm(X) ]@~ - @r[(page @Pageref(@Parm(L)-spec))]@Sindexref@Parmquote(X)@;") -@Textform(Var = "@f[*@Parm(Text)*]") -@Textform(Varref = "@f[*@Parm(Text)* ]@~ - @r[(page @Pageref(@Parm(Text)-var))]@Vindexref@Parmquote(Text)@;") -@Form(Xvarref = "@f[*@Parm(X)* ]@~ - @r[(page @Pageref(@Parm(L)-var))]@Vindexref@Parmquote(X)@;") -@Textform(Conref = "@f[@Parm(Text) ]@~ - @r[(page @Pageref(@Parm(Text)-con))]@Conindexref@Parmquote(Text)@;") -@Form(Xconref = "@f[@Parm(X) ]@~ - @r[(page @Pageref(@Parm(L)-con))]@Conindexref@Parmquote(X)@;") -@Form(Kwdref = "@f[:@Parm(K) ]@~ - @r[(page @Pageref(@Parm(F)-@Parm(K)-kwd))]@Kindexref2(S {for@f[ @Parm(F)]}, - K @Parmquote(K))@;") -@Form(SubKwdref = "@f[:@Parm(K)] @~ - @r[(page @Pageref(@Parm(F)-@Parm(O)-@Parm(K)-kwd))]@~ - @Kindexref2(S {for@f[ :@Parm(O) ]option to@f[ @Parm(F)]}, - K @Parmquote(K))") - -@Indexentry(Key { 1}, Entry {@IndexHeadings[Index]@Blankspace(1)@Begin(IndexEnvironment)}) -@Indexentry(Key {~~~ }, Entry {@End(IndexEnvironment)}) - -@Textform(IndexCleanup = " ") diff --git a/docs/database/spice.lib b/docs/database/spice.lib deleted file mode 100644 index a6520620e2c2b17d1fe1359e1183eac8639f30b7..0000000000000000000000000000000000000000 --- a/docs/database/spice.lib +++ /dev/null @@ -1,67 +0,0 @@ -@Marker(Library, Spice, Press, Dover, Postscript) - -@libraryfile(table) -@modify(HD3, above 0.3inch, below 0.15inch) -@modify(HD2, below 0.25inch) -@modify[HD4, above .3inch, below 0, break before] -@modify(paragraph, - ContentsForm=" ", - TitleForm="@HD4[@parm(title)@hsp(1quad)]", - numbered [], referenced []) -@textform(mline="@enter(liner,script +5pts)@tabclear()@&@ @\@leave(liner)") - -@define(twocolumn,columns 2,columnmargin 1cm,spacing 12pts,boxed, - linewidth 3inch) - -@form(SpiceTitlePage={ -@begin(titlepage) -@begin(titlebox,centered) -@majorheading(CARNEGIE-MELLON UNIVERSITY) -@heading(DEPARTMENT@ OF@ COMPUTER@ SCIENCE) -@heading[SPICE@ PROJECT] -@begin(format, leftmargin +1.10inch, rightmargin +1.10inch) -@mline() -@begin(center, spacing 1) -@heading[@Parm(Title)] - -@Parm(Author) - -@Parm(Date,default="@value(date)") -@end(center) -@mline() -@end(format) -@end(titlebox) - -@Parm(cruft, default="") - -@begin(center,spacing 1.3, above .5inch) -Keywords and index categories: @Parm(Index,default="<not specified>") -Location of machine-readable File: @parm(File,default="@value(Manuscript) @@ @value(site)") -@end(center) - -@Copyrightnotice(@Parm(Copyrightholder, default <Carnegie-Mellon University>)) -@begin(researchcredit) -@imbed( internal, -def "This is an internal working document of the Computer Science - Department, Carnegie-Mellon University, Schenley Park, Pittsburgh, - PA 15213. Some of the ideas expressed in this document may be - only partially developed or erroneous. Distribution of this document - outside the immediate working community is discouraged; publication - of this document is forbidden.") - -Supported by the Defense Advanced Research Projects Agency, Department -of Defense, ARPA Order 3597, monitored by the Air Force Avionics -Laboratory under contract F33615-78-C-1551. The views -and conclusions contained in this document are those of the authors -and should not be interpreted as representing the official policies, -either expressed or implied, of the Defense Advanced Research -Projects Agency or the U.S. Government. -@end(researchcredit) -@end(titlepage) - -@newpage - -@comment[ Leave larger blank area at top of first page ] -@format[ @blankspace( 1inch ) ] -}) @comment[ End of SpiceTitlePage form ] -@Marker(Library,Spice) diff --git a/docs/database/spicer.fon b/docs/database/spicer.fon deleted file mode 100644 index 5244c3d385c5055d57c5a2cf953e15144938166c..0000000000000000000000000000000000000000 --- a/docs/database/spicer.fon +++ /dev/null @@ -1,230 +0,0 @@ -@Marker(Font,SpiceRoman10,Press) -@DefineFont(BodyFont, - R=<Xerox "TimesRoman10R">, - I=<Xerox "TimesRoman10I">, - B=<Xerox "TimesRoman10B">, - P=<Ascii "TimesRoman10BI">, - F=<Ascii "SailA10R">, - C=<Xerox "TimesRoman8R">, - Z=<Xerox "Zfont10R">, - G=<Xgreek "Hippo10R">, - Y=<Xerox "TimesRoman8R">, - X=<Xerox "CMSY10S10R">, - U=<Ascii "Sail10">, - A=<Ascii "APL10">, - T=<Ascii "SailA10R">, - K=<Ascii "Operators10R">, - L=<Ascii "Operators20R">, - M=<Ascii "Relation9R">, - N=<Ascii "AllArrows10R">) - -@comment(Shrunk: 14-12,10-9,9-8,8-7,6-5 except K and G) -@DefineFont(SmallBodyFont, - R=<Xerox "TimesRoman8R">, - B=<Xerox "TimesRoman8B">, - I=<Xerox "TimesRoman8I">, - P=<Xerox "TimesRoman8BI">, - G=<Xgreek "Hippo8R">, - F=<Ascii "SailA8R">, - Z=<Xerox "Zfont10R">, - Y=<Xerox "TimesRoman8R">, - X=<Xerox "CMSY8R">, - U=<Ascii "Sail8">, - A=<Ascii "APL8">, - C=<Xerox "TimesRoman6R">, - T=<Ascii "SailA8R">, - K=<Ascii "Operators8R">, - L=<Ascii "Operators12R">, - M=<Ascii "Relation8R">, - N=<Ascii "AllArrows8R">) @Comment{GLS 5/17/81: AllArrows7R nonexistent} - -@DefineFont(LargeBodyFont, - R=<Ascii "TimesRoman12">, - I=<Ascii "TimesRoman12I">, - B=<Ascii "TimesRoman12B">, - C=<Ascii "TimesRoman10">) -@DefineFont(SquareRootFont, - R=<Ascii "SquareRoot10">) - -@DefineFont(TitleFont1, - R=<Xerox "TimesRoman10B">, - I=<Xerox "TimesRoman10BI">, - F=<Ascii "SailA10R">, - C=<Xerox "TimesRoman8B">) -@DefineFont(TitleFont2, - R=<Xerox "TimesRoman12B">, - I=<Xerox "TimesRoman12BI">, - F=<Ascii "SailA12R">, - C=<Xerox "TimesRoman9B">) -@DefineFont(TitleFont3, - R=<Xerox "TimesRoman12B">, - I=<Xerox "TimesRoman12BI">, - F=<Ascii "SailA12R">, - C=<Xerox "TimesRoman9B">) -@DefineFont(TitleFont4, - R=<Xerox "TimesRoman12B">, - I=<Xerox "TimesRoman12BI">, - F=<Ascii "SailA12R">, - C=<Xerox "TimesRoman9B">) -@DefineFont(TitleFont5, - R=<Xerox "TimesRoman18B">, - I=<Xerox "TimesRoman18BI">, - C=<Xerox "TimesRoman12B">) - -@Equate(DisplayFont=BodyFont,TitleFont0=BodyFont,HeadingFont=TitleFont3) -@Marker(Font,SpiceRoman11,Press) -@DefineFont(BodyFont, - R=<Xerox "TimesRoman11R">, - I=<Xerox "TimesRoman11I">, - B=<Xerox "TimesRoman11B">, - P=<Ascii "TimesRoman11BI">, - F=<Ascii "SailA11R">, - C=<Xerox "TimesRoman9R">, - Z=<Xerox "Zfont11R">, - G=<Xgreek "Hippo11R">, - Y=<Xerox "TimesRoman9R">, - X=<Xerox "CMSY10S10R">, - U=<Ascii "Sail10">, - A=<Ascii "APL10">, - T=<Ascii "SailA11R">) - -@DefineFont(SmallBodyFont, - R=<Xerox "TimesRoman9R">, - B=<Xerox "TimesRoman9B">, - I=<Xerox "TimesRoman9I">, - P=<Xerox "TimesRoman9BI">, - G=<Xgreek "Hippo9R">, - F=<Ascii "SailA9R">, - Z=<Xerox "Zfont11R">, - Y=<Xerox "TimesRoman9R">, - X=<Xerox "CMSY8R">, - C=<Xerox "TimesRoman6R">, - U=<Ascii "Sail9">, - A=<Ascii "APL8">, - T=<Ascii "SailA9R">) - -@DefineFont(TitleFont1, - R=<Xerox "TimesRoman11B">, - I=<Xerox "TimesRoman11BI">, - C=<Xerox "TimesRoman9B">) -@DefineFont(TitleFont2, - R=<Xerox "TimesRoman12B">, - I=<Xerox "TimesRoman12BI">, - C=<Xerox "TimesRoman9B">) -@DefineFont(TitleFont3, - R=<Xerox "TimesRoman12B">, - I=<Xerox "TimesRoman12BI">, - C=<Xerox "TimesRoman9B">) -@DefineFont(TitleFont4, - R=<Xerox "TimesRoman12B">, - I=<Xerox "TimesRoman12BI">, - C=<Xerox "TimesRoman9B">) -@DefineFont(TitleFont5, - R=<Xerox "TimesRoman18B">, - I=<Xerox "TimesRoman18BI">, - C=<Xerox "TimesRoman12B">) - -@Equate(DisplayFont=BodyFont,TitleFont0=BodyFont,HeadingFont=TitleFont3) -@Marker(Font,SpiceRoman12,Press) -@DefineFont(BodyFont, - R=<Xerox "TimesRoman12R">, - I=<Xerox "TimesRoman12I">, - B=<Xerox "TimesRoman12B">, - P=<Ascii "TimesRoman12BI">, - F=<Ascii "SailA10R">, - C=<Xerox "TimesRoman10R">, - Z=<Xerox "Zfont12R">, - G=<Xgreek "Hippo12R">, - Y=<Xerox "TimesRoman10R">, - X=<Xerox "CMSY10S10R">, - U=<Ascii "Sail12">, - T=<Ascii "SailA10R">) - -@DefineFont(SmallBodyFont, - R=<Xerox "TimesRoman10R">, - B=<Xerox "TimesRoman10B">, - I=<Xerox "TimesRoman10I">, - P=<Xerox "TimesRoman10BI">, - G=<Xgreek "Hippo10R">, - F=<Ascii "SailA9R">, - Z=<Xerox "Zfont12R">, - Y=<Xerox "TimesRoman10R">, - X=<Xerox "CMSY8R">, - C=<Xerox "TimesRoman6R">, - U=<Ascii "Sail10">, - A=<Ascii "APL10">, - T=<Ascii "SailA9R">) - -@DefineFont(TitleFont1, - R=<Xerox "TimesRoman12B">, - I=<Xerox "TimesRoman12BI">, - C=<Xerox "TimesRoman10B">) -@DefineFont(TitleFont2, - R=<Xerox "TimesRoman14B">, - I=<Xerox "TimesRoman14BI">, - C=<Xerox "TimesRoman9B">) -@DefineFont(TitleFont3, - R=<Xerox "TimesRoman16B">, - I=<Xerox "TimesRoman16BI">, - C=<Xerox "TimesRoman12B">) -@DefineFont(TitleFont4, - R=<Xerox "TimesRoman16B">, - I=<Xerox "TimesRoman16BI">, - C=<Xerox "TimesRoman12B">) -@DefineFont(TitleFont5, - R=<Xerox "TimesRoman18B">, - I=<Xerox "TimesRoman18BI">, - C=<Xerox "TimesRoman14B">) - -@Equate(DisplayFont=BodyFont,TitleFont0=BodyFont,HeadingFont=TitleFont3) -@Marker(Font,SpiceRoman14,Press) -@DefineFont(BodyFont, - R=<Xerox "TimesRoman14R">, - I=<Xerox "TimesRoman14I">, - B=<Xerox "TimesRoman14B">, - P=<Ascii "TimesRoman14BI">, - F=<Ascii "SailA14R">, - C=<Xerox "TimesRoman10R">, - Z=<Xerox "Zfont14R">, - G=<Xgreek "Hippo14R">, - Y=<Xerox "TimesRoman10R">, - X=<Xerox "CMSY10S10R">, - U=<Ascii "Sail14">, - T=<Ascii "SailA14R">) - -@DefineFont(SmallBodyFont, - R=<Xerox "TimesRoman10R">, - B=<Xerox "TimesRoman10B">, - I=<Xerox "TimesRoman10I">, - P=<Xerox "TimesRoman10BI">, - G=<Xgreek "Hippo10R">, - F=<Ascii "SailA10R">, - Z=<Xerox "Zfont10R">, - Y=<Xerox "TimesRoman10R">, - X=<Xerox "CMSY10S10R">, - C=<Xerox "TimesRoman8R">, - U=<Ascii "Sail12">, - T=<Ascii "SailA10R">) - -@DefineFont(TitleFont1, - R=<Xerox "TimesRoman14B">, - I=<Xerox "TimesRoman14BI">, - C=<Xerox "TimesRoman10B">) -@DefineFont(TitleFont2, - R=<Xerox "TimesRoman16B">, - I=<Xerox "TimesRoman16BI">, - C=<Xerox "TimesRoman12B">) -@DefineFont(TitleFont3, - R=<Xerox "TimesRoman16B">, - I=<Xerox "TimesRoman16BI">, - C=<Xerox "TimesRoman12B">) -@DefineFont(TitleFont4, - R=<Xerox "TimesRoman18B">, - I=<Xerox "TimesRoman18BI">, - C=<Xerox "TimesRoman14B">) -@DefineFont(TitleFont5, - R=<Xerox "TimesRoman18B">, - I=<Xerox "TimesRoman18BI">, - C=<Xerox "TimesRoman14B">) - -@Equate(DisplayFont=BodyFont,TitleFont0=BodyFont,HeadingFont=TitleFont3) diff --git a/docs/database/table.lib b/docs/database/table.lib deleted file mode 100644 index 0d572fe8305de202a7683bdeaef38f62b1d567e1..0000000000000000000000000000000000000000 --- a/docs/database/table.lib +++ /dev/null @@ -1,27 +0,0 @@ -@Marker(Library,Table,Dover,Postscript) - -@Comment{New library definitions for tables.} - -@Style(StringMax=10000) -@Modify(Table, Spacing 1) - -@Define(Liner, underline all, tabexport off, script -1pt, - rightmargin +1pts, leftmargin +2pts) -@Define(up6, script +6pts) - -@textform(VB={@string(NID = "@parm(text)")@case(NID, - 1 "@hsp(1pt)@ovp[|]@up6[|]", - 2 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\", - 3 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\", - 4 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\", - 5 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\", - 6 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\", - 7 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\", - else "@hsp(1pt)@ovp[|]@up6[|]")}) - -@Form(TLine="@enter(Liner, script @parm<height, default=[+3pts]>)@~ - @tabclear()@&@ @\@leave(Liner)") -@TextForm(BLine="@ovp<@Liner(@tabclear()@&@ @\)>@VB(@parm(text))") -@TextForm(TL="@hsp(1)@parm(text)@>@ovp[|]@up6[|]@\") -@TextForm(TC="@=@parm(text)@>@ovp[|]@up6[|]@\") -@TextForm(TR="@>@parm(text)@hsp(1)@ovp[|]@up6[|]@\") diff --git a/docs/database/uttir.lib b/docs/database/uttir.lib deleted file mode 100644 index 63bdfdca67ef1eb5f48026028813ec89f5890ac4..0000000000000000000000000000000000000000 --- a/docs/database/uttir.lib +++ /dev/null @@ -1,329 +0,0 @@ -@Comment{Version of BOLIO.LIB that provides a single unified index -instead of separate indexes for functions, variables, constants, -keywords, and concepts.} - -@Marker(Library, Uttir, Press, Dover, Postscript) - -@Libraryfile(DBolio) - - -@Comment{Constraints on the definition of IndexEnvironment: - Indent = - LeftMargin - (Linewidth + Leftmargin + Columnmargin) * Columns - Columnmargin - = global line width -} -@Define(IndexEnvironment, Boxed, Columns 2, Columnmargin 0.5in, - Linewidth 2.7in, Leftmargin +0.3in, Indent -0.3in) - -@Define(KeySpreadEnvironment, Facecode F) -@Textform(SpreadKeys = "@KeySpreadEnvironment<@SpreadKeysLoop@Parm(Text)[]>") -@Textform(SpreadKeysLoop = - "@String(SpreadKeysTemp = @Parmquote(Text))@Case(SpreadKeysTemp, - null <>, else < :@Parm(Text)@SpreadKeysLoop>)") - -@Form(IndexKeys = "@Textform(IndexKeysLoop = - '@String(IndexKeysTemp = @Quote{@Parmquote(Text)})@Case(IndexKeysTemp, - null <>, else [@Kindex2(P = @Quote{@Parmquote(Text)}, - S = {for@f( @Parm(Fun))})@IndexKeysLoop])')@IndexKeysLoop@Parm(Keys)[]@~") - -@Counter(UnNumberedIndex,TitleEnv HD1A,ContentsEnv tc1,Announced,Alias Chapter) - -@Textform(IndexHeadings = "@UnnumberedIndex@Parmquote(Text) -@String(ChapterTitle = @Parmquote(Text)) -@Pageheading(Immediate, Left = <>, Right = <>) -@Pagefooting(Immediate, Center = <@Value(Page)>) -@Pageheading(Odd, Left = <@c[@Value(ChapterTitle)]>, Right = <@Value(Page)>) -@Pageheading(Even, Left = <@Value(Page)>, Right = <@c[@Value(ReportTitle)]>) -@Pagefooting(Center = <>) -") - -@Textform(Incompatibility = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4) - @b[Compatibility note:] @Index(@b[Compatibility note]) - @Parm(Text) @End(Quotation)") -@Textform(Implementation = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4) - @b[Implementation note:] @Index(@b[Implementation note]) - @Parm(Text) @End(Quotation)") -@Textform(Rationale = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4) - @b[Rationale:] @Index(@b[Rationale]) @Parm(Text) @End(Quotation)") -@Comment{ -@Textform(Query = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4) - @f[???] @b[Query:] @Index(@b[Query]) @Parm(Text) @End(Quotation)") -} - -@Textform(Kwd = "@f[:@Parm(Text)]") -@Textform(KeywordList = " - @Begin(Description) - @Textform(Keyword = '@Begin(Multiple)@~ -@f[:@Quote<@Parm(Text)> ]@\@Kindex2(P = @Quote<@Parmquote(Text)>, - S = {for@f[ @Parm(Text)]})@~ - @Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~') - @Textform(FirstKeyword = '@Begin(Multiple)@~ -@f[:@Quote<@Parm(Text)> @r[or] ]@Kindex2(P = @Quote<@Parmquote(Text)>, - S = {for@f[ @Parm(Text)]})@~ - @Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~') - @Textform(NextKeyword = '@~ -@f[:@Quote<@Parm(Text)> @r[or] ]@Kindex2(P = @Quote<@Parmquote(Text)>, - S = {for@f[ @Parm(Text)]})@~ - @Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~') - @Textform(LastKeyword = '@~ -@f[:@Quote<@Parm(Text)> ]@\@Kindex2(P = @Quote<@Parmquote(Text)>, - S = {for@f[ @Parm(Text)]})@~ - @Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~') - @Textform(SubKeywordList = ' - @Begin(Description) - @Textform(SubKeyword = <@Begin(Multiple)@~ -@f[:@Quote{@Quote[@Parm(Text)]} ]@\@Kindex2(P = @Quote{@Quote[@Parmquote(Text)]}, - S = {for@f[ @Quote[@Parm(Text)] ]option @~ - to@f[ @Parm(Text)]})@~ - @Label{@Parm(Text)-@Quote[@Parm(Text)]-@Quote{@Quote[@Parm(Text)]}-kwd}@~>)') -") -@Textform(PseudoKeyword = "@Begin(Multiple)@Parm(Text) @\@~") -@Commandstring(Endkeyword = "@End(Multiple)") -@Commandstring(Endkeywordlist = "@End(Description)") -@Textform(PseudoSubKeyword = "@Begin(Multiple)@Parm(Text) @\@~") -@Commandstring(EndSubKeyword = "@End(Multiple)") -@Commandstring(EndSubKeywordlist = "@End(Description)") -@Textform(RandomKeywordList = " - @Begin(Description) - @Index2(P = {Keywords}, S = {for@f[ ]@Parm(Text)}) - @Textform(RandomKeyword = '@Begin(Multiple) -@f[:@Quote<@Parm(Text)> ]@\@Kindex2(P = @Quote<@Parmquote(Text)>, - S = {for@f[ ]@Parm(Text)})@~') -") -@Textform(PseudoRandomKeyword = "@Begin(Multiple)@Parm(Text) @\@~") -@Commandstring(Endrandomkeyword = "@End(Multiple)") -@Commandstring(Endrandomkeywordlist = "@End(Description)") - -@Form(Defvar = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @f[@Imbed(Package, def '@Parm(Package):')@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\@~ - @Send(FunList {@f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\})@~ - @Imbed(Nostar, undef<@Vindex@Parmquote(Var)>, def<@Vxindex@Parmquote(Var)>)@~ - @Imbed(Nolabel, undef '@Imbed(Varlabel, - def <@Label{@Parm(Varlabel)-var}>, - undef <@Label{@Parm(Var)-var}>)')@~ - @Begin(Defbody)@Tabclear ") -@Form(Defvar1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @f[@Imbed(Package, def '@Parm(Package):')@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\@~ - @Send(FunList {@f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\})@~ - @Imbed(Nostar, undef<@Vindex@Parmquote(Var)>, def<@Vxindex@Parmquote(Var)>)@~ - @Imbed(Nolabel, undef '@Imbed(Varlabel, - def <@Label{@Parm(Varlabel)-var}>, - undef <@Label{@Parm(Var)-var}>)')@~ - @End(Undefbody)") -@Commandstring(Enddefvar = "@End(Defbody)@End(Defenvironment)") - -@Form(Defcon = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @f[@Imbed(Package, def '@Parm(Package):')@Parm(Var)] @>[@i[Constant]]@\@~ - @Send(FunList {@f[@Parm(Var)] @>[@i[Constant]]@\})@~ - @Conindex@Parmquote(Var)@~ - @Imbed(Nolabel, undef '@Imbed(Varlabel, - def <@Label{@Parm(Varlabel)-con}>, - undef <@Label{@Parm(Var)-con}>)')@~ - @Begin(Defbody)@Tabclear ") -@Form(Defcon1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @f[@Imbed(Package, def '@Parm(Package):')@Parm(Var)] @>[@i[Constant]]@\@~ - @Send(FunList {@f[@Parm(Var)] @>[@i[Constant]]@\})@~ - @Conindex@Parmquote(Var)@~ - @Imbed(Nolabel, undef '@Imbed(Varlabel, - def <@Label{@Parm(Varlabel)-con}>, - undef <@Label{@Parm(Var)-con}>)')@~ - @End(Undefbody)") -@Commandstring(Enddefcon = "@End(Defbody)@End(Defenvironment)") - -@Form(Defun = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\ -@Imbed(MoreKeys, def <@/@Spreadkeys(@Parm(MoreKeys)) ->)@~ -@Imbed(YetMoreKeys, def <@/@Spreadkeys(@Parm(YetMoreKeys)) ->)@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, - def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\@Imbed(MoreKeys, - def < -@/@f[@Spreadkeys(@Parm(MoreKeys))]>)@Imbed(YetMoreKeys, - def < -@/@f[@Spreadkeys(@Parm(YetMoreKeys))]>)})@~ - @Findex@Parmquote(Fun)@~ - @Imbed(SuppressKeyIndex, undef < - @Imbed(Keys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(Keys))')@~ - @Imbed(MoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(MoreKeys))')@~ - @Imbed(YetMoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(YetMoreKeys))')>)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def <@Label{@Parm(Funlabel)-fun}>, - undef <@Label{@Parm(Fun)-fun}>)')@~ - @Begin(Defbody)@Tabclear ") -@Form(Defun1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\ -@Imbed(MoreKeys, def <@/@Spreadkeys(@Parm(MoreKeys)) ->)@~ -@Imbed(YetMoreKeys, def <@/@Spreadkeys(@Parm(YetMoreKeys)) ->)@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, - def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\@Imbed(MoreKeys, - def < -@/@f[@Spreadkeys(@Parm(MoreKeys))]>)@Imbed(YetMoreKeys, - def < -@/@f[@Spreadkeys(@Parm(YetMoreKeys))]>)})@~ - @Findex@Parmquote(Fun)@~ - @Imbed(SuppressKeyIndex, undef < - @Imbed(Keys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(Keys))')@~ - @Imbed(MoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(MoreKeys))')@~ - @Imbed(YetMoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(YetMoreKeys))')>)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def [@Label{@Parm(Funlabel)-fun}], - undef [@Label{@Parm(Fun)-fun}])')@~ - @End(Undefbody)") -@Commandstring(Enddefun = "@End(Defbody)@End(Defenvironment)") - -@Form(Defmac = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\})@~ - @Mindex@Parmquote(Fun)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def <@Label{@Parm(Funlabel)-mac}>, - undef <@Label{@Parm(Fun)-mac}>)')@~ - @Begin(Defbody)@Tabclear ") -@Form(Defmac1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\})@~ - @Mindex@Parmquote(Fun)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def <@Label{@Parm(Funlabel)-mac}>, - undef <@Label{@Parm(Fun)-mac}>)')@~ - @End(Undefbody)") -@Commandstring(Enddefmac = "@End(Defbody)@End(Defenvironment)") - -@Form(Defspec = "@Begin(Defenvironment)@Comment(Tabset?)@~ - @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\})@~ - @Sindex@Parmquote(Fun)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def <@Label{@Parm(Funlabel)-spec}>, - undef <@Label{@Parm(Fun)-spec}>)')@~ - @Begin(Defbody)@Tabclear ") -@Form(Defspec1 = "@Begin(Undefbody)@Comment(Tabset?)@~ - @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\@~ - @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\})@~ - @Sindex@Parmquote(Fun)@~ - @Imbed(Nolabel, undef '@Imbed(Funlabel, - def <@Label{@Parm(Funlabel)-spec}>, - undef <@Label{@Parm(Fun)-spec}>)')@~ - @End(Undefbody)") -@Commandstring(Enddefspec = "@End(Defbody)@End(Defenvironment)") - -@Textform(Xindent = "@hsp(2.0em)") -@Textform(Xsepr = "@hsp(0.5em)") -@Textform(Def = "@Index@Parmquote(Text)@i@Parmquote(Text)") -@Textform(Index = "@Indexentry{Key {@Parm(Text) !1}, - Entry {@r[@Parm(Text)]@Xsepr()}, Number {@r[@Parmvalue(Page)]}}@'") -@Form(PossiblyIndexedRef = "@Indexentry{Key {@Parm(K) !1}, - Entry {@r[@Parm(F)]@Xsepr()}, Number {@r[@Parmvalue(Page)]}}@Parm(E)") -@Textform(Index1 = "@Indexentry{Key {@Parm(Text) !1}, - Entry {@r[@Parm(Text)]@Xsepr()}}@'") -@Form(Index2 = "@Index1@Parmquote(P)@Indexentry{Key {@Parm(P) !2 @Parm(S)}, - Entry {@Xindent()@r[@Parm(S)]@Xsepr()}, Number {@Parmvalue(Page)}}@'") -@Form(Seealso = "@Index1@Parmquote(P)@Indexentry{Key {@Parm(P) !3 @Parm(S)}, - Entry {@Xindent()@Xindent()@r[See also:]}, Number @Parmquote(S)}@'") -@Form(Xindex = "@Indexentry{Key {@Parm(X) @Parm(T) 1}, - Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()}, - Number {@b[@Parmvalue(Page)]}}@'") -@Form(Xindexref = "@Indexentry{Key {@Parm(X) @Parm(T) 1}, - Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()}, - Number {@Parmvalue(Page)}}@'") -@Form(Xindex1 = "@Indexentry{Key {@Parm(X) @Parm(T) 1}, - Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()}}@'") -@Form(Xindex2 = "@Xindex1(X @Parmquote(X), T @Parmquote(T), - P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~ - @Indexentry{Key {@Parm(X) @Parm(T) 2 @Parm(S)}, - Entry {@Xindent()@Parm(S)@Xsepr()}, - Number {@b[@Parmvalue(Page)]}}@'") -@Form(Xindexref2 = "@Xindex1(X @Parmquote(X), T @Parmquote(T), - P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~ - @Indexentry{Key {@Parm(X) @Parm(T) 2 @Parm(S)}, - Entry {@Xindent()@Parm(S)@Xsepr()}, - Number {@Parmvalue(Page)}}@'") -@Form(Xseealso = "@Xindex1(X @Parmquote(X), T @Parmquote(T), - P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~ - @Indexentry{Key {@Parm(X) @Parm(T) 3 @Parm(S)}, - Entry {@Xindent()@Xindent()@r[See also:]}, - Number @Parmquote(S)}}@'") - -@Textform(Cindex = "@Index@Parmquote(Text)@'") - -@Textform(Findex = "@Case(IndexFuns, Yes '@Xindex(T {function}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Textform(Findexref = "@Case(IndexFuns, Yes '@Xindexref(T {function}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Form(Findex2 = "@Case(IndexFuns, Yes '@Xindex2(T {function}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") -@Form(Fseealso = "@Case(IndexFuns, Yes '@Xseealso(T {function}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") - -@Textform(Mindex = "@Case(IndexFuns, Yes '@Xindex(T {macro}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Textform(Mindexref = "@Case(IndexFuns, Yes '@Xindexref(T {macro}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Form(Mindex2 = "@Case(IndexFuns, Yes '@Xindex2(T {macro}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") -@Form(Mseealso = "@Case(IndexFuns, Yes '@Xseealso(T {macro}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") - -@Textform(Sindex = "@Case(IndexFuns, Yes '@Xindex(T {special form}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Textform(Sindexref = "@Case(IndexFuns, Yes '@Xindexref(T {special form}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'") -@Form(Sindex2 = "@Case(IndexFuns, Yes '@Xindex2(T {special form}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") -@Form(Sseealso = "@Case(IndexFuns, Yes '@Xseealso(T {special form}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'") - -@Textform(Vindex = "@Xindex(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[*]}, R{@f[*]})@'") -@Textform(Vxindex = "@Xindex(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Textform(Vindexref = "@Xindexref(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[*]}, R{@f[*]})@'") -@Form(Vindex2 = "@Xindex2(T {variable}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[*]}, R{@f[*]})@'") -@Form(Vseealso = "@Xseealso(T {variable}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[*]}, R{@f[*]})@'") - -@Textform(Conindex = "@Xindex(T {constant}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Textform(Conindexref = "@Xindexref(T {constant}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Form(Conindex2 = "@Xindex2(T {constant}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") -@Form(Conseealso = "@Xseealso(T {constant}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") - -@Textform(Kindex = "@Xindex(T {keyword}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[:]})@'") -@Textform(Kindexref = "@Xindexref(T {keyword}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[:]})@'") -@Form(Kindex2 = "@Xindex2(T {keyword}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[:]})@'") -@Form(Kindexref2 = "@Xindexref2(T {keyword}, X {@Parm(K)}, P {@f[@Parm(K)]}, S @Parmquote(S), Q {@f[:]})@'") -@Form(Kseealso = "@Xseealso(T {keyword}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[:]})@'") - -@Textform(Declindex = "@Xindex(T {declaration}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Textform(Declindexref = "@Xindexref(T {declaration}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Form(Declindex2 = "@Xindex2(T {declaration}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") -@Form(Declseealso = "@Xseealso(T {declaration}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") - -@Textform(Typeindex = "@Xindex(T {type specifier}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Textform(Typeindexref = "@Xindexref(T {type specifier}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'") -@Form(Typeindex2 = "@Xindex2(T {type specifier}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") -@Form(Typeseealso = "@Xseealso(T {type specifier}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'") - -@Textform(Funref = "@f[@Parm(Text) ]@~ - @r[(page @Pageref(@Parm(Text)-fun))]@Findexref@Parmquote(Text)@;") -@Textform(Funreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-fun))]@Findexref@Parmquote(Text)@;") -@Form(Xfunref = "@f[@Parm(X) ]@~ - @r[(page @Pageref(@Parm(L)-fun))]@Findexref@Parmquote(X)@;") -@Textform(Macref = "@f[@Parm(Text) ]@~ - @r[(page @Pageref(@Parm(Text)-mac))]@Mindexref@Parmquote(Text)@;") -@Textform(Macreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-mac))]@Mindexref@Parmquote(Text)@;") -@Form(Xmacref = "@f[@Parm(X) ]@~ - @r[(page @Pageref(@Parm(L)-mac))]@Mindexref@Parmquote(X)@;") -@Textform(Specref = "@f[@Parm(Text) ]@~ - @r[(page @Pageref(@Parm(Text)-spec))]@Sindexref@Parmquote(Text)@;") -@Textform(Specreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-spec))]@Sindexref@Parmquote(Text)@;") -@Form(XSpecref = "@f[@Parm(X) ]@~ - @r[(page @Pageref(@Parm(L)-spec))]@Sindexref@Parmquote(X)@;") -@Textform(Var = "@f[*@Parm(Text)*]") -@Textform(Varref = "@f[*@Parm(Text)* ]@~ - @r[(page @Pageref(@Parm(Text)-var))]@Vindexref@Parmquote(Text)@;") -@Form(Xvarref = "@f[*@Parm(X)* ]@~ - @r[(page @Pageref(@Parm(L)-var))]@Vindexref@Parmquote(X)@;") -@Textform(Conref = "@f[@Parm(Text) ]@~ - @r[(page @Pageref(@Parm(Text)-con))]@Conindexref@Parmquote(Text)@;") -@Form(Xconref = "@f[@Parm(X) ]@~ - @r[(page @Pageref(@Parm(L)-con))]@Conindexref@Parmquote(X)@;") -@Form(Kwdref = "@f[:@Parm(K) ]@~ - @r[(page @Pageref(@Parm(F)-@Parm(K)-kwd))]@Kindexref2(S {for@f[ @Parm(F)]}, - K @Parmquote(K))@;") -@Form(SubKwdref = "@f[:@Parm(K)] @~ - @r[(page @Pageref(@Parm(F)-@Parm(O)-@Parm(K)-kwd))]@~ - @Kindexref2(S {for@f[ :@Parm(O) ]option to@f[ @Parm(F)]}, - K @Parmquote(K))") - -@Indexentry(Key { 1}, Entry {@IndexHeadings[Index]@Blankspace(1)@Begin(IndexEnvironment)}) -@Indexentry(Key {~~~ }, Entry {@End(IndexEnvironment)}) - -@Textform(IndexCleanup = " ") diff --git a/docs/doc-diff.lisp b/docs/doc-diff.lisp deleted file mode 100644 index 7f232bb68f2d9ec72bfa50a76ef747258a3fc47e..0000000000000000000000000000000000000000 --- a/docs/doc-diff.lisp +++ /dev/null @@ -1,384 +0,0 @@ -;;; -*- Package: Hemlock -*- -;;; -;;; A hack to compare the functions and variables defined by the hemlock -;;; documents with the ones defined in the core. -;;; -;;; Use GROVEL-LABELS. -;;; - -(in-package "HEMLOCK") - - -(defvar *defined-labels* (make-hash-table :test #'equal)) - -;;; Ignore these because they would be internal (not for the user) if Hemlock -;;; had that kind of definition power. -;;; -(defvar *hvars-to-ignore* - '(auto-save-state current-package draft-information headers-buffer - headers-information message-buffer message-information spell-information - default-message-modeline-fields current-compile-server current-eval-server)) - -(defvar *cmds-to-ignore* - '("Beginning Of Parse" "Echo Area Backward Character" - "Echo Area Backward Word" "Echo Area Delete Previous Character" - "Echo Area Kill Previous Word" "Do Nothing" "Illegal" "Insert Parse Default" - "Italic Comment Mode" "Kill Parse" "Lisp Insert )" "Next Parse" - "Previous Parse" "Start Italic Comment" "Insert ()" "Move over )" - "Current Compile Server" "Current Eval Server" "Defhvar" "Defindent")) - -;;; These do not get removed from *defined-labels* because they are not -;;; command names, variable names, or "HI" function names. These are now -;;; documented in the Command Implementor's Manual, but we don't want to call -;;; FIND-UNDOCUMENTED-SYMBOLS on these packages due to all the uninteresting -;;; symbols they hold. In the case of routines defined in the "ED" package, -;;; they aren't exported anyway. -;;; -;;; Do not add names to this list that occur in the ED package and have -;;; asterisks (e.g., specials like *kill-ring* and *last-search-string*). Use -;;; the variable below, *unimplemented-strings-to-ignore*. -;;; -(defvar *unimplemented-to-ignore* - '(spell:spell-try-word spell:maybe-read-spell-dictionary spell:spell-root-word - spell:max-entry-length spell:spell-read-dictionary - spell:spell-collect-close-words spell:correct-spelling - spell:spell-add-entry spell:spell-remove-entry spell:spell-root-flags - - ext:translate-character ext:define-keyboard-modifier - ext:define-mouse-code ext:translate-mouse-character ext:define-keysym - - dired:find-file dired:make-directory dired:delete-file - dired:pathnames-from-pattern dired:copy-file dired:rename-file - - get-search-pattern current-mark file-compile kill-characters - indent-region-for-commands display-page-directory previous-buffer - sentence-offset interactive buffer-default-pathname - add-definition-dir-translation push-buffer-mark do-active-group - paragraph-offset word-offset create-slave make-region-undo - process-file-options pre-command-parse-check top-level-offset fill-region - pop-buffer-mark region-eval get-current-compile-server mark-top-level-form - ed page-directory find-file-buffer deactivate-region valid-spot - buffer-history kill-region string-eval backward-up-list - define-file-type-hook buffer-history check-region-query-size - change-to-buffer region-compile current-region mark-paragraph form-offset - check-region-active read-buffer-file fill-region-by-paragraphs - forward-up-list define-file-option buffer-mark region-active-p - inside-defun-p activate-region start-defun-p delete-buffer-if-possible - get-current-eval-server goto-page write-buffer-file save-for-undo - eval-form-in-server indent-region in-lisp pathname-to-buffer-name - page-offset defun-region delete-definition-dir-translation - delete-horizontal-space supply-generic-pointer-up-function)) - -;;; This is just like *unimplemented-to-ignore*, but these names are hard to -;;; deal with in *unimplemented-to-ignore* due to one of the following reasons: -;;; Scribe, -;;; The name is an example and truly unimplemented, or -;;; The name has asterisks in core but not in the Scribe label name. -;;; -(defvar *unimplemented-strings-to-ignore* - '("SAMPLECOMMAND" "SAMPLEVARIABLE" - - "MARK-GTR" "MARK-NEQ" "MARK-LSS" "MARK-LEQ" "MARK-GEQ" "MARK-EQL" - "LINE-GEQ" "LINE-LSS" "LINE-GTR" "LINE-LEQ" - - "KILL-RING" "LAST-SEARCH-STRING" "EPHEMERALLY-ACTIVE-COMMAND-TYPES" - "HEMLOCK-BEEP" "LAST-SEARCH-PATTERN" "ACTIVE-FILE-GROUP" - - "ERROR-FUNCTION" "REPORT-FUNCTION" "UPDATE-DEFAULT" "YESP-FUNCTION" - "CLOBBER-DEFAULT" "RECURSIVE-DEFAULT")) - - -(defun grovel-labels (aux-files output-file) - "Read each of the files in the list Aux-Files to find what commands are - documented, then compare it with the commands defined in core. We write - documentation forms to the output-file for things defined but not documented, - and we put a list of things documented but not implemented in a comment." - (clrhash *defined-labels*) - (dolist (labels-file aux-files) - (with-open-file (s labels-file :direction :input) - (loop - (let ((l (read-line s nil nil))) - (unless l (return)) - (multiple-value-bind (kind label) - (parse-label l) - (when kind - (let ((old (gethash label *defined-labels*))) - (when (and old - (not (eq old :hemlock-variable)) - (not (eq kind :hemlock-variable))) - (format t "~S multiply defined as ~S and ~S.~%" - label old kind)) - (setf (gethash label *defined-labels*) kind)))))))) - (with-open-file (s output-file :direction :output - :if-exists :new-version) - (map-undocumented-hemlock-things *command-names* :command s - #'document-command *cmds-to-ignore*) - (terpri s) - (map-undocumented-hemlock-things *global-variable-names* :hemlock-variable s - #'document-variable *hvars-to-ignore*) - (terpri s) - (find-undocumented-symbols "HEMLOCK-INTERNALS" s) - (terpri s) - (write-line "@begin[comment]" s) - (let ((ignored-symbols (copy-list *unimplemented-to-ignore*)) - (ignored-strings (copy-list *unimplemented-strings-to-ignore*))) - (maphash #'(lambda (name type) - (cond ((member name ignored-symbols - :test #'string= :key #'symbol-name) - (setf ignored-symbols - (delete name ignored-symbols - :test #'string= :key #'symbol-name))) - ((member name ignored-strings :test #'string=) - (setf ignored-strings - (delete name ignored-strings :test #'string=))) - (t - (format s "~A ~S is not implemented.~%" type name)))) - *defined-labels*) - (when ignored-symbols - (format s - "~&******************* These ignored \"unimplemented\" symbols ~ - were not used.~%~S~%********************~2%" - ignored-symbols)) - (when ignored-strings - (format s - "~&******************* These ignored \"unimplemented\" strings ~ - were not used.~%~S~%********************~2%" - ignored-strings))) - (write-line "@end[comment]" s) - (values))) - - -;;; Iterate over a string table, checking that each thing has a corresponding -;;; label of the specified kind. If there is no label, then call the function -;;; with the value and stream. If the label is the wrong kind, print a comment -;;; on Stream before calling the function. We also blast the label so we will -;;; know that it was defined. -;;; -(defun map-undocumented-hemlock-things (table kind stream function ignore-stuff) - (do-strings (string value table) - (let* ((lab (nstring-upcase (remove #\space string))) - (lkind (gethash lab *defined-labels*))) - (cond ((and (eq kind :command) - (member (command-name value) ignore-stuff - :test #'string-equal)) - (setf ignore-stuff - (remove (command-name value) ignore-stuff - :test #'string-equal))) - ((member value ignore-stuff) - (setf ignore-stuff (remove value ignore-stuff))) - (t - (unless (eq lkind kind) - (when lkind - (format stream - "@comment{~S documented as a ~A, ~ - but defined as a ~A.}~2%" - string lkind kind)) - (funcall function value stream)))) - (remhash lab *defined-labels*))) - (when ignore-stuff - (format stream - "~&******************** These ignored ~Ss were not used.~%~ - ~S~%********************~2%" - kind ignore-stuff))) - - - -(defvar *undocumented-symbols-to-ignore* - '(make-xwindow-like-hwindow mark/= default-font input-waiting mark= - modify-kbdmac-stream delete-line-font-marks font-mark hemlock-output-stream - command reprompt store-cut-string make-kbdmac-stream window window-font - delete-font-mark fetch-cut-string fun-defined-from-pathname - hemlock-region-stream line< buffer mark< move-font-mark - editor-describe-function enter-window-autoraise ring mark<= search-pattern - *print-region* mark>= string-table line mark> line> line>= line<= - after-editor-initializations *invoke-hook* defhvar)) - -(defun find-undocumented-symbols (package stream) - (let ((ignore-symbols *undocumented-symbols-to-ignore*)) - (do-external-symbols (sym package) - (let* ((name (string-trim "*" (symbol-name sym))) - (kind (gethash name *defined-labels*))) - (ecase kind - ((nil) - (if (member sym ignore-symbols) - (setf ignore-symbols (remove sym ignore-symbols)) - (let ((*standard-output* stream)) - ;; Bind this to squelch CLOS/DESCRIBE bad interaction. - (describe sym) - (terpri) - (terpri)))) - ((:function :macro :special-form) - (let ((def (cond ((macro-function sym) :macro) - ((special-form-p sym) :special-form) - ((fboundp sym) :function)))) - (unless (eq kind def) - (format stream - "@comment{~S is ~:[not defined~;~:*defined as a ~A~]~ - , but is documented as a ~A}~%" sym def kind)))) - (:constant - (unless (constantp sym) - (format stream - "@comment{~S is documented as a constant, but isn't ~ - defined.}~%" - sym))) - (:variable - (unless (or (get sym 'lisp::globally-special) - (string= name (symbol-name sym))) - (format stream - "@comment{~S is documented as a special, but isn't ~ - declared.}~%" - sym)))) - (remhash name *defined-labels*))) - (when ignore-symbols - (format stream - "~&******************** These ignored symbols were not used.~%~ - ~S~%********************~2%" - ignore-symbols)))) - - -(defvar *suffix-codes* (make-hash-table :test #'equal)) -(setf (gethash "COM" *suffix-codes*) :command) -(setf (gethash "HVAR" *suffix-codes*) :hemlock-variable) -(setf (gethash "FUN" *suffix-codes*) :function) -(setf (gethash "MAC" *suffix-codes*) :macro) -(setf (gethash "SPEC" *suffix-codes*) :special-form) -(setf (gethash "VAR" *suffix-codes*) :variable) -(setf (gethash "CON" *suffix-codes*) :constant) - - -;;; Parse a line from a Scribe .Aux file, returning the kind of the thing -;;; documented and its name. -;;; -(defun parse-label (entry) - (let* ((end (search "), Value" entry :start2 28)) - (hpos (position #\- entry :start 28 :end end :from-end t))) - (if hpos - (let* ((suffix (subseq entry (1+ hpos) end)) - (found (gethash suffix *suffix-codes*))) - (if found - (values found (subseq entry 28 hpos)) - (values nil nil))) - (values nil nil)))) - - -(defun document-command (command stream) - (format stream "@defcom[com ~S" (command-name command)) - (let ((binds (command-bindings command))) - (when binds - (format stream ", bind (") - (print-command-bindings binds stream) - (format stream ")")) - (format stream "]~%~A~%@enddefcom~2%" - (command-documentation command)))) - - -(defun document-variable (var stream) - (let* ((name (variable-name var :global)) - (len (length name))) - (unless (string= name "Mode Hook" :start1 (- len 9)) - (format stream "@defhvar[var ~S~@[, val {~(~S~)}~]]~%~A~%@enddefhvar~2%" - name (variable-value var :global) - (variable-documentation var :global))))) - - -(defvar *definition-pattern* - (new-search-pattern :string-insensitive :forward " -@def")) - -(defvar *insert-pattern* - (new-search-pattern :string-insensitive :backward " - -")) - -(defvar *definition-macros* (make-hash-table :test #'equal)) -(setf (gethash "COM" *definition-macros*) :command) -(setf (gethash "HVAR" *definition-macros*) :hemlock-variable) -(setf (gethash "UN" *definition-macros*) :function) -(setf (gethash "MAC" *definition-macros*) :macro) -(setf (gethash "SPEC" *definition-macros*) :special-form) -(setf (gethash "VAR" *definition-macros*) :variable) -(setf (gethash "CON" *definition-macros*) :constant) -(setf (gethash "COM1" *definition-macros*) :command) -(setf (gethash "HVAR1" *definition-macros*) :hemlock-variable) -(setf (gethash "UN1" *definition-macros*) :function) -(setf (gethash "MAC1" *definition-macros*) :macro) -(setf (gethash "SPEC1" *definition-macros*) :special-form) -(setf (gethash "VAR1" *definition-macros*) :variable) -(setf (gethash "CON1" *definition-macros*) :constant) - -(defun parse-doc-macro (line) - (let* ((bracket (or (position #\[ line) - (error "No opening #\[ ???"))) - (name (nstring-upcase (subseq line 4 bracket))) - (kind (gethash name *definition-macros*)) - (nend (case (char line (+ bracket 5)) - (#\" - (position #\" line :start (+ bracket 6))) - (#\{ - (position #\} line :start (+ bracket 6))) - (t nil)))) - (cond ((not kind) - (format t "Unknown definition macro:~%~A~%" line) - (values nil nil)) - ((not nend) - (format t "Can't parse name:~%~A~%" line) - (values nil nil)) - (t - (values kind (subseq line (+ bracket 6) nend)))))) - - -(defun annotate-with-online-documentation (input-file output-file) - "Take a Scribe input file and produce a Scribe output file with the online - documentation for each thing inserted before the offline documentation." - (let* ((temp-buffer (make-buffer "Annotate Temporary")) - (point (buffer-point temp-buffer))) - (unwind-protect - (progn - (read-file input-file point) - (buffer-start point) - (loop - (unless (find-pattern point *definition-pattern*) - (return)) - (line-offset point 1) - (multiple-value-bind - (kind name) - (parse-doc-macro (line-string (mark-line point))) - (when kind - (with-mark ((insert point :left-inserting)) - (unless (find-pattern insert *insert-pattern*) - (buffer-start insert)) - (line-offset insert 2 0) - (with-output-to-mark (stream insert :full) - (ecase kind - ((:function :macro :special-form :constant) - (format stream "@begin[format]~%") - (let ((*standard-output* stream)) - (describe (intern (string-upcase name)))) - (format stream "~&@end[format]~2%")) - (:variable - (format stream "@begin[format]~%") - (let ((*standard-output* stream)) - (describe (intern (concatenate 'string "*" - (string-upcase name) - "*")))) - (format stream "~&@end[format]~2%")) - (:command - (let ((command (getstring name *command-names*))) - (when command - (format stream "@begin[verse]~%Command @hid[~A]: (" - (command-name command)) - (print-command-bindings (command-bindings command) - stream) - (format stream ")~%@end[verse]~%~A~2&" - (command-documentation command))))) - (:hemlock-variable - (let ((var (getstring name *global-variable-names*))) - (when var - (format stream "@begin[verse]~%Variable @hid[~A]: ~ - (~(~S~))~%@end[verse]~%~A~2&" - (variable-name var :global) - (variable-value var :global) - (variable-documentation var :global)))))) - ))))) - (write-file (buffer-region temp-buffer) output-file)) - (delete-buffer temp-buffer)))) diff --git a/docs/hem/cim/aux-sys.mss b/docs/hem/cim/aux-sys.mss deleted file mode 100644 index 945aa7a3358237cbce850305522cb7d773ed410d..0000000000000000000000000000000000000000 --- a/docs/hem/cim/aux-sys.mss +++ /dev/null @@ -1,694 +0,0 @@ -@comment{-*- Dictionary: /usr/lisp/scribe/hem/hem; Mode: spell; Package: Hemlock; Log: /usr/lisp/scribe/hem/hem-docs.log -*-} -@chapter (Auxiliary Systems) -This chapter describes utilities that some implementations of @hemlock may -leave unprovided or unsupported. - - -@section[Key-events] -@index(I/O) -@index[keyboard input] -@index[input, keyboard] -@index[mouse input] -@index[input, mouse] -@label[key-events] - -These routines are defined in the @f["EXTENSIONS"] package since other projects -have often used @hemlock's input translations for interfacing to CLX. - - -@subsection[Introduction] - -The canonical representation of editor input is a key-event structure. Users -can bind commands to keys (see section @ref[key-bindings]), which are non-zero -length sequences of key-events. A key-event consists of an identifying token -known as a @i[keysym] and a field of bits representing modifiers. Users define -keysyms, integers between 0 and 65535 inclusively, by supplying names that -reflect the legends on their keyboard's keys. Users define modifier names -similarly, but the system chooses the bit and mask for recognizing the -modifier. You can use keysym and modifier names to textually specify -key-events and Hemlock keys in a @f[#k] syntax. The following are some -examples: -@begin[programexample] - #k"C-u" - #k"Control-u" - #k"c-m-z" - #k"control-x meta-d" - #k"a" - #k"A" - #k"Linefeed" -@end[programexample] -This is convenient for use within code and in init files containing -@f[bind-key] calls. - -The @f[#k] syntax is delimited by double quotes, but the system parses the -contents rather than reading it as a Common Lisp string. Within the double -quotes, spaces separate multiple key-events. A single key-event optionally -starts with modifier names terminated by hyphens. Modifier names are -alphabetic sequences of characters which the system uses case-insensitively. -Following modifiers is a keysym name, which is case-insensitive if it consists -of multiple characters, but if the name consists of only a single character, -then it is case-sensitive. - -You can escape special characters @dash hyphen, double quote, open angle -bracket, close angle bracket, and space @dash with a backslash, and you can -specify a backslash by using two contiguously. You can use angle brackets to -enclose a keysym name with many special characters in it. Between angle -brackets appearing in a keysym name position, there are only two special -characters, the closing angle bracket and backslash. - - - -@subsection[Interface] - -All of the following routines and variables are exported from the "EXTENSIONS" -("EXT") package. - - -@defun[fun {define-keysym}, args {@i[keysym] @i[preferred-name] @rest @i[other-names]}] -This function establishes a mapping from @i[preferred-name] to @i[keysym] for -purposes of @f[#k] syntax. @i[Other-names] also map to @i[keysym], but the -system uses @i[preferred-name] when printing key-events. The names are -case-insensitive simple-strings; however, if the string contains a single -character, then it is used case-sensitively. Redefining a keysym or re-using -names has undefined effects. - -You can use this to define unused keysyms, but primarily this defines keysyms -defined in the @i[X Window System Protocol, MIT X Consortium Standard, X -Version 11, Release 4]. @f[translate-key-event] uses this knowledge to -determine what keysyms are modifier keysyms and what keysym stand for -alphabetic key-events. -@enddefun - - -@defun[fun {define-mouse-keysym}, args {@i[button] @i[keysym] @i[name] @i[shifted-bit] @i[event-key]}] -This function defines @i[keysym] named @i[name] for key-events representing the -X @i[button] cross the X @i[event-key] (@kwd[button-press] or -@kwd[button-release]). @i[Shifted-bit] is a defined modifier name that -@f[translate-mouse-key-event] sets in the key-event it returns whenever the X -shift bit is set in an incoming event. - -Note, by default, there are distinct keysyms for each button distinguishing -whether the user pressed or released the button. - -@i[Keysym] should be an one unspecified in @i[X Window System Protocol, MIT X -Consortium Standard, X Version 11, Release 4]. -@enddefun - - -@defun[fun {name-keysym}, args {@i[name]}] -This function returns the keysym named @i[name]. If @i[name] is unknown, this -returns @nil. -@enddefun - -@defun[fun {keysym-names}, args {@i[keysym]}] -This function returns the list of all names for @i[keysym]. If @i[keysym] is -undefined, this returns @nil. -@enddefun - -@defun[fun {keysym-preferred-name}, args {@i[keysym]}] -This returns the preferred name for @i[keysym], how it is typically printed. -If @i[keysym] is undefined, this returns @nil. -@enddefun - -@defun[fun {define-key-event-modifier}, args {@i[long-name] @i[short-name]}] -This establishes @i[long-name] and @i[short-name] as modifier names for -purposes of specifying key-events in @f[#k] syntax. The names are -case-insensitive simple-strings. If either name is already defined, this -signals an error. - -The system defines the following default modifiers (first the long name, -then the short name): -@begin[Itemize] -@f["Hyper"], @f["H"] - -@f["Super"], @f["S"] - -@f["Meta"], @f["M"] - -@f["Control"], @f["C"] - -@f["Shift"], @f["Shift"] - -@f["Lock"], @f["Lock"] -@end[Itemize] -@enddefun - - -@defvar[var {all-modifier-names}] -This variable holds all the defined modifier names. -@enddefvar - - -@defun[fun {define-clx-modifier}, args {@i[clx-mask] @i[modifier-name]}] -This function establishes a mapping from @i[clx-mask] to a defined key-event -@i[modifier-name]. @f[translate-key-event] and @f[translate-mouse-key-event] -can only return key-events with bits defined by this routine. - -The system defines the following default mappings between CLX modifiers and -key-event modifiers: -@begin[Itemize] -@f[(xlib:make-state-mask :mod-1) --> "Meta"] - -@f[(xlib:make-state-mask :control) --> "Control"] - -@f[(xlib:make-state-mask :lock) --> "Lock"] - -@f[(xlib:make-state-mask :shift) --> "Shift"] -@end[Itemize] -@enddefun - - -@defun[fun {make-key-event-bits}, args {@rest @i[modifier-names]}] -This function returns bits suitable for @f[make-key-event] from the supplied -@i[modifier-names]. If any name is undefined, this signals an error. -@enddefun - -@defun[fun {key-event-modifier-mask}, args {@i[modifier-name]}] -This function returns a mask for @i[modifier-name]. This mask is suitable for -use with @f[key-event-bits]. If @i[modifier-name] is undefined, this signals -an error. -@enddefun - -@defun[fun {key-event-bits-modifiers}, args {@i[bits]}] -This returns a list of key-event modifier names, one for each modifier -set in @i[bits]. -@enddefun - - -@defun[fun {translate-key-event}, args {@i[display] @i[scan-code] @i[bits]}] -This function translates the X @i[scan-code] and X @i[bits] to a key-event. -First this maps @i[scan-code] to an X keysym using @f[xlib:keycode->keysym] -looking at @i[bits] and supplying index as @f[1] if the X shift bit is on, -@f[0] otherwise. - -If the resulting keysym is undefined, and it is not a modifier keysym, -then this signals an error. If the keysym is a modifier key, then this -returns @nil. - -If these conditions are satisfied -@begin[Itemize] -The keysym is defined. - -The X shift bit is off. - -The X lock bit is on. - -The X keysym represents a lowercase letter. -@end[Itemize] -then this maps the @i[scan-code] again supplying index as @f[1] this time, -treating the X lock bit as a caps-lock bit. If this results in an undefined -keysym, this signals an error. Otherwise, this makes a key-event with the -keysym and bits formed by mapping the X bits to key-event bits. - -Otherwise, this makes a key-event with the keysym and bits formed by -mapping the X bits to key-event bits. -@enddefun - - -@defun[fun {translate-mouse-key-event}, args {@i[scan-code] @i[bits] @i[event-key]}] -This function translates the X button code, @i[scan-code], and modifier bits, -@i[bits], for the X @i[event-key] into a key-event. See -@f[define-mouse-keysym]. -@enddefun - -@defun[fun {make-key-event}, args {@i[object] @i[bits]}] -This function returns a key-event described by @i[object] with @i[bits]. -@i[Object] is one of keysym, string, or key-event. When @i[object] is a -key-event, this uses @f[key-event-keysym]. You can form @i[bits] with -@f[make-key-event-bits] or @f[key-event-modifier-mask]. -@enddefun - -@defun[fun {key-event-p}, args {@i[object]}] -This function returns whether @i[object] is a key-event. -@enddefun - -@defun[fun {key-event-bits}, args {@i[key-event]}] -This function returns the bits field of a @i[key-event]. -@enddefun - -@defun[fun {key-event-keysym}, args {@i[key-event]}] -This function returns the keysym field of a @i[key-event]. -@enddefun - -@defun[fun {char-key-event}, args {@i[character]}] -This function returns the key-event associated with @i[character]. You can -associate a key-event with a character by @f[setf]'ing this form. -@enddefun - -@defun[fun {key-event-char}, args {@i[key-event]}] -This function returns the character associated with @i[key-event]. You can -associate a character with a key-event by @f[setf]'ing this form. The system -defaultly translates key-events in some implementation dependent way for text -insertion; for example, under an ASCII system, the key-event @f[#k"C-h"], as -well as @f[#k"backspace"] would map to the Common Lisp character that causes a -backspace. -@enddefun - -@defun[fun {key-event-bit-p}, args {@i[key-event] @i[bit-name]}] -This function returns whether @i[key-event] has the bit set named by -@i[bit-name]. This signals an error if @i[bit-name] is undefined. -@enddefun - -@defmac[fun {do-alpha-key-events}, args -{(@i[var] @i[kind] @optional @i[result]) @mstar<@i[form]>}] - This macro evaluates each @i[form] with @i[var] bound to a key-event -representing an alphabetic character. @i[Kind] is one of @kwd[lower], -@kwd[upper], or @kwd[both], and this binds @i[var] to each key-event in order -as specified in @i[X Window System Protocol, MIT X Consortium Standard, X -Version 11, Release 4]. When @kwd[both] is specified, this processes lowercase -letters first. -@enddefmac - -@defun[fun {print-pretty-key}, args {@i[key] @optional @i[stream] @i[long-names-p]}] -This prints @i[key], a key-event or vector of key-events, in a user-expected -fashion to @i[stream]. @i[Long-names-p] indicates whether modifiers should -print with their long or short name. @i[Stream] defaults to -@var[standard-output]. -@enddefun - -@defun[fun {print-pretty-key-event}, args {@i[key-event] @optional @i[stream] @i[long-names-p]}] -This prints @i[key-event] to @i[stream] in a user-expected fashion. -@i[Long-names-p] indicates whether modifier names should appear using the long -name or short name. @i[Stream] defaults to @var[standard-output]. -@enddefun - - - -@section (CLX Interface) - -@subsection (Graphics Window Hooks) -This section describes a few hooks used by Hemlock's internals to handle -graphics windows that manifest Hemlock windows. Some heavy users of Hemlock as -a tool have needed these in the past, but typically functions that replace the -default values of these hooks must be written in the "@f[HEMLOCK-INTERNALS]" -package. All of these symbols are internal to this package. - -If you need this level of control for your application, consult the current -implementation for code fragments that will be useful in correctly writing your -own window hook functions. - -@defvar[var {create-window-hook}] -This holds a function that @Hemlock calls when @f[make-window] executes under -CLX. @Hemlock passes the CLX display and the following arguments from -@f[make-window]: starting mark, ask-user, x, y, width, height, and modelinep. -The function returns a CLX window or nil indicating one could not be made. -@enddefvar - -@defvar[var {delete-window-hook}] -This holds a function that @hemlock calls when @f[delete-window] executes under -CLX. @hemlock passes the CLX window and the @hemlock window to this function. -@enddefvar - -@defvar[var {random-typeout-hook}] -This holds a function that @hemlock calls when random typeout occurs under CLX. -@hemlock passes it a @hemlock device, a pre-existing CLX window or @nil, and -the number of pixels needed to display the number of lines requested in the -@f[with-pop-up-display] form. It should return a window, and if a new window -is created, then a CLX gcontext must be the second value. -@enddefvar - -@defvar[var {create-initial-windows-hook}] -This holds a function that @hemlock calls when it initializes the screen -manager and makes the first windows, typically windows for the @hid[Main] and -@hid[Echo Area] buffers. @hemlock passes the function a @hemlock device. -@enddefvar - - -@subsection (Entering and Leaving Windows) - -@defhvar[var "Enter Window Hook"] -When the mouse enters an editor window, @hemlock invokes the functions in this -hook. These functions take a @Hemlock window as an argument. -@enddefhvar - -@defhvar[var "Exit Window Hook"] -When the mouse exits an editor window, @hemlock invokes the functions in this -hook. These functions take a @Hemlock window as an argument. -@enddefhvar - - -@subsection (How to Lose Up-Events) -Often the only useful activity user's design for the mouse is to click on -something. @Hemlock sees a character representing the down event, but what do -you do with the up event character that you know must follow? Having the -command eat it would be tasteless, and would inhibit later customizations that -make use of it, possibly adding on to the down click command's functionality. -Bind the corresponding up character to the command described here. - -@defcom[com "Do Nothing"] -This does nothing as many times as you tell it. -@enddefcom - - -@section (Slave Lisps) -@index (Slave lisp interface functions) -Some implementations of @hemlock feature the ability to manage multiple slave -Lisps, each connected to one editor Lisp. The routines discussed here spawn -slaves, send evaluation and compilation requests, return the current server, -etc. This is very powerful because without it you can lose your editing state -when code you are developing causes a fatal error in Lisp. - -The routines described in this section are best suited for creating editor -commands that interact with slave Lisps, but in the past users implemented -several independent Lisps as nodes communicating via these functions. There is -a better level on which to write such code that avoids the extra effort these -routines take for the editor's sake. See the @i[CMU Common Lisp User's Manual] -for the @f[remote] and @f[wire] packages. - - -@subsection (The Current Slave) -There is a slave-information structure that these return which is suitable for -passing to the routines described in the following subsections. - -@defun[fun {create-slave}, args {@optional @i[name]}] -This creates a slave that tries to connect to the editor. When the slave -connects to the editor, this returns a slave-information structure, and the -interactive buffer is the buffer named @i[name]. This generates a name if -@i[name] is @nil. In case the slave never connects, this will eventually -timeout and signal an editor-error. -@enddefun - -@defun[fun {get-current-eval-server}, args {@optional @i[errorp]}] -@defhvar1[var {Current Eval Server}] -This returns the server-information for the @hid[Current Eval Server] after -making sure it is valid. Of course, a slave Lisp can die at anytime. If this -variable is @nil, and @i[errorp] is non-@nil, then this signals an -editor-error; otherwise, it tries to make a new slave. If there is no current -eval server, then this tries to make a new slave, prompting the user based on a -few variables (see the @i[Hemlock User's Manual]). -@enddefun - -@defun[fun {get-current-compile-server}] -@defhvar1[var {Current Compile Server}] -This returns the server-information for the @hid[Current Compile Server] after -making sure it is valid. This may return nil. Since multiple slaves may -exist, it is convenient to use one for developing code and one for compiling -files. The compilation commands that use slave Lisps prefer to use the current -compile server but will fall back on the current eval server when necessary. -Typically, users only have separate compile servers when the slave Lisp can -live on a separate workstation to save cycles on the editor machine, and the -@hemlock commands only use this for compiling files. -@enddefun - - -@subsection (Asynchronous Operation Queuing) -The routines in this section queue requests with an eval server. Requests are -always satisfied in order, but these do not wait for notification that the -operation actually happened. Because of this, the user can continue editing -while his evaluation or compilation occurs. Note, these usually execute in the -slave immediately, but if the interactive buffer connected to the slave is -waiting for a form to return a value, the operation requested must wait until -the slave is free again. - -@defun[fun {string-eval}, args {@i[string]}, keys {[server][package][context]}] -@defun1[fun {region-eval}, args {@i[region]}, keys {[server][package][context]}] -@defun1[fun {region-compile}, args {@i[region]}, keys {[server][package]}] -@f[string-eval] queues the evaluation of the form read from @i[string] on eval -server @i[server]. @i[Server] defaults to the result of -@f[get-current-server], and @i[string] is a simple-string. The evaluation -occurs with @var[package] bound in the slave to the package named by -@i[package], which defaults to @hid[Current Package] or the empty string; the -empty string indicates that the slave should evaluate the form in its current -package. The slave reads the form in @i[string] within this context as well. -@i[Context] is a string to use when reporting start and end notifications in -the @hid[Echo Area] buffer; it defaults to the concatenation of @f["evaluation -of "] and @i[string]. - -@f[region-eval] is the same as @f[string-eval], but @i[context] defaults -differently. If the user leaves this unsupplied, then it becomes a string -involving part of the first line of region. - -@f[region-compile] is the same as the above. @i[Server] defaults the same; it -does not default to @f[get-current-compile-server] since this compiles the -region into the slave Lisp's environment, to affect what you are currently -working on. -@enddefun - -@defun[fun {file-compile}, args {@i[file]}, - keys {[output-file][error-file][load][server]}, - morekeys {[package]}] -@defhvar1[var {Remote Compile File}, val {nil}] -This compiles @i[file] in a slave Lisp. When @i[output-file] is @true (the -default), this uses a temporary output file that is publicly writable in case -the client is on another machine, which allows for file systems that do not -permit remote write access. This renames the temporary file to the appropriate -binary name or deletes it after compilation. Setting @hid[Remote Compile File] -to @nil, inhibits this. If @i[output-file] is non-@nil and not @true, then it -is the name of the binary file to write. The compilation occurs with -@var[package] bound in the slave to the package named by @i[package], which -defaults to @hid[Current Package] or the empty string; the empty string -indicates that the slave should evaluate the form in its current package. -@i[Error-file] is the file in which to record compiler output, and a @nil value -inhibits this file's creation. @i[Load] indicates whether to load the -resulting binary file, defaults to @nil. @i[Server] defaults to -@f[get-current-compile-server], but if this returns nil, then @i[server] -defaults to @f[get-current-server]. -@enddefun - -@subsection (Synchronous Operation Queuing) -The routines in this section queue requests with an eval server and wait for -confirmation that the evaluation actually occurred. Because of this, the user -cannot continue editing while the slave executes the request. Note, these -usually execute in the slave immediately, but if the interactive buffer -connected to the slave is waiting for a form to return a value, the operation -requested must wait until the slave is free again. - -@defun[fun {eval-form-in-server}, - args {@i[server-info] @i[string] @optional @i[package]}] - This function queues the evaluation of a form in the server associated with -@i[server-info] and waits for the results. The server @f[read]'s the form from -@i[string] with @var[package] bound to the package named by @i[package]. This -returns the results from the slave Lisp in a list of string values. You can -@f[read] from the strings or simply display them depending on the @f[print]'ing -of the evaluation results. - -@i[Package] defaults to @hid[Current Package]. If this is @nil, the server -uses the value of @var[package] in the server. - -While the slave executes the form, it binds @var[terminal-io] to a stream that -signals errors when read from and dumps output to a bit-bucket. This prevents -the editor and slave from dead locking by waiting for each other to reply. -@enddefun - -@defun[fun {eval-form-in-server-1}, - args {@i[server-info] @i[string] @optional @i[package]}] - This function calls @f[eval-form-in-server] and @f[read]'s the result in the -first string it returns. This result must be @f[read]'able in the editor's -Lisp. -@enddefun - - -@section (Spelling) -@index (Spelling checking) -@hemlock supports spelling checking and correcting commands based on the ITS -Ispell dictionary. These commands use the following routines which include -adding and deleting entries, reading the Ispell dictionary in a compiled binary -format, reading user dictionary files in a text format, and checking and -correcting possible spellings. - -@defun[fun {maybe-read-spell-dictionary}, package {spell}] -This reads the default binary Ispell dictionary. Users must call this before -the following routines will work. -@enddefun - -@defun[fun {spell-read-dictionary}, package {spell}, args {@i[filename]}] -This adds entries to the dictionary from the lines in the file @i[filename]. -Dictionary files contain line oriented records like the following: -@begin[programexample] -entry1/flag1/flag2 -entry2 -entry3/flag1 -@end[programexample] -The flags are the Ispell flags indicating which endings are appropriate for the -given entry root, but these are unnecessary for user dictionary files. You can -consult Ispell documentation if you want to know more about them. -@enddefun - -@defun[fun {spell-add-entry}, package {spell}, - args {@i[line] @optional @i[word-end]}] -This takes a line from a dictionary file, and adds the entry described by -@i[line] to the dictionary. @i[Word-end] defaults to the position of the first -slash character or the length of the line. @i[Line] is destructively modified. -@enddefun - -@defun[fun {spell-remove-entry}, package {spell}, args {@i[entry]}] -This removes entry, a simple-string, from the dictionary, so it will be an -unknown word. This destructively modifies @i[entry]. If it is a root word, -then all words derived with @i[entry] and its flags will also be deleted. If -@i[entry] is a word derived from some root word, then the root and any words -derived from it remain known words. -@enddefun - -@defun[fun {correct-spelling}, package {spell}, args {@i[word]}] -This checks the spelling of @i[word] and outputs the results. If this finds -@i[word] is correctly spelled due to some appropriate suffix on a root, it -generates output indicating this. If this finds @i[word] as a root entry, it -simply outputs that it found @i[word]. If this cannot find @i[word] at all, -then it outputs possibly correct close spellings. This writes to -@var[standard-output], and it calls @f[maybe-read-spell-dictionary] before -attempting any lookups. -@enddefun - -@defun[fun {spell-try-word}, package {spell}, args {@i[word] @i[word-len]}] -@defcon1[var {max-entry-length}, val {31}] -This returns an index into the dictionary if it finds @i[word] or an -appropriate root. @i[Word-len] must be inclusively in the range 2 through -@f[max-entry-length], and it is the length of @i[word]. @i[Word] must be -uppercase. This returns a second value indicating whether it found @i[word] -due to a suffix flag, @nil if @i[word] is a root entry. -@enddefun - -@defun[fun {spell-root-word}, package {spell}, args {@i[index]}] -This returns a copy of the root word at dictionary entry @i[index]. This index -is the same as returned by @f[spell-try-word]. -@enddefun - -@defun[fun {spell-collect-close-words}, package {spell}, args {@i[word]}] -This returns a list of words correctly spelled that are @i[close] to @i[word]. -@i[Word] must be uppercase, and its length must be inclusively in the range 2 -through @f[max-entry-length]. Close words are determined by the Ispell rules: -@begin[enumerate] -Two adjacent letters can be transposed to form a correct spelling. - -One letter can be changed to form a correct spelling. - -One letter can be added to form a correct spelling. - -One letter can be removed to form a correct spelling. -@end[enumerate] -@enddefun - -@defun[fun {spell-root-flags}, package {spell}, args {@i[index]}] -This returns a list of suffix flags as capital letters that apply to the -dictionary root entry at @i[index]. This index is the same as returned by -@f[spell-try-word]. -@enddefun - - -@section (File Utilities) -Some implementations of @hemlock provide extensive directory editing commands, -@hid[Dired], including a single wildcard feature. An asterisk denotes a -wildcard. - -@defun[fun {copy-file}, package {dired}, - args {@i[spec1] @i[spec2]}, keys {[update][clobber][directory]}] - This function copies @i[spec1] to @i[spec2]. It accepts a single wildcard in -the filename portion of the specification, and it accepts directories. This -copies files maintaining the source's write date. - -If @i[spec1] and @i[spec2] are both directories, this recursively copies the -files and subdirectory structure of @i[spec1]; if @i[spec2] is in the -subdirectory structure of @i[spec1], the recursion will not descend into it. -Use @f["/spec1/*"] to copy only the files from @i[spec1] to directory -@i[spec2]. - -If @i[spec2] is a directory, and @i[spec1] is a file, then this copies -@i[spec1] into @i[spec2] with the same @f[pathname-name]. - -When @kwd[update] is non-@nil, then the copying process only copies files if the -source is newer than the destination. - -When @kwd[update] and @kwd[clobber] are @nil, and the destination exists, the -copying process stops and asks the user whether the destination should be -overwritten. - -When the user supplies @kwd[directory], it is a list of pathnames, directories -excluded, and @i[spec1] is a pattern containing one wildcard. This then copies -each of the pathnames whose @f[pathname-name] matches the pattern. @i[Spec2] -is either a directory or a pathname whose @f[pathname-name] contains a -wildcard. -@enddefun - -@defun[fun {rename-file}, package {dired}, - args {@i[spec1] @i[spec2]}, keys {[clobber][directory]}] - This function renames @i[spec1] to @i[spec2]. It accepts a single wildcard in -the filename portion of the specification, and @i[spec2] may be a directory -with the destination specification resulting in the merging of @i[spec2] with -@i[spec1]. If @kwd[clobber] is @nil, and @i[spec2] exists, then this asks the -user to confirm the renaming. When renaming a directory, end the specification -without the trailing slash. - -When the user supplies @kwd[directory], it is a list of pathnames, directories -excluded, and @i[spec1] is a pattern containing one wildcard. This then copies -each of the pathnames whose @f[pathname-name] matches the pattern. @i[Spec2] -is either a directory or a pathname whose @f[pathname-name] contains a -wildcard. -@enddefun - -@defun[fun {delete-file}, package {dired}, - args {@i[spec]}, keys {[recursive][clobber]}] - This function deletes @i[spec]. It accepts a single wildcard in the filename -portion of the specification, and it asks for confirmation on each file if -@kwd[clobber] is @nil. If @kwd[recursive] is non-@nil, then @i[spec] may be a -directory to recursively delete the entirety of the directory and its -subdirectory structure. An empty directory may be specified without -@kwd[recursive] being non-@nil. Specify directories with the trailing -slash. -@enddefun - -@defun[fun {find-file}, package {dired}, - args {@i[name] @optional @i[directory] @i[find-all]}] - This function finds the file with @f[file-namestring] @i[name], recursively -looking in @i[directory]. If @i[find-all] is non-@nil (defaults to @nil), then -this continues searching even after finding a first occurrence of file. -@i[Name] may contain a single wildcard, which causes @i[find-all] to default to -@true instead of @nil. -@enddefun - -@defun[fun {make-directory}, package {dired}, args {@i[name]}] -This function creates the directory with @i[name]. If it already exists, this -signals an error. -@enddefun - -@defun[fun {pathnames-from-pattern}, package {dired}, - args {@i[pattern] @i[files]}] -This function returns a list of pathnames from the list @i[files] whose -@f[file-namestring]'s match @i[pattern]. @i[Pattern] must be a non-empty -string and contain only one asterisk. @i[Files] contains no directories. -@enddefun - -@defvar[var {update-default}, package {dired}] -@defvar1[var {clobber-default}, package {dired}] -@defvar1[var {recursive-default}, package {dired}] -These are the default values for the keyword arguments above with corresponding -names. These default to @nil, @true, and @nil respectively. -@enddefvar - -@defvar[var {report-function}, package {dired}] -@defvar1[var {error-function}, package {dired}] -@defvar1[var {yesp-function}, package {dired}] -These are the function the above routines call to report progress, signal -errors, and prompt for @i[yes] or @i[no]. These all take format strings and -arguments. -@enddefvar - - -@defun[fun {merge-relative-pathnames}, args {@i[pathname] @i[default-directory]}] -This function merges @i[pathname] with @i[default-directory]. If @i[pathname] -is not absolute, this assumes it is relative to @i[default-directory]. The -result is always a directory pathname. -@enddefun - -@defun[fun {directoryp}, args {@i[pathname]}] -This function returns whether @i[pathname] names a directory: it has no name -and no type fields. -@enddefun - - -@section (Beeping) - -@defun[fun {hemlock-beep}] -@Hemlock binds @f[system:*beep-function*] to this function to beep the device. -It is different for different devices. -@enddefvar - -@defhvar[var "Bell Style", val {:border-flash}] -@defhvar1[var "Beep Border Width", val {20}] -@hid[Bell Style] determines what @var[hemlock-beep] does in @hemlock under CLX. -Acceptable values are @kwd[border-flash], @kwd[feep], -@kwd[border-flash-and-feep], @kwd[flash], @kwd[flash-and-feep], and @nil (do -nothing). - -@hid[Beep Border Width] is the width in pixels of the border flashed by border -flash beep styles. -@enddefhvar diff --git a/docs/hem/cim/cim.mss b/docs/hem/cim/cim.mss deleted file mode 100644 index 03ae31f51712e36eacc62587993e49cf2919661e..0000000000000000000000000000000000000000 --- a/docs/hem/cim/cim.mss +++ /dev/null @@ -1,4039 +0,0 @@ -@make[Manual] @comment{-*- Dictionary: /afs/cs/project/clisp/docs/hem/hem; Mode: spell; Package: Hemlock; Log: /usr/lisp/scribe/hem/hem-docs.log -*-} -@Device[postscript] -@style(FontFamily = TimesRoman) -@Style(Spacing = 1.2 lines) -@Style(StringMax = 5000) -@style(Hyphenation = On) -@style(Date="March 1952") -@use(database "/afs/cs/project/clisp/docs/database/") -@Style [DoubleSided] -@Libraryfile[ArpaCredit] -@Libraryfile[Hem] -@Libraryfile[Spice] -@Libraryfile[Uttir] - -@String(ReportTitle "Hemlock Command Implementor's Manual") - -@comment< -@begin[TitlePage] -@begin[TitleBox] -> -@blankspace(1.3inches) -@heading[Hemlock Command Implementor's Manual] - -@center[ -@b<Bill Chiles> -@b<Rob MacLachlan> - -@b<@value[date]> - -@b<CMU-CS-89-134-R1> -] -@comment<@end[TitleBox]> -@blankspace(2lines) -@begin[Center] -School of Computer Science -Carnegie Mellon University -Pittsburgh, PA 15213 -@end[Center] - -@blankspace(2lines) -@begin[Center] -This is a revised version of Technical Report CMU-CS-87-159. -@end[Center] -@heading[Abstract] -@begin(Text, indent 0) -This document describes how to write commands for the @Hemlock text editor, as -of version M3.2. @Hemlock is a customizable, extensible text editor whose -initial command set closely resembles that of ITS/TOPS-20 @Emacs. @Hemlock is -written in the CMU Common Lisp and has been ported to other implementations. -@end(Text) - -@blankspace(0.5in) -@begin[ResearchCredit] -@arpacredit[Contract=Basic87-90] -@end[ResearchCredit] -@comment<@end[TitlePage]> - - -@commandstring(dash = "@Y[M]") - - -@Tabclear - -@chapter(Introduction) - - @hemlock is a text editor which follows in the tradition of editors -such as EMACS and the Lisp Machine editor ZWEI. In its basic form, -@hemlock has almost the same command set as EMACS, and similar -features such as multiple buffers and windows, extended commands, -and built in documentation. - -Both user extensions and the original commands are written in Lisp, -therefore a command implementor will have a working knowledge of this -language. Users not familiar with Lisp need not despair however. Many -users of Multics EMACS, another text editor written in Lisp, came to learn -Lisp simply for the purpose of writing their own editor extensions, and -found, to their surprise, that it was really pretty easy to write simple -commands. - -This document describes the Common Lisp functions, macros and data structures -that are used to implement new commands. The basic editor consists of a set of -Lisp utility functions for manipulating buffers and the other data structures -of the editor as well as handling the display. All user level commands are -written in terms of these functions. To find out how to define commands see -chapter @ref[commands]. - -@chapter(Representation of Text) -@index (Lines) -@section(Lines) -In @hemlock all text is in some @i[line]. Text is broken into lines wherever -it contains a newline character; newline characters are never stored, but are -assumed to exist between every pair of lines. The implicit newline character -is treated as a single character by the text primitives. - -@defun[fun {linep}, args {@i[line]}] -This function returns @true if @i[line] is a @f[line] object, otherwise @nil. -@enddefun - -@defun[fun {line-string}, args {@i[line]}] -Given a @i(line), this function returns as a simple string the characters in -the line. This is @f[setf]'able to set the @f[line-string] to any string that -does not contain newline characters. It is an error to destructively modify -the result of @f[line-string] or to destructively modify any string after the -@f[line-string] of some line has been set to that string. -@enddefun - -@defun[fun {line-previous}, args {@i[line]}] -@defun1[fun {line-next}, args {@i[line]}] -Given a @i(line), @f[line-previous] returns the previous line or @nil if there -is no previous line. Similarly, @f[line-next] returns the line following -@i[line] or @nil. -@enddefun - -@defun[fun {line-buffer}, args {@i[line]}] -This function returns the buffer which contains this @i(line). Since a -line may not be associated with any buffer, in which case @f[line-buffer] -returns @nil. -@enddefun - -@defun[fun {line-length}, args {@i[line]}] -This function returns the number of characters in the @i(line). This excludes -the newline character at the end. -@enddefun - -@defun[fun {line-character}, args {@i[line] @i[index]}] -This function returns the character at position @i[index] within @i[line]. It -is an error for @i[index] to be greater than the length of the line or less -than zero. If @i[index] is equal to the length of the line, this returns a -@f[#\newline] character. -@enddefun - -@defun[fun {line-plist}, args {@i[line]}] -This function returns the property-list for @i[line]. @f[setf], @f[getf], -@f[putf] and @f[remf] can be used to change properties. This is typically used -in conjunction with @f[line-signature] to cache information about the line's -contents. -@enddefun - -@defun[fun {line-signature}, args {@i[line]}] -This function returns an object that serves as a signature for a @i[line]'s -contents. It is guaranteed that any modification of text on the line will -result in the signature changing so that it is not @f[eql] to any previous -value. The signature may change even when the text remains unmodified, but -this does not happen often. -@enddefun - - -@section(Marks) -@label[marks] -@index (Marks) -A mark indicates a specific position within the text represented by a line and -a character position within that line. Although a mark is sometimes loosely -referred to as pointing to some character, it in fact points between -characters. If the @f[charpos] is zero, the previous character is the newline -character separating the previous line from the mark's @f[line]. If the -charpos is equal to the number of characters in the line, the next character is -the newline character separating the current line from the next. If the mark's -line has no previous line, a mark with @f[charpos] of zero has no previous -character; if the mark's line has no next line, a mark with @f[charpos] equal -to the length of the line has no next character. - -This section discusses the very basic operations involving marks, but a lot of -@hemlock programming is built on altering some text at a mark. For more -extended uses of marks see chapter @ref[doing-stuff]. - - -@subsection(Kinds of Marks) -@index (Permanent marks) -@index (Temporary marks) -A mark may have one of two lifetimes: @i[temporary] or @i[permanent]. -Permanent marks remain valid after arbitrary operations on the text; temporary -marks do not. Temporary marks are used because less bookkeeping overhead is -involved in their creation and use. If a temporary mark is used after the text -it points to has been modified results will be unpredictable. Permanent marks -continue to point between the same two characters regardless of insertions and -deletions made before or after them. - -There are two different kinds of permanent marks which differ only in their -behavior when text is inserted @i(at the position of the mark); text is -inserted to the left of a @i[left-inserting] mark and to the right of -@i[right-inserting] mark. - - -@subsection(Mark Functions) -@defun[fun {markp}, args {@i[mark]}] -This function returns @true if @i[mark] is a @f[mark] object, otherwise @nil. -@enddefun - -@defun[fun {mark-line}, args {@i[mark]}] -This function returns the line to which @i(mark) points. -@enddefun - -@defun[fun {mark-charpos}, args {@i[mark]}] -This function returns the character position of the character after @i(mark). -If @i[mark]'s line has no next line, this returns the length of the line as -usual; however, there is actually is no character after the mark. -@enddefun - -@defun[fun {mark-kind}, args {@i[mark]}] -This function returns one of @kwd[right-inserting], @kwd[left-inserting] or -@kwd[temporary] depending on the mark's kind. A corresponding @f[setf] form -changes the mark's kind. -@enddefun - -@defun[fun {previous-character}, args {@i[mark]}] -@defun1[fun {next-character}, args {@i[mark]}] -This function returns the character immediately before (after) the position of -the @i[mark], or @nil if there is no previous (next) character. These -characters may be set with @f[setf] when they exist; the @f[setf] methods for -these forms signal errors when there is no previous or next character. -@enddefun - - -@subsection(Making Marks) -@defun[fun {mark}, args {@i[line] @i[charpos] @optional @i[kind]}] -This function returns a mark object that points to the @i(charpos)'th character -of the @i(line). @i(Kind) is the kind of mark to create, one of -@kwd[temporary], @kwd[left-inserting], or @kwd[right-inserting]. The default -is @kwd[temporary]. -@enddefun - -@defun[fun {copy-mark}, args {@i[mark] @optional @i[kind]}] -This function returns a new mark pointing to the same position and of the same -kind, or of kind @i[kind] if it is supplied. -@enddefun - -@defun[fun {delete-mark}, args {@i[mark]}] -This function deletes @i(mark). Delete any permanent marks when you are -finished using it. -@enddefun - -@Defmac[Fun {with-mark}, Args - {(@Mstar<(@i[mark] @i[pos] @mopt[@i(kind)])>) @Mstar<@i[form]>}] - This macro binds to each variable @i[mark] a mark of kind @i[kind], which -defaults to @kwd[temporary], pointing to the same position as the mark @i[pos]. -On exit from the scope the mark is deleted. The value of the last @i[form] is -the value returned. -@enddefmac - - -@subsection(Moving Marks) -@index(Moving marks) -These functions destructively modify marks to point to new positions. Other -sections of this document describe mark moving routines specific to higher -level text forms than characters and lines, such as words, sentences, -paragraphs, Lisp forms, etc. - -@defun[fun {move-to-position}, args {@i[mark] @i[charpos] @optional @i[line]}] -This function changes the @i(mark) to point to the given character position on -the line @i(line). @i(Line) defaults to @i[mark]'s line. -@enddefun - -@defun[fun {move-mark}, args {@i[mark] @i[new-position]}] -This function moves @i[mark] to the same position as the mark @i[new-position] -and returns it. -@enddefun - -@defun[fun {line-start}, args {@i[mark] @optional @i[line]}] -@defun1[fun {line-end}, args {@i[mark] @optional @i[line]}] -This function changes @i[mark] to point to the beginning or the end of @i(line) -and returns it. @i[Line] defaults to @i[mark]'s line. -@enddefun - -@defun[fun {buffer-start}, args {@i[mark] @optional @i[buffer]}] -@defun1[fun {buffer-end}, args {@i[mark] @optional @i[buffer]}] -These functions change @i[mark] to point to the beginning or end of @i[buffer], -which defaults to the buffer @i[mark] currently points into. If @i[buffer] is -unsupplied, then it is an error for @i[mark] to be disassociated from any -buffer. -@enddefun - -@defun[fun {mark-before}, args {@i[mark]}] -@defun1[fun {mark-after}, args {@i[mark]}] -These functions change @i[mark] to point one character before or after the -current position. If there is no character before/after the current position, -then they return @nil and leave @i[mark] unmodified. -@enddefun - -@defun[fun {character-offset}, args {@i[mark] @i[n]}] -This function changes @i[mark] to point @i[n] characters after (@i[n] before if -@i[n] is negative) the current position. If there are less than @i[n] -characters after (before) the @i[mark], then this returns @nil and @i[mark] is -unmodified. -@enddefun - -@defun[fun {line-offset}, args {@i[mark] @i[n] @optional @i[charpos]}] -This function changes @i[mark] to point @i[n] lines after (@i[n] before if -@i[n] is negative) the current position. The character position of the -resulting mark is -@lisp -(min (line-length @i(resulting-line)) (mark-charpos @i(mark))) -@endlisp -if @i[charpos] is unspecified, or -@lisp -(min (line-length @i(resulting-line)) @i(charpos)) -@endlisp -if it is. As with @t(character-offset), if there are not @i[n] lines then -@nil is returned and @i[mark] is not modified. -@enddefun - - -@section(Regions) -@index (Regions) -A region is simply a pair of marks: a starting mark and an ending mark. -The text in a region consists of the characters following the starting -mark and preceding the ending mark (keep in mind that a mark points between -characters on a line, not at them). - -By modifying the starting or ending mark in a region it is possible to -produce regions with a start and end which are out of order or even in -different buffers. The use of such regions is undefined and may -result in arbitrarily bad behavior. - - -@subsection(Region Functions) -@defun[fun {region}, args {@i[start] @i[end]}] -This function returns a region constructed from the marks @i[start] and -@i[end]. It is an error for the marks to point to non-contiguous lines or for -@i(start) to come after @i(end). -@enddefun - -@defun[fun {regionp}, args {@i[region]}] -This function returns @true if @i[region] is a @f[region] object, otherwise -@nil. -@enddefun - -@defun[fun {make-empty-region}] -This function returns a region with start and end marks pointing to the start -of one empty line. The start mark is a @kwd[right-inserting] mark, and the end -is a @kwd[left-inserting] mark. -@enddefun - -@defun[fun {copy-region}, args {@i[region]}] -This function returns a region containing a copy of the text in the specified -@i[region]. The resulting region is completely disjoint from @i[region] with -respect to data references @dash marks, lines, text, etc. -@enddefun - -@defun[fun {region-to-string}, args {@i[region]}] -@defun1[fun {string-to-region}, args {@i[string]}] -These functions coerce regions to Lisp strings and vice versa. Within the -string, lines are delimited by newline characters. -@enddefun - -@defun[fun {line-to-region}, args {@i[line]}] -This function returns a region containing all the characters on @i[line]. The -first mark is @kwd[right-inserting] and the last is @kwd[left-inserting]. -@enddefun - -@defun[fun {region-start}, args {@i[region]}] -@defun1[fun {region-end}, args {@i[region]}] -This function returns the start or end mark of @i(region). -@enddefun - -@defun[fun {region-bounds}, args {@i[region]}] -This function returns as multiple-values the starting and ending marks of -@i[region]. -@enddefun - -@defun[fun {set-region-bounds}, args {@i[region] @i[start] @i[end]}] -This function sets the start and end of region to @i[start] and @i[end]. It is -an error for @i[start] to be after or in a different buffer from @i[end]. -@enddefun - -@index(Counting lines and characters) -@defun[fun {count-lines}, args {@i[region]}] -This function returns the number of lines in the @i(region), first and last -lines inclusive. A newline is associated with the line it follows, thus a -region containing some number of non-newline characters followed by one newline -is one line, but if a newline were added at the beginning, it would be two -lines. -@enddefun - -@defun[fun {count-characters}, args {@i[region]}] -This function returns the number of characters in a given @i(region). This -counts line breaks as one character. -@enddefun - -@defun[fun {check-region-query-size}, args {@i[region]}] -@defhvar1[var {Region Query Size}, val {30}] -@f[check-region-query-size] counts the lines in @i[region], and if their number -exceeds the @hid[Region Query Size] threshold, it prompts the user for -confirmation. This should be used in commands that perform destructive -operations and are not undoable. If the user responds negatively, then this -signals an editor-error, aborting whatever command was in progress. -@enddefun - - - -@chapter(Buffers) -@index (Buffers) -@label[buffers] -A buffer is an environment within @hemlock consisting of: -@begin(enumerate) -A name. - -A piece of text. - -A current focus of attention, the point. - -An associated file (optional). - -A write protect flag. - -Some variables (page @pageref[variables]). - -Some key bindings (page @pageref[key-bindings]). - -Some collection of modes (page @pageref[modes]). - -Some windows in which it is displayed (page @pageref[windows]). - -A list of modeline fields (optional). -@end(enumerate) - - -@section (The Current Buffer) -@index (Current buffer) -@defun[fun {current-buffer}] -@defhvar1[var {Set Buffer Hook}] -@defhvar1[var {After Set Buffer Hook}] -@f[current-buffer] returns the current buffer object. Usually this is the -buffer that @funref[current-window] is displaying. This value may be changed -with @f[setf], and the @f[setf] method invokes @hid[Set Buffer Hook] before the -change occurs with the new value. After the change occurs, the method invokes -@hid[After Set Buffer Hook] with the old value. -@enddefun - -@defun[fun {current-point}] -This function returns the @f[buffer-point] of the current buffer. -This is such a common idiom in commands that it is defined despite -its trivial implementation. -@enddefun - -@defun[fun {current-mark}] -@defun1[fun {pop-buffer-mark}] -@defun1[fun {push-buffer-mark}, args {@i[mark] @optional @i[activate-region]}] -@index(Buffer mark stack) -@index(Mark stack) -@label(mark-stack) -@f[current-mark] returns the top of the current buffer's mark stack. There -always is at least one mark at the beginning of the buffer's region, and all -marks returned are right-inserting. - -@f[pop-buffer-mark] pops the current buffer's mark stack, returning the mark. -If the stack becomes empty, this pushes a new mark on the stack pointing to the -buffer's start. This always deactivates the current region (see section -@ref[active-regions]). - -@f[push-buffer-mark] pushes @i[mark] into the current buffer's mark stack, -ensuring that the mark is right-inserting. If @i[mark] does not point into the -current buffer, this signals an error. Optionally, the current region is made -active, but this never deactivates the current region (see section -@ref[active-regions]). @i[Mark] is returned. -@enddefun - -@defvar[var {buffer-list}] -This variable holds a list of all the buffer objects made with @f[make-buffer]. -@enddefvar - -@defvar[var {buffer-names}] -This variable holds a @f[string-table] (page @pageref(string-tables)) of all the -names of the buffers in @var[buffer-list]. The values of the entries are the -corresponding buffer objects. -@enddefvar - -@defvar[var {buffer-history}] -This is a list of buffer objects ordered from those most recently selected to -those selected farthest in the past. When someone makes a buffer, an element -of @hid[Make Buffer Hook] adds this buffer to the end of this list. When -someone deletes a buffer, an element of @hid[Delete Buffer Hook] removes the -buffer from this list. Each buffer occurs in this list exactly once, but it -never contains the @var[echo-area-buffer]. -@enddefvar - -@defun[fun {change-to-buffer}, args {@i[buffer]}] -This switches to @i[buffer] in the @f[current-window] maintaining -@f[buffer-history]. -@enddefun - -@defun[fun {previous-buffer}] -This returns the first buffer from @var[buffer-history] that is not the -@f[current-buffer]. If none can be found, then this returns @nil. -@enddefun - - -@section(Buffer Functions) -@defun[fun {make-buffer}, args {@i[name]}, keys {[modes][modeline-fields][delete-hook]}] -@defhvar1[var {Make Buffer Hook}] -@defhvar1[var {Default Modeline Fields}] -@f[make-buffer] creates and returns a buffer with the given @i(name). If a -buffer named @i[name] already exists, @nil is returned. @i[Modes] is a list of -modes which should be in effect in the buffer, major mode first, followed by -any minor modes. If this is omitted then the buffer is created with the list -of modes contained in @hvarref[Default Modes]. @i[Modeline-fields] is a list -of modeline-field objects (see section @ref[modelines]) which may be @nil. -@f[delete-hook] is a list of delete hooks specific to this buffer, and -@f[delete-buffer] invokes these along with @hid[Delete Buffer Hook]. - -Buffers created with @f[make-buffer] are entered into the list -@var[buffer-list], and their names are inserted into the -string-table @var[buffer-names]. When a buffer is created the hook -@hid[Make Buffer Hook] is invoked with the new buffer. -@enddefun - -@defun[fun {bufferp}, args {@i[buffer]}] -Returns @true if @i[buffer] is a @f[buffer] object, otherwise @nil. -@enddefun - -@defun[fun {buffer-name}, args {@i[buffer]}] -@defhvar1[var {Buffer Name Hook}] -@f[buffer-name] returns the name, which is a string, of the given @i(buffer). -The corresponding @f[setf] method invokes @hid[Buffer Name Hook] with -@i[buffer] and the new name and then sets the buffer's name. When the user -supplies a name for which a buffer already exists, the @f[setf] method signals -an error. -@enddefun - -@defun[fun {buffer-region}, args {@i[buffer]}] -Returns the @i[buffer]'s region. This can be set with @f[setf]. Note, this -returns the region that contains all the text in a buffer, not the -@funref[current-region]. -@enddefun - -@defun[fun {buffer-pathname}, args {@i[buffer]}] -@defhvar1[var {Buffer Pathname Hook}] -@f[buffer-pathname] returns the pathname of the file associated with -the given @i(buffer), or nil if it has no associated file. This is -the truename of the file as of the most recent time it was read or -written. There is a @f[setf] form to change the pathname. When the -pathname is changed the hook @hid[Buffer Pathname Hook] is invoked -with the buffer and new value. -@enddefun - -@defun[fun {buffer-write-date}, args {@i[buffer]}] -Returns the write date for the file associated with the buffer in universal -time format. When this the @f[buffer-pathname] is set, use @f[setf] to set -this to the corresponding write date, or to @nil if the date is unknown or -there is no file. -@enddefun - -@defun[fun {buffer-point}, args {@i[buffer]}] -Returns the mark which is the current location within @i[buffer]. To -move the point, use @f[move-mark] or @funref[move-to-position] rather -than setting @f[buffer-point] with @f[setf]. -@enddefun - -@defun[fun {buffer-mark}, args {@i[buffer]}] -@index(Buffer mark stack) -@index(Mark stack) -This function returns the top of @i[buffer]'s mark stack. There always -is at least one mark at the beginning of @i[buffer]'s region, and all marks -returned are right-inserting. -@enddefun - -@defun[fun {buffer-start-mark}, args {@i[buffer]}] -@defun1[fun {buffer-end-mark}, args {@i[buffer]}] -These functions return the start and end marks of @i[buffer]'s region: -@Begin[ProgramExample] -(buffer-start-mark buffer) <==> - (region-start (buffer-region buffer)) -and -(buffer-end-mark buffer) <==> - (region-end (buffer-region buffer)) -@End[ProgramExample] -@enddefun - -@defun[fun {buffer-writable}, args {@i[buffer]}] -@defhvar1[var "Buffer Writable Hook"] -This function returns @true if you can modify the @i(buffer), @nil if you -cannot. If a buffer is not writable, then any attempt to alter text in the -buffer results in an error. There is a @f[setf] method to change this value. - -The @f[setf] method invokes the functions in @hid[Buffer Writable Hook] on the -buffer and new value before storing the new value. -@enddefun - -@defun[fun {buffer-modified}, args {@i[buffer]}] -@defhvar1[var "Buffer Modified Hook"] -@f[buffer-modified] returns @true if the @i[buffer] has been modified, @nil if -it hasn't. This attribute is set whenever a text-altering operation is -performed on a buffer. There is a @f[setf] method to change this value. - -The @f[setf] method invokes the functions in @hid[Buffer Modified Hook] with -the buffer whenever the value of the modified flag changes. -@enddefun - -@defmac[fun {with-writable-buffer}, args {(@i[buffer]) @rest @i[forms]}] -This macro executes @i[forms] with @i[buffer]'s writable status set. After -@i[forms] execute, this resets the @i[buffer]'s writable and modified status. -@enddefmac - -@defun[fun {buffer-signature}, args {@i[buffer]}] -This function returns an arbitrary number which reflects the buffer's current -@i[signature]. The result is @f[eql] to a previous result if and only if the -buffer has not been modified between the calls. -@enddefun - -@defun[fun {buffer-variables}, args {@i[buffer]}] -This function returns a string-table (page @pageref[string-tables]) containing -the names of the buffer's local variables. See chapter @ref[variables]. -@enddefun - -@defun[fun {buffer-modes}, args {@i[buffer]}] -This function returns the list of the names of the modes active in @i[buffer]. -The major mode is first, followed by any minor modes. See chapter @ref[modes]. -@enddefun - -@defun[fun {buffer-windows}, args {@i[buffer]}] -This function returns the list of all the windows in which the buffer may be -displayed. This list may include windows which are not currently visible. See -page @pageref[windows] for a discussion of windows. -@enddefun - -@defun[fun {buffer-delete-hook}, args {@i[buffer]}] -This function returns the list of buffer specific functions @f[delete-buffer] -invokes when deleting a buffer. This is @f[setf]'able. -@enddefun - -@defun[fun {delete-buffer}, args {@i[buffer]}] -@defhvar1[var {Delete Buffer Hook}] -@f[delete-buffer] removes @i[buffer] from @varref[buffer-list] and its name -from @varref[buffer-names]. Before @i[buffer] is deleted, this invokes the -functions on @i[buffer] returned by @f[buffer-delete-hook] and those found in -@hid[Delete Buffer Hook]. If @i[buffer] is the @f[current-buffer], or if it is -displayed in any windows, then this function signals an error. -@enddefun - -@defun[fun {delete-buffer-if-possible}, args {@i[buffer]}] -This uses @f[delete-buffer] to delete @i[buffer] if at all possible. If -@i[buffer] is the @f[current-buffer], then this sets the @f[current-buffer] to -the first distinct buffer in @f[buffer-history]. If @i[buffer] is displayed in -any windows, then this makes each window display the same distinct buffer. -@enddefun - - -@section(Modelines) -@index(Modelines) -@label(modelines) - -A Buffer may specify a modeline, a line of text which is displayed across the -bottom of a window to indicate status information. Modelines are described as -a list of @f[modeline-field] objects which have individual update functions and -are optionally fixed-width. These have an @f[eql] name for convenience in -referencing and updating, but the name must be unique for all created -modeline-field objects. When creating a modeline-field with a specified width, -the result of the update function is either truncated or padded on the right to -meet the constraint. All modeline-field functions must return simple strings -with standard characters, and these take a buffer and a window as arguments. -Modeline-field objects are typically shared amongst, or aliased by, different -buffers' modeline fields lists. These lists are unique allowing fields to -behave the same wherever they occur, but different buffers may display these -fields in different arrangements. - -Whenever one of the following changes occurs, all of a buffer's modeline fields -are updated: -@Begin[Itemize] -A buffer's major mode is set. - -One of a buffer's minor modes is turned on or off. - -A buffer is renamed. - -A buffer's pathname changes. - -A buffer's modified status changes. - -A window's buffer is changed. -@End[Itemize] - -The policy is that whenever one of these changes occurs, it is guaranteed that -the modeline will be updated before the next trip through redisplay. -Furthermore, since the system cannot know what modeline-field objects the -user has added whose update functions rely on these values, or how he has -changed @hid[Default Modeline Fields], we must update all the fields. When any -but the last occurs, the modeline-field update function is invoked once for -each window into the buffer. When a window's buffer changes, each -modeline-field update function is invoked once; other windows' modeline -fields should not be affected due to a given window's buffer changing. - -The user should note that modelines can be updated at any time, so update -functions should be careful to avoid needless delays (for example, waiting for -a local area network to determine information). - -@defun[fun {make-modeline-field}, keys {[name][width][function]}] -@defun1[fun {modeline-field-p}, args @i(modeline-field)] -@defun1[fun {modeline-field-name}, args @i(modeline-field)] -@f[make-modeline-field] returns a modeline-field object with @i[name], -@i[width], and @i[function]. @i[Width] defaults to @nil meaning that the field -is variable width; otherwise, the programmer must supply this as a positive -integer. @i[Function] must take a buffer and window as arguments and return a -@f[simple-string] containing only standard characters. If @i[name] already -names a modeline-field object, then this signals an error. - -@f[modeline-field-name] returns the name field of a modeline-field object. If -this is set with @f[setf], and the new name already names a modeline-field, -then the @f[setf] method signals an error. - -@f[modeline-field-p] returns @true or @nil, depending on whether its argument -is a @f[modeline-field] object. -@enddefun - -@defun[fun {modeline-field}, args {@i[name]}] -This returns the modeline-field object named @i[name]. If none exists, this -returns nil. -@enddefun - -@defun[fun {modeline-field-function}, args {@i[modeline-field]}] -Returns the function called when updating the @i[modeline-field]. When this is -set with @f[setf], the @f[setf] method updates @i[modeline-field] for all -windows on all buffers that contain the given field, so the next trip through -redisplay will reflect the change. All modeline-field functions must return -simple strings with standard characters, and they take a buffer and a window -as arguments. -@enddefun - -@defun[fun {modeline-field-width}, args {@i[modeline-field]}] -Returns the width to which @i[modeline-field] is constrained, or @nil -indicating that it is variable width. When this is set with @f[setf], the -@f[setf] method updates all modeline-fields for all windows on all buffers that -contain the given field, so the next trip through redisplay will reflect the -change. All the fields for any such modeline display must be updated, which is -not the case when setting a modeline-field's function. -@enddefun - -@defun[fun {buffer-modeline-fields}, args {@i[buffer]}] -Returns a copy of the list of @i[buffer]'s modeline-field objects. This list -can be destructively modified without affecting display of @i[buffer]'s -modeline, but modifying any particular field's components (for example, width -or function) causes the changes to be reflected the next trip through redisplay -in every modeline display that uses the modified modeline-field. When this is -set with @f[setf], @f[update-modeline-fields] is called for each window into -@i[buffer]. -@enddefun - -@defun[fun {buffer-modeline-field-p}, args {@i[buffer] @i[field]}] -If @i[field], a modeline-field or the name of one, is in buffer's list of -modeline-field objects, it is returned; otherwise, this returns nil. -@enddefun - -@defun[fun {update-modeline-fields}, args {@i[buffer] @i[window]}] -This invokes each modeline-field object's function from @i[buffer]'s list, -passing @i[buffer] and @i[window]. The results are collected regarding each -modeline-field object's width as appropriate, and the window is marked so -the next trip through redisplay will reflect the changes. If window does not -display modelines, then no computation occurs. -@enddefun - -@defun[fun {update-modeline-field}, args {@i[buffer] @i[window] @i[field-or-name}] -This invokes the modeline-field object's function for @i[field-or-name], which -is a modeline-field object or the name of one for @i[buffer]. This passes -@i[buffer] and @i[window] to the update function. The result is applied to the -@i[window]'s modeline display using the modeline-field object's width, and the -window is marked so the next trip through redisplay will reflect the changes. -If the window does not display modelines, then no computation occurs. If -@i[field-or-name] is not found in @i[buffer]'s list of modeline-field objects, -then this signals an error. See @f[buffer-modeline-field-p] above. -@enddefun - - - -@chapter(Altering and Searching Text) -@label[doing-stuff] - -@section(Altering Text) -@index(Altering text) -@index(Inserting) -@index(Deleting) -A note on marks and text alteration: @kwd[temporary] marks are invalid -after any change has been made to the text the mark points to; it is an -error to use a temporary mark after such a change has been made. If -text is deleted which has permanent marks pointing into it then they -are left pointing to the position where the text was. - -@defun[fun {insert-character}, args {@i[mark] @i[character]}] -@defun1[fun {insert-string}, args {@i[mark] @i[string]}] -@defun1[fun {insert-region}, args {@i[mark] @i[region]}] -Inserts @i[character], @i[string] or @i[region] at @i[mark]. -@f[insert-character] signals an error if @i[character] is not -@f[string-char-p]. If @i[string] or @i[region] is empty, and @i[mark] is in -some buffer, then @hemlock leaves @f[buffer-modified] of @i[mark]'s buffer -unaffected. -@enddefun - -@defun[fun {ninsert-region}, args {@i[mark] @i[region]}] -Like @f[insert-region], inserts the @i[region] at the @i[mark]'s position, -destroying the source region. This must be used with caution, since if anyone -else can refer to the source region bad things will happen. In particular, one -should make sure the region is not linked into any existing buffer. If -@i[region] is empty, and @i[mark] is in some buffer, then @hemlock leaves -@f[buffer-modified] of @i[mark]'s buffer unaffected. -@enddefun - -@defun[fun {delete-characters}, args {@i[mark] @i[n]}] -This deletes @i[n] characters after the @i[mark] (or -@i[n] before if @i[n] is -negative). If @i[n] characters after (or -@i[n] before) the @i[mark] do not -exist, then this returns @nil; otherwise, it returns @true. If @i[n] is zero, -and @i[mark] is in some buffer, then @hemlock leaves @f[buffer-modified] of -@i[mark]'s buffer unaffected. -@enddefun - -@defun[fun {delete-region}, args {@i[region]}] -This deletes @i[region]. This is faster than @f[delete-and-save-region] -(below) because no lines are copied. If @i[region] is empty and contained in -some buffer's @f[buffer-region], then @hemlock leaves @f[buffer-modified] of -the buffer unaffected. -@enddefun - -@defun[fun {delete-and-save-region}, args {@i[region]}] -This deletes @i[region] and returns a region containing the original -@i[region]'s text. If @i[region] is empty and contained in some buffer's -@f[buffer-region], then @hemlock leaves @f[buffer-modified] of the buffer -unaffected. In this case, this returns a distinct empty region. -@enddefun - -@defun[fun {filter-region}, args {@i[function] @i[region]}] -Destructively modifies @i[region] by replacing the text -of each line with the result of the application of @i[function] to a -string containing that text. @i[Function] must obey the following -restrictions: -@begin[enumerate] -The argument may not be destructively modified. - -The return value may not contain newline characters. - -The return value may not be destructively modified after it is -returned from @i[function]. -@end[enumerate] -The strings are passed in order, and are always simple strings. - -Using this function, a region could be uppercased by doing: -@lisp -(filter-region #'string-upcase region) -@endlisp -@enddefun - - -@section(Text Predicates) -@defun[fun {start-line-p}, args {@i[mark]}] -Returns @true if the @i(mark) points before the first character in a line, -@nil otherwise. -@enddefun - -@defun[fun {end-line-p}, args {@i[mark]}] -Returns @true if the @i(mark) points after the last character in a line and -before the newline, @nil otherwise. -@enddefun - -@defun[fun {empty-line-p}, args {@i[mark]}] -Return @true of the line which @i[mark] points to contains no characters. -@enddefun - -@defun[fun {blank-line-p}, args {@i[line]}] -Returns @true if @i[line] contains only characters with a -@hid[Whitespace] attribute of 1. See chapter @ref[character-attributes] for -discussion of character attributes. -@enddefun - -@defun[fun {blank-before-p}, args {@i[mark]}] -@defun1[fun {blank-after-p}, args {@i[mark]}] -These functions test if all the characters preceding or following -@i[mark] on the line it is on have a @hid[Whitespace] attribute of @f[1]. -@enddefun - -@defun[fun {same-line-p}, args {@i[mark1] @i[mark2]}] -Returns @true if @i(mark1) and @i(mark2) point to the same line, or @nil -otherwise; That is, -@example[(same-line-p a b) <==> (eq (mark-line a) (mark-line b))] -@enddefun - -@defun[fun {mark<}, funlabel {mark-LSS}, args {@i[mark1] @i[mark2]}] -@defun1[fun {mark<=}, funlabel {mark-LEQ}, args {@i[mark1] @i[mark2]}] -@defun1[fun {mark=}, funlabel {mark-EQL}, args {@i[mark1] @i[mark2]}] -@defun1[fun {mark/=}, funlabel {mark-NEQ}, args {@i[mark1] @i[mark2]}] -@defun1[fun {mark>=}, funlabel {mark-GEQ}, args {@i[mark1] @i[mark2]}] -@defun1[fun {mark>}, funlabel {mark-GTR}, args {@i[mark1] @i[mark2]}] -These predicates test the relative ordering of two marks in a piece of -text, that is a mark is @f[mark>] another if it points to a position -after it. If the marks point into different, non-connected pieces of -text, such as different buffers, then it is an error to test their -ordering; for such marks @f[mark=] is always false and @f[mark/=] is -always true. -@enddefun - -@defun[fun {line<}, funlabel {line-LSS}, args {@i[line1] @i[line2]}] -@defun1[fun {line<=}, funlabel {line-LEQ}, args {@i[line1] @i[line2]}] -@defun1[fun {line>=}, funlabel {line-GEQ}, args {@i[line1] @i[line2]}] -@defun1[fun {line>}, funlabel {line-GTR}, args {@i[line1] @i[line2]}] -These predicates test the ordering of @i[line1] and @i[line2]. If the -lines are in unconnected pieces of text it is an error to test their -ordering. -@enddefun - -@defun[fun {lines-related}, args {@i[line1] @i[line2]}] -This function returns @true if @i[line1] and @i[line2] are in the same -piece of text, or @nil otherwise. -@enddefun - -@defun[fun {first-line-p}, args {@i[mark]}] -@defun1[fun {last-line-p}, args {@i[mark]}] -@f[first-line-p] returns @true if there is no line before the line -@i[mark] is on, and @nil otherwise. @i[Last-line-p] similarly tests -tests whether there is no line after @i[mark]. -@enddefun - - -@section(Kill Ring) -@index(Kill ring) -@label(kill-ring) - -@defvar[var {kill-ring}] -This is a ring (see section @ref[rings]) of regions deleted from buffers. -Some commands save affected regions on the kill ring before performing -modifications. You should consider making the command undoable (see section -@ref[undo]), but this is a simple way of achieving a less satisfactory means -for the user to recover. -@enddefvar - -@defun[fun {kill-region}, args {@i[region] @i[current-type]}] -This kills @i[region] saving it in @var[kill-ring]. @i[Current-type] is either -@kwd[kill-forward] or @kwd[kill-backward]. When the @funref[last-command-type] -is one of these, this adds @i[region] to the beginning or end, respectively, of -the top of @var[kill-ring]. The result of calling this is undoable using the -command @hid[Undo] (see the @i[Hemlock User's Manual]). This sets -@f[last-command-type] to @i[current-type], and it interacts with -@f[kill-characters]. -@enddefun - -@defun[fun {kill-characters}, args {@i[mark] @i[count]}] -@defhvar1[var {Character Deletion Threshold}, val {5}] -@f[kill-characters] kills @i[count] characters after @i[mark] if @i[count] is -positive, otherwise before @i[mark] if @i[count] is negative. When @i[count] -is greater than or equal to @hid[Character Deletion Threshold], the killed -characters are saved on @var[kill-ring]. This may be called multiple times -contiguously (that is, without @funref[last-command-type] being set) to -accumulate an effective count for purposes of comparison with the threshold. - -This sets @f[last-command-type], and it interacts with @f[kill-region]. When -this adds a new region to @var[kill-ring], it sets @f[last-command-type] to -@kwd[kill-forward] (if @i[count] is positive) or @kwd[kill-backward] (if -@i[count] is negative). When @f[last-command-type] is @kwd[kill-forward] or -@kwd[kill-backward], this adds the killed characters to the beginning (if -@i[count] is negative) or the end (if @i[count] is positive) of the top of -@var[kill-ring], and it sets @f[last-command-type] as if it added a new region -to @var[kill-ring]. When the kill ring is unaffected, this sets -@f[last-command-type] to @kwd[char-kill-forward] or @kwd[char-kill-backward] -depending on whether @i[count] is positive or negative, respectively. - -This returns mark if it deletes characters. If there are not @i[count] -characters in the appropriate direction, this returns nil. -@enddefun - - -@section(Active Regions) -@index(Active regions) -@label(active-regions) - -Every buffer has a mark stack (page @pageref[mark-stack]) and a mark known as -the point where most text altering nominally occurs. Between the top of the -mark stack, the @f[current-mark], and the @f[current-buffer]'s point, the -@f[current-point], is what is known as the @f[current-region]. Certain -commands signal errors when the user tries to operate on the @f[current-region] -without its having been activated. If the user turns off this feature, then -the @f[current-region] is effectively always active. - -When writing a command that marks a region of text, the programmer should make -sure to activate the region. This typically occurs naturally from the -primitives that you use to mark regions, but sometimes you must explicitly -activate the region. These commands should be written this way, so they do not -require the user to separately mark an area and then activate it. Commands -that modify regions do not have to worry about deactivating the region since -modifying a buffer automatically deactivates the region. Commands that insert -text often activate the region ephemerally; that is, the region is active for -the immediately following command, allowing the user wants to delete the region -inserted, fill it, or whatever. - -Once a marking command makes the region active, it remains active until: -@begin[itemize] -a command uses the region, - -a command modifies the buffer, - -a command changes the current window or buffer, - -a command signals an editor-error, - -or the user types @binding[C-g]. -@end[itemize] - -@defhvar[var "Active Regions Enabled", val {t}] -When this variable is non-@nil, some primitives signal an editor-error if -the region is not active. This may be set to @nil for more traditional @emacs -region semantics. -@enddefhvar - -@defvar[var {ephemerally-active-command-types}] -This is a list of command types (see section @ref[command-types]), and its -initial value is the list of @kwd[ephemerally-active] and @kwd[unkill]. When -the previous command's type is one of these, the @f[current-region] is active -for the currently executing command only, regardless of whether it does -something to deactivate the region. However, the current command may activate -the region for future commands. @kwd[ephemerally-active] is a default command -type that may be used to ephemerally activate the region, and @kwd[unkill] is -the type used by two commands, @hid[Un-kill] and @hid[Rotate Kill Ring] (what -users typically think of as @binding[C-y] and @binding[M-y]). -@enddefvar - -@defun[fun {activate-region}] -This makes the @f[current-region] active. -@enddefun - -@defun[fun {deactivate-region}] -After invoking this the @f[current-region] is no longer active. -@enddefun - -@defun[fun {region-active-p}] -Returns whether the @f[current-region] is active, including ephemerally. This -ignores @hid[Active Regions Enabled]. -@enddefun - -@defun[fun {check-region-active}] -This signals an editor-error when active regions are enabled, and the -@f[current-region] is not active. -@enddefun - -@defun[fun {current-region}, - args {@optional @i[error-if-not-active] @i[deactivate-region]}] -This returns a region formed with @f[current-mark] and @f[current-point], -optionally signaling an editor-error if the current region is not active. -@i[Error-if-not-active] defaults to @true. Each call returns a distinct region -object. Depending on @i[deactivate-region] (defaults to @true), fetching the -current region deactivates it. @hemlock primitives are free to modify text -regardless of whether the region is active, so a command that checks for this -can deactivate the region whenever it is convenient. -@enddefun - - -@section(Searching and Replacing) -@index(Searching) -@index(Replacing) - -Before using any of these functions to do a character search, look at character -attributes (page @pageref[character-attributes]). They provide a facility -similar to the syntax table in real EMACS. Syntax tables are a powerful, -general, and efficient mechanism for assigning meanings to characters in -various modes. - -@defcon[var {search-char-code-limit}] -An exclusive upper limit for the char-code of characters given to the searching -functions. The result of searches for characters with a char-code greater than -or equal to this limit is ill-defined, but it is @i[not] an error to do such -searches. -@enddefcon - -@defun[fun {new-search-pattern}, -args {@i[kind] @i[direction] @i[pattern] @optional @i[result-search-pattern]}] - -Returns a @i[search-pattern] object which can be given to the @f[find-pattern] -and @f[replace-pattern] functions. A search-pattern is a specification of a -particular sort of search to do. @i[direction] is either @kwd[forward] or -@kwd[backward], indicating the direction to search in. @i[kind] specifies the -kind of search pattern to make, and @i[pattern] is a thing which specifies what -to search for. - -The interpretation of @i[pattern] depends on the @i[kind] of pattern being -made. Currently defined kinds of search pattern are: -@begin(description) -@kwd[string-insensitive]@\Does a case-insensitive string search, -@i[pattern] being the string to search for. - -@kwd[string-sensitive]@\Does a case-sensitive string search for -@i[pattern]. - -@kwd[character]@\Finds an occurrence of the character @i[pattern]. -This is case sensitive. - -@kwd[not-character]@\Find a character which is not the character -@i[pattern]. - -@kwd[test]@\Finds a character which satisfies the function @i[pattern]. -This function may not be applied an any particular fashion, so it -should depend only on what its argument is, and should have no -side-effects. - -@kwd[test-not]@\Similar to as @kwd[test], except it finds a character that -fails the test. - -@kwd[any]@\Finds a character that is in the string @i[pattern]. - -@kwd[not-any]@\Finds a character that is not in the string @i[pattern]. -@end(description) - -@i[result-search-pattern], if supplied, is a search-pattern to -destructively modify to produce the new pattern. Where reasonable -this should be supplied, since some kinds of search patterns may -involve large data structures. -@enddefun - -@defun[fun {search-pattern-p}, args {@i[search-pattern]}] -Returns @true if @i[search-pattern] is a @f[search-pattern] object, otherwise -@nil. -@enddefun - -@defun[fun {get-search-pattern}, args {@i[string] @i[direction]}] -@defvar1[var {last-search-pattern}] -@defvar1[var {last-search-string}] -@f[get-search-pattern] interfaces to a default search string and pattern that -search and replacing commands can use. These commands then share a default -when prompting for what to search or replace, and save on consing a search -pattern each time they execute. This uses @hid[Default Search Kind] (see the -@i[Hemlock User's Manual]) when updating the pattern object. This returns the -pattern, so you probably don't need to refer to @var[last-search-pattern], but -@var[last-search-string] is useful when prompting. -@enddefun - -@defun[fun {find-pattern}, args {@i[mark] @i[search-pattern]}] -Find the next match of @i[search-pattern] starting at @i[mark]. If a -match is found then @i[mark] is altered to point before the matched text -and the number of characters matched is returned. If no match is -found then @nil is returned and @i[mark] is not modified. -@enddefun - -@defun[fun {replace-pattern}, args - {@i[mark] @i[search-pattern] @i[replacement] @optional @i[n]}] -Replace @i[n] matches of @i[search-pattern] with the string -@i[replacement] starting at @i[mark]. If @i[n] is @nil (the default) -then replace all matches. A mark pointing before the last replacement -done is returned. -@enddefun - - - -@Chapter(The Current Environment) -@label(current-environment) -@index(Current environment) - -@section(Different Scopes) - In @hemlock the values of @i[variables] (page @pageref[variables]), -@i[key-bindings] (page @pageref(key-bindings)) and -@i[character-attributes] (page @pageref[character-attributes]) may -depend on the @funref(current-buffer) and the modes -active in it. There are three possible scopes for -@hemlock values: -@begin(description) -@i[buffer local]@\The value is present only if the buffer it is local -to is the @f[current-buffer]. - -@i[mode local]@\The value is present only when the mode it is local to -is active in the @f[current-buffer]. - -@i[global]@\The value is always present unless shadowed by a buffer or -mode local value. -@end(description) - - -@section(Shadowing) - It is possible for there to be a conflict between different values -for the same thing in different scopes. For example, there be might a -global binding for a given variable and also a local binding in the -current buffer. Whenever there is a conflict shadowing occurs, -permitting only one of the values to be visible in the current -environment. - - The process of resolving such a conflict can be described as a -search down a list of places where the value might be defined, returning -the first value found. The order for the search is as follows: -@begin(enumerate) -Local values in the current buffer. - -Mode local values in the minor modes of the current buffer, in order -from the highest precedence mode to the lowest precedence mode. The -order of minor modes with equal precedences is undefined. - -Mode local values in the current buffer's major mode. - -Global values. -@end(enumerate) - - - -@chapter(Hemlock Variables) -@index (Hemlock variables) -@label(variables) -@hemlock implements a system of variables separate from normal Lisp variables -for the following reasons: -@begin(enumerate) -@hemlock has different scoping rules which are useful in an editor. @hemlock -variables can be local to a @i(buffer) (page @pageref[buffers]) or a @i(mode) -(page @pageref[modes]). - -@hemlock variables have @i(hooks) (page @pageref[hooks]), lists of functions -called when someone sets the variable. See @f[variable-value] for the -arguments @hemlock passes to these hook functions. - -There is a database of variable names and documentation which makes it easier -to find out what variables exist and what their values mean. -@end(enumerate) - - -@section(Variable Names) -To the user, a variable name is a case insensitive string. This -string is referred to as the @i[string name] of the variable. A -string name is conventionally composed of words separated by spaces. - -In Lisp code a variable name is a symbol. The name of this symbol is -created by replacing any spaces in the string name with hyphens. This -symbol name is always interned in the @hemlock package and referring -to a symbol with the same name in the wrong package is an error. - -@defvar[var {global-variable-names}] -This variable holds a string-table of the names of all the global @hemlock -variables. The value of each entry is the symbol name of the variable. -@enddefvar - -@defun[fun {current-variable-tables}] -This function returns a list of variable tables currently established, -globally, in the @f[current-buffer], and by the modes of the -@f[current-buffer]. This list is suitable for use with -@f[prompt-for-variable]. -@enddefun - - -@section(Variable Functions) -In the following descriptions @i[name] is the symbol name of the variable. - -@defun[fun {defhvar}, args {@i[string-name] @i[documentation]}, - keys {[mode][buffer][hooks][value]}] - This function defines a @hemlock variable. Functions that take a variable -name signal an error when the variable is undefined. -@begin(description) -@i[string-name]@\The string name of the variable to define. - -@i[documentation]@\The documentation string for the variable. - -@multiple{ -@kwd[mode], -@kwd[buffer]}@\ - If @i[buffer] is supplied, the variable is local to that buffer. If @i[mode] -is supplied, it is local to that mode. If neither is supplied, it is global. - -@kwd[value]@\ - This is the initial value for the variable, which defaults to @nil. - -@kwd[hooks]@\ - This is the initial list of functions to call when someone sets the variable's -value. These functions execute before @hemlock establishes the new value. See -@f[variable-value] for the arguments passed to the hook functions. -@end(description) -If a variable with the same name already exists in the same place, then -@f[defhvar] sets its hooks and value from @i[hooks] and @i[value] if the user -supplies these keywords. -@enddefun - -@defun[fun {variable-value}, args {@i[name] @optional @i[kind] @i[where]}] -This function returns the value of a @hemlock variable in some place. -The following values for @i[kind] are defined: -@begin[description] -@kwd[current]@\ - Return the value present in the current environment, taking into consideration -any mode or buffer local variables. This is the default. - -@kwd[global]@\ - Return the global value. - -@kwd[mode]@\ - Return the value in the mode named @i[where]. - -@kwd[buffer]@\ - Return the value in the buffer @i[where]. -@end[description] -When set with @f[setf], @hemlock sets the value of the specified variable and -invokes the functions in its hook list with @i[name], @i[kind], @i[where], and -the new value. -@enddefun - -@defun[fun {variable-documentation}, args - {@i[name] @optional @i[kind] @i[where]}] -@defun1[fun {variable-hooks}, args - {@i[name] @optional @i[kind] @i[where]}] -@defun1[fun {variable-name}, args - {@i[name] @optional @i[kind] @i[where]}] -These function return the documentation, hooks and string name of a -@hemlock variable. The @i[kind] and @i[where] arguments are the same -as for @f[variable-value]. The documentation and hook list may be set -using @f[setf]. -@enddefun - -@defun[fun {string-to-variable}, args {@i[string]}] -This function converts a string into the corresponding variable symbol -name. @i[String] need not be the name of an actual @hemlock variable. -@enddefun - -@defmac[fun {value}, args {@i[name]}] -@defmac1[fun {setv}, args {@i[name] @i[new-value]}] -These macros get and set the current value of the @hemlock variable -@i[name]. @i[Name] is not evaluated. There is a @f[setf] form for -@f[value]. -@enddefmac - -@Defmac[Fun {hlet}, Args {(@Mstar<(@i[var] @i[value])>) @Mstar<@i[form]>}] -This macro is very similar to @f[let] in effect; within its scope each -of the @hemlock variables @i[var] have the respective @i[value]s, but -after the scope is exited by any means the binding is removed. This -does not cause any hooks to be invoked. The value of the last -@i[form] is returned. -@enddefmac - -@defun[fun {hemlock-bound-p}, args {@i[name] @optional @i[kind] @i[where]}] -Returns @true if @i[name] is defined as a @hemlock variable in the -place specified by @i[kind] and @i[where], or @nil otherwise. -@enddefun - -@defun[fun {delete-variable}, args {@i(name) @optional @i[kind] @i[where]}] -@defhvar1[var {Delete Variable Hook}] -@f[delete-variable] makes the @hemlock variable @i[name] no longer -defined in the specified place. @i[Kind] and @i[where] have the same -meanings as they do for @f[variable-value], except that @kwd[current] -is not available, and the default for @i[kind] is @kwd[global] - -An error will be signaled if no such variable exists. The hook, -@hid[Delete Variable Hook] is invoked with the same arguments before the -variable is deleted. -@enddefun - - -@section(Hooks) -@index(Hooks) -@label[hooks] -@hemlock actions such as setting variables, changing buffers, changing windows, -turning modes on and off, etc., often have hooks associated with them. A hook -is a list of functions called before the system performs the action. The -manual describes the object specific hooks with the rest of the operations -defined on these objects. - -Often hooks are stored in @hemlock variables, @hid[Delete Buffer Hook] and -@hid[Set Window Hook] for example. This leads to a minor point of confusion -because these variables have hooks that the system executes when someone -changes their values. These hook functions @hemlock invokes when someone sets -a variable are an example of a hook stored in an object instead of a @hemlock -variable. These are all hooks for editor activity, but @hemlock keeps them in -different kinds of locations. This is why some of the routines in this section -have a special interpretation of the hook @i[place] argument. - -@defmac[fun {add-hook}, args {@i[place] @i[hook-fun]}] -@defmac1[fun {remove-hook}, args {@i[place] @i[hook-fun]}] -These macros add or remove a hook function in some @i[place]. If @i[hook-fun] -already exists in @i[place], this call has no effect. If @i[place] is a -symbol, then it is a @hemlock variable; otherwise, it is a generalized variable -or storage location. Here are two examples: -@Begin[ProgramExample] -(add-hook delete-buffer-hook 'remove-buffer-from-menu) - -(add-hook (variable-hooks 'check-mail-interval) - 'reschedule-mail-check) -@End[ProgramExample] -@enddefmac - -@defmac[fun {invoke-hook}, args {@i[place] @rest @i[args]}] -This macro calls all the functions in @i[place]. If @i[place] is a symbol, -then it is a @hemlock variable; otherwise, it is a generalized variable. -@enddefun - - - -@chapter(Commands) -@index (Commands) -@label[commands] - - -@section(Introduction) -The way that the user tells @hemlock to do something is by invoking a -@i(command). Commands have three attributes: -@begin(description) -@i[name]@\A command's name provides a way to refer to it. Command -names are usually capitalized words separated by spaces, such as -@hid[Forward Word]. - -@i[documentation]@\The documentation for a command is used by -on-line help facilities. - -@i[function]@\A command is implemented by a Lisp function, which is callable -from Lisp. -@end(description) - -@defvar[var {command-names}] -Holds a string-table (page @pageref[string-tables]) associating -command names to command objects. Whenever a new command is defined -it is entered in this table. -@enddefvar - - -@subsection(Defining Commands) - -@defmac[fun {defcommand}, args -{@^@mgroup<@i[command-name] @MOR (@i[command-name] @i[function-name])> @i[lambda-list] -@\@i[command-doc] @i[function-doc] @mstar<@i[form]>}] - -Defines a command named @i[name]. @f[defcommand] creates a function to -implement the command from the @i[lambda-list] and @i[form]'s supplied. The -@i[lambda-list] must specify one required argument, see section -@ref[invoking-commands-as-functions], which by convention is typically named -@f[p]. If the caller does not specify @i[function-name], @f[defcommand] -creates the command name by replacing all spaces with hyphens and appending -"@f[-command]". @i[Function-doc] becomes the documentation for the function -and should primarily describe issues involved in calling the command as a -function, such as what any additional arguments are. @i[Command-doc] becomes -the command documentation for the command. @enddefmac - -@defun[fun {make-command}, args - {@i[name] @i[documentation] @i[function]}] -Defines a new command named @i[name], with command documentation -@I[documentation] and function @i[function]. The command in entered -in the string-table @varref[command-names], with the command object as -its value. Normally command implementors will use the @f[defcommand] -macro, but this permits access to the command definition mechanism at -a lower level, which is occasionally useful. -@enddefun - -@defun[fun {commandp}, args {@i[command]}] -Returns @true if @i[command] is a @f[command] object, otherwise @nil. -@enddefun - -@defun[fun {command-documentation}, args {@i[command]}] -@defun1[fun {command-function}, args {@i[command]}] -@defun1[fun {command-name}, args {@i[command]}] -Returns the documentation, function, or name for @i[command]. These -may be set with @f[setf]. -@enddefun - - -@subsection(Command Documentation) -@i[Command documentation] is a description of what the command does -when it is invoked as an extended command or from a key. Command -documentation may be either a string or a function. If the -documentation is a string then the first line should briefly summarize -the command, with remaining lines filling the details. Example: -@lisp -(defcommand "Forward Character" (p) - "Move the point forward one character. - With prefix argument move that many characters, with negative - argument go backwards." - "Move the point of the current buffer forward p characters." - . . .) -@endlisp - -Command documentation may also be a function of one argument. The -function is called with either @kwd[short] or @kwd[full], indicating -that the function should return a short documentation string or do -something to document the command fully. - - -@section(The Command Interpreter) -@index[Interpreter, command] -@index[Invocation, command] -@index[Command interpreter] - -The @i[command interpreter] is a function which reads key-events (see section -@ref[key-events-intro]) from the keyboard and dispatches to different commands -on the basis of what the user types. When the command interpreter executes a -command, we say it @i[invokes] the command. The command interpreter also -provides facilities for communication between commands contiguously running -commands, such as a last command type register. It also takes care of -resetting communication mechanisms, clearing the echo area, displaying partial -keys typed slowly by the user, etc. - -@defvar[var {invoke-hook}] -This variable contains a function the command interpreter calls when it wants -to invoke a command. The function receives the command and the prefix argument -as arguments. The initial value is a function which simply funcalls the -@f[command-function] of the command with the supplied prefix argument. This is -useful for implementing keyboard macros and similar things. -@enddefhvar - -@defhvar[var "Command Abort Hook"] -The command interpreter invokes the function in this variable whenever someone -aborts a command (for example, if someone called @f[editor-error]). -@enddefhvar - -When @hemlock initially starts the command interpreter is in control, but -commands may read from the keyboard themselves and assign whatever -interpretation they will to the key-events read. Commands may call the command -interpreter recursively using the function @funref[recursive-edit]. - - -@subsection(Editor Input) -@label[key-events-intro] -@index[key-events] - -The canonical representation of editor input is a key-event structure. Users -can bind commands to keys (see section @ref[key-bindings]), which are non-zero -length sequences of key-events. A key-event consists of an identifying token -known as a @i[keysym] and a field of bits representing modifiers. Users define -keysyms, integers between 0 and 65535 inclusively, by supplying names that -reflect the legends on their keyboard's keys. Users define modifier names -similarly, but the system chooses the bit and mask for recognizing the -modifier. You can use keysym and modifier names to textually specify -key-events and Hemlock keys in a @f[#k] syntax. The following are some -examples: -@begin[programexample] - #k"C-u" - #k"Control-u" - #k"c-m-z" - #k"control-x meta-d" - #k"a" - #k"A" - #k"Linefeed" -@end[programexample] -This is convenient for use within code and in init files containing -@f[bind-key] calls. - -The @f[#k] syntax is delimited by double quotes, but the system parses the -contents rather than reading it as a Common Lisp string. Within the double -quotes, spaces separate multiple key-events. A single key-event optionally -starts with modifier names terminated by hyphens. Modifier names are -alphabetic sequences of characters which the system uses case-insensitively. -Following modifiers is a keysym name, which is case-insensitive if it consists -of multiple characters, but if the name consists of only a single character, -then it is case-sensitive. - -You can escape special characters @dash hyphen, double quote, open angle -bracket, close angle bracket, and space @dash with a backslash, and you can -specify a backslash by using two contiguously. You can use angle brackets to -enclose a keysym name with many special characters in it. Between angle -brackets appearing in a keysym name position, there are only two special -characters, the closing angle bracket and backslash. - -For more information on key-events see section @ref[key-events]. - - - -@subsection(Binding Commands to Keys) -@label[Key-Bindings] -@Index[Key Bindings] - -The command interpreter determines which command to invoke on the basis of -@i[key bindings]. A key binding is an association between a command and a -sequence of key-events (see section @ref[key-events-intro]. A sequence of -key-events is called a @i[key] and is represented by a single key-event or a -sequence (list or vector) of key-events. - -Since key bindings may be local to a mode or buffer, the current environment -(page @pageref[current-environment]) determines the set of key bindings in -effect at any given time. When the command interpreter tries to find the -binding for a key, it first checks if there is a local binding in the -@w[@funref[current-buffer]], then if there is a binding in each of the minor -modes and the major mode for the current buffer @w[(page @pageref[modes])], and -finally checks to see if there is a global binding. If no binding is found, -then the command interpreter beeps or flashes the screen to indicate this. - -@defun[fun {bind-key}, args - {@i(name) @i(key) @optional @i[kind] @i[where]}] - This function associates command @i[name] and @i[key] in some environment. -@i[Key] is either a key-event or a sequence of key-events. There are three -possible values of @i[kind]: -@begin(description) -@kwd[global]@\ - The default, make a global key binding. - -@kwd[mode]@\ - Make a mode specific key binding in the mode whose name is @i[where]. - -@kwd[buffer]@\ - Make a binding which is local to buffer @i[where]. -@end(description) - -This processes @i[key] for key translations before establishing the binding. -See section @ref[key-trans]. - -If the key is some prefix of a key binding which already exists in the -specified place, then the new one will override the old one, effectively -deleting it. - -@f[ext:do-alpha-key-events] is useful for setting up bindings in certain new -modes. -@enddefun - -@defun[fun {command-bindings}, args {@i[command]}] -This function returns a list of the places where @i[command] is bound. A place -is specified as a list of the key (always a vector), the kind of binding, and -where (either the mode or buffer to which the binding is local, or @nil if it -is a global). -@enddefun - -@defun[fun {delete-key-binding}, args {@i[key] @optional @i[kind] @i[where]}] -This function removes the binding of @i[key] in some place. @i[Key] is either -a key-event or a sequence of key-events. @i[kind] is the kind of binding to -delete, one of @kwd[global] (the default), @kwd[mode] or @kwd[buffer]. If -@i[kind] is @kwd[mode], @i[where] is the mode name, and if @i[kind] is -@kwd[buffer], then @i[where] is the buffer. - -This function signals an error if @i[key] is unbound. - -This processes @i[key] for key translations before deleting the binding. See -section @ref[key-trans]. -@enddefun - -@defun[fun {get-command}, args {@i[key] @optional @i[kind] @i[where]}] -This function returns the command bound to @i[key], returning @nil if it is -unbound. @i[Key] is either a key-event or a sequence of key-events. If -@i[key] is an initial subsequence of some keys, then this returns the keyword -@kwd[prefix]. There are four cases of @i[kind]: -@begin(description) -@kwd[current]@\ - Return the current binding of @i[key] using the current buffer's search list. -If there are any transparent key bindings for @i[key], then they are returned -in a list as a second value. - -@kwd[global]@\ - Return the global binding of @i[key]. This is the default. - -@kwd[mode]@\ - Return the binding of @i[key] in the mode named @i[where]. - -@kwd[buffer]@\ - Return the binding of @i[key] local to the buffer @i[where]. -@end(description) - -This processes @i[key] for key translations before looking for any binding. -See section @ref[key-trans]. -@enddefun - -@defun[fun {map-bindings}, Args {@i[function] @i[kind] @optional @i[where]}] -This function maps over the key bindings in some place. For each binding, this -passes @i[function] the key and the command bound to it. @i[Kind] and -@i[where] are the same as in @f[bind-key]. The key is not guaranteed to remain -valid after a given iteration. -@enddefmac - - -@subsection[Key Translation] -@index[bit-prefix keys] -@index[key translation] -@index[translating keys] -@label[key-trans] -Key translation is a process that the command interpreter applies to keys -before doing anything else. There are two kinds of key translations: -substitution and bit-prefix. In either case, the command interpreter -translates a key when a specified key-event sequence appears in a key. - -In a substitution translation, the system replaces the matched subsequence with -another key-event sequence. Key translation is not recursively applied to the -substituted key-events. - -In a bit-prefix translation, the system removes the matched subsequence and -effectively sets the specified bits in the next key-event in the key. - -While translating a key, if the system encounters an incomplete final -subsequence of key-events, it aborts the translation process. This happens -when those last key-events form a prefix of some translation. It also happens -when they translate to a bit-prefix, but there is no following key-event to -which the system can apply the indicated modifier. If there is a binding for -this partially untranslated key, then the command interpreter will invoke that -command; otherwise, it will wait for the user to type more key-events. - -@defun[fun {key-translation}, args {@i[key]}] -This form is @f[setf]'able and allows users to register key translations that -the command interpreter will use as users type key-events. - -This function returns the key translation for @i[key], returning @nil if there -is none. @i[Key] is either a key-event or a sequence of key-events. If -@i[key] is a prefix of a translation, then this returns @kwd[prefix]. - -A key translation is either a key or modifier specification. The bits -translations have a list form: @w<@f[(:bits {]@i[bit-name]@f[}*)]>. - -Whenever @i[key] appears as a subsequence of a key argument to the binding -manipulation functions, that portion will be replaced with the translation. -@enddefun - - - -@subsection[Transparent Key Bindings] -@label[transparent-key-bindings] -@index[Transparent key bindings] - -Key bindings local to a mode may be @i[transparent]. A transparent key -binding does not shadow less local key bindings, but rather indicates that -the bound command should be invoked before the first normal key binding. -Transparent key bindings are primarily useful for implementing minor modes -such as auto fill and word abbreviation. There may be several transparent -key bindings for a given key, in which case all of the commands bound are -invoked in the order they were found. If there no normal key binding for a -key typed, then the command interpreter acts as though the key is unbound -even if there are transparent key bindings. - -The @kwd[transparent-p] argument to @funref[defmode] determines whether the -key bindings in a mode are transparent or not. - - -@subsection (Interactive) -@index (Keyboard macro vs. interactive) -@index (Interactive vs. keyboard macro) -@Hemlock supports keyboard macros. A user may enter a mode where the editor -records his actions, and when the user exits this mode, the command @hid[Last -Keyboard Macro] plays back the actions. Some commands behave differently when -invoked as part of the definition of a keyboard macro. For example, when used -in a keyboard macro, a command that @f[message]'s useless user confirmation -will slow down the repeated invocations of @hid[Last Keyboard Macro] because -the command will pause on each execution to make sure the user sees the -message. This can be eliminated with the use of @f[interactive]. As another -example, some commands conditionally signal an editor-error versus simply -beeping the device depending on whether it executes on behalf of the user or a -keyboard macro. - -@defun[fun {interactive}] -This returns @true when the user invoked the command directly. -@enddefun - - -@section(Command Types) -@index(Command types) -@label(command-types) -In many editors the behavior of a command depends on the kind of command -invoked before it. @hemlock provides a mechanism to support this known as -@i(command type). - -@defun[fun {last-command-type}] -This returns the command type of the last command invoked. If this is set with -@f[setf], the supplied value becomes the value of @f[last-command-type] until -the next command completes. If the previous command did not set -@f[last-command-type], then its value is @nil. Normally a command type is a -keyword. The command type is not cleared after a command is invoked due to a -transparent key binding. -@enddefun - - -@section(Command Arguments) -@label[invoking-commands-as-functions] -There are three ways in which a command may be invoked: It may be bound to a -key which has been typed, it may be invoked as an extended command, or it may -be called as a Lisp function. Ideally commands should be written in such a way -that they will behave sensibly no matter which way they are invoked. The -functions which implement commands must obey certain conventions about argument -passing if the command is to function properly. - - -@subsection(The Prefix Argument) -@index(Prefix arguments) -Whenever a command is invoked it is passed as its first argument what -is known as the @i[prefix argument]. The prefix argument is always -either an integer or @nil. When a command uses this value it is -usually as a repeat count, or some conceptually similar function. - -@defun[fun {prefix-argument}] -This function returns the current value of the prefix argument. When -set with @f[setf], the new value becomes the prefix argument for the -next command. -@enddefun - -If the prefix argument is not set by the previous command then the -prefix argument for a command is @nil. The prefix argument is not cleared -after a command is invoked due to a transparent key binding. - - -@subsection(Lisp Arguments) -It is often desirable to call commands from Lisp code, in which case -arguments which would otherwise be prompted for are passed as optional -arguments following the prefix argument. A command should prompt for -any arguments not supplied. - - -@section(Recursive Edits) -@index(Recursive edits) -@defmac[fun {use-buffer}, args {@i[buffer] @mstar<@i[form]>}] -The effect of this is similar to setting the current-buffer to @i[buffer] -during the evaluation of @i[forms]. There are restrictions placed on what the -code can expect about its environment. In particular, the value of any global -binding of a @hemlock variable which is also a mode local variable of some mode -is ill-defined; if the variable has a global binding it will be bound, but the -value may not be the global value. It is also impossible to nest -@f[use-buffer]'s in different buffers. The reason for using @f[use-buffer] is -that it may be significantly faster than changing @f[current-buffer] to -@i[buffer] and back. -@enddefmac - -@defun[fun {recursive-edit}, args {@optional @i[handle-abort]}] -@defhvar1[var {Enter Recursive Edit Hook}] -@index[aborting] -@f[recursive-edit] invokes the command interpreter. The command interpreter -will read from the keyboard and invoke commands until it is terminated with -either @f[exit-recursive-edit] or @f[abort-recursive-edit]. - -Normally, an editor-error or @bf[C-g] aborts the command in progress and -returns control to the top-level command loop. If @f[recursive-edit] is used -with @i[handle-abort] true, then @f[editor-error] or @bf[C-g] will only abort -back to the recursive command loop. - -Before the command interpreter is entered the hook -@hid[Enter Recursive Edit Hook] is invoked. -@enddefun - -@defun[fun {in-recursive-edit}] -This returns whether the calling point is dynamically within a recursive edit -context. -@enddefun - -@defun[fun {exit-recursive-edit}, args {@optional @i[values-list]}] -@defhvar1[var {Exit Recursive Edit Hook}] -@f[exit-recursive-edit] exits a recursive edit returning as multiple values -each element of @i[values-list], which defaults to @nil. This invokes -@hid[Exit Recursive Edit Hook] after exiting the command interpreter. If no -recursive edit is in progress, then this signals an error. -@enddefun - -@defun[fun {abort-recursive-edit}, args {@rest @i[args]}] -@defhvar1[var {Abort Recursive Edit Hook}] -@f[abort-recursive-edit] terminates a recursive edit by applying -@funref[editor-error] to @i[args] after exiting the command interpreter. This -invokes @hid[Abort Recursive Edit Hook] with @i[args] before aborting the -recursive edit . If no recursive edit is in progress, then this signals an -error. -@enddefun - - - -@Chapter(Modes) -@label[modes] -@index (Modes) -A mode is a collection of @hemlock values which may be present in the current -environment @w<(page @pageref(current-environment))> depending on the editing -task at hand. Examples of typical modes are @hid[Lisp], for editing Lisp code, -and @hid[Echo Area], for prompting in the echo area. - - -@section(Mode Hooks) - When a mode is added to or removed from a buffer, its @i[mode hook] -is invoked. The hook functions take two arguments, the buffer -involved and @true if the mode is being added or @nil if it is being -removed. - -Mode hooks are typically used to make a mode do something additional to -what it usually does. One might, for example, make a text mode hook -that turned on auto-fill mode when you entered. - - -@section(Major and Minor Modes) -There are two kinds of modes, @i[major] modes and @i[minor] modes. A buffer -always has exactly one major mode, but it may have any number of minor modes. -Major modes may have mode character attributes while minor modes may not. - -A major mode is usually used to change the environment in some major way, such -as to install special commands for editing some language. Minor modes -generally change some small attribute of the environment, such as whether lines -are automatically broken when they get too long. A minor mode should work -regardless of what major mode and minor modes are in effect. - -@defhvar[var {Default Modes}, val {("Fundamental" "Save")}] -This variable contains a list of mode names which are instantiated in a -buffer when no other information is available. -@enddefhvar - -@defvar[var {mode-names}] -Holds a string-table of the names of all the modes. -@enddefvar - -@defcom[com "Illegal"] -This is a useful command to bind in modes that wish to shadow global bindings -by making them effectively illegal. Also, although less likely, minor modes -may shadow major mode bindings with this. This command calls @f[editor-error]. -@enddefcom - - -@section(Mode Functions) - -@defun[fun {defmode}, args {@i[name]}, - keys {[setup-function][cleanup-function][major-p]}, - morekeys {[precedence][transparent-p][documentation]}] -This function defines a new mode named @i[name], and enters it in -@varref[mode-names]. If @i[major-p] is supplied and is not @nil -then the mode is a major mode; otherwise it is a minor mode. - -@i[Setup-function] and @i[cleanup-function] are functions which are -invoked with the buffer affected, after the mode is turned on, and -before it is turned off, respectively. These functions typically are -used to make buffer-local key or variable bindings and to remove them -when the mode is turned off. - -@i[Precedence] is only meaningful for a minor mode. The precedence of a -minor mode determines the order in which it in a buffer's list of modes. -When searching for values in the current environment, minor modes are -searched in order, so the precedence of a minor mode determines which value -is found when there are several definitions. - -@i[Transparent-p] determines whether key bindings local to the defined mode -are transparent. Transparent key bindings are invoked in addition to the -first normal key binding found rather than shadowing less local key bindings. - -@i[Documentation] is some introductory text about the mode. Commands such as -@hid[Describe Mode] use this. -@enddefun - -@defun[fun {mode-documentation}, args {@i[name]}] -This function returns the documentation for the mode named @i[name]. -@enddefun - -@defun[fun {buffer-major-mode}, args {@i[buffer]}] -@defhvar1[var {Buffer Major Mode Hook}] -@f[buffer-major-mode] returns the name of @i[buffer]'s major mode. -The major mode may be changed with @f[setf]; then - @hid[Buffer Major Mode Hook] is invoked with -@i[buffer] and the new mode. -@enddefun - -@defun[fun {buffer-minor-mode}, args {@i[buffer] @i[name]}] -@defhvar1[var {Buffer Minor Mode Hook}] -@f[buffer-minor-mode] returns @true if the minor mode @i[name] is active -in @i[buffer], @nil otherwise. A minor mode may be turned on or off -by using @f[setf]; then @hid[Buffer Minor Mode Hook] is -invoked with @i[buffer], @i[name] and the new value. -@enddefun - -@defun[fun {mode-variables}, args {@i[name]}] -Returns the string-table of mode local variables. -@enddefun - -@defun[fun {mode-major-p}, args {@i[name]}] -Returns @true if @i[name] is the name of a major mode, or @nil if -it is the name of a minor mode. It is an error for @i[name] not to be -the name of a mode. -@enddefun - - - -@chapter(Character Attributes) -@label(character-attributes) -@index(Character attributes) -@index(Syntax tables) - -@section(Introduction) -Character attributes provide a global database of information about characters. -This facility is similar to, but more general than, the @i[syntax tables] of -other editors such as @f[EMACS]. For example, you should use character -attributes for commands that need information regarding whether a character is -@i[whitespace] or not. Use character attributes for these reasons: -@begin(enumerate) -If this information is all in one place, then it is easy the change the -behavior of the editor by changing the syntax table, much easier than it would -be if character constants were wired into commands. - -This centralization of information avoids needless duplication of effort. - -The syntax table primitives are probably faster than anything that can be -written above the primitive level. -@end(enumerate) - -Note that an essential part of the character attribute scheme is that -@i[character attributes are global and are there for the user to change.] -Information about characters which is internal to some set of commands (and -which the user should not know about) should not be maintained as a character -attribute. For such uses various character searching abilities are provided by -the function @funref[find-pattern]. - -@defcon[var {syntax-char-code-limit}] -The exclusive upper bound on character codes which are significant in -the character attribute functions. Font and bits are always ignored. -@enddefcon - - -@section(Character Attribute Names) - -As for @hemlock variables, character attributes have a user visible -string name, but are referred to in Lisp code as a symbol. The string -name, which is typically composed of capitalized words separated by -spaces, is translated into a keyword by replacing all spaces with -hyphens and interning this string in the keyword package. The -attribute named @hid[Ada Syntax] would thus become @kwd[ada-syntax]. - -@defvar[var {character-attribute-names}] -Whenever a character attribute is defined, its name is entered in -this string table (page @pageref[string-tables]), with the -corresponding keyword as the value. -@enddefvar - - -@section(Character Attribute Functions) - -@defun[fun {defattribute}, args - {@i[name] @i[documentation] @optional @i[type] @i[initial-value]}] - This function defines a new character attribute with @i[name], a -simple-string. Character attribute operations take attribute arguments as a -keyword whose name is @i[name] uppercased with spaces replaced by hyphens. - -@i[Documentation] describes the uses of the character attribute. - -@i[Type], which defaults to @w<@f[(mod 2)]>, specifies what type the values of -the character attribute are. Values of a character attribute may be of any -type which may be specified to @f[make-array]. @i[Initial-value] (default -@f[0]) is the value which all characters will initially have for this -attribute. -@enddefun - -@defun[fun {character-attribute-name}, args {@i[attribute]}] -@defun1[fun {character-attribute-documentation}, args {@i[attribute]}] -These functions return the name or documentation for @i[attribute]. -@enddefun - -@defun[fun {character-attribute}, args {@i[attribute] @i[character]}] -@defhvar1[var {Character Attribute Hook}] -@f[character-attribute] returns the value of @i[attribute] for @i[character]. -This signals an error if @i[attribute] is undefined. - -@f[setf] will set a character's attributes. This @f[setf] method invokes the -functions in @hid[Character Attribute Hook] on the attribute and character -before it makes the change. - -If @i[character] is @nil, then the value of the attribute for the beginning or -end of the buffer can be accessed or set. The buffer beginning and end thus -become a sort of fictitious character, which simplifies the use of character -attributes in many cases. -@enddefun - -@defun[fun {character-attribute-p}, args {@i[symbol]}] -This function returns @true if @i[symbol] is the name of a character attribute, -@nil otherwise. -@enddefun - -@defun[fun {shadow-attribute}, args -{@i[attribute] @i[character] @i[value] @i[mode]}] -@defhvar1[var {Shadow Attribute Hook}] -This function establishes @i[value] as the value of @i[character]'s -@i[attribute] attribute when in the mode @i[mode]. @i[Mode] must be the name -of a major mode. @hid[Shadow Attribute Hook] is invoked with the same -arguments when this function is called. If the value for an attribute is set -while the value is shadowed, then only the shadowed value is affected, not the -global one. -@enddefun - -@defun[fun {unshadow-attribute}, args {@i[attribute] @i[character] @i[mode]}] -@defhvar1[var {Unshadow Attribute Hook}] -Make the value of @i[attribute] for @i[character] no longer be shadowed in -@i[mode]. @hid[Unshadow Attribute Hook] is invoked with the same arguments -when this function is called. -@enddefun - -@defun[fun {find-attribute}, - args {@i[mark] @i[attribute] @optional @i[test]}] -@defun1[fun {reverse-find-attribute}, - args {@i[mark] @i[attribute] @optional @i[test]}] - These functions find the next (or previous) character with some value for the -character attribute @i[attribute] starting at @i[mark]. They pass @i[Test] one -argument, the value of @i[attribute] for the character tested. If the test -succeeds, then these routines modify @i[mark] to point before (after for -@f[reverse-find-attribute]) the character which satisfied the test. If no -characters satisfy the test, then these return @nil, and @i[mark] remains -unmodified. @i[Test] defaults to @f[not zerop]. There is no guarantee that -the test is applied in any particular fashion, so it should have no side -effects and depend only on its argument. -@enddefun - - -@section(Character Attribute Hooks) - -It is often useful to use the character attribute mechanism as an abstract -interface to other information about characters which in fact is stored -elsewhere. For example, some implementation of @hemlock might decide to define -a @hid[Print Representation] attribute which controls how a character is -displayed on the screen. - -To make this easy to do, each attribute has a list of hook functions -which are invoked with the attribute, character and new value whenever -the current value changes for any reason. - -@defun[fun {character-attribute-hooks}, args {@i[attribute]}] -Return the current hook list for @i[attribute]. This may be set with -@f[setf]. The @f[add-hook] and @macref[remove-hook] macros should -be used to manipulate these lists. -@enddefun - - -@section (System Defined Character Attributes) -@label(sys-def-chars) -These are predefined in @hemlock: -@begin[description] -@hid[Whitespace]@\ -A value of @f[1] indicates the character is whitespace. - -@hid[Word Delimiter]@\ -A value of @f[1] indicates the character separates words (see section -@ref[text-functions]). - -@hid[Digit]@\ -A value of @f[1] indicates the character is a base ten digit. This may be -shadowed in modes or buffers to mean something else. - -@hid[Space]@\ -This is like @hid[Whitespace], but it should not include @binding[Newline]. -@hemlock uses this primarily for handling indentation on a line. - -@hid[Sentence Terminator]@\ -A value of @f[1] indicates these characters terminate sentences (see section -@ref[text-functions]). - -@hid[Sentence Closing Char]@\ -A value of @f[1] indicates these delimiting characters, such as @binding["] -or @binding[)], may follow a @hid[Sentence Terminator] (see section -@ref[text-functions]). - -@hid[Paragraph Delimiter]@\ -A value of @f[1] indicates these characters delimit paragraphs when they begin -a line (see section @ref[text-functions]). - -@hid[Page Delimiter]@\ -A value of @f[1] indicates this character separates logical pages (see section -@ref[logical-pages]) when it begins a line. - -@hid[Scribe Syntax]@\ -This uses the following symbol values: -@begin[multiple] -@begin[description] -@nil@\These characters have no interesting properties. - -@kwd[escape]@\This is @binding[@@] for the Scribe formatting language. - -@kwd[open-paren]@\These characters begin delimited text. - -@kwd[close-paren]@\These characters end delimited text. - -@kwd[space]@\These characters can terminate the name of a formatting command. - -@kwd[newline]@\These characters can terminate the name of a formatting command. -@end[description] -@end[multiple] - - -@hid[Lisp Syntax]@\ -This uses symbol values from the following: -@begin[multiple] -@begin[description] -@nil@\These characters have no interesting properties. - -@kwd[space]@\These characters act like whitespace and should not include -@binding[Newline]. - -@kwd[newline]@\This is the @binding[Newline] character. - -@kwd[open-paren]@\This is @binding[(] character. - -@kwd[close-paren]@\This is @binding[)] character. - -@kwd[prefix]@\This is a character that is a part of any form it precedes @dash -for example, the single quote, @binding[']. - -@kwd[string-quote]@\This is the character that quotes a string literal, -@binding["].@comment["] - -@kwd[char-quote]@\This is the character that escapes a single character, -@binding[\]. - -@kwd[comment]@\This is the character that makes a comment with the rest of the -line, @binding[;]. - -@kwd[constituent]@\These characters are constitute symbol names. -@end[description] -@end[multiple] - -@end[description] - - - -@chapter (Controlling the Display) -@section (Windows) -@tag[windows] -@index(Windows) -@index(modelines) - -A window is a mechanism for displaying part of a buffer on some physical -device. A window is a way to view a buffer but is not synonymous with one; a -buffer may be viewed in any number of windows. A window may have a -@i[modeline] which is a line of text displayed across the bottom of a window to -indicate status information, typically related to the buffer displayed. - - -@section (The Current Window) -@index (Current window) -@defun[fun {current-window}, args {}] -@defhvar1[var {Set Window Hook}] -@f[current-window] returns the window in which the cursor is currently -displayed. The cursor always tracks the buffer-point of the corresponding -buffer. If the point is moved to a position which would be off the screen the -recentering process is invoked. Recentering shifts the starting point of the -window so that the point is once again displayed. The current window may be -changed with @f[setf]. Before the current window is changed, the hook @hid[Set -Window Hook] is invoked with the new value. -@enddefun - -@defvar[var {window-list}] -Holds a list of all the window objects made with @funref[make-window]. -@enddefvar - - -@section(Window Functions) - -@defun[fun {make-window}, args {@i[mark]}, - keys {[modelinep][window][ask-user]}, - morekeys {[x][y][width][height]}, - morekeys {[proportion]}] -@defhvar1[var {Default Window Width}] -@defhvar1[var {Default Window Height}] -@defhvar1[var {Make Window Hook}] - -@comment[NOTE, we purposefully do not document the font-family or device - arguments since we don't officially support fonts or devices.] - -@f[make-window] returns a window displaying text starting at @i[mark], which -must point into a buffer. If it could not make a window on the device, it -returns nil. The default action is to make the new window a proportion of the -@f[current-window]'s height to make room for the new window. - -@i[Modelinep] specifies whether the window should display buffer modelines. - -@i[Window] is a device dependent window to be used with the Hemlock window. -The device may not support this argument. @i[Window] becomes the parent window -for a new group of windows that behave in a stack orientation as windows do on -the terminal. - -If @i[ask-user] is non-@nil, @hemlock prompts the user for the missing -dimensions (@i[x], @i[y], @i[width], and @i[height]) to make a new group of -windows, as with the @i[window] argument. The device may not support this -argument. Non-null values other than @f[t] may have device dependent meanings. -@i[X] and @i[y] are in pixel units, but @i[width] and @i[height] are characters -units. @hid[Default Window Width] and @hid[Default Window Height] are the -default values for the @i[width] and @i[height] arguments. - -@i[Proportion] determines what proportion of the @f[current-window]'s height -the new window will use. The @f[current-window] retains whatever space left -after accommodating the new one. The default is to split the window in half. - -This invokes @hid[Make Window Hook] with the new window. -@enddefun - -@defun[fun {windowp}, args {@i[window]}] -This function returns @true if @i[window] is a @f[window] object, otherwise -@nil. -@enddefun - -@defun[fun {delete-window}, args {@i[window]}] -@defhvar1[var {Delete Window Hook}] -@f[delete-window] makes @i[window] go away, first invoking @hid[Delete Window -Hook] with @i[window]. -@enddefun - -@defun[fun {window-buffer}, args {@i[window]}] -@defhvar1[var {Window Buffer Hook}] -@f[window-buffer] returns the buffer from which the window displays -text. This may be changed with @f[setf], in which case the hook -@hid[Window Buffer Hook] is invoked beforehand with the window and the -new buffer. -@enddefun - -@defun[fun {window-display-start}, args {@i[window]}] -@defun1[fun {window-display-end}, args {@i[window]}] -@f[window-display-start] returns the mark that points before the first -character displayed in @i[window]. Note that if @i[window] is the current -window, then moving the start may not prove much, since recentering may move it -back to approximately where it was originally. - -@f[window-display-end] is similar, but points after the last character -displayed. Moving the end is meaningless, since redisplay always moves it to -after the last character. -@enddefun - -@defun[fun {window-display-recentering}, args {@i[window]}] -This function returns whether redisplay will ensure the buffer's point of -@i[window]'s buffer is visible after redisplay. This is @f[setf]'able, and -changing @i[window]'s buffer sets this to @nil via @hid[Window Buffer Hook]. -@enddefun - -@defun[fun {window-point}, args {@i[window]}] -This function returns as a mark the position in the buffer where the cursor is -displayed. This may be set with @f[setf]. If @i[window] is the current -window, then setting the point will have little effect; it is forced to track -the buffer point. When the window is not current, the window point is the -position that the buffer point will be moved to when the window becomes -current. -@enddefun - -@defun[fun {center-window}, args {@i[window] @i[mark]}] -This function attempts to adjust window's display start so the that @i[mark] is -vertically centered within the window. -@enddefun - -@defun[fun {scroll-window}, args {@i[window] @i[n]}] -This function scrolls the window down @i[n] display lines; if @i[n] is negative -scroll up. Leave the cursor at the same text position unless we scroll it off -the screen, in which case the cursor is moved to the end of the window closest -to its old position. -@enddefun - -@defun[fun {displayed-p}, args {@i[mark] @i[window]}] -Returns @true if either the character before or the character after @i[mark] -is being displayed in @i[window], or @nil otherwise. -@enddefun - -@defun[fun {window-height}, args {@i[window]}] -@defun1[fun {window-width}, args {@i[window]}] -Height or width of the area of the window used for displaying the -buffer, in character positions. These values may be changed with -@f[setf], but the setting attempt may fail, in which case nothing is done. -@enddefun - -@defun[fun {next-window}, args {@i[window]}] -@defun1[fun {previous-window}, args {@i[window]}] -Return the next or previous window of @i[window]. The exact meaning of next -and previous depends on the device displaying the window. It should be -possible to cycle through all the windows displayed on a device using either -next or previous (implying that these functions wrap around.) -@enddefun - - -@section(Cursor Positions) -@index(Cursor positions) -A cursor position is an absolute position within a window's coordinate -system. The origin is in the upper-left-hand corner and the unit -is character positions. - -@defun[fun {mark-to-cursorpos}, args {@i[mark] @i[window]}] -Returns as multiple values the @f[X] and @f[Y] position on which -@i[mark] is being displayed in @i[window], or @nil if it is not within the -bounds displayed. -@enddefun - -@defun[fun {cursorpos-to-mark}, args {@i[X] @i[Y] @i[window]}] -Returns as a mark the text position which corresponds to the given -(@i[X], @i[Y]) position within window, or @nil if that -position does not correspond to any text within @i[window]. -@enddefun - -@defun[fun {last-key-event-cursorpos}] -Interprets mouse input. It returns as multiple values the (@i[X], @i[Y]) -position and the window where the pointing device was the last time some key -event happened. If the information is unavailable, this returns @nil. -@enddefun - -@defun[fun {mark-column}, args {@i[mark]}] -This function returns the @i[X] position at which @i[mark] would be displayed, -supposing its line was displayed on an infinitely wide screen. This takes into -consideration strange characters such as tabs. -@enddefun - -@defun[fun {move-to-column}, args {@i[mark] @i[column] @optional @i[line]}] -This function is analogous to @funref[move-to-position], except that -it moves @i[mark] to the position on @i[line] which corresponds to the -specified @i[column]. @i[Line] defaults to the line that @i[mark] is -currently on. If the line would not reach to the specified column, -then @nil is returned and @i[mark] is not modified. Note that since a -character may be displayed on more than one column on the screen, -several different values of @i[column] may cause @i[mark] to be moved -to the same position. -@enddefun - -@defun[fun {show-mark}, args {@i[mark] @i[window] @i[time]}] -This function highlights the position of @i[mark] within @i[window] for -@i[time] seconds, possibly by moving the cursor there. The wait may be aborted -if there is pending input. If @i[mark] is positioned outside the text -displayed by @i[window], then this returns @nil, otherwise @true. -@enddefun - - -@section(Redisplay) -Redisplay translates changes in the internal representation of text into -changes on the screen. Ideally this process finds the minimal transformation -to make the screen correspond to the text in order to maximize the speed of -redisplay. - -@defun[fun {redisplay}] -@defhvar1[var "Redisplay Hook"] -@f[redisplay] executes the redisplay process, and @hemlock typically invokes -this whenever it looks for input. The redisplay process frequently checks for -input, and if it detects any, it aborts. The return value is interpreted as -follows: -@begin[description] -@false@\No update was needed. - -@true@\Update was needed, and completed successfully. - -@kwd[editor-input]@\Update is needed, but was aborted due to pending input. -@end[description] - -This function invokes the functions in @hid[Redisplay Hook] on the current -window after computing screen transformations but before executing them. After -invoking the hook, this recomputes the redisplay and then executes it on the -current window. - -For the current window and any window with @f[window-display-recentering] set, -@f[redisplay] ensures the buffer's point for the window's buffer is visible -after redisplay. -@enddefun - -@defun[fun {redisplay-all}] -This causes all editor windows to be completely redisplayed. For the current -window and any window with @f[window-display-recentering] set, this ensures the -buffer's point for the window's buffer is visible after redisplay. The return -values are the same as for redisplay, except that @false is never returned. -@enddefun - -@defun[fun {editor-finish-output}, args {@i[window]}] -This makes sure the editor is synchronized with respect to redisplay output to -@i[window]. This may do nothing on some devices. -@enddefun - - - -@chapter(Logical Key-Events) -@label[logical-key-events] -@index[Logical key-events] - - -@section[Introduction] -Some primitives such as @funref[prompt-for-key] and commands such as EMACS -query replace read key-events directly from the keyboard instead of using the -command interpreter. To encourage consistency between these commands and to -make them portable and easy to customize, there is a mechanism for defining -@i[logical key-events]. - -A logical key-event is a keyword which stands for some set of key-events. The -system globally interprets these key-events as indicators a particular action. -For example, the @kwd[help] logical key-event represents the set of key-events -that request help in a given @hemlock implementation. This mapping is a -many-to-many mapping, not one-to-one, so a given logical key-event may have -multiple corresponding actual key-events. Also, any key-event may represent -different logical key-events. - - -@section[Logical Key-Event Functions] - -@defvar[var {logical-key-event-names}] -This variable holds a string-table mapping all logical key-event names to the -keyword identifying the logical key-event. -@enddefvar - -@defun[fun {define-logical-key-event}, args {@i[string-name] @i[documentation]}] - This function defines a new logical key-event with name @i[string-name], a -simple-string. Logical key-event operations take logical key-events arguments -as a keyword whose name is @i[string-name] uppercased with spaces replaced by -hyphens. - -@i[Documentation] describes the action indicated by the logical key-event. -@enddefun - -@defun[fun {logical-key-event-key-events}, args {@i[keyword]}] -This function returns the list of key-events representing the logical key-event -@i[keyword]. -@enddefun - -@defun[fun {logical-key-event-name}, args {@i[keyword]}] -@defun1[fun {logical-key-event-documentation}, args {@i[keyword]}] -These functions return the string name and documentation given to -@f[define-logical-key-event] for logical key-event @i[keyword]. -@enddefun - -@defun[fun {logical-key-event-p}, args {@i[key-event] @i[keyword]}] -This function returns @f[t] if @i[key-event] is the logical key-event -@i[keyword]. This is @f[setf]'able establishing or disestablishing key-events -as particular logical key-events. It is a error for @i[keyword] to be an -undefined logical key-event. -@enddefun - - -@section[System Defined Logical Key-Events] -There are many default logical key-events, some of which are used by functions -documented in this manual. If a command wants to read a single key-event -command that fits one of these descriptions then the key-event read should be -compared to the corresponding logical key-event instead of explicitly -mentioning the particular key-event in the code. In many cases you can use the -@macref[command-case] macro. It makes logical key-events easy to use and takes -care of prompting and displaying help messages. - -@begin[description] -@kwd[yes]@\ - Indicates the prompter should take the action under consideration. - -@kwd[no]@\ - Indicates the prompter should NOT take the action under consideration. - -@kwd[do-all]@\ - Indicates the prompter should repeat the action under consideration as many -times as possible. - -@kwd[do-once]@\ - Indicates the prompter should execute the action under consideration once and -then exit. - -@kwd[exit]@\ - Indicates the prompter should terminate its activity in a normal fashion. - -@kwd[abort]@\ - Indicates the prompter should terminate its activity without performing any -closing actions of convenience, for example. - -@kwd[keep]@\ - Indicates the prompter should preserve something. - -@kwd[help]@\ - Indicates the prompter should display some help information. - -@kwd[confirm]@\ - Indicates the prompter should take any input provided or use the default if -the user entered nothing. - -@kwd[quote]@\ - Indicates the prompter should take the following key-event as itself without -any sort of command interpretation. - -@kwd[recursive-edit]@\ - Indicates the prompter should enter a recursive edit in the current context. - -@kwd[cancel]@\ - Indicates the prompter should cancel the effect of a previous key-event input. - -@kwd[forward-search]@\ - Indicates the prompter should search forward in the current context. - -@kwd[backward-search]@\ - Indicates the prompter should search backward in the current context. -@end[description] - -@blankspace(1 line) -Define a new logical key-event whenever: -@begin[enumerate] -The key-event concerned represents a general class of actions, and -several commands may want to take a similar action of this type. - -The exact key-event a command implementor chooses may generate violent taste -disputes among users, and then the users can trivially change the command in -their init files. - -You are using @f[command-case] which prevents implementors from specifying -non-standard characters for dispatching in otherwise possibly portable code, -and you can define and set the logical key-event in a site dependent file where -you can mention implementation dependent characters. -@end[enumerate] - - - -@chapter(The Echo Area) - -@hemlock provides a number of facilities for displaying information and -prompting the user for it. Most of these work through a small window displayed -at the bottom of the screen. This is called the echo area and is supported by -a buffer and a window. This buffer's modeline (see section @ref[modelines]) is -referred to as the status line, which, unlike other buffers' modelines, is used -to show general status about the editor, Lisp, or world. - -@defhvar[var {Default Status Line Fields}] -This is the initial list of modeline-field objects stored in the echo area -buffer. -@enddefhvar - -@defhvar[var "Echo Area Height", val {3}] -This variable determines the initial height in lines of the echo area window. -@enddefhvar - - -@section(Echo Area Functions) -It is considered poor taste to perform text operations on the echo area buffer -to display messages; the @f[message] function should be used instead. A -command must use this function or set @funref[buffer-modified] for the -@hid[Echo Area] buffer to @nil to cause @hemlock to leave text in the echo area -after the command's execution. - -@defun[fun {clear-echo-area}] -Clears the echo area. -@enddefun - -@defun[fun {message}, args {@i[control-string] @rest @i[format-arguments]}] -@defun1[fun {loud-message}, args {@i[control-string] @rest @i[format-arguments]}] -@defhvar1[var {Message Pause}, val {0.5}] -Displays a message in the echo area. The message is always displayed on a -fresh line. @f[message] pauses for @hid[Message Pause] seconds before -returning to assure that messages are not displayed too briefly to be seen. -Because of this, @f[message] is the best way to display text in the echo area. - -@f[loud-message] is like @f[message], but it first clears the echo area and -beeps. -@enddefun - -@defvar[var {echo-area-window}] -@defvar1[var {echo-area-buffer}] -@f[echo-area-buffer] contains the buffer object for the echo area, which is -named @hid[Echo Area]. This buffer is usually in @hid[Echo Area] mode. -@f[echo-area-window] contains a window displaying @f[echo-area-buffer]. Its -modeline is the status line, see the beginning of this chapter. -@enddefvar - -@defvar[var {echo-area-stream}] -@index (Echo area) -This is a buffered @hemlock output stream -(@pageref[make-hemlock-output-stream-fun]) which inserts text written to it at -the point of the echo area buffer. Since this stream is buffered a -@f[force-output] must be done when output is complete to assure that it is -displayed. -@enddefvar - - -@section(Prompting Functions) -@index(Prompting functions) -Most of the prompting functions accept the following keyword arguments: -@begin(description) -@kwd[must-exist] @\If @kwd[must-exist] has a non-@nil value then the -user is prompted until a valid response is obtained. If -@kwd[must-exist] is @nil then return as a string whatever is input. -The default is @true. - -@kwd[default] @\If null input is given when the user is prompted -then this value is returned. If no default is given then -some input must be given before anything interesting will happen. - -@kwd[default-string] @\If a @kwd[default] is given then this is a -string to be printed to indicate what the default is. The default is -some representation of the value for @kwd[default], for example for a -buffer it is the name of the buffer. - -@kwd[prompt] @\This is the prompt string to display. - -@kwd[help] @\@multiple{ -This is similar to @kwd[prompt], except that it is displayed when -the help command is typed during input. @comment{If there is some known number -of options as in keyword parses, then they may be displayed, depending -on the setting of @hvarref[Help Show Options].} - -This may also be a function. When called with no arguments, it should either -return a string which is the help text or perform some action to help the user, -returning @Nil.} -@end(description) - -@defun[fun {prompt-for-buffer}, keys {[prompt][help][must-exist][default]}, - morekeys {[default-string]}] -Prompts with completion for a buffer name and returns the corresponding buffer. -If @i[must-exist] is @nil, then it returns the input string if it is not a -buffer name. This refuses to accept the empty string as input when -@kwd[default] and @kwd[default-string] are @nil. @kwd[default-string] may be -used to supply a default buffer name when @kwd[default] is @nil, but when -@kwd[must-exist] is non-@nil, it must name an already existing buffer. -@enddefun - -@defmac[fun {command-case}, Args {(@mstar<@i[key] @i[value]>) @Mstar<(@Mgroup"(@MSTAR'@i[tag]') @MOR @i[tag]" @i[help] @MSTAR'@i[form]')>}] - This macro is analogous to the Common Lisp @f[case] macro. Commands such as -@hid[Query Replace] use this to get a key-event, translate it to a character, -and then to dispatch on the character to some case. In addition to character -dispatching, this supports logical key-events @w<(page -@pageref[logical-key-events])> by using the input key-event directly without -translating it to a character. Since the description of this macro is rather -complex, first consider the following example: -@lisp -(defcommand "Save All Buffers" (p) - "Give the User a chance to save each modified buffer." - "Give the User a chance to save each modified buffer." - (dolist (b *buffer-list*) - (select-buffer-command () b) - (when (buffer-modified b) - (command-case (:prompt "Save this buffer: [Y] " - :help "Save buffer, or do something else:") - ((:yes :confirm) - "Save this buffer and go on to the next." - (save-file-command () b)) - (:no "Skip saving this buffer, and go on to the next.") - (:recursive-edit - "Go into a recursive edit in this buffer." - (do-recursive-edit) (reprompt)) - ((:exit #\p) "Punt this silly loop." - (return nil)))))) -@endlisp - -@f[command-case] prompts for a key-event and then executes the code in the -first branch with a logical key-event or a character (called @i[tags]) matching -the input. Each character must be a standard-character, one that satisfies the -Common Lisp @f[standard-char-p] predicate, and the dispatching mechanism -compares the input key-event to any character tags by mapping the key-event to -a character with @f[ext:key-event-char]. If the tag is a logical key-event, -then the search for an appropriate case compares the key-event read with the -tag using @f[logical-key-event-p]. - -All uses of @f[command-case] have two default cases, @kwd[help] and -@kwd[abort]. You can override these easily by specifying your own branches -that include these logical key-event tags. The @kwd[help] branch displays in a -pop-up window the a description of the valid responses using the variously -specified help strings. The @kwd[abort] branch signals an editor-error. - -The @i[key]/@i[value] arguments control the prompting. The following are valid -values: -@begin[description] -@kwd[help]@\ - The default @kwd[help] case displays this string in a pop-up window. In -addition it formats a description of the valid input including each case's -@i[help] string. - -@kwd[prompt]@\ - This is the prompt used when reading the key-event. - -@kwd[change-window]@\ - If this is non-nil (the default), then the echo area window becomes the -current window while the prompting mechanism reads a key-event. Sometimes it -is desirable to maintain the current window since it may be easier for users to -answer the question if they can see where the current point is. - -@kwd[bind]@\ - This specifies a variable to which the prompting mechanism binds the input -key-event. Any case may reference this variable. If you wish to know what -character corresponds to the key-event, use @f[ext:key-event-char]. -@end(description) - -Instead of specifying a tag or list of tags, you may use @true. This becomes -the default branch, and its forms execute if no other branch is taken, -including the default @kwd[help] and @kwd[abort] cases. This option has no -@i[help] string, and the default @kwd[help] case does not describe the default -branch. Every @f[command-case] has a default branch; if none is specified, the -macro includes one that @f[system:beep]'s and @f[reprompt]'s (see below). - -Within the body of @f[command-case], there is a defined @f[reprompt] macro. -It causes the prompting mechanism and dispatching mechanism to immediately -repeat without further execution in the current branch. -@enddefmac - - -@defun[fun {prompt-for-key-event}, keys {[prompt][change-window]}] -This function prompts for a key-event returning immediately when the user types -the next key-event. @macref[command-case] is more useful for most purposes. -When appropriate, use logical key-events @w<(page -@pageref[logical-key-events])>. -@enddefun - -@defun[fun {prompt-for-key}, keys {[prompt][help][must-exist][default]}, - morekeys {[default-string]}] - This function prompts for a @i[key], a vector of key-events, suitable for -passing to any of the functions that manipulate key bindings @w<(page -@pageref[key-bindings])>. If @i[must-exist] is true, then the key must be -bound in the current environment, and the command currently bound is returned -as the second value. -@enddefun - -@defun[fun {prompt-for-file}, keys {[prompt][help][must-exist][default]}, - morekeys {[default-string]}] - This function prompts for an acceptable filename in some system dependent -fashion. "Acceptable" means that it is a legal filename, and it exists if -@i[must-exist] is non-@nil. @f[prompt-for-file] returns a Common Lisp -pathname. - -If the file exists as entered, then this returns it, otherwise it is merged -with @i[default] as by @f[merge-pathnames]. -@enddefun - -@defun[fun {prompt-for-integer}, keys {[prompt][help][must-exist][default]}, - morekeys {[default-string]}] - This function prompts for a possibly signed integer. If @i[must-exist] is -@nil, then @f[prompt-for-integer] returns the input as a string if it is not a -valid integer. -@enddefun - -@defun[fun {prompt-for-keyword}, args {@i[string-tables]}, - keys {[prompt][help][must-exist]}, - morekeys {[default][default-string]}] - This function prompts for a keyword with completion, using the string tables -in the list @i[string-tables]. If @I[must-exist] is non-@nil, then the result -must be an unambiguous prefix of a string in one of the @i[string-tables], and -the returns the complete string even if only a prefix of the full string was -typed. In addition, this returns the value of the corresponding entry in the -string table as the second value. - -If @i[must-exist] is @nil, then this function returns the string exactly as -entered. The difference between @f[prompt-for-keyword] with @i[must-exist] -@nil, and @f[prompt-for-string], is the user may complete the input using the -@hid<Complete Parse> and @hid<Complete Field> commands. -@enddefun - -@defun[fun {prompt-for-expression}, - keys {[prompt][help][must-exist][default]}, - morekeys {[default-string]}] - This function reads a Lisp expression. If @i[must-exist] is @nil, and a read -error occurs, then this returns the string typed. -@enddefun - -@defun[fun {prompt-for-string}, keys -{[prompt][help][default][default-string]}] - This function prompts for a string; this cannot fail. -@enddefun - -@defun[fun {prompt-for-variable}, keys {[prompt][help][must-exist][default]}, - morekeys {[default-string]}] - This function prompts for a variable name. If @i[must-exist] is non-@nil, -then the string must be a variable @i[defined in the current environment], in -which case the symbol name of the variable found is returned as the second -value. -@enddefun - -@defun[fun {prompt-for-y-or-n}, keys {[prompt][help][must-exist][default]}, - morekeys {[default-string]}] - This prompts for @binding[y], @binding[Y], @binding[n], or @binding[N], -returning @true or @nil without waiting for confirmation. When the user types -a confirmation key, this returns @i[default] if it is supplied. If -@i[must-exist] is @nil, this returns whatever key-event the user first types; -however, if the user types one of the above key-events, this returns @true or -@nil. This is analogous to the Common Lisp function @f[y-or-n-p]. -@enddefun - -@defun[fun {prompt-for-yes-or-no}, keys {[prompt][help][must-exist][default]}, - morekeys {[default-string]}] - This function is to @f[prompt-for-y-or-n] as @f[yes-or-no-p] is to -@f[y-or-n-p]. "Yes" or "No" must be typed out in full and -confirmation must be given. -@enddefun - - -@section(Control of Parsing Behavior) - -@defhvar[var {Beep On Ambiguity}, val {@true}] -If this variable is true, then an attempt to complete a parse which is -ambiguous will result in a "beep". -@enddefhvar - - -@begin(comment) -@hemlock provides for limited control of parsing routine behaviour The -character attribute @hid[Parse Field Separator] is a boolean attribute, a value -of @f[1] indicating that the character is a field separator recognized by the -@hid<Complete Field> command. -@end(comment) - -@begin(comment) -@defhvar[var {Help Show Options}] -During a keyword or similar parse, typing the help command may cause a -list of options to be displayed. If displaying the help would take up -more lines than the value of this variable then confirmation will be -asked for before they will be displayed. -@enddefhvar -@end(comment) - - - -@section(Defining New Prompting Functions) -Prompting functions are implemented as a recursive edit in the -@hid[Echo Area] buffer. Completion, help, and other parsing features -are implemented by commands which are bound in @hid[Echo Area Mode]. - -A prompting function passes information down into the recursive edit -by binding a collection of special variables. - -@defvar[var {parse-verification-function}] -The system binds this to a function that @comref[Confirm Parse] calls. It does -most of the work when parsing prompted input. @comref[Confirm Parse] passes -one argument, which is the string that was in @var<parse-input-region> when the -user invokes the command. The function should return a list of values which -are to be the result of the recursive edit, or @nil indicating that the parse -failed. In order to return zero values, a non-@nil second value may be -returned along with a @nil first value. -@enddefvar - -@defvar[var {parse-string-tables}] -This is the list of @f[string-table]s, if any, that pertain to this parse. -@enddefvar - -@defvar[var {parse-value-must-exist}] -This is bound to the value of the @kwd[must-exist] argument, and is -referred to by the verification function, and possibly some of the -commands. -@enddefvar - -@defvar[var {parse-default}] -When prompting the user, this is bound to a string representing the default -object, the value supplied as the @kwd[default] argument. @hid<Confirm Parse> -supplies this to the parse verification function when the -@var<parse-input-region> is empty. -@enddefvar - -@defvar[var {parse-default-string}] -When prompting the user, if @var[parse-default] is @nil, @hemlock displays this -string as a representation of the default object; for example, when prompting -for a buffer, this variable would be bound to the buffer name. -@enddefvar - -@defvar[var {parse-type}] -The kind of parse in progress, one of @kwd[file], @kwd[keyword] or -@kwd[string]. This tells the completion commands how to do completion, with -@kwd[string] disabling completion. -@enddefvar - -@defvar[var {parse-prompt}] -The prompt being used for the current parse. -@enddefvar - -@defvar[var {parse-help}] -The help string or function being used for the current parse. -@enddefvar - -@defvar[var {parse-starting-mark}] -This variable holds a mark in the @varref[echo-area-buffer] which -is the position at which the parse began. -@enddefvar - -@defvar[var {parse-input-region}] -This variable holds a region with @var[parse-starting-mark] as its -start and the end of the echo-area buffer as its end. When -@hid[Confirm Parse] is called, the text in this region is the text -that will be parsed. -@enddefvar - - -@section(Some Echo Area Commands) - -These are some of the @hid[Echo Area] commands that coordinate with the -prompting routines. @Hemlock binds other commands specific to the @hid[Echo -Area], but they are uninteresting to mention here, such as deleting to the -beginning of the line or deleting backwards a word. - -@defcom[com {Help On Parse}, - stuff (bound to @bf[Home, C-_] in @hid[Echo Area] mode)] -Display the help text for the parse currently in progress. -@enddefcom - -@defcom[com {Complete Keyword}, - stuff (bound to @bf[Escape] in @hid[Echo Area] mode)] -This attempts to complete the current region as a keyword in -@var[string-tables]. It signals an editor-error if the input is ambiguous -or incorrect. -@enddefcom - -@defcom[com {Complete Field}, - stuff (bound to @bf[Space] in @hid[Echo Area] mode)] -Similar to @hid[Complete Keyword], but only attempts to complete up to and -including the first character in the keyword with a non-zero -@kwd[parse-field-separator] attribute. If -there is no field separator then attempt to complete the entire keyword. -If it is not a keyword parse then just self-insert. -@enddefcom - -@defcom[com {Confirm Parse}, - stuff (bound to @bf[Return] in @hid[Echo Area] mode)] -If @var[string-tables] is non-@nil find the string in the region in -them. Call @var[parse-verification-function] with the current input. -If it returns a non-@nil value then that is returned as the value of -the parse. A parse may return a @nil value if the verification -function returns a non-@nil second value. -@enddefcom - - - -@chapter (Files) -@index (Files) -This chapter discusses ways to read and write files at various levels @dash at -marks, into regions, and into buffers. This also treats automatic mechanisms -that affect the state of buffers in which files are read. - -@section (File Options and Type Hooks) -@index (File options) -@index (Type hooks) -@index (File type hooks) -The user specifies file options with a special syntax on the first line of a -file. If the first line contains the string "@f[-*-]", then @hemlock -interprets the text between the first such occurrence and the second, which -must be contained in one line , as a list of @w{"@f<@i[option]: @i[value]>"} -pairs separated by semicolons. The following is a typical example: -@begin[programexample] -;;; -*- Mode: Lisp, Editor; Package: Hemlock -*- -@end[programexample] -See the @i[Hemlock User's Manual] for more details and predefined options. - -File type hooks are executed when @hemlock reads a file into a buffer based on -the type of the pathname. When the user specifies a @hid[Mode] file option -that turns on a major mode, @hemlock ignores type hooks. This mechanism is -mostly used as a simple means for turning on some appropriate default major -mode. - -@defmac[fun {define-file-option}, args -{@i[name] (@i[buffer] @i[value]) @mstar<@i[declaration]> @mstar<@i[form]>}] -This defines a new file option with the string name @i[name]. @i[Buffer] and -@i[value] specify variable names for the buffer and the option value string, -and @i[form]'s are evaluated with these bound. -@enddefmac - -@defmac[fun {define-file-type-hook}, args -{@i[type-list] (@i[buffer] @i[type]) @mstar<@i[declaration]> @mstar<@i[form]>}] - -This defines some code that @f[process-file-options] (below) executes when the -file options fail to set a major mode. This associates each type, a -@f[simple-string], in @i[type-list] with a routine that binds @i[buffer] to the -buffer the file is in and @i[type] to the type of the pathname. -@enddefmac - -@defun[fun {process-file-options}, args {@i[buffer] @optional @i[pathname]}] -This checks for file options in buffer and invokes handlers if there are any. -@i[Pathname] defaults to @i[buffer]'s pathname but may be @nil. If there is no -@hid[Mode] file option that specifies a major mode, and @i[pathname] has a -type, then this tries to invoke the appropriate file type hook. -@f[read-buffer-file] calls this. -@enddefun - - -@section (Pathnames and Buffers) -There is no good way to uniquely identify buffer names and pathnames. However, -@hemlock has one way of mapping pathnames to buffer names that should be used -for consistency among customizations and primitives. Independent of this, -@hemlock provides a means for consistently generating prompting defaults when -asking the user for pathnames. - -@defun[fun {pathname-to-buffer-name}, args {@i[pathname]}] -This function returns a string of the form "@f[file-namestring] -@f[directory-namestring]". -@enddefun - -@defhvar[var "Pathname Defaults", val {(pathname "gazonk.del")}] -@defhvar1[var "Last Resort Pathname Defaults Function"] -@defhvar1[var "Last Resort Pathname Defaults", val {(pathname "gazonk")}] -These variables control the computation of default pathnames when needed for -promting the user. @hid[Pathname Defaults] is a @i[sticky] default. -See the @i[Hemlock User's Manual] for more details. -@enddefhvar - -@defun[fun {buffer-default-pathname}, args {@i[buffer]}] -This returns @hid[Buffer Pathname] if it is bound. If it is not bound, and -@i[buffer]'s name is composed solely of alphnumeric characters, then return a -pathname formed from @i[buffer]'s name. If @i[buffer]'s name has other -characters in it, then return the value of @hid[Last Resort Pathname Defaults -Function] called on @i[buffer]. -@enddefun - -@section (File Groups) -@index (File groups) -File groups provide a simple way of collecting the files that compose a system -and naming that collection. @Hemlock supports commands for searching, -replacing, and compiling groups. - -@defvar[var {active-file-group}] -This is the list of files that constitute the currently selected file group. -If this is @nil, then there is no current group. -@enddefvar - -@defmac[fun {do-active-group}, args {@mstar<@i[form]>}] -@defhvar1[var "Group Find File", val {nil}] -@defhvar1[var "Group Save File Confirm", val {t}] -@f[do-active-group] iterates over @var[active-file-group] executing the forms -once for each file. While the forms are executing, the file is in the current -buffer, and the point is at the beginning. If there is no active group, this -signals an editor-error. - -This reads each file into its own buffer using @f[find-file-buffer]. Since -unwanted buffers may consume large amounts of memory, @hid[Group Find File] -controls whether to delete the buffer after executing the forms. When the -variable is false, this deletes the buffer if it did not previously exist; -however, regardless of this variable, if the user leaves the buffer modified, -the buffer persists after the forms have completed. Whenever this processes a -buffer that already existed, it saves the location of the buffer's point before -and restores it afterwards. - -After processing a buffer, if it is modified, @f[do-active-group] tries to save -it. If @hid[Group Save File Confirm] is non-@nil, it asks for confirmation. -@enddefmac - - -@section (File Reading and Writing) -Common Lisp pathnames are used by the file primitives. For probing, checking -write dates, and so forth, all of the Common Lisp file functions are available. - -@defun[fun {read-file}, args {@i[pathname] @i[mark]}] -This inserts the file named by @i[pathname] at @i[mark]. -@enddefun - -@defun[fun {write-file}, args {@i[region] @i[pathname]}, - keys {[keep-backup][access][append]}] -@defhvar1[var {Keep Backup Files}, val {@nil}] -This function writes the contents of @i[region] to the file named by -@i[pathname]. This writes @i[region] using a stream as if it were opened with -@kwd[if-exists] supplied as @kwd[rename-and-delete]. - -When @i[keep-backup], which defaults to the value of @hid[Keep Backup Files], -is non-@nil, this opens the stream as if @kwd[if-exists] were @kwd[rename]. If -@i[append] is non-@nil, this writes the file as if it were opened with -@kwd[if-exists] supplied as @kwd[append]. - -This signals an error if both @i[append] and @i[keep-backup] are supplied as -non-@nil. - -@i[Access] is an implementation dependent value that is suitable for setting -@i[pathname]'s access or protection bits. -@enddefun - - -@defun[fun {write-buffer-file}, args {@i[buffer] @i[pathname]}] -@defhvar1[var {Write File Hook}] -@defhvar1[var {Add Newline at EOF on Writing File}, val {@kwd[ask-user]}] -@f[write-buffer-file] writes @i[buffer] to the file named by @i[pathname] -including the following: -@begin[itemize] -It assumes pathname is somehow related to @i[buffer]'s pathname: if the -@i[buffer]'s write date is not the same as @i[pathname]'s, then this prompts -the user for confirmation before overwriting the file. - -It consults @hid[Add Newline at EOF on Writing File] (see @i[Hemlock User's -Manual] for possible values) and interacts with the user if necessary. - -It sets @hid[Pathname Defaults], and after using @f[write-file], marks -@i[buffer] unmodified. - -It updates @i[Buffer]'s pathname and write date. - -It renames the buffer according to the new pathname if possible. - -It invokes @hid[Write File Hook]. -@end[itemize] - -@hid[Write File Hook] is a list of functions that take the newly written buffer -as an argument. -@enddefun - - -@defun[fun {read-buffer-file}, args {@i[pathname] @i[buffer]}] -@defhvar1[var {Read File Hook}] -@f[read-buffer-file] deletes @i[buffer]'s region and uses @f[read-file] to read -@i[pathname] into it, including the following: -@begin[itemize] -It sets @i[buffer]'s write date to the file's write date if the file exists; -otherwise, it @f[message]'s that this is a new file and sets @i[buffer]'s write -date to @nil. - -It moves @i[buffer]'s point to the beginning. - -It sets @i[buffer]'s unmodified status. - -It sets @i[buffer]'s pathname to the result of probing @i[pathname] if the file -exists; otherwise, this function sets @i[buffer]'s pathname to the result of -merging @i[pathname] with @f[default-directory]. - -It sets @hid[Pathname Defaults] to the result of the previous item. - -It processes the file options. - -It invokes @hid[Read File Hook]. -@end[itemize] - -@hid[Read File Hook] is a list functions that take two arguments @dash the -buffer read into and whether the file existed, @true if so. -@enddefun - - -@defun[fun {find-file-buffer}, args {@i[pathname]}] -This returns a buffer assoicated with the @i[pathname], reading the file into a -new buffer if necessary. This returns a second value indicating whether a new -buffer was created, @true if so. If the file has already been read, this -checks to see if the file has been modified on disk since it was read, giving -the user various recovery options. This is the basis of the @hid[Find File] -command. -@enddefun - - - -@chapter (Hemlock's Lisp Environment) - -@index (Lisp environment) -This chapter is sort of a catch all for any functions and variables -which concern @hemlock's interaction with the outside world. - -@section(Entering and Leaving the Editor) - -@defun[fun {ed}, args {@optional @i[x]}] -@defhvar1[var "Entry Hook"] -@f[ed] enters the editor. It is basically as specified in Common Lisp. If -@i[x] is supplied and is a symbol, the definition of @i[x] is put into a -buffer, and that buffer is selected. If @i[x] is a pathname, the file -specified by @i[x] is visited in a new buffer. If @i[x] is not supplied or -@nil, the editor is entered in the same state as when last exited. - -The @hid[Entry Hook] is invoked each time the editor is entered. -@enddefhvar - -@defun[fun {exit-hemlock}, args {@optional @i[value]}] -@defhvar1[var {Exit Hook}] -@f[exit-hemlock] leaves @hemlock and return to Lisp; @i[value] is the -value to return, which defaults to @true. The hook -@hvarref[Exit Hook] is invoked before this is done. -@enddefun - -@defun[fun {pause-hemlock}] -@f[pause-hemlock] suspends the editor process and returns control to the shell. -When the process is resumed, it will still be running @hemlock. -@enddefun - - -@section(Keyboard Input) -@index(I/O) -@index[keyboard input] -@index[input, keyboard] - -Keyboard input interacts with a number of other parts of the editor. Since the -command loop works by reading from the keyboard, keyboard input is the initial -cause of everything that happens. Also, @hemlock redisplays in the low-level -input loop when there is no available input from the user. - - -@defvar[var {editor-input}] -@defvar1[var {real-editor-input}] -@defhvar1[var "Input Hook"] -@defhvar1[var "Abort Hook"] -@index[aborting] -@var[editor-input] is an object on which @hemlock's I/O routines operate. You -can get input, clear input, return input, and listen for input. Input appears -as key-events. - -@var[real-editor-input] holds the initial value of @var[editor-input]. This is -useful for reading from the user when @var[editor-input] is rebound (such as -within a keyboard macro.) - -@Hemlock invokes the functions in @hid[Input Hook] each time someone reads a -key-event from @var[real-editor-input]. These take no arguments. -@enddefvar - -@defun[fun {get-key-event}, args {@i[editor-input] @optional @i[ignore-abort-attempts-p]}] -This function returns a key-event as soon as it is available on -@i[editor-input]. @i[Editor-input] is either @var[editor-input] or -@var[real-editor-input]. @i[Ignore-abort-attempts-p] indicates whether -@binding[C-g] and @binding[C-G] throw to the editor's top-level command loop; -when this is non-nil, this function returns those key-events when the user -types them. Otherwise, it aborts the editor's current state, returning to the -command loop. - -When the user aborts, @Hemlock invokes the functions in @hid[Abort Hook]. -These functions take no arguments. When aborting, @Hemlock ignores the -@hid[Input Hook]. -@enddefun - - -@defun[fun {unget-key-event}, args {@i[key-event] @i[editor-input]}] -This function returns @i[key-event] to @i[editor-input], so the next invocation -of @f[get-key-event] will return @i[key-event]. If @i[key-event] is -@f[#k"C-g"] or @f[#k"C-G"], then whether @f[get-key-event] returns it depends -on that function's second argument. @i[Editor-input] is either -@var[editor-input] or @var[real-editor-input]. -@enddefun - -@defun[fun {clear-editor-input}, args {@i[editor-input]}] -This function flushes any pending input on @i[editor-input]. @i[Editor-input] -is either @var[editor-input] or @var[real-editor-input]. -@enddefun - -@defun[fun {listen-editor-input}, args {@i[editor-input]}] -This function returns whether there is any input available on @i[editor-input]. -@i[Editor-input] is either @var[editor-input] or @var[real-editor-input]. -@enddefun - -@defun[fun {editor-sleep}, args {@i[time]}] -Return either after @i[time] seconds have elapsed or when input is available on -@var[editor-input]. -@enddefun - -@defvar[var {key-event-history}] -This is a @hemlock ring buffer (see page @pageref[rings]) that holds the last -60 key-events read from the keyboard. -@enddefvar - -@defvar[var {last-key-event-typed}] -Commands use this variable to realize the last key-event the user typed to -invoke the commands. Before @hemlock ever reads any input, the value is @nil. -This variable usually holds the last key-event read from the keyboard, but it -is also maintained within keyboard macros allowing commands to behave the same -on each repetition as they did in the recording invocation. -@enddefvar - -@defvar[var {input-transcript}] -If this is non-@nil then it should be an adjustable vector with a fill-pointer. -When it is non-@nil, @hemlock pushes all input read onto this vector. -@enddefvar - - - -@section(Hemlock Streams) -It is possible to create streams which output to or get input from a buffer. -This mechanism is quite powerful and permits easy interfacing of @hemlock to -Lisp. - -@defun[fun {make-hemlock-output-stream}, args - {@i[mark] @optional @i[buffered]}] -@defun1[fun {hemlock-output-stream-p}, args {@i[object]}] -@f[make-hemlock-output-stream] returns a stream that inserts at the permanent -mark @i[mark] all output directed to it. @i[Buffered] controls whether the -stream is buffered or not, and its valid values are the following keywords: -@begin[description] -@kwd[none]@\No buffering is done. This is the default. - -@kwd[line]@\The buffer is flushed whenever a newline is written or -when it is explicitly done with @f[force-output]. - -@kwd[full]@\The screen is only brought up to date when it is -explicitly done with @f[force-output] -@end[description] - -@f[hemlock-output-stream-p] returns @true if @i[object] is a -@f[hemlock-output-stream] object. -@enddefun - -@defun[fun {make-hemlock-region-stream}, args {@i[region]}] -@defun1[fun {hemlock-region-stream-p}, args {@i[object]}] -@f[make-hemlock-region-stream] returns a stream from which the text in -@i[region] can be read. @f[hemlock-region-stream-p] returns @true if -@i[object] is a @f[hemlock-region-stream] object. -@enddefun - -@defmac[fun {with-input-from-region}, args -{(@i[var] @i[region]) @mstar<@i[declaration]> @mstar<@i[form]>}] -While evaluating @i[form]s, binds @i[var] to a stream which returns input -from @i[region]. -@enddefmac - -@defmac[fun {with-output-to-mark}, args -{(@i[var] @i[mark] @mopt<@i"buffered">) @mstar<@i[declaration]> @mstar<@i[form]>}] - During the evaluation of the @i[form]s, binds @i[var] to a stream which -inserts output at the permanent @i[mark]. @i[Buffered] has the same meaning as -for @f[make-hemlock-output-stream]. -@enddefmac - -@defmac[fun {with-pop-up-display}, args {(@i[var] @key @i[height name]) @mstar<@i[declaration]> @mstar<@i[form]>}] -@defvar1[var {random-typeout-buffers}] - This macro executes @i[forms] in a context with @i[var] bound to a stream. -@Hemlock collects output to this stream and tries to pop up a display of the -appropriate height containing all the output. When @i[height] is supplied, -@Hemlock creates the pop-up display immediately, forcing output on line breaks. -The system saves the output in a buffer named @i[name], which defaults to -@hid[Random Typeout]. When the window is the incorrect height, the display -mechanism will scroll the window with more-style prompting. This is useful -for displaying information of temporary interest. - -When a buffer with name @i[name] already exists and was not previously created -by @f[with-pop-up-display], @Hemlock signals an error. - -@var[random-typeout-buffers] is an association list mapping random typeout -buffers to the streams that operate on the buffers. -@enddefmac - - -@section (Interface to the Error System) -The error system interface is minimal. There is a simple editor-error -condition which is a subtype of error and a convenient means for signaling -them. @Hemlock also provides a standard handler for error conditions while in -the editor. - -@defun[fun {editor-error-format-string}, args {@i[condition]}] -@defun1[fun {editor-error-format-arguments}, args {@i[condition]}] -Handlers for editor-error conditions can access the condition object with -these. -@enddefun - -@defun[fun {editor-error}, args {@rest @i[args]}] -This function is called to signal minor errors within Hemlock; these are errors -that a normal user could encounter in the course of editing such as a search -failing or an attempt to delete past the end of the buffer. This function -@f[signal]'s an editor-error condition formed from @i[args], which are @nil or -a @f[format] string possibly followed by @f[format] arguments. @Hemlock -invokes commands in a dynamic context with an editor-error condition handler -bound. This default handler beeps or flashes (or both) the display. If the -condition passed to the handler has a non-@nil string slot, the handler also -invokes @f[message] on it. The command in progress is always aborted, and this -function never returns. -@enddefun - -@defmac[fun {handle-lisp-errors}, args {@mstar<@i[form]>}] -Within the body of this macro any Lisp errors that occur are handled in some -fashion more gracefully than simply dumping the user in the debugger. This -macro should be wrapped around code which may get an error due to some action -of the user @dash for example, evaluating code fragments on the behalf of and -supplied by the user. Using this in a command allows the established handler -to shadow the default editor-error handler, so commands should take care to -signal user errors (calls to @f[editor-errors]) outside of this context. -@enddefmac - - -@section (Definition Editing) -@index (Definition editing) -@hemlock provides commands for finding the definition of a function, macro, or -command and placing the user at the definition in a buffer. This, of course, -is implementation dependent, and if an implementation does not associate a -source file with a routine, or if @hemlock cannot get at the information, then -these commands do not work. If the Lisp system does not store an absolute -pathname, independent of the machine on which the maintainer built the system, -then users need a way of translating a source pathname to one that will be able -to locate the source. - -@defun[fun {add-definition-dir-translation}, args {@i[dir1] @i[dir2]}] -This maps directory pathname @i[dir1] to @i[dir2]. Successive invocations -using the same @i[dir1] push into a translation list. When @hemlock seeks a -definition source file, and it has a translation, then it tries the -translations in order. This is useful if your sources are on various machines, -some of which may be down. When @hemlock tries to find a translation, it first -looks for translations of longer directory pathnames, finding more specific -translations before shorter, more general ones. -@enddefun - -@defun[fun {delete-definition-dir-translation}, args {@i[dir]}] -This deletes the mapping of @i[dir] to all directories to which it has been -mapped. -@enddefun - - -@section (Event Scheduling) -@index (Event scheduling) -@index (Scheduling events) -The mechanism described in this chapter is only operative when the Lisp process -is actually running inside of @hemlock, within the @f[ed] function. The -designers intended its use to be associated with the editor, such as with -auto-saving files, reminding the user, etc. - -@defun[fun {schedule-event}, args {@i[time] @i[function] @optional @i[repeat]}] -This causes @hemlock to call @i[function] after @i[time] seconds have passed, -optionally repeating every @i[time] seconds. @i[Repeat] defaults to @true. -This is a rough mechanism since commands can take an arbitrary amount of time -to run; @hemlock invokes @i[function] at the first possible moment after -@i[time] has elapsed. @i[Function] takes the time in seconds that has elapsed -since the last time it was called (or since it was scheduled for the first -invocation). -@enddefun - -@defun[fun {remove-scheduled-event}, args {@i[function]}] -This removes @i[function] from the scheduling queue. @i[Function] does not -have to be in the queue. -@enddefun - - -@section (Miscellaneous) - -@defun[fun {in-lisp}, args {@mstar<@i[form]>}] -@index[Evaluating Lisp code] -This evaluates @i[form]'s inside @f[handle-lisp-errors]. It also binds -@var[package] to the package named by @hid[Current Package] if it is non-@nil. -Use this when evaluating Lisp code on behalf of the user. -@enddefun - -@defmac[fun {do-alpha-chars}, args {(@i[var] @i[kind] [@i[result]]) @mstar<@i[form]>}] -This iterates over alphabetic characters in Common Lisp binding @i[var] to each -character in order as specified under character relations in @i[Common Lisp the -Language]. @i[Kind] is one of @kwd[lower], @kwd[upper], or @kwd[both]. When -the user supplies @kwd[both], lowercase characters are processed first. -@enddefmac - - - -@chapter (High-Level Text Primitives) -This chapter discusses primitives that operate on higher level text forms than -characters and words. For English text, there are functions that know about -sentence and paragraph structures, and for Lisp sources, there are functions -that understand this language. This chapter also describes mechanisms for -organizing file sections into @i[logical pages] and for formatting text forms. - - -@section (Indenting Text) -@index (Indenting) -@label(indenting) - -@defhvar[var "Indent Function", val {tab-to-tab-stop}] -The value of this variable determines how indentation is done, and it is a -function which is passed a mark as its argument. The function should indent -the line that the mark points to. The function may move the mark around on -the line. The mark will be @f[:left-inserting]. The default simply inserts a -@binding[tab] character at the mark. A function for @hid[Lisp] mode probably -moves the mark to the beginning of the line, deletes horizontal whitespace, and -computes some appropriate indentation for Lisp code. -@enddefhvar - -@defhvar[var "Indent with Tabs", val {indent-using-tabs}] -@defhvar1[var "Spaces per Tab", val {8}] -@hid[Indent with Tabs] holds a function that takes a mark and a number of -spaces. The function will insert a maximum number of tabs and a minimum number -of spaces at mark to move the specified number of columns. The default -definition uses @hid[Spaces per Tab] to determine the size of a tab. @i[Note,] -@hid[Spaces per Tab] @i[is not used everywhere in @hemlock yet, so changing -this variable could have unexpected results.] -@enddefhvar - -@defun[fun {indent-region}, args {@i[region]}] -@defun1[fun {indent-region-for-commands}, args {@i[region]}] -@f[indent-region] invokes the value of @hid[Indent Function] on every line of -region. @f[indent-region-for-commands] uses @f[indent-region] but first saves -the region for the @hid[Undo] command. -@enddefun - -@defun[fun {delete-horizontal-space}, args {@i[mark]}] -This deletes all characters with a @hid[Space] attribute (see section -@ref[sys-def-chars]) of @f[1]. -@enddefun - - -@section (Lisp Text Buffers) -@index (Lisp text functions) -@hemlock bases its Lisp primitives on parsing a block of the buffer and -annotating lines as to what kind of Lisp syntax occurs on the line or what kind -of form a mark might be in (for example, string, comment, list, etc.). These -do not work well if the block of parsed forms is exceeded when moving marks -around these forms, but the block that gets parsed is somewhat programmable. - -There is also a notion of a @i[top level form] which this documentation often -uses synonymously with @i[defun], meaning a Lisp form occurring in a source -file delimited by parentheses with the opening parenthesis at the beginning of -some line. The names of the functions include this inconsistency. - -@defun[fun {pre-command-parse-check}, args {@i[mark] @i[for-sure]}] -@defhvar1[var {Parse Start Function}, val {start-of-parse-block}] -@defhvar1[var {Parse End Function}, val {end-of-parse-block}] -@defhvar1[var {Minimum Lines Parsed}, val {50}] -@defhvar1[var {Maximum Lines Parsed}, val {500}] -@defhvar1[var {Defun Parse Goal}, val {2}] -@f[pre-command-parse-check] calls @hid[Parse Start Function] and @hid[Parse End -Function] on @i[mark] to get two marks. It then parses all the lines between -the marks including the complete lines they point into. When @i[for-sure] is -non-@nil, this parses the area regardless of any cached information about the -lines. Every command that uses the following routines calls this before doing -so. - -The default values of the start and end variables use @hid[Minimum Lines -Parsed], @hid[Maximum Lines Parsed], and @hid[Defun Parse Goal] to determine -how big a region to parse. These two functions always include at least the -minimum number of lines before and after the mark passed to them. They try to -include @hid[Defun Parse Goal] number of top level forms before and after the -mark passed them, but these functions never return marks that include more than -the maximum number of lines before or after the mark passed to them. -@enddefun - -@defun[fun {form-offset}, args {@i[mark] @i[count]}] -This tries to move @i[mark] @i[count] forms forward if positive or -@i[count] -forms backwards if negative. @i[Mark] is always moved. If there were enough -forms in the appropriate direction, this returns @i[mark], otherwise nil. -@enddefun - -@defun[fun {top-level-offset}, args {@i[mark] @i[count]}] -This tries to move @i[mark] @i[count] top level forms forward if positive or --@i[count] top level forms backwards if negative. If there were enough top -level forms in the appropriate direction, this returns @i[mark], otherwise nil. -@i[Mark] is moved only if this is successful. -@enddefun - -@defun[fun {mark-top-level-form}, args {@i[mark1] @i[mark2]}] -This moves @i[mark1] and @i[mark2] to the beginning and end, respectively, of -the current or next top level form. @i[Mark1] is used as a reference to start -looking. The marks may be altered even if unsuccessful. If successful, return -@i[mark2], else nil. @i[Mark2] is left at the beginning of the line following -the top level form if possible, but if the last line has text after the closing -parenthesis, this leaves the mark immediately after the form. -@enddefun - -@defun[fun {defun-region}, args {@i[mark]}] -This returns a region around the current or next defun with respect to -@i[mark]. @i[Mark] is not used to form the region. If there is no appropriate -top level form, this signals an editor-error. This calls -@f[pre-command-parse-check] first. -@enddefun - -@defun[fun {inside-defun-p}, args {@i[mark]}] -@defun1[fun {start-defun-p}, args {@i[mark]}] -These return, respectively, whether @i[mark] is inside a top level form or at -the beginning of a line immediately before a character whose @hid[Lisp Syntax] -(see section @ref[sys-def-chars]) value is @kwd[opening-paren]. -@enddefun - -@defun[fun {forward-up-list}, args {@i[mark]}] -@defun1[fun {backward-up-list}, args {@i[mark]}] -Respectively, these move @i[mark] immediately past a character whose @hid[Lisp -Syntax] (see section @ref[sys-def-chars]) value is @kwd[closing-paren] or -immediately before a character whose @hid[Lisp Syntax] value is -@kwd[opening-paren]. -@enddefun - -@defun[fun {valid-spot}, args {@i[mark] @i[forwardp]}] -This returns @true or @nil depending on whether the character indicated by -@i[mark] is a valid spot. When @i[forwardp] is set, use the character after -mark and vice versa. Valid spots exclude commented text, inside strings, and -character quoting. -@enddefun - -@defun[fun {defindent}, args {@i[name] @i[count]}] -This defines the function with @i[name] to have @i[count] special arguments. -@f[indent-for-lisp], the value of @hid[Indent Function] (see section -@ref[indenting]) in @hid[Lisp] mode, uses this to specially indent these -arguments. For example, @f[do] has two, @f[with-open-file] has one, etc. -There are many of these defined by the system including definitions for special -@hemlock forms. @i[Name] is a simple-string, case insensitive and purely -textual (that is, not read by the Lisp reader); therefore, @f["with-a-mumble"] -is distinct from @f["mumble:with-a-mumble"]. -@enddefun - - -@section (English Text Buffers) -@index (English text functions) -@label(text-functions) -This section describes some routines that understand basic English language -forms. - -@defun[fun {word-offset}, args {@i[mark] @i[count]}] -This moves @i[mark] @i[count] words forward (if positive) or backwards (if -negative). If @i[mark] is in the middle of a word, that counts as one. If -there were @i[count] (-@i[count] if negative) words in the appropriate -direction, this returns @i[mark], otherwise nil. This always moves @i[mark]. -A word lies between two characters whose @hid[Word Delimiter] attribute value -is @f[1] (see section @ref[sys-def-chars]). -@enddefun - -@defun[fun {sentence-offset}, args {@i[mark] @i[count]}] -This moves @i[mark] @i[count] sentences forward (if positive) or backwards (if -negative). If @i[mark] is in the middle of a sentence, that counts as one. If -there were @i[count] (-@i[count] if negative) sentences in the appropriate -direction, this returns @i[mark], otherwise nil. This always moves @i[mark]. - -A sentence ends with a character whose @hid[Sentence Terminator] attribute is -@f[1] followed by two spaces, a newline, or the end of the buffer. The -terminating character is optionally followed by any number of characters whose -@hid[Sentence Closing Char] attribute is @f[1]. A sentence begins after a -previous sentence ends, at the beginning of a paragraph, or at the beginning of -the buffer. -@enddefun - -@defun[fun {paragraph-offset}, args {@i[mark] @i[count] @optional @i[prefix]}] -@defhvar1[var {Paragraph Delimiter Function}, var {default-para-delim-function}] -This moves @i[mark] @i[count] paragraphs forward (if positive) or backwards (if -negative). If @i[mark] is in the middle of a paragraph, that counts as one. -If there were @i[count] (-@i[count] if negative) paragraphs in the appropriate -direction, this returns @i[mark], otherwise nil. This only moves @i[mark] if -there were enough paragraphs. - -@hid[Paragraph Delimiter Function] holds a function that takes a mark, -typically at the beginning of a line, and returns whether or not the current -line should break the paragraph. @f[default-para-delim-function] returns @true -if the next character, the first on the line, has a @hid[Paragraph Delimiter] -attribute value of @f[1]. This is typically a space, for an indented -paragraph, or a newline, for a block style. Some modes require a more -complicated determinant; for example, @hid[Scribe] modes adds some characters -to the set and special cases certain formatting commands. - -@i[Prefix] defaults to @hid[Fill Prefix] (see section @ref[filling]), and the -right prefix is necessary to correctly skip paragraphs. If @i[prefix] is -non-@nil, and a line begins with @i[prefix], then the scanning process skips -the prefix before invoking the @hid[Paragraph Delimiter Function]. -Note, when scanning for paragraph bounds, and @i[prefix] is non-@nil, lines are -potentially part of the paragraph regardless of whether they contain the prefix; -only the result of invoking the delimiter function matters. - -The programmer should be aware of an idiom for finding the end of the current -paragraph. Assume @f[paragraphp] is the result of moving @f[mark] one -paragraph, then the following correctly determines whether there actually is a -current paragraph: -@begin[programexample] -(or paragraphp - (and (last-line-p mark) - (end-line-p mark) - (not (blank-line-p (mark-line mark))))) -@end[programexample] -In this example @f[mark] is at the end of the last paragraph in the buffer, and -there is no last newline character in the buffer. @f[paragraph-offset] would -have returned @nil since it could not skip any paragraphs since @f[mark] was at -the end of the current and last paragraph. However, you still have found a -current paragraph on which to operate. @f[mark-paragraph] understands this -problem. -@enddefun - -@defun[fun {mark-paragraph}, args {@f[mark1] @f[mark2]}] -This marks the next or current paragraph, setting @i[mark1] to the beginning -and @i[mark2] to the end. This uses @hid[Fill Prefix] (see section -@ref[filling]). @i[Mark1] is always on the first line of the paragraph, -regardless of whether the previous line is blank. @i[Mark2] is typically at -the beginning of the line after the line the paragraph ends on, this returns -@i[mark2] on success. If this cannot find a paragraph, then the marks are left -unmoved, and @nil is returned. -@enddefun - - -@section (Logical Pages) -@index (Logical pages) -@index (Page functions) -@label(logical-pages) -Logical pages are a way of dividing a file into coarse divisions. This is -analogous to dividing a paper into sections, and @hemlock provides primitives -for moving between the pages of a file and listing a directory of the page -titles. Pages are separated by @hid[Page Delimiter] characters (see section -@ref[sys-def-chars]) that appear at the beginning of a line. - -@defun[fun {goto-page}, args {@i[mark] @i[n]}] -This moves @i[mark] to the absolute page numbered @i[n]. If there are less -than @i[n] pages, it signals an editor-error. If it returns, it returns -@i[mark]. @hemlock numbers pages starting with one for the page delimited by -the beginning of the buffer and the first @hid[Page Delimiter] (or the end of -the buffer). -@enddefun - -@defun[fun {page-offset}, args {@i[mark] @i[n]}] -This moves mark forward @i[n] (-@i[n] backwards, if @i[n] is negative) -@hid[Page Delimiter] characters that are in the zero'th line position. If a -@hid[Page Delimiter] is the immediately next character after mark (or before -mark, if @i[n] is negative), then skip it before starting. This always moves -@i[mark], and if there were enough pages to move over, it returns @i[mark]; -otherwise, it returns @nil. -@enddefun - -@defun[fun {page-directory}, args {@i[buffer]}] -This returns a list of each first non-blank line in @i[buffer] that follows a -@hid[Page Delimiter] character that is in the zero'th line position. This -includes the first line of the @i[buffer] as the first page title. If a page -is empty, then its title is the empty string. -@enddefun - -@defun[fun {display-page-directory}, args {@i[stream] @i[directory]}] -This writes the list of strings, @i[directory], to @i[stream], enumerating them -in a field three wide. The number and string are separated by two spaces, and -the first line contains headings for the page numbers and title strings. -@enddefun - - -@section (Filling) -@index (filling) -@label(filling) -Filling is an operation on text that breaks long lines at word boundaries -before a given column and merges shorter lines together in an attempt to make -each line roughly the specified length. This is different from justification -which tries to add whitespace in awkward places to make each line exactly the -same length. @Hemlock's filling optionally inserts a specified string at the -beginning of each line. Also, it eliminates extra whitespace between lines and -words, but it knows two spaces follow sentences (see section -@ref[text-functions]). - -@defhvar[var "Fill Column", val {75}] -@defhvar1[var "Fill Prefix", val {nil}] -These variables hold the default values of the prefix and column arguments to -@hemlock's filling primitives. If @hid[Fill Prefix] is @nil, then there is no -fill prefix. -@enddefhvar - -@defun[fun {fill-region}, args {@i[region] @optional @i[prefix] @i[column]}] -This deletes any blank lines in region and fills it according to prefix and -column. @i[Prefix] and @i[column] default to @hid[Fill Prefix] and @hid[Fill -Column]. -@enddefun - -@defun[fun {fill-region-by-paragraphs}, - args {@i[region] @optional @i[prefix] @i[column]}] -This finds paragraphs (see section @ref[text-functions]) within region and -fills them with @f[fill-region]. This ignores blank lines between paragraphs. -@i[Prefix] and @i[column] default to @hid[Fill Prefix] and @hid[Fill Column]. -@enddefun - - - -@chapter (Utilities) -@index (Utilities) -This chapter describes a number of utilities for manipulating some types of -objects @hemlock uses to record information. String-tables are used to store -names of variables, commands, modes, and buffers. Ring lists can be used to -provide a kill ring, recent command history, or other user-visible features. - - -@section(String-table Functions) -@index (String-tables) -@label(string-tables) - -String tables are similar to Common Lisp hash tables in that they associate a -value with an object. There are a few useful differences: in a string table -the key is always a case insensitive string, and primitives are provided to -facilitate keyword completion and recognition. Any type of string may be added -to a string table, but the string table functions always return -@f[simple-string]'s. - -A string entry in one of these tables may be thought of as being separated into -fields or keywords. The interface provides keyword completion and recognition -which is primarily used to implement some @hid[Echo Area] commands. These -routines perform a prefix match on a field-by-field basis allowing the -ambiguous specification of earlier fields while going on to enter later fields. -While string tables may use any @f[string-char] as a separator, the use of -characters other than @binding[space] may make the @hid[Echo Area] commands -fail or work unexpectedly. - -@defun[fun {make-string-table}, keys {[separator][initial-contents]}] -This function creates an empty string table that uses @i[separator] as the -character, which must be a @f[string-char], that distinguishes fields. -@i[Initial-contents] specifies an initial set of strings and their values in -the form of a dotted @f[a-list], for example: -@Begin[ProgramExample] -'(("Global" . t) ("Mode" . t) ("Buffer" . t)) -@End[ProgramExample] -@enddefun - -@defun[fun {string-table-p}, args {@i[string-table]}] -This function returns @true if @i[string-table] is a @f[string-table] object, -otherwise @nil. -@enddefun - -@defun[fun {string-table-separator}, args {@i[string-table]}] -This function returns the separator character given to @f[make-string-table]. -@enddefun - -@defun[fun {delete-string}, args {@i[string] @i[table]}] -@defun1[fun {clrstring}, args {@i[table]}] -@f[delete-string] removes any entry for @i[string] from the @f[string-table] -@i[table], returning @true if there was an entry. @f[clrstring] removes all -entries from @i[table]. -@enddefun - -@defun[fun {getstring}, args {@i[string] @i[table]}] -This function returns as multiple values, first the value corresponding to the -string if it is found and @nil if it isn't, and second @true if it is found and -@nil if it isn't. - -This may be set with @f[setf] to add a new entry or to store a new value for a -string. It is an error to try to insert a string with more than one -field separator character occurring contiguously. -@enddefun - -@defun[fun {complete-string}, args {@i[string] @i[tables]}] -This function completes @i[string] as far as possible over the list of -@i[tables], returning five values. It is an error for @i[tables] to have -different separator characters. The five return values are as follows: -@begin[itemize] -The maximal completion of the string or @nil if there is none. - -An indication of the usefulness of the returned string: -@begin[description] -@kwd[none]@\ -There is no completion of @i[string]. - -@kwd[complete]@\ -The completion is a valid entry, but other valid completions exist too. This -occurs when the supplied string is an entry as well as initial substring of -another entry. - -@kwd[unique]@\ -The completion is a valid entry and unique. - -@kwd[ambiguous]@\ -The completion is invalid; @f[get-string] would return @nil and @nil if given -the returned string. -@end[description] - -The value of the string when the completion is @kwd[unique] or @kwd[complete], -otherwise @nil. - -An index, or nil, into the completion returned, indicating where the addition -of a single field to @i[string] ends. The command @hid[Complete Field] uses -this when the completion contains the addition to @i[string] of more than one -field. - -An index to the separator following the first ambiguous field when the -completion is @kwd[ambiguous] or @kwd[complete], otherwise @nil. -@end[itemize] -@enddefun - -@defun[fun {find-ambiguous}, args {@i[string] @i[table]}] -@defun1[fun {find-containing}, args {@i[string] @i[table]}] -@f[find-ambiguous] returns a list in alphabetical order of all the -strings in @i[table] matching @i[string]. This considers an entry as matching -if each field in @i[string], taken in order, is an initial substring of the -entry's fields; entry may have fields remaining. - -@f[find-containing] is similar, but it ignores the order of the fields in -@i[string], returning all strings in @i[table] matching any permutation of the -fields in @i[string]. -@enddefun - -@defmac[fun {do-strings}, args {(@i[string-var] @i[value-var] @i[table] @MOPT<@i[result]>) @mstar<@i[declaration]> @mstar<@i[tag] @MOR @i[statement]>}] -This macro iterates over the strings in @i[table] in alphabetical order. On -each iteration, it binds @i[string-var] to an entry's string and @i[value-var] -to an entry's value. -@enddefmac - - -@section (Ring Functions) -@index (Rings) -@label[rings] -There are various purposes in an editor for which a ring of values can be used, -so @hemlock provides a general ring buffer type. It is used for maintaining a -ring of killed regions (see section @ref[kill-ring]), a ring of marks (see -section @ref[mark-stack]), or a ring of command strings which various modes and -commands maintain as a history mechanism. - -@defun[fun {make-ring}, args {@i[length] @optional @i[delete-function]}] -Makes an empty ring object capable of holding up to @i[length] Lisp objects. -@i[Delete-function] is a function that each object is passed to before it falls -off the end. @i[Length] must be greater than zero. -@enddefun - -@defun[fun {ringp}, args {@i[ring]}] -Returns @true if @i[ring] is a @f[ring] object, otherwise @nil. -@enddefun - -@defun[fun {ring-length}, args {@i[ring]}] -Returns as multiple-values the number of elements which @i[ring] -currently holds and the maximum number of elements which it may hold. -@enddefun - -@defun[fun {ring-ref}, args {@i[ring] @i[index]}] -Returns the @i[index]'th item in the @i[ring], where zero is the index -of the most recently pushed. This may be set with @f[setf]. -@enddefun - -@defun[fun {ring-push}, args {@i[object] @i[ring]}] -Pushes @i[object] into @i[ring], possibly causing the oldest item to -go away. -@enddefun - -@defun[fun {ring-pop}, args {@i[ring]}] -Removes the most recently pushed object from @i[ring] and returns it. -If the ring contains no elements then an error is signalled. -@enddefun - -@defun[fun {rotate-ring}, args {@i[ring] @i[offset]}] -With a positive @i[offset], rotates @i[ring] forward that many times. -In a forward rotation the index of each element is reduced by one, -except the one which initially had a zero index, which is made the -last element. A negative offset rotates the ring the other way. -@enddefun - - -@section (Undoing commands) -@index (Undo functions) -@label(undo) - -@defun[fun {save-for-undo}, args {@i[name] @i[method] @optional @i[cleanup] @i[method-undo] @i[buffer]}] -This saves information to undo a command. @i[Name] is a string to display when -prompting the user for confirmation when he invokes the @hid[Undo] command (for -example, @f["kill"] or @f["Fill Paragraph"]). @i[Method] is the function to -invoke to undo the effect of the command. @i[Method-undo] is a function that -undoes the undo function, or effectively re-establishes the state immediately -after invoking the command. If there is any existing undo information, this -invokes the @i[cleanup] function; typically @i[method] closes over or uses -permanent marks into a buffer, and the @i[cleanup] function should delete such -references. @i[Buffer] defaults to the @f[current-buffer], and the @hid[Undo] -command only invokes undo methods when they were saved for the buffer that is -current when the user invokes @hid[Undo]. -@enddefun - -@defun[fun {make-region-undo}, args {@i[kind] @i[name] @i[region] @optional @i[mark-or-region]}] -This handles three common cases that commands fall into when setting up undo -methods, including cleanup and method-undo functions (see @f[save-for-undo]). -These cases are indicated by the @i[kind] argument: -@begin[description] -@kwd[twiddle]@\ -Use this kind when a command modifies a region, and the undo information -indicates how to swap between two regions @dash the one before any modification -occurs and the resulting region. @i[Region] is the resulting region, and it -has permanent marks into the buffer. @i[Mark-or-region] is a region without -marks into the buffer (for example, the result of @f[copy-region]). As a -result of calling this, a first invocation of @hid[Undo] deletes @i[region], -saving it, and inserts @i[mark-or-region] where @i[region] used to be. The -undo method sets up for a second invocation of @hid[Undo] that will undo the -effect of the undo; that is, after two calls, the buffer is exactly as it was -after invoking the command. This activity is repeatable any number of times. -This establishes a cleanup method that deletes the two permanent marks into the -buffer used to locate the modified region. - -@kwd[insert]@\ -Use this kind when a command has deleted a region, and the undo information -indicates how to re-insert the region. @i[Region] is the deleted and saved -region, and it does not contain marks into any buffer. @i[Mark-or-region] is a -permanent mark into the buffer where the undo method should insert @i[region]. -As a result of calling this, a first invocation of @hid[Undo] inserts -@i[region] at @i[mark-or-region] and forms a region around the inserted text -with permanent marks into the buffer. This allows a second invocation of -@hid[Undo] to undo the effect of the undo; that is, after two calls, the buffer -is exactly as it was after invoking the command. This activity is repeatable -any number of times. This establishes a cleanup method that deletes either the -permanent mark into the buffer or the two permanent marks of the region, -depending on how many times the user used @hid[Undo]. - -@kwd[delete]@\ -Use this kind when a command has inserted a block of text, and the undo -information indicates how to delete the region. @i[Region] has permanent marks -into the buffer and surrounds the inserted text. Leave @i[Mark-or-region] -unspecified. As a result of calling this, a first invocation of @hid[Undo] -deletes @i[region], saving it, and establishes a permanent mark into the buffer -to remember where the @i[region] was. This allows a second invocation of -@hid[Undo] to undo the effect of the undo; that is, after two calls, the buffer -is exactly as it was after invoking the command. This activity is repeatable -any number of times. This establishes a cleanup method that deletes either the -permanent mark into the buffer or the two permanent marks of the region, -depending on how many times the user used @hid[Undo]. -@end[description] - -@blankspace(1 line) -@i[Name] in all cases is an appropriate string indicating what the command did. -This is used by @hid[Undo] when prompting the user for confirmation before -calling the undo method. The string used by @hid[Undo] alternates between this -argument and something to indicate that the user is undoing an undo. -@enddefun - - - -@chapter (Miscellaneous) -This chapter is somewhat of a catch-all for comments and features that don't -fit well anywhere else. - - -@section (Generic Pointer Up) -@hid[Generic Pointer Up] is a @hemlock command bound to mouse up-clicks. It -invokes a function supplied with the interface described in this section. This -command allows different commands to be bound to the same down-click in various -modes with one command bound to the corresponding up-click. - -@defun[fun {supply-generic-pointer-up-function}, args {@i[function]}] -@index[Generic Pointer Up] -This function supplies a function that @hid[Generic Pointer Up] invokes the -next time it executes. -@enddefun - - -@section (Using View Mode) -@hid[View] mode supports scrolling through files automatically terminating the -buffer at end-of-file as well as commands for quitting the mode and popping -back to the buffer that spawned the @hid[View] mode buffer. Modes such as -@hid[Dired] and @hid[Lisp-Lib] use this to view files and description of -library entries. - -Modes that want similar commands should use @f[view-file-command] to view a -file and get a handle on the view buffer. To allow the @hid[View Return] and -@hid[View Quit] commands to return to the originating buffer, you must set the -variable @hid[View Return Function] in the viewing buffer to a function that -knows how to do this. Furthermore, since you now have a reference to the -originating buffer, you must add a buffer local delete hook to it that will -clear the view return function's reference. This needs to happen for two -reasons in case the user deletes the originating buffer: -@Begin[Enumerate] -You don't want the return function to go to a non-existing, invalid buffer. - -Since the viewing buffer still exists, its @hid[View Return Function] buffer -local variable still exists. This means the function still references the -deleted originating buffer, and garbage collection cannot reclaim the memory -locked down by the deleted buffer. -@End[Enumerate] - -The following is a piece of code that could implement part of @hid[Dired View -File] that uses two closures to accomplish that described above: -@Begin[ProgramExample] -(let* ((dired-buf (current-buffer)) - (buffer (view-file-command nil pathname))) - (push #'(lambda (buffer) - (declare (ignore buffer)) - (setf dired-buf nil)) - (buffer-delete-hook dired-buf)) - (setf (variable-value 'view-return-function :buffer buffer) - #'(lambda () - (if dired-buf - (change-to-buffer dired-buf) - (dired-from-buffer-pathname-command nil))))) -@End[ProgramExample] - -The @hid[Dired] buffer's delete hook clears the return function's reference to -the @hid[Dired] buffer. The return function tests the variable to see if it -still holds a buffer when the function executes. - - - -@comment[@chapter (Auxiliary Systems)] -@include(aux-sys) diff --git a/docs/hem/hem-docs.log b/docs/hem/hem-docs.log deleted file mode 100644 index 25528a02ec961d09ec75b75e10fde41a4ef6e139..0000000000000000000000000000000000000000 --- a/docs/hem/hem-docs.log +++ /dev/null @@ -1,43 +0,0 @@ -/usr1/lisp/scribe/hem/user/lisp.mss, 01-Sep-89 10:27:47, Edit by Chiles. - Modifying slave interaction description. - -/usr1/lisp/scribe/hem/cim/cim.mss, 01-Sep-89 10:25:15, Edit by Chiles. - Added description of LOUD-MESSAGE. - -/usr1/lisp/scribe/hem/cim/aux-sys.mss, 01-Sep-89 10:22:22, Edit by Chiles. - Updating slave Lisp interaction functions. - -/usr1/lisp/scribe/hem/cim.mss, 27-Jun-89 15:19:47, Edit by Chiles. - Moved "Auxiliary Systems" chapter into its own file, and qualified lots of - the described symbols with their home package. - -/usr1/lisp/scribe/hem/hemimpl.mss, 22-Jun-89 12:56:23, Edit by Chiles. - Added new WITH-POP-UP-DISPLAY. - - Updated all the English in the prompting functions section. - - Added the "Keep" logical character description. - - -/usr1/lisp/scribe/hem/hemuser.mss, 22-Jun-89 12:55:03, Edit by Chiles. - Added new pop-up windows section. - - Modified modelines section, talked about status line. - - Added completion section. - - -/usr1/lisp/scribe/hem/hemuser.mss, 20-May-89 18:03:57, Edit by Chiles. - Modified example after "Name Keyboard Macro". Scribe was screwing up a paren - in the @binding. I changed it to a programexample, but check the result. - -/usr1/lisp/scribe/hemimpl.mss, 18-May-89 13:00:09, Edit by Chiles. - Addes sections to miscellaneous chapter for View mode interaction and - SUPPLY-GENERIC-POINTER-UP-FUNCTION - -/usr1/lisp/scribe/hemimpl.mss, 15-May-89 17:40:09, Edit by Chiles. - Added new Miscellaneous chapter. - -/usr1/lisp/scribe/hemuser.mss, 15-May-89 14:14:37, Edit by Chiles. - Modified "View" mode section. - diff --git a/docs/hem/hem.dict b/docs/hem/hem.dict deleted file mode 100644 index 312c9d2258d3ffbe0e90d757a7d0f5db82d345fc..0000000000000000000000000000000000000000 --- a/docs/hem/hem.dict +++ /dev/null @@ -1,446 +0,0 @@ -NEWLINE -WHITESPACE -MISINTERPRETED -ENDCOMMANDS -RUBOUT -COMMANDBODY -DEFCOMMAND -ENDDEFCOMMAND -ALT -BF -LINEFEED -TRANSPOSITION -SPICETITLEPAGE -CONTENTSMACROS -TIMESROMANKERN -NEWFACECODE -COPYFONT -PRESSFILE -BINDINGFONT -TIMESROMAN -SUBSTITUTECHAR -ASSOCFONT -SETFONTINFO -STANDARDR -STANDARDBBI -SSF -HELVETICA -BOLDPAGENO -PAGENO -BEGINENTRY -TABCLEAR -TABSET -EXTRALEFTMARGIN -ENDENTRY -ININIT -COMMANDENV -CM -COMMANDTEXT -LEFTMARGIN -RIGHTMARGIN -ARGS -TABDIVIDE -CHPGNO -NCONV -CHAPTERNO -CHAPID -PAGEHEADING -BORDERSTYLE -SPICETP -MACLACHLAN -ABS -WHIZZY -SCREENFULL -REF -RIGHTDOWN -LEFTDOWN -MIDDLEDOWN -MIDDLEUP -BIZZARE -FORMFEED -NEWLINES -UN -YANKS -YANKED -OOPS -TYPOS -LOWERCASE -UPPERCASE -TRANSPOSING -TRANSPOSE -EMACS -UNINITIATED -TRANSPOSITIONS -TRANSPOSES -LF -PAREN -COMMANDEND -BOYER -MOORE -UNREADING -FOO -FILENAME -BUFFER'S -SYS -TECO -PROGRAMEXAMPLE -TRASHED -SEMI -PATHNAME -UPD -SRCCOM -LOSSAGE -DEFUN -PARENS -DEFSTRUCT -DEFMACRO -UNREADABLE -ED -RECOMPILATION -RECOMPILE -SFASL -EVAL -UNDAMAGED -NEWPAGE -INDEXINCLUDE -NLM -EMS -RLM -CENUMERATE -LEFTMPOSN -BULLETPOSN -NRM -CDESCRIPTION -RRM -DEFHVAR -ENDDEFHVAR -HVAR -SLISP -PICE -ISP -CLISP -OMMON -MACS -DOC -PORTED -ZWEI -'S -BLOTCH -PERQ -META -KEYPAD -LEFTUP -COMMAND -'S -FACECODE -VARS -SOS -MODELESS -MODELINE -MSS -UNDERRATED -MALCOORDINATION -RIGHTARROW -LEFTARROW -DOWNARROW -UPARROW -SPASTIC -EOF -PATHNAMES -GAZONK -DEL -IO -INOPERATIVE -TYPESCRIPT -KEYTRAN -REDIRECTED -BACKTRACE -CONDITIONALIZE -INIT -'HEMLOCK -SETV -DEFINDENT -ABBREVIATORY -NEUTRALIZES -UNEXPAND -RESYNCHRONIZING -FORMFEEDS -COMMAND'S -HEMLOCKMAN -READDEFS -RESHAPE -IDIOM -CURVACEOUS -PERCENTAGEWISE -ABBREVS -ABBREV -PROB -BINARIES -ENDDEFVAR -FEEP -KWD -DEFUNS -VAL -DEFCOM -ENDDEFCOM -LLISP -REBINDS -TYPESCRIPTS -SYNTAXES -COMREF -MAKUNBOUND -DEFVAR -ENDDEFUN -VAR -ARGS -DEFUN -DEFVAR -ENDDEFVAR -CHECKIN -EXT -GETSTRING -CLRSTRING -HASHTABLES -TYPEOUT -ERRORP -REPROMPT -DOLIST -CURSORPOS -RECENTERING -MACREF -ZEROP -UNSHADOW -MOD -DEFATTRIBUTE -ADA -INTERNING -MOREKEYS -CLEANUP -DEFMODE -FUNCALLS -MGROUP -HLET -ENDDEFCON -DEFCON -UPCASE -'STRING -UPPERCASED -NINSERT -FUNLABEL -EQ -VARREF -TRUENAME -HVARREF -FUNREF -ENDLISP -MIN -ENDDEFMAC -MOPT -POS -MSTAR -DEFMAC -'TH -MARK'S -CHARPOS -EQL -LINE'S -REMF -PUTF -GETF -PLIST -SETF -MULTICS -WHOLEY -SKEF -UTTIR -SINGLESIDED -HYPHENATION -NAMESTRING -NAMESTRINGS -FASL -DEF -DEFANYTHING -CRYPTIC -WILDCARDS -FILESYSTEM -PAGEREF -XTERM -TERMCAP -UNIX -LIB -MISC -VERBATIM -MODELINES -PIXELS -BITMAP -WORKSTATION -USR -COM -PREFIXING -HYPER -CRUFT -LIBRARYFILE -FONTFAMILY -STRINGMAX -BEEPING -AUTORAISE -TELNET -SLAVE'S -SERVER'S -PREPENDING -OFFLOADING -ICONIFY -LPR -INFO -CHECKPOINTED -ROBERT -MUNGING -DEACTIVATED -EPHEMERALLY -DEACTIVATE -HQB -MODELINEP -RINGP -SUBTYPES -SUBTYPE -MSTAR' -WINDOWP -COMMANDP -MOR -GTR -GEQ -NEQ -LEQ -LSS -FIELD'S -WINDOWS' -BUFFERS' -BUFFERP -DEACTIVATES -REGIONP -MARKP -LINEP -COMMANDSTRING -DOD -RESEARCHCREDIT -CS -CMU -CHILES -BLANKSPACE -TITLEBOX -TITLEPAGE -REPORTTITLE -ARPACREDIT -DOUBLESIDED -UNDOABLE -LISPS -CLX -SPEC -DISASSOCIATED -MAILERS -RAND -AFS -SUPFILE -STEPPENWOLF -GPA -CRYPT -HOSTBASE -LOGIN -RT'S -FRAME'S -ARPANET -SETENV -FORWCOMPS -REPLCOMPS -RMMPROC -RM -FORMFILE -NOCC -FCC -REPL -PREVS -RFSLINK -HOSTNAME -XBIFF -RFS -GROUPNAME -ACCOUNTNAME -BLURBS -WORKSTATION'S -PROFILENAME -USERNAME -MAILDROP -MACHINENAME -WORKSTATIONS -HEADERS' -LISPY -FIELDS' -INBOX -ANNO -NOTATING -MH -ID -MH'S -MSGS -EXP -CC -DATEFIELD -BB -MSG -FOLDER'S -COMP -FORW -DRAFTFOLDER -DRAFTMESSAGE -INC -HEMLOCKDELETED -RMM -NOTATED -UNDELETE -ID'S -RMF -REFILE -REFILING -REFILED -DEACTIVATING -UNKILL -ZERO'TH -DIR -VS -KEYSYM -KEYCODE -XLIB -KEYSYM'S -FORWARDP -HI -ISPELL -LEN -LISP'S -TWIDDLE -RIGHTUP -HEMUSER -MACROEXPAND -UNPROVIDED -DIRED -WILDCARD -UNDELETING -TXT -PATHNAME'S -SUBDIRECTORIES -SUBDIRECTORY -FILENAMES -BUFED -HINIT -WINDOWING -UNSUPPLIED -CALLABLE -'ABLE -OP -FORGOES -AUX -'RESCHEDULE -'CHECK -'REMOVE -BITCHFUCKSALL -SUBPROCESS -KEYSYMS diff --git a/docs/hem/user/commands.mss b/docs/hem/user/commands.mss deleted file mode 100644 index 7d547bd04f4a89a5f4db8050f4d6b4eb07a12192..0000000000000000000000000000000000000000 --- a/docs/hem/user/commands.mss +++ /dev/null @@ -1,822 +0,0 @@ -@comment{-*- Dictionary: hem; Mode: spell; Package: Hemlock -*-} -@chap[Basic Commands] -@section[Motion Commands] - -@index[commands, basic]@index[motion]There is a fairly small number of -basic commands for moving around in the buffer. While there are many other -more complex motion commands, these are by far the most commonly used and -the easiest to learn. - -@defcom[com "Forward Character", bind (C-f, Rightarrow)] -@defcom1[com "Backward Character", bind (C-b, Leftarrow)] -@index[character, motion] -@hid[Forward Character] moves the point forward by one character. If a prefix -argument is supplied, then the point is moved by that many characters. -@hid[Backward Character] is identical, except that it moves the point -backwards. -@enddefcom - -@defcom[com "Forward Word", bind {M-f}] -@defcom1[com "Backward Word", bind {M-b}] -@index[word, motion]These commands move the point forward and backward -over words. The point is always left between the last word and first -non-word character in the direction of motion. This means that after moving -backward the cursor appears on the first character of the word, while after -moving forward, the cursor appears on the delimiting character. Supplying -a prefix argument moves the point by that many words. -@enddefcom - -@defcom[com "Next Line", bind (C-n, Downarrow)] -@defcom1[com "Previous Line", bind (C-p, Uparrow)] -@defcom1[com "Goto Absolute Line"] -@index[line, motion] -@hid[Next Line] and @hid[Previous Line] move to adjacent lines, while remaining -the same distance within a line. Note that this motion is by logical lines, -each of which may take up many lines on the screen if it wraps. If a prefix -argument is supplied, then the point is moved by that many lines. - -The position within the line at the start is recorded, and each successive -use of @binding[C-p] or @binding[C-n] attempts to move the point to that -position on the new line. If it is not possible to move to the recorded -position because the line is shorter, then the point is left at the end of -the line. - -@hid[Goto Absolute Line] moves to the indicated line, as if you counted them -starting at the beginning of the buffer with number one. If the user supplies -a prefix argument, it is the line number; otherwise, @Hemlock prompts the user -for the line. -@enddefcom - -@defcom[com "End of Line", bind {C-e}] -@defcom1[com "Beginning of Line", bind {C-a}] -@hid[End of Line] moves the point to the end of the current line, while -@hid[Beginning of Line] moves to the beginning. If a prefix argument is -supplied, then the point is moved to the end or beginning of the line that -many lines below the current one. -@enddefcom - -@defcom[com "Scroll Window Down", bind {C-v}] -@defcom1[com "Scroll Window Up", bind {M-v}] -@index[scrolling] -@hid[Scroll Window Down] moves forward in the buffer by one screenful of text, -the exact amount being determined by the size of the window. If a prefix -argument is supplied, then this scrolls the screen that many lines. When this -action scrolls the line with the point off the screen, it this command moves -the point to the vertical center of the window. @hid[Scroll Window Up] is -identical to @hid[Scroll Window Down], except that it moves backwards. -@enddefcom - -@defhvar[var "Scroll Overlap", val {2}] -This variable is used by @hid[Scroll Window Down] and @hid[Scroll Window Up] to -determine the number of lines by which the new and old screen should overlap. -@enddefhvar - -@defcom[com "End of Buffer", bind (M-<)] -@defcom1[com "Beginning of Buffer", bind (@bf[M->])] -These commands are used to conveniently get to the very beginning and end of the -text in a buffer. Before the point is moved, its position is saved by -pushing it on the mark stack (see page @pageref[marks]). -@enddefcom - -@defcom[com "Top of Window", bind (M-,)] -@defcom1[com "Bottom of Window", bind (M-.)] -@index[window, motion]@hid[Top of Window] moves the point to the beginning of -the first line displayed in the current window. @hid[Bottom of Window] moves -to the beginning of the last line displayed. -@enddefcom - - -@section[The Mark and The Region] - -@label[marks]@index[marks]@index[region]@index[selection]Each buffer has a -distinguished position known as the @i[mark]. The mark initially points to the -beginning of the buffer. The area between the mark and the point is known as -the @i[region]. Many @hemlock commands which manipulate large pieces of text -use the text in the region. To use these commands, one must first use some -command to mark the region. - -@index[active regions]Although the mark is always pointing somewhere (initially -to the beginning of the buffer), region commands insist that the region be made -@i[active] before it can be used. This prevents accidental use of a region -command from mysteriously mangling large amounts of text. - -@defhvar[var "Active Regions Enabled", val {t}] -When this variable is true, region commands beep unless the region is active. -This may be set to @false for more traditional @emacs region semantics. -@enddefhvar - -Once a marking command makes the region active, it remains active until: -@begin[itemize] -a command uses the region, - -a command modifies the buffer, - -a command changes the current window or buffer, - -a command signals an editor error, - -or the user types @binding[C-g]. -@end[itemize] -Motion commands have the effect of redefining the region, since they move the -point and leave the region active. - -@index[ephemerally active regions]Commands that insert a large chunk of -text into the buffer usually set an @i[ephemerally active] region around -the inserted text. An ephemerally active region is always deactivated by -the next command, regardless of the kind of command. The ephemerally -active region allows an immediately following region command to manipulate -the inserted text, but doesn't persist annoyingly. This is also very -useful with active region highlighting, since it visibly marks the inserted -text. - - -@defhvar[var "Highlight Active Region", val {t}] -@defhvar1[var "Active Region Highlighting Font", val {nil}] -When @hid[Highlight Active Region] is true, @hemlock displays the text in the -region in a different font whenever the region is active. This provides a -visible indication of what text will be manipulated by a region command. -Active region highlighting is only supported under @windows. - -@hid[Active Region Highlighting Font] is the name of the font to use for active -region highlighting. If unspecified, @hemlock uses an underline font. -@enddefhvar - - -@defcom[com "Set/Pop Mark", bind (C-@@)] -This command moves the mark to the point (saving the old mark on the mark -stack) and activates the region. After using this command to mark one end of -the region, use motion commands to move to the other end, then do the region -command. This is the traditional @emacs marking command; when running under a -windowing system with mouse support, it is usually easier to use the mouse with -the @comref[Point to Here] and @comref[Generic Pointer Up]. - -For historical reasons, the prefix argument causes this command to do things -that are distinct commands in @Hemlock. A prefix argument of four does -@hid[Pop and Goto Mark], and a prefix argument of @f[16] does -@hid[Pop Mark]. -@enddefcom - -@defcom[com "Mark Whole Buffer", bind (C-x h)] -@defcom1[com "Mark to Beginning of Buffer", bind (C-<)] -@defcom1[com "Mark to End of Buffer", bind (C->)] -@hid[Mark Whole Buffer] sets the region around the whole buffer, with the point -at the beginning and the mark at the end. If a prefix argument is supplied, -then the mark is put at the beginning and the point at the end. The mark is -pushed on the mark stack beforehand, so popping the stack twice will restore -it. - -@hid[Mark to Beginning of Buffer] sets the current region from point to the -beginning of the buffer. - -@hid[Mark to End of Buffer] sets the current region from the end of the buffer -to point. -@enddefcom - -@defcom[com "Activate Region", bind (C-x C-Space, C-x C-@@)] -This command makes the region active, using whatever the current position of -the mark happens to be. This is useful primarily when the region is -accidentally deactivated. -@enddefcom - - -@subsection[The Mark Stack] - -@index[mark stack]As was hinted at earlier, each buffer has a @i[mark stack], -providing a history of positions in that buffer. The current mark is the mark -on the top of the stack; earlier values are recovered by popping the stack. -Since commands that move a long distance save the old position on the mark -stack, the mark stack commands are useful for jumping to interesting places in -a buffer without having to do a search. - -@defcom[com "Pop Mark", bind (C-M-Space)] -@defcom1[com "Pop and Goto Mark", bind (M-@@, M-Space)] -@hid[Pop Mark] pops the mark stack, restoring the current mark to the next most -recent value. @hid[Pop and Goto Mark] also pops the mark stack, but instead of -discarding the current mark, it moves the point to that position. Both -commands deactivate the region. -@enddefcom - -@defcom[com "Exchange Point and Mark", bind (C-x C-x)] -This command interchanges the position of the point and the mark, thus moving -to where the mark was, and leaving the mark where the point was. This command -can be used to switch between two positions in a buffer, since repeating it -undoes its effect. The old mark isn't pushed on the mark stack, since it is -saved in the point. -@enddefcom - - -@subsection[Using The Mouse] - -@index[mouse]It can be convenient to use the mouse to point to positions in -text, especially when moving large distances. @hemlock defines several -commands for using the mouse. These commands can only be used when running -under @windows (see page @pageref[using-x].) - -@defcom[com "Here to Top of Window", bind (Rightdown)] -@defcom1[com "Top Line to Here", bind (Leftdown)] -@index[window, motion]@hid[Here to Top of Window] scrolls the window so as to -move the line which is under the mouse cursor to the top of the window. This -has the effect of moving forward in the buffer by the distance from the top of -the window to the mouse cursor. @hid[Top Line to Here] is the inverse -operation, it scrolls backward, moving current the top line underneath the -mouse. - -If the mouse is near the left edge of a window, then these commands do smooth -scrolling. @hid[Here To Top of Window] repeatedly scrolls the window up by one -line until the mouse button is released. Similarly, @hid[Top Line to Here] -smoothly scrolls down. -@enddefcom - -@defcom[com "Point to Here", bind (Middledown, S-Leftdown)] -This command moves the point to the position of the mouse, changing to a -different window if necessary. - -When used in a window's modeline, this moves the point of the window's buffer -to the position within the file that is the same percentage, start to end, as -the horizontal position of the mouse within the modeline. This also makes this -window current if necessary. - -This command supplies a function @hid[Generic Pointer Up] invokes if it runs -without any intervening generic pointer up predecessors executing. If the -position of the pointer is different than the current point when the user -invokes @hid[Generic Pointer Up], then this function pushes a buffer mark at -point and moves point to the pointer's position. This allows the user to mark -off a region with the mouse. -@enddefcom - -@defcom[com "Generic Pointer Up", bind (Middleup, S-Leftup)] -Other commands determine this command's action by supplying functions that -this command invokes. The following built-in commands supply the following -generic up actions: -@Begin[Description] -@hid[Point to Here]@\ - When the position of the pointer is different than the current point, the -action pushes a buffer mark at point and moves point to the pointer's position. - -@hid[Bufed Goto and Quit]@\ - The action is a no-op. -@End[Description] -@enddefcom - -@defcom[com "Insert Kill Buffer", bind (S-Rightdown)] -This command is a combination of @hid[Point to Here] and @comref[Un-Kill]. It -moves the point to the mouse location and inserts the most recently killed -text. -@enddefcom - - -@section[Modification Commands] -@index[commands, modification] - -There is a wide variety of basic text-modification commands, but once again the -simplest ones are the most often used. - -@subsection[Inserting Characters] -@index[character, insertion] -@index[insertion, character] - -In @hemlock, you can insert characters with graphic representations by typing -the corresponding key-event which you normally generate with the obvious -keyboard key. You can only insert characters whose codes correspond to ASCII -codes. To insert those without graphic representations, use @hid[Quoted -Insert]. - -@defcom[com "Self Insert"] -@hid[Self Insert] inserts into the buffer the character corresponding to the -key-event typed to invoke the command. This command is normally bound to all -such key-events @binding[Space]. If a prefix argument is supplied, then this -inserts the character that many times. -@enddefcom - -@defcom[com "New Line", bind (Return)] -This command, which has roughly the same effect as inserting a @bf[Newline], -is used to move onto a new blank line. If there are at least two blank -lines beneath the current one then @binding[Return] cleans off any -whitespace on the next line and uses it, instead of inserting a newline. -This behavior is desirable when inserting in the middle of text, because -the bottom half of the screen does not scroll down each time @hid[New Line] -is used. -@enddefcom - -@defcom[com "Quoted Insert", bind {C-q}] -Many key-events have corresponding ASCII characters, but these key-events are -bound to commands other than @hid[Self Insert]. Sometimes they are otherwise -encumbered such as with @binding[C-g]. @hid[Quoted Insert] prompts for a -key-event, without any command interpretation semantics, and inserts the -corresponding character. If the appropriate character has some code other than -an ASCII code, this will beep and abort the command. A common use for this -command is inserting a @bf[Formfeed] by typing @binding[C-q C-l]. If a prefix -argument is supplied, then the character is inserted that many times. -@enddefcom - -@defcom[com "Open Line", bind {C-o}] -This command inserts a newline into the buffer without moving the point. -This command may also be given a prefix argument to insert a number of -newlines, thus opening up some room to work in the middle of a screen of -text. See also @comref[Delete Blank Lines]. -@enddefcom - - -@subsection[Deleting Characters] -@index[deletion, character] -@index[character, deletion] -There are a number of commands for deleting characters as well. - -@defhvar[var "Character Deletion Threshold", val {5}] -If more than this many characters are deleted by a character deletion command, -then the deleted text is placed in the kill ring. -@enddefhvar - -@defcom[com "Delete Next Character", bind {C-d}] -@defcom1[com "Delete Previous Character", bind (Delete, Backspace)] -@hid[Delete Next Character] deletes the character immediately following the -point, that is, the character which appears under the cursor. When given a -prefix argument, @binding[C-d] deletes that many characters after the -point. @hid[Delete Previous Character] is identical, except that it -deletes characters before the point. -@enddefcom - -@defcom[com "Delete Previous Character Expanding Tabs"] -@hid[Delete Previous Character Expanding Tabs] is identical to -@hid[Delete Previous Character], except that it treats tabs as the -equivalent number of spaces. Various language modes that use tabs for -indentation bind @binding[Delete] to this command. -@enddefcom - - -@subsection[Killing and Deleting] - -@index[killing]@index[cutting]@index[pasting]@index[kill ring]@hemlock has many -commands which kill text. Killing is a variety of deletion which saves the -deleted text for later retrieval. The killed text is saved in a ring buffer -known as the @i[kill ring]. Killing has two main advantages over deletion: -@begin[enumerate] -If text is accidentally killed, a not uncommon occurrence, then it can be -restored. - -Text can be moved from one place to another by killing it and then -restoring it in the new location. -@end[enumerate] - -Killing is not the same as deleting. When a command is said to delete -text, the text is permanently gone and is not pushed on the kill ring. -Commands which delete text generally only delete things of little -importance, such as single characters or whitespace. - -@subsection[Kill Ring Manipulation] -@defcom[com "Un-Kill", bind {C-y}] -@index[kill ring, manipulation]This command "yanks" back the most -recently killed piece of text, leaving the mark before the inserted text -and the point after. If a prefix argument is supplied, then the text that -distance back in the kill ring is yanked. -@enddefcom - -@defcom[com "Rotate Kill Ring", bind {M-y}] -This command rotates the kill ring forward, replacing the most recently -yanked text with the next most recent text in the kill ring. @binding[M-y] -may only be used immediately after a use of @binding[C-y] or a previous -use of @binding[M-y]. This command is used to step back through the text -in the kill ring if the desired text was not the most recently killed, and -thus could not be retrieved directly with a @binding[C-y]. If a prefix -argument is supplied, then the kill ring is rotated that many times. -@enddefcom - -@defcom[com "Kill Region", bind {C-w}] -@index[region, killing]This command kills the text between the point and -mark, pushing it onto the kill ring. This command is usually the best way -to move or remove large quantities of text. -@enddefcom - -@defcom[com "Save Region", bind {M-w}] -This command pushes the text in the region on the kill ring, but doesn't -actually kill it, giving an effect similar to typing @binding[C-w C-y]. -This command is useful for duplicating large pieces of text. -@enddefcom - -@subsection[Killing Commands] - -@index[commands, killing]Most commands which kill text append into the -kill ring, meaning that consecutive uses of killing commands will insert -all text killed into the top entry in the kill ring. This allows large -pieces of text to be killed by repeatedly using a killing command. - -@defcom[com "Kill Line", bind {C-k}] -@defcom1[com "Backward Kill Line"] -@index[line, killing]@hid[Kill Line] kills the text from the point to the -end of the current line, deleting the line if it is empty. If a prefix -argument is supplied, then that many lines are killed. Note that a prefix -argument is not the same as a repeat count. - -@hid[Backward Kill Line] is similar, except that it kills from the point to the -beginning of the line. If it is called at the beginning of the line, it kills -the newline and any trailing whitespace on the previous line. With a prefix -argument, this command is the same as @hid[Kill Line] with a negated argument. -@enddefcom - -@defcom[com "Kill Next Word", bind {M-d}] -@defcom1[com "Kill Previous Word", bind (M-Backspace, M-Delete)] -@index[word, killing]@hid[Kill Next Word] kills from the point to the end -of the current or next word. If a prefix argument is supplied, then that -many words are killed. @hid[Kill Previous Word] is identical, except that -it kills backward. -@enddefcom - -@subsection[Case Modification Commands] - -@index[case modification]@hemlock provides a few case modification -commands, which are often useful for correcting typos. - -@defcom[com "Capitalize Word", bind {M-c}] -@defcom1[com "Lowercase Word", bind {M-l}] -@defcom1[com "Uppercase Word", bind {M-u}] -@index[word, case modification]These commands modify the case of the -characters from the point to the end of the current or next word, leaving -the point after the end of the word affected. A positive prefix argument -modifies that many words, moving forward. A negative prefix argument -modifies that many words before the point, but leaves the point unmoved. -@enddefcom - -@defcom[com "Lowercase Region", bind (C-x C-l)] -@defcom1[com "Uppercase Region", bind (C-x C-u)] -@index[region, case modification]These commands case-fold the text in the -region. Since these commands can damage large amounts of text, they ask for -confirmation before modifying large regions and can be undone with @hid[Undo]. -@enddefcom - -@subsection[Transposition Commands] - -@index[transposition]@index[commands, transposition]@hemlock provides a -number of transposition commands. A transposition command swaps the -"things" before and after the point and moves forward one "thing". Just -how a "thing" is defined depends on the particular transposition command. -Transposition commands, particularly -@hid[Transpose Characters] and @hid[Transpose Words], are useful for -correcting typos. More obscure transposition commands can be used to amaze -your friends and demonstrate your immense knowledge of exotic @emacs -commands. - -To the uninitiated, the behavior of transposition commands may seem mysterious; -this has led some implementors to attempt to improve the definition of -transposition, but right-thinking people will accept no substitutes. The -@emacs transposition definition used in @hemlock has two useful properties: -@begin[enumerate] -Repeated applications of a transposition command have a useful effect. The -way to visualize this effect is that each use of the transposition command -drags the previous thing over the next thing. It is possible to correct -double transpositions easily using @hid[Transpose Characters]. - -Transposition commands move backward with a negative prefix argument, thus -undoing the effect of the equivalent positive argument. -@end[enumerate] - -@defcom[com "Transpose Characters", bind {C-t}] -@index[character, transposition]This command exchanges the characters on -either side of the point and moves forward, unless at the end of a line, in -which case it transposes the previous two characters without moving. -@enddefcom - -@defcom[com "Transpose Lines", bind (C-x C-t)] -@index[line, transposition]This command transposes the previous and -current line, moving down to the next line. With a zero argument, it -transposes the current line and the line the mark is on. -@enddefcom - -@defcom[com "Transpose Words", bind {M-t}] -@index[word, transposition]This command transposes the previous word and -the current or next word. -@enddefcom - - -@defcom[com "Transpose Regions", bind (C-x t)] -This command transposes two regions with endpoints defined by the mark stack -and point. To use this command, place three marks (in order) at the start and -end of the first region, and at the start of the second region, then place the -point at the end of the second region. Unlike the other transposition -commands, a second use will simply undo the effect of the first use, and to do -even this, you must reactivate the current region. -@enddefcom - - -@subsection[Whitespace Manipulation] -These commands change the amount of space between words. See also the -indentation commands in section @ref[indentation]. - -@defcom[com "Just One Space", bind (M-|)] -@index[whitespace, manipulation]@index[indentation, manipulation]This -command deletes all whitespace characters before and after the point and then -inserts one space. If a prefix argument is supplied, then that number of -spaces is inserted. -@enddefcom - -@defcom[com "Delete Horizontal Space", bind (M-\)] -This command deletes all blank characters around the point. -@enddefcom - -@defcom[com "Delete Blank Lines", bind (C-x C-o)] -This command deletes all blank lines surrounding the current line, leaving the -point on a single blank line. If the point is already on a single blank line, -then that line is deleted. If the point is on a non-blank line, then all blank -lines immediately following that line are deleted. This command is often used -to clean up after @comref[Open Line]. -@enddefcom - -@section[Filtering] - -@i[Filtering] is a simple way to perform a fairly arbitrary transformation -on text. Filtering text replaces the string in each line with the result -of applying a @llisp function of one argument to that string. The function must -neither destructively modify the argument nor the return value. It is an -error for the function to return a string containing newline characters. - -@defcom[com "Filter Region"] -This function prompts for an expression which is evaluated to obtain a -function to be used to filter the text in the region. For example, to -capitalize all the words in the region one could respond: -@begin[programexample] -Function: #'@comment<>string-capitalize -@end[programexample] -Since the function may be called many times, it should probably be -compiled. Functions for one-time use can be compiled using the compile -function as in the following example which removes all the semicolons on any line -which contains the string "@f[PASCAL]": -@begin[programexample] -Function: (compile nil '(lambda (s) - (if (search "PASCAL" s) - (remove #\; s) - s))) -@end[programexample] -@enddefcom - -@section[Searching and Replacing] -@index[searching]@index[replacing] -Searching for some string known to appear in the text is a commonly used method -of moving long distances in a file. Replacing occurrences of one pattern with -another is a useful way to make many simple changes to text. @hemlock provides -powerful commands for doing both of these operations. - -@defhvar[var "String Search Ignore Case", val {t}] -@index[case sensitivity] -This variable determines the kind of search done by searching and replacing -commands. -@enddefhvar - -@defcom[com "Incremental Search", bind {C-s}] -@defcom1[com "Reverse Incremental Search", bind {C-r}] -@hid[Incremental Search] searches for an occurrence of a string after the -current point. It is known as an incremental search because it reads -key-events form the keyboard one at a time and immediately searches for the -pattern of corresponding characters as you type. This is useful because -it is possible to initially type in a very short pattern and then add more -characters if it turns out that this pattern has too many spurious matches. - -This command dispatches on the following key-events as sub-commands: -@begin[description] -@binding[C-s]@\ - Search forward for an occurrence of the current pattern. This can be used -repeatedly to skip from one occurrence of the pattern to the next, or it can be -used to change the direction of the search if it is currently a reverse search. -If @binding[C-s] is typed when the search string is empty, then a search is -done for the string that was used by the last searching command. - -@binding[C-r]@\ - Similar to @binding[C-s], except that it searches backwards. - -@binding[Delete, Backspace]@\ - Undoes the effect of the last key-event typed. If that key-event simply added -to the search pattern, then this removes the character from the pattern, moving -back to the last match found before entering the removed character. If the -character was a @binding[C-s] or @binding[C-r], then this moves back to the -previous match and possibly reverses the search direction. - -@binding[C-g]@\ - If the search is currently failing, meaning that there is no occurrence of the -search pattern in the direction of search, then @binding[C-g] deletes enough -characters off the end of the pattern to make it successful. If the search -is currently successful, then @binding[C-g] causes the search to be aborted, -leaving the point where it was when the search started. Aborting the search -inhibits the saving of the current search pattern as the last search string. - -@binding[Escape]@\ - Exit at the current position in the text, unless the search string is empty, -in which case a non-incremental string search is entered. - -@binding[C-q]@\ - Search for the character corresponding to the next key-event, rather than -treating it as a command. -@end[description] -Any key-event not corresponding to a graphic character, except those just -described, causes the search to exit. @hemlock then uses the key-event in it -normal command interpretation. - -For example, typing @binding[C-a] will exit the search @i[and] go to the -beginning of the current line. When either of these commands successfully -exits, they push the starting position (before the search) on the mark stack. -If the current region was active when the search started, this foregoes pushing -a mark. -@enddefcom - -@defcom[com "Forward Search", bind (M-s)] -@defcom1[com "Reverse Search", bind (M-r)] -These commands do a normal dumb string search, prompting for the search -string in a normal dumb fashion. One reason for using a non-incremental -search is that it may be faster since it is possible to specify a long -search string from the very start. Since @hemlock uses the Boyer--Moore -search algorithm, the speed of the search increases with the size of the -search string. -When either of these commands successfully exits, they push the starting -position (before the search) on the mark stack. This is inhibited when the -current region is active. -@enddefcom - -@defcom[com "Query Replace", bind (M-%)] -This command prompts in the echo area for a target string and a replacement -string. It then searches for an occurrence of the target after the point. -When it finds a match, it prompts for a key-event indicating what action to -take. The following are valid responses: -@begin[description] -@binding[Space, y]@\ - Replace this occurrence of the target with the replacement string, and search -again. - -@binding[Delete, Backspace, n]@\ - Do not replace this occurrence, but continue the search. - -@binding[!]@\ - Replace this and all remaining occurrences without prompting again. - -@binding[.]@\ - Replace this occurrence and exit. - -@binding[C-r]@\ - Go into a recursive edit (see page @pageref[recursive-edits]) at the current -location. The search will be continued from wherever the point is left when -the recursive edit is exited. This is useful for handling more complicated -cases where a simple replacement will not achieve the desired effect. - -@binding[Escape]@\ - Exit without doing any replacement. - -@binding[Home, C-_, ?, h]@\ - Print a list of all the options available. -@end[description] -Any other key-event causes the command to exit, returning the key-event to the -input stream; thus, @hemlock will interpret it normally for a command binding. - -When the current region is active, this command uses it instead of the region -from point to the end of the buffer. This is especially useful when you expect -to use the @binding[!] option. - -If the replacement string is all lowercase, then a heuristic is used that -attempts to make the case of the replacement the same as that of the -particular occurrence of the target pattern. If "@f[foo]" is being -replaced with "@f[bar]" then "@f[Foo]" is replaced with "@f[Bar]" and -"@f[FOO]" with "@f[BAR]". - -This command may be undone with @hid[Undo], but its undoing may not be undone. -On a successful exit from this command, the starting position (before the -search) is pushed on the mark stack. -@enddefcom - -@defhvar[var "Case Replace", val {t}] -@index[case sensitivity] -If this variable is true then the case preserving heuristic in -@hid[Query Replace] is enabled, otherwise all replacements are done with -the replacement string exactly as specified. -@enddefhvar - -@defcom[com "Replace String"] -This command is the same as @hid[Query Replace] except it operates without ever -querying the user before making replacements. After prompting for a target and -replacement string, it replaces all occurrences of the target string following -the point. If a prefix argument is specified, then only that many occurrences -are replaced. When the current region is active, this command uses it instead -of the region from point to the end of the buffer. -@enddefcom - -@defcom[com "List Matching Lines"] -This command prompts for a search string and displays in a pop-up window all -the lines containing the string that are after the point. If a prefix argument -is specified, then this displays that many lines before and after each matching -line. When the current region is active, this command uses it instead of the -region from point to the end of the buffer. -@enddefcom - -@defcom[com "Delete Matching Lines"] -@defcom1[com "Delete Non-Matching Lines"] -@hid[Delete Matching Lines] prompts for a search string and deletes all lines -containing the string that are after the point. Similarly, @hid[Delete -Non-Matching Lines] deletes all lines following the point that do not contain -the specified string. When the current region is active, these commands uses -it instead of the region from point to the end of the buffer. -@enddefcom - - -@section[Page Commands] -@index[page commands] -Another unit of text recognized by @hemlock is the page. A @i[page] is a piece -of text delimited by formfeeds (@f[^L]'s.) The first non-blank line after the -page marker is the @i[page title]. The page commands are quite useful when -logically distinct parts of a file are put on separate pages. See also -@comref[Count Lines Page]. These commands only recognize @f[^L]'s at the -beginning of a lines, so those quoted in string literals do not get in the way. - -@defcom[com "Previous Page", bind (C-x @bf<]>)] -@defcom1[com "Next Page", bind (C-x [)] -@hid[Previous Page] moves the point to the previous page delimiter, while -@hid[Next Page] moves to the next one. Any page delimiters next to the point -are skipped. The prefix argument is a repeat count. -@enddefcom - -@defcom[com "Mark Page", bind (C-x C-p)] -This command puts the point at the beginning of the current page and the mark -at the end. If given a prefix argument, marks the page that many pages from the -current one. -@enddefcom - -@defcom[com "Goto Page"] -This command does various things, depending on the prefix argument: -@begin[description] -@i[no argument]@\goes to the next page. - -@i[positive argument]@\goes to an absolute page number, moving that many pages -from the beginning of the file. - -@i[zero argument]@\prompts for string and goes to the page with that string in -its title. Repeated invocations in this manner continue searching from the -point of the last find, and a first search with a particular pattern pushes a -buffer mark. - -@i[negative argument]@\moves backward by that many pages, if possible. -@end[description] -@enddefcom - -@defcom[com "View Page Directory"] -@defcom1[com "Insert Page Directory"] -@hid[View Page Directory] uses a pop-up window to display the number and title -of each page in the current buffer. @hid[Insert Page Directory] is the same -except that it inserts the text at the beginning of the buffer. With a prefix -argument, @hid[Insert Page Directory] inserts at the point. -@enddefcom - - -@section[Counting Commands] - -@defcom[com "Count Words"] -This command counts the number of words from the current point to the end of -the buffer, displaying a message in the echo area. When the current region is -active, this uses it instead of the region from the point to the end of the -buffer. Word delimiters are determined by the current major mode. -@enddefcom - -@defcom[com "Count Lines"] -This command counts the number of lines from the current point to the end of -the buffer, displaying a message in the echo area. When the current region is -active, this uses it instead of the region from the point to the end of the -buffer. -@enddefcom - -@defcom[com "Count Lines Page", bind (C-x l)] -This command displays the number of lines in the current page and the number of -lines before and after the point within that page. If given a prefix argument, -the entire buffer is counted instead of just the current page. -@enddefcom - -@defcom[com "Count Occurrences"] -This command prompts for a search string and displays the number of occurrences -of that string in the text from the point to the end of the buffer. When the -current region is active, this uses it instead of the region from the point to -the end of the buffer. -@enddefcom - - -@section[Registers] -@index[registers] -Registers allow you to save a text position or chunk of text associated with a -key-event. This is a convenient way to repeatedly access a commonly-used -location or text fragment. The concept and key bindings should be familiar to -TECO users. - -@defcom[com "Save Position", bind (C-x s)] -@defcom1[com "Jump to Saved Position", bind (C-x j)] -These commands manipulate registers containing textual positions. -@hid[Save Position] prompts for a register and saves the location of the -current point in that register. @hid[Jump to Saved Position] prompts for a -register and moves the point to the position saved in that register. If the -saved position is in a different buffer, then that buffer is made current. -@enddefcom - -@defcom[com "Put Register", bind (C-x x)] -@defcom1[com "Get Register", bind (C-x g)] -These commands manipulate registers containing text. @hid[Put Register] -prompts for a register and puts the text in the current region into the -register. @hid[Get Register] prompts for a register and inserts the text in -that register at the current point. -@enddefcom - -@defcom[com "List Registers"] -@defcom1[com "Kill Register"] -@hid[List Registers] displays a list of all the currently defined registers in -a pop-up window, along with a brief description of their contents. -@hid[Kill Register] prompts for the name of a register and deletes that -register. -@enddefcom diff --git a/docs/hem/user/intro.mss b/docs/hem/user/intro.mss deleted file mode 100644 index 3ee6ceeac039c0005d16d4470e31336d742126f5..0000000000000000000000000000000000000000 --- a/docs/hem/user/intro.mss +++ /dev/null @@ -1,1127 +0,0 @@ -@comment{-*- Dictionary: target:scribe/hem/hem; Mode: spell; Package: Hemlock -*-} -@chap[Introduction] - -@hemlock is a text editor which follows in the tradition of @emacs -and the Lisp Machine editor ZWEI. In its basic form, @hemlock has almost -the same command set as ITS/TOPS-20 @emacs@foot[In this document, "Emacs" -refers to this, the original version, rather than to any of the large -numbers of text editors inspired by it which may go by the same name.], -and similar features such as multiple windows and extended commands, as -well as built in documentation features. The reader should bear in mind -that whenever some powerful feature of @hemlock is described, it has -probably been directly inspired by @emacs. - -This manual describes @hemlock@comment{}'s commands and other user visible -features and then goes on to tell how to make simple customizations. For -complete documentation of the @hemlock primitives with which commands are -written, the @i[Hemlock Command Implementor's Manual] is also available. - - - -@section[The Point and The Cursor] - -@index[point] -@index[cursor] -The @i[point] is the current focus of editing activity. Text typed in by the -user is inserted at the point. Nearly all commands use the point as a -indication of what text to examine or modify. Textual positions in @hemlock -are between characters. This may seem a bit curious at first, but it is -necessary since text must be inserted between characters. Although the point -points between characters, it is sometimes said to point @i[at] a character, in -which case the character after the point is referred to. - -The @i[cursor] is the visible indication of the current focus of attention: a -rectangular blotch under @windows, or the hardware cursor on a terminal. The -cursor is usually displayed on the character which is immediately after the -point, but it may be displayed in other places. Wherever the cursor is -displayed it indicates the current focus of attention. When input is being -prompted for in the echo area, the cursor is displayed where the input is to -go. Under @windows the cursor is only displayed when @hemlock is waiting -for input. - - -@section[Notation] - -There are a number of notational conventions used in this manual which need -some explanation. - - -@subsection[Key-events] - -@label[key-events] -@index[key-events, notation] -@index[bits, key-event] -@index[modifiers, key-event] -The canonical representation of editor input is a @i[key-event]. When you type -on the keyboard, @hemlock receives key-events. Key-events have names for their -basic form, and we refer to this name as a @i[keysym]. This manual displays -keysyms in a @bf[Bold] font. For example, @bf[a] and @bf[b] are the keys that -normally cause the editor to insert the characters @i[a] and @i[b]. - -Key-events have @i[modifiers] or @i[bits] indicating a special interpretation -of the root key-event. Although the keyboard places limitations on what -key-events you can actually type, @hemlock understands arbitrary combinations -of the following modifiers: @i[Control], @i[Meta], @i[Super], @i[Hyper], -@i[Shift], and @i[Lock]. This manual represents the bits in a key-event by -prefixing the keysym with combinations of @bf[C-], @bf[M-], @bf[S-], @bf[H-], -@bf[Shift-], and @bf[Lock]. For example, @bf[a] with both the control and meta -bits set appears as @bf[C-M-a]. In general, ignore the shift and lock -modifiers since this manual never talks about keysyms that explicitly have -these bits set; that is, it may talk about the key-event @bf[A], but it would -never mention @bf[Shift-a]. These are actually distinct key-events, but -typical input coercion turns presents @hemlock with the former, not the latter. - -Key-event modifiers are totally independent of the keysym. This may be new to -you if you are used to thinking in terms of ASCII character codes. For -example, with key-events you can distinctly identify both uppercase and -lowercase keysyms with the control bit set; therefore, @bf[C-a] and @bf[C-A] -may have different meanings to @hemlock. - -Some keysyms' names consist of more than a single character, and these usually -correspond to the legend on the keyboard. For example, some keyboards let you -enter @bf[Home], @bf[Return], @bf[F9], etc. - -In addition to a keyboard, you may have a mouse or pointer device. Key-events -also represent this kind of input. For example, the down and up transitions of -the @i[left button] correspond to the @bf[Leftdown] and @bf[Leftup] keysyms. - -See sections @ref[key-bindings], @ref[using-x], @ref[using-terminals] - - -@subsection[Commands] - -@index[commands]@label[commands]Nearly everything that can be done in -@hemlock is done using a command. Since there are many things worth -doing, @hemlock provides many commands, currently nearly two hundred. -Most of this manual is a description of what commands exist, how they are -invoked, and what they do. This is the format of a command's -documentation: - -@defcom[com "Sample Command", bind (C-M-q, C-`)] -@begin[quotation, facecode i, leftmargin 8ems, rightmargin 3.5ems, -below 0.8 lines] -This command's name is @hid[Sample Command], and it is bound to -@w(@bf(C-M-q)) and @bf[C-`], meaning that typing either of these will -invoke it. After this header comes a description of what the command does: -@end[quotation] - -This command replaces all occurrences following the point of the string -"@f[Pascal]" with the string "@f[Lisp]". If a prefix argument is supplied, -then it is interpreted as the maximum number of occurrences to replace. If -the prefix argument is negative then the replacements are done backwards -from the point. -@comment< -@begin[quotation, facecode i, leftmargin 8ems, rightmargin 3.5ems, -above 0.8 lines, below 0.8 lines] -Toward the end of the description there may be information primarily of -interest to customizers and command implementors. If you don't understand -this information, don't worry, the writer probably forgot to speak English. -@end[quotation] - -@b[Arguments:] -@begin[description] -@i[target]@\The string to replace with "@f[Lisp]". - -@i[buffer]@\The buffer to do the replacement in. If this is @f[:all] then -the replacement is done in all buffers. -@end[description]> -@enddefcom - - -@subsection[Hemlock Variables] - -@index[variables, hemlock]@hemlock variables supply a simple -customization mechanism by permitting commands to be parameterized. For -details see page @pageref[vars]. - -@defhvar[var "Sample Variable", val {36}] -@begin[quotation, facecode i, leftmargin 8ems, below 0.8 lines] -The name of this variable is @hid[Sample Variable] and its initial value is -36. -@end[quotation] -This variable sets a lower limit on the number of replacements that be done -by @hid[Sample Command]. If the prefix argument is supplied, and smaller -in absolute value than @hid[Sample Variable], then the user is prompted as -to whether that small a number of occurrences should be replaced, so as to -avoid a possibly disastrous error. -@enddefhvar - - -@section[Invoking Commands] -@index[invocation, command] -In order to get a command to do its thing, it must be invoked. The user can do -this two ways, by typing the @i[key] to which the command is @i[bound] or by -using an @i[extended command]. Commonly used commands are invoked via their -key bindings since they are faster to type, while less used commands are -invoked as extended commands since they are easier to remember. - - -@subsection[Key Bindings] -@index[bindings, key] -@index[key bindings] -@label[key-bindings] -A key is a sequence of key-events (see section @ref[key-events]) typed on the -keyboard, usually only one or two in length. Sections @ref[using-x] and -@ref[using-terminals] contain information on particular input devices. - -When a command is bound to a key, typing the key causes @hemlock to invoke the -command. When the command completes its job, @hemlock returns to reading -another key, and this continually repeats. - -Some commands read key-events interpreting them however each command desires. -When commands do this, key bindings have no effect, but you can usually abort -@hemlock whenever it is waiting for input by typing @binding[C-g] (see section -@ref[aborting]). You can usually find out what options are available by typing -@binding[C-_] or @binding[Home] (see section @ref[help]). - -The user can easily rebind keys to different commands, bind new keys to -commands, or establish bindings for commands never bound before (see section -@ref[binding-keys]). - -In addition to the key bindings explicitly listed with each command, there are -some implicit bindings created by using key translations@foot[Key translations -are documented in the @i[Hemlock Command Implementor's Manual].]. These -bindings are not displayed by documentation commands such as @hid[Where Is]. -By default, there are only a few key translations. The modifier-prefix -characters @bf[C-^], @bf[Escape], @bf[C-z], or @bf[C-c] may be used when typing -keys to convert the following key-event to a control, meta, control-meta, or -hyper key-event. For example, @bf[C-x Escape b] invokes the same commands as -@bf[C-x M-b], and @bf[C-z u] is the same as @bf[C-M-u]. This allows user to -type more interesting keys on limited keyboards that lack control, meta, and -hyper keys. -@index[bit-prefix key-events] - - -@defhvar[var "Key Echo Delay", val {1.0}] -A key binding may be composed of several key-events, especially when you enter -it using modifier-prefix key-events. @hemlock provides feedback for partially -entered keys by displaying the typed key-events in the echo area. In order to -avoid excessive output and clearing of the echo area, this display is delayed -by @hid[Key Echo Delay] seconds. If this variable is set to @nil, then -@hemlock foregoes displaying initial subsequences of keys. -@enddefhvar - - -@subsection[Extended Commands] - -@index[commands, extended]A command is invoked as an extended command by -typing its name to the @hid[Extended Command] command, which is invoked -using its key binding, @binding[M-x]. - -@defcom[com "Extended Command", bind {M-x}] -This command prompts in the echo area for the name of a command, and then -invokes that command. The prefix argument is passed through to the command -invoked. The command name need not be typed out in full, as long as enough -of its name is supplied to uniquely identify it. Completion is available -using @binding[Escape] and @binding[Space], and a list of possible completions -is given by @binding[Home] or @binding[C-_]. -@enddefcom - - -@section[The Prefix Argument] - -@index[prefix argument]The prefix argument is an integer argument which -may be supplied to a command. It is known as the prefix argument because -it is specified by invoking some prefix argument setting command -immediately before the command to be given the argument. The following -statements about the interpretation of the prefix argument are true: -@begin[itemize] -When it is meaningful, most commands interpret the prefix argument as a -repeat count, causing the same effect as invoking the command that many -times. - -When it is meaningful, most commands that use the prefix argument interpret -a negative prefix argument as meaning the same thing as a positive -argument, but the action is done in the opposite direction. - -Most commands treat the absence of a prefix argument as meaning the same -thing as a prefix argument of one. - -Many commands ignore the prefix argument entirely. - -Some commands do none of the above. -@end[itemize] -The following commands are used to set the prefix argument: - -@defcom[com "Argument Digit", stuff (bound to all control or meta digits)] -Typing a number using this command sets the prefix argument to that number, -for example, typing @binding[M-1 M-2] sets the prefix argument to twelve. -@enddefcom - -@defcom[com "Negative Argument", bind {M--}] -This command negates the prefix argument, or if there is none, sets it to -negative one. For example, typing @binding[M-- M-7] sets the prefix -argument to negative seven. -@enddefcom - -@defcom[com "Universal Argument", bind {C-u}] -@defhvar1[var "Universal Argument Default", val {4}] -This command sets the prefix argument or multiplies it by four. If digits -are typed immediately afterward, they are echoed in the echo area, and the -prefix argument is set to the specified number. If no digits are typed -then the prefix argument is multiplied by four. @binding[C-u - 7] sets the -prefix argument to negative seven. @binding[C-u C-u] sets the prefix -argument to sixteen. @binding[M-4 M-2 C-u] sets the prefix argument to one -hundred and sixty-eight. @binding[C-u M-0] sets the prefix argument to -forty. - -@hid[Universal Argument Default] determines the default value and multiplier -for the @hid[Universal Argument] command. -@enddefcom - - -@section[Modes] - -@label[modes]@index[modes]A mode provides a way to change @hemlock@comment{}'s -behavior by specifying a modification to current key bindings, values of -variables, and other things. Modes are typically used to adjust @hemlock -to suit a particular editing task, e.g. @hid[Lisp] mode is used for editing -@llisp code. - -Modes in @hemlock are not like modes in most text editors; @hemlock is really a -"modeless" editor. There are two ways that the @hemlock mode concept differs -from the conventional one: -@begin[enumerate] -Modes do not usually alter the environment in a very big way, i.e. replace -the set of commands bound with another totally disjoint one. When a mode -redefines what a key does, it is usually redefined to have a slightly -different meaning, rather than a totally different one. For this reason, -typing a given key does pretty much the same thing no matter what modes are -in effect. This property is the distinguishing characteristic of a -modeless editor. - -Once the modes appropriate for editing a given file have been chosen, they -are seldom, if ever, changed. One of the advantages of modeless editors is -that time is not wasted changing modes. -@end[enumerate] - -@index[major mode]A @i[major mode] is used to make some big change in the -editing environment. Language modes such as @hid[Pascal] mode are major -modes. A major mode is usually turned on by invoking the command -@i{mode-name}@hid[ Mode] as an extended command. There is only one major -mode present at a time. Turning on a major mode turns off the one that is -currently in effect. - -@index[minor mode]A @i[minor mode] is used to make a small change in the -environment, such as automatically breaking lines if they get too long. -Unlike major modes, any number of minor modes may be present at once. -Ideally minor modes should do the "right thing" no matter what major and -minor modes are in effect, but this is may not be the case when key -bindings conflict. - -Modes can be envisioned as switches, the major mode corresponding to one big -switch which is thrown into the correct position for the type of editing being -done, and each minor mode corresponding to an on-off switch which controls -whether a certain characteristic is present. - -@defcom[com "Fundamental Mode"] -This command puts the current buffer into @hid[Fundamental] mode. -@hid[Fundamental] mode is the most basic major mode: it's the next best thing -to no mode at all. -@enddefcom - - -@section[Display Conventions] -@index[display conventions] -There are two ways that @hemlock displays information on the screen; one is -normal @i[buffer display], in which the text being edited is shown on the -screen, and the other is a @i[pop-up window]. - - -@subsection[Pop-Up Windows] -@index[pop-up windows] -@index[random typeout] -@label[pop-up] -Some commands print out information that is of little permanent value, and -these commands use a @i[pop-up] window to display the information. It is known -as a @i[pop-up] window because it temporarily appears on the screen overlaying -text already displayed. Most commands of this nature can generate their output -quickly, but in case there is a lot of output, or the user wants to repeatedly -refer to the same output while editing, @hemlock saves the output in a buffer. -Different commands may use different buffers to save their output, and we refer -to these as @i[random typeout] buffers. - -If the amount of output exceeds the size of the pop-up window, @Hemlock -displays the message @w<"@f[--More--]"> after each window full. The following -are valid responses to this prompt: -@Begin[Description] -@bf[Space], @bf[y]@\ - Display the next window full of text. - -@bf[Delete], @bf[Backspace], @bf[n]@\ - Abort any further output. - -@bf[Escape], @bf[!]@\ - Remove the window and continue saving any further output in the buffer. - -@bf[k]@\ - This is the same as @bf[!] or @bf[escape], but @hemlock makes a normal window -over the pop-up window. This only works on bitmap devices. -@End[Description] -Any other input causes the system to abort using the key-event to determine -the next command to execute. - -When the output is complete, @hemlock displays the string @w<"@f[--Flush--]"> -in the pop-up window's modeline, indicating that the user may flush the -temporary display. Typing any of the key-events described above removes the -pop-up window, but typing @bf[k] still produces a window suitable for normal -editing. Any other input also flushes the display, but @hemlock uses the -key-event to determine the next command to invoke. - -@defcom[com "Select Random Typeout Buffer", bind {H-t}] -This command makes the most recently used random typeout buffer the current -buffer in the current window. -@enddefcom - -Random typeout buffers are always in @hid[Fundamental] mode. - - -@subsection[Buffer Display] -@index[buffer, display] -@index[display, buffer] - -If a line of text is too long to fit within the screen width it is @i[wrapped], -with @hemlock displaying consecutive pieces of the text line on as many screen -lines as needed to hold the text. @hemlock indicates a wrapped line by placing -a line-wrap character in the last column of each screen line. Currently, the -line-wrap character is an exclamation point (@f[!]). It is possible for a line -to wrap off the bottom of the screen or on to the top. - -@hemlock wraps screen lines when the line is completely full regardless of the -line-wrap character. Most editors insert the line-wrap character and wrap a -single character when a screen line would be full if the editor had avoided -wrapping the line. In this situation, @hemlock would leave the screen line -full. This means there are always at least two characters on the next screen -line if @hemlock wraps a line of display. When the cursor is at the end of a -line which is the full width of the screen, it is displayed in the last column, -since it cannot be displayed off the edge. - -@hemlock displays most characters as themselves, but it treats some -specially: -@begin[itemize] -Tabs are treated as tabs, with eight character tab-stops. - -Characters corresponding to ASCII control characters are printed as -@f[^]@i[char]; for example, a formfeed is @f[^L]. - -Characters with the most-significant bit on are displayed as -@f[<]@i[hex-code]@f[>]; for example, @f[<E2>]. -@end[itemize] -Since a character may be displayed using more than one printing character, -there are some positions on the screen which are in the middle of a character. -When the cursor is on a character with a multiple-character representation, -@hemlock always displays the cursor on the first character. - - -@subsection[Recentering Windows] -@index[recentering windows] -@index[windows, recentering] - -When redisplaying the current window, @hemlock makes sure the current point is -visible. This is the behavior you see when you are entering text near the -bottom of the window, and suddenly redisplay shifts your position to the -window's center. - -Some buffers receive input from streams and other processes, and you might have -windows displaying these. However, if those windows are not the current -window, the output will run off the bottom of the windows, and you won't be -able to see the output as it appears in the buffers. You can change to a -window in which you want to track output and invoke the following command to -remedy this situation. - -@defcom[com "Track Buffer Point"] -This command makes the current window track the buffer's point. This means -that each time Hemlock redisplays, it will make sure the buffer's point is -visible in the window. This is useful for windows that are not current and -that display buffer's that receive output from streams coming from other -processes. -@enddefcom - - -@subsection[Modelines] -@label[modelines] -@index[modeline] -A modeline is the line displayed at the bottom of each window where @hemlock -shows information about the buffer displayed in that window. Here is a typical -modeline: -@begin[programexample] -Hemlock USER: (Fundamental Fill) /usr/slisp/hemlock/user.mss -@end[programexample] -This tells us that the file associated with this buffer is -"@f[/usr/slisp/hemlock/user.mss]", and the @hid[Current Package] for Lisp -interaction commands is the @f["USER"] package. The modes currently present -are @hid[Fundamental] and @hid[Fill]; the major mode is always displayed first, -followed by any minor modes. If the buffer has no associated file, then the -buffer name will be present instead: -@begin[programexample] -Hemlock PLAY: (Lisp) Silly: -@end[programexample] -In this case, the buffer is named @hid[Silly] and is in @hid[Lisp] mode. The -user has set @hid[Current Package] for this buffer to @f["PLAY"]. - -@defhvar[var "Maximum Modeline Pathname Length", val {nil}] -This variable controls how much of a pathname @hemlock displays in a modeline. -Some distributed file systems can have very long pathnames which leads to the -more particular information in a pathname running off the end of a modeline. -When set, the system chops off leading directories until the name is less than -the integer value of this variable. Three dots, @f[...], indicate a truncated -name. The user can establish this variable buffer locally with the -@hid[Defhvar] command. -@enddefhvar - -If the user has modified the buffer since the last time it was read from or -save to a file, then the modeline contains an asterisk (@f[*]) between the -modes list and the file or buffer name: -@begin[programexample] -Hemlock USER: (Fundamental Fill) * /usr/slisp/hemlock/user.mss -@end[programexample] -This serves as a reminder that the buffer should be saved eventually. - -@index[status line] -There is a special modeline known as the @i[status line] which appears as the -@hid[Echo Area]'s modeline. @Hemlock and user code use this area to display -general information not particular to a buffer @dash recursive edits, whether -you just received mail, etc. - - -@section[Use with X Windows] -@label[using-x] -@index[X windows, use with] -You should use @hemlock on a workstation with a bitmap display and a windowing -system since @hemlock makes good use of a non-ASCII device, mouse, and the -extra modifier keys typically associated with workstations. This section -discusses using @hemlock under X windows, the only supported windowing system. - - -@subsection[Window Groups] -@index[window management] -@label[groups] -@hemlock manages windows under X in groups. This allows @hemlock to be more -sophisticated in its window management without being rude in the X paradigm of -screen usage. With window groups, @hemlock can ignore where the groups are, -but within a group, it can maintain the window creation and deletion behavior -users expect in editors without any interference from window managers. - -Initially there are two groups, a main window and the @hid[Echo Area]. If you -keep a pop-up display, see section @ref[pop-up], @hemlock puts the window it -creates in its own group. There are commands for creating new groups. - -@hemlock only links windows within a group for purposes of the @hid[Next -Window], @hid[Previous Window], and @hid[Delete Next Window] commands. To move -between groups, you must use the @hid[Point to Here] command bound to the -mouse. - -Window manager commands can reshape and move groups on the screen. - - -@subsection[Event Translation] -@index[keyboard use under X] -@index[translation of keys under X] -Each X key event is translated into a canonical input representation, a -key-event. The X key event consists of a scan-code and modifier bits, and -these translate to an X keysym. This keysym and the modifier bits map to a -key-event. - -If you type a key with a shift key held down, this typically maps to a distinct -X keysym. For example, the shift of @bf[3] is @bf[#], and these have different -X keysyms. Some keys map to the same X keysym regardless of the shift bit, -such as @bf[Tab], @bf[Space], @bf[Return], etc. When the X lock bit is on, the -system treats this as a caps-lock, only mapping keysyms for lowercase letters -to shifted keysyms. - -The key-event has a keysym and a field of bits. The X keysyms map directly to -the key-event keysyms. There is a distinct mapping for each CLX modifier bit -to a key-event bit. This tends to eliminate shift and lock modifiers, so -key-events usually only have control, meta, hyper, and super bits on. Hyper -and super usually get turned on with prefix key-events that set them on the -following key-event, but you can turn certain keys on the keyboard into hyper -and super keys. See the X manuals and the @i[Hemlock Command Implementor's -Manual] for details. - -The system also maps mouse input to key-events. Each mouse button has distinct -key-event keysyms for whether the user pressed or released it. For -convenience, @hemlock makes use of an odd property of converting mouse events -to key-events. If you enter a mouse event with the shift key held down, -@hemlock sees the key-event keysym for the mouse event, but the key-event has -the super bit turned on. For example, if you press the left button with the -shift key pressed, @hemlock sees @bf[S-Leftdown]. - -Note that with the two button mouse on the IBM RT PC, the only way to to send -@bf[Middledown] is to press both the left and right buttons simultaneously. -This is awkward, and it often confuses the X server. For this reason, the -commands bound to the middle button are also bound to the shifted left button, -@bf[S-Leftdown], which is much easier to type. - - -@subsection[Cut Buffer Commands] -@index[cutting]@index[pasting] These commands allow the X cut buffer to be -used from @hemlock . Although @hemlock can cut arbitrarily large regions, -a bug in the standard version 10 xterm prevents large regions from being -pasted into an xterm window. - -@defcom[com "Region to Cut Buffer", bind {M-Insert}] -@defcom1[com "Insert Cut Buffer", bind {Insert}] -These commands manipulate the X cut buffer. @hid[Region to Cut Buffer] puts -the text in the region into the cut buffer. @hid[Insert Cut Buffer] inserts -the contents of the cut buffer at the point. -@enddefcom - -@subsection[Redisplay and Screen Management] - -These variables control a number of the characteristics of @hemlock bitmap -screen management. - -@defhvar[var "Bell Style", val {:border-flash}] -@defhvar1[var "Beep Border Width", val {20}] -@hid[Bell Style] determines what beeps do in @hemlock. Acceptable values are -@kwd[border-flash], @kwd[feep], @kwd[border-flash-and-feep], @kwd[flash], -@kwd[flash-and-feep], and @nil (do nothing). - -@hid[Beep Border Width] is the width in pixels of the border flashed by border -flash beep styles. -@enddefhvar - -@defhvar[var "Reverse Video", val {nil}] -If this variable is true, then @hemlock paints white on black in window -bodies, black on white in modelines. -@enddefhvar - -@defhvar[var "Thumb Bar Meter", val {t}] -If this variable is true, then windows will be created to be displayed with a -ruler in the bottom border of the window. -@enddefhvar - -@defhvar[var "Set Window Autoraise", val {:echo-only}] -When true, changing the current window will automatically raise the new current -window. If the value is @kwd[echo-only], then only the echo area window will -be raised automatically upon becoming current. -@enddefhvar - -@defhvar[var "Default Initial Window Width", val {80}] -@defhvar1[var "Default Initial Window Height", val {24}] -@defhvar1[var "Default Initial Window X"] -@defhvar1[var "Default Initial Window Y"] -@defhvar1[var "Default Window Height", val {24}] -@defhvar1[var "Default Window Width", val {80}] -@index[window placement] -@Hemlock uses the variables with "@hid[Initial]" in their names when it first -starts up to make its first window. The width and height are specified in -character units, but the x and y are specified in pixels. The other variables -determine the width and height for interactive window creation, such as making -a window with @comref[New Window]. -@enddefhvar - -@defhvar[var "Cursor Bitmap File", val {"library:hemlock.cursor"}] -This variable determines where the mouse cursor bitmap is read from when -@hemlock starts up. The mask is found by merging this name with "@f[.mask]". -This has to be a full pathname for the C routine. -@enddefhvar - - -@defhvar[var "Default Font"] -This variable holds the string name of the font to be used for normal text -display: buffer text, modelines, random typeout, etc. The font is loaded at -initialization time, so this variable must be set before entering @hemlock. -When @nil, the display type is used to choose a font. -@enddefhvar - - -@section[Use With Terminals] -@label[using-terminals]@index[terminals, use with] @hemlock can also be used -with ASCII terminals and terminal emulators. Capabilities that depend on -@windows (such as mouse commands) are not available, but nearly everything else -can be done. - -@subsection[Terminal Initialization] - -@index[terminal speed] -@index[speed, terminal] -@index[slow terminals] -@index[incremental redisplay] -For best redisplay performance, it is very important to set the terminal speed: -@lisp -stty 2400 -@endlisp -Often when running @hemlock using TTY redisplay, Hemlock will actually be -talking to a PTY whose speed is initialized to infinity. In reality, the -terminal will be much slower, resulting in @hemlock's output getting way ahead -of the terminal. This prevents @hemlock from briefly stopping redisplay to -allow the terminal to catch up. See also @hvarref<Scroll Redraw Ratio>. - -The terminal control sequences are obtained from the termcap database using the -normal Unix conventions. The @f["TERM"] environment variable holds the -terminal type. The @f["TERMCAP"] environment variable can be used to override -the default termcap database (in @f["/etc/termcap"]). The size of the terminal -can be altered from the termcap default through the use of: -@lisp -stty rows @i{height} columns @i{width} -@endlisp - -@subsection[Terminal Input] -@index[ASCII keyboard translation] -@index[bit-prefix key-events] -@index[prefix key-events] -@index[key-event, prefix] -The most important limitation of a terminal is its input capabilities. On a -workstation with function keys and independent control, meta, and shift -modifiers, it is possible to type 800 or so distinct single keystrokes. -Although by default, @hemlock uses only a fraction of these combinations, there -are many more than the 128 key-events available in ASCII. - -On a terminal, @hemlock attempts to translate ASCII control characters into the -most useful key-event: -@begin[itemize] -On a terminal, control does not compose with shift. If the control key is down -when you type a letter keys, the terminal always sends one code regardless of -whether the shift key is held. Since @hemlock primarily binds commands to -key-events with keysyms representing lowercase letters regardless of what bits -are set in the key-event, the system translates the ASCII control codes to a -keysym representing the appropriate lowercase characters. This keysym then -forms a key-event with the control bit set. Users can type @bf[C-c] followed -by an uppercase character to form a key-event with a keysym representing an -uppercase character and bits with the control bit set. - -On a terminal, some of the named keys generate an ASCII control code. For -example, @f[Return] usually sends a @f[C-m]. The system translates these ASCII -codes to a key-event with an appropriate keysym instead of the keysym named by -the character which names the ASCII code. In the above example, typing the -@f[Return] key would generate a key-event with the @bf[Return] keysym and no -bits. It would NOT translate to a key-event with the @bf[m] keysym and the -control bit. -@end[itemize] - -Since terminals have no meta key, you must use the @bf[Escape] and @bf[C-Z] -modifier-prefix key-events to invoke commands bound to key-events with the meta -bit or meta and control bits set. ASCII terminals cannot generate all -key-events which have the control bit on, so you can use the @bf[C-^] -modifier-prefix. The @bf[C-c] prefix sets the hyper bit on the next key-event -typed. - -When running @hemlock from a terminal @f[^\] is the interrupt key-event. -Typing this will place you in the Lisp debugger. - -When using a terminal, pop-up output windows cannot be retained after the -completion of the command. - - -@subsection[Terminal Redisplay] - -Redisplay is substantially different on a terminal. @Hemlock uses different -algorithms, and different parameters control redisplay and screen management. - -Terminal redisplay uses the Unix termcap database to find out how to use a -terminal. @hemlock is useful with terminals that lack capabilities for -inserting and deleting lines and characters, and some terminal emulators -implement these operations very inefficiently (such as xterm). -If you realize poor performance when scrolling, create a termcap entry that -excludes these capabilities. - -@defhvar[var "Scroll Redraw Ratio", val {nil}] -This is a ratio of "inserted" lines to the size of a window. When this ratio -is exceeded, insert/delete line terminal optimization is aborted, and every -altered line is simply redrawn as efficiently as possible. For example, -setting this to 1/4 will cause scrolling commands to redraw the entire window -instead of moving the bottom two lines of the window to the top (typically 3/4 -of the window is being deleted upward and inserted downward, hence a redraw); -however, commands like @hid[New Line] and @hid[Open Line] will still work -efficiently, inserting a line and moving the rest of the window's text -downward. -@enddefhvar - - -@section[The Echo Area] - -@index[echo area] -@index[prompting] -The echo area is the region which occupies the bottom few lines on the screen. -It is used for two purposes: displaying brief messages to the user and -prompting. - -When a command needs some information from the user, it requests it by -displaying a @i[prompt] in the echo area. The following is a typical prompt: -@begin[programexample] -Select Buffer: [hemlock-init.lisp /usr/foo/] -@end[programexample] -The general format of a prompt is a one or two word description of the input -requested, possibly followed by a @i[default] in brackets. The default is a -standard response to the prompt that @hemlock uses if you type @bf[Return] -without giving any other input. - -There are four general kinds of prompts: @comment<Key prompts?> -@begin[description] -@i[key-event]@\ - The response is a single key-event and no confirming @binding[Return] is -needed. - -@i[keyword]@\ - The response is a selection from one of a limited number of choices. -Completion is available using @binding[Space] and @binding[Escape], and you -only need to supply enough of the keyword to distinguish it from any other -choice. In some cases a keyword prompt accepts unknown input, indicating the -prompter should create a new entry. If this is the case, then you must enter -the keyword fully specified or completed using @binding[Escape]; this -distinguishes entering an old keyword from making a new keyword which is a -prefix of an old one since the system completes partial input automatically. - -@i[file]@\ - The response is the name of a file, which may have to exist. Unlike other -prompts, the default has some effect even after the user supplies some input: -the system @i[merges] the default with the input filename. See page -@pageref(merging) for a description of filename merging. @bf[Escape] and -@bf[Space] complete the input for a file parse. - -@i[string]@\ - The response is a string which must satisfy some property, such as being the -name of an existing file. -@end[description] - -@index[history, echo area] -These key-events have special meanings when prompting: -@begin[description] -@binding[Return]@\ - Confirm the current parse. If no input has been entered, then use the -default. If for some reason the input is unacceptable, @hemlock does two -things: -@Begin[enumerate] -beeps, if the variable @hid[Beep on Ambiguity] set, and - -moves the point to the end of the first word requiring disambiguation. -@End[enumerate] -This allows you to add to the input before confirming the it again. - -@binding[Home, C-_]@\ - Print some sort of help message. If the parse is a keyword parse, then print -all the possible completions of the current input in a pop-up window. - -@binding[Escape]@\ - Attempt to complete the input to a keyword or file parse as far as possible, -beeping if the result is ambiguous. When the result is ambiguous, @hemlock -moves the point to the first ambiguous field, which may be the end of the -completed input. - -@binding[Space]@\ - In a keyword parse, attempt to complete the input up to the next space. This -is useful for completing the names of @hemlock commands and similar things -without beeping a lot, and you can continue entering fields while leaving -previous fields ambiguous. For example, you can invoke @hid[Forward Word] as -an extended command by typing @binding[M-X f Space w Return]. Each time the -user enters space, @Hemlock attempts to complete the current field and all -previous fields. - -@binding[C-i, Tab]@\ - In a string or keyword parse, insert the default so that it may be edited. - -@binding[C-p]@\ - Retrieve the text of the last string input from a history of echo area inputs. -Repeating this moves to successively earlier inputs. - -@binding[C-n]@\ - Go the other way in the echo area history. - -@binding[C-q]@\ - Quote the next key-event so that it is not interpreted as a command. -@end[description] - -@defhvar[var "Ignore File Types"] -This variable is a list of file types (or extensions), represented as a string -without the dot, e.g. @f["fasl"]. Files having any of the specified types will -be considered nonexistent for completion purposes, making an unambiguous -completion more likely. The initial value contains most common binary and -output file types. -@enddefhvar - - -@section[Online Help] - -@label[help] -@index[online help] -@index[documentation, hemlock] -@hemlock has a fairly good online documentation facility. You can get brief -documentation for every command, variable, character attribute, and key -by typing a key. - -@defcom[com "Help", bind (Home, C-_)] -This command prompt for a key-event indicating one of a number of other -documentation commands. The following are valid responses: -@begin[description] -@bf[a]@\ - List commands and other things whose names contain a specified keyword. - -@bf[d]@\ - Give the documentation and bindings for a specified command. - -@bf[g]@\ - Give the documentation for any @hemlock thing. - -@bf[v]@\ - Give the documentation for a @hemlock variable and its values. - -@bf[c]@\ - Give the documentation for a command bound to some key. - -@bf[l]@\ - List the last sixty key-events typed. - -@bf[m]@\ - Give the documentation for a mode followed by a short description of its -mode-specific bindings. - -@bf[p]@\ - Give the documentation and bindings for commands that have at least one -binding involving a mouse/pointer key-event. - -@bf[w]@\ - List all the key bindings for a specified command. - -@bf[t]@\ - Describe a @llisp object. - -@binding[q]@\ - Quit without doing anything. - -@binding[Home, C-_, ?, h]@\ - List all of the options and what they do. -@end[description] -@enddefcom - -@defcom[com "Apropos", bind (Home a, C-_ a)] -This command prints brief documentation for all commands, variables, and -character attributes whose names match the input. This performs a prefix match -on each supplied word separately, intersecting the names in each word's result. -For example, giving @hid[Apropos] "@f[f m]" causes it to tersely describe -following commands and variables: -@Begin[Itemize] -@hid[Auto Fill Mode] - -@hid[Fundamental Mode] - -@hid[Mark Form] - -@hid[Default Modeline Fields] - -@hid[Fill Mode Hook] - -@hid[Fundamental Mode Hook] -@End[Itemize] -Notice @hid[Mark Form] demonstrates that the "@f[f]" words may follow the -"@f[m]" order of the fields does not matter for @hid[Apropos]. - -The bindings of commands and values of variables are printed with the -documentation. -@enddefcom - -@defcom[com "Describe Command", bind (Home d, C-_ d)] -This command prompts for a command and prints its full documentation and all -the keys bound to it. -@enddefcom - -@defcom[com "Describe Key", bind (Home c, C-_ c, M-?)] -This command prints full documentation for the command which is bound to -the specified key in the current environment. -@enddefcom - -@defcom[com "Describe Mode", bind (Home m, C-_ m)] -This command prints the documentation for a mode followed by a short -description of each of its mode-specific bindings. -@enddefcom - -@defcom[com "Show Variable"] -@defcom1[com "Describe and Show Variable"] -@hid[Show Variable] prompts for the name of a variable and displays -the global value of the variable, the value local to the current buffer (if -any), and the value of the variable in all defined modes that have it as a -local variable. @hid[Describe and Show Variable] displays the variable's -documentation in addition to the values. -@enddefcom - -@defcom[com "What Lossage", bind (Home l, C-_ l)] -This command displays the last sixty key-events typed. This can be useful -if, for example, you are curious what the command was that you typed by -accident. -@enddefcom - -@defcom[com "Describe Pointer"] -This command displays the documentation and bindings for commands that have -some binding involving a mouse/pointer key-event. It will not show the -documentation for the @hid[Illegal] command regardless of whether it has a -pointer binding. -@enddefcom - -@defcom[com "Where Is", bind (Home w, C-_ w)] -This command prompts for the name of a command and displays its key -bindings in a pop-up window. If a key binding is not global, the -environment in which it is available is displayed. -@enddefcom - -@defcom[com "Generic Describe", bind (Home g, C-_ g)] -This command prints full documentation for any thing that has -documentation. It first prompts for the kind of thing to document, the -following options being available: -@begin[description] -@i[attribute]@\Describe a character attribute, given its name. - -@i[command]@\Describe a command, given its name. - -@i[key]@\Describe a command, given a key to which it is bound. - -@i[variable]@\Describe a variable, given its name. This is the default. -@end[description] -@enddefcom - - -@section[Entering and Exiting] - -@index[entering hemlock]@hemlock is entered by using the @clisp @f[ed] -function. Simply typing @f[(ed)] will enter @hemlock, leaving you in the state -that you were in when you left it. If @hemlock has never been entered before -then the current buffer will be @hid[Main]. The @f[-edit] command-line switch -may also be used to enter @hemlock: see page @pageref[edit-switch]. - -@f[ed] may optionally be given a file name or a symbol argument. Typing -@f[(ed @i[filename])] will cause the specified file to be read into @hemlock, -as though by @hid[Find File]. Typing @w<@f[(ed @i[symbol])]> will pretty-print -the definition of the symbol into a buffer whose name is obtained by adding -"@f[Edit ]" to the beginning of the symbol's name. - -@defcom[com "Exit Hemlock", bind (C-c, C-x C-z)] -@defcom1[com "Pause Hemlock"] -@index[exiting hemlock]@hid[Exit Hemlock] exits @hemlock, returning @f[t]. -@hid[Exit Hemlock] does not by default save modified buffers, or do -anything else that you might think it should do; it simply exits. At any time -after exiting you may reenter by typing @f[(ed)] to @llisp without losing -anything. Before you quit from @llisp using @f[(quit)], you should -save any modified files that you want to be saved. - -@hid[Pause Hemlock] is similar, but it suspends the @llisp process and returns -control to the shell. When the process is resumed, it will still be running -@hemlock. -@enddefcom - - -@section[Helpful Information] - -@label[aborting] -@index[aborting] -@index[undoing] -@index[error recovery] -This section contains assorted helpful information which may be useful in -staying out of trouble or getting out of trouble. - -@begin[itemize] -It is possible to get some sort of help nearly everywhere by typing -@binding[Home] or @binding[C-_]. - -Various commands take over the keyboard and insist that you type the key-events -that they want as input. If you get in such a situation and want to get out, -you can usually do so by typing @bf[C-g] some small number of times. If this -fails you can try typing @binding[C-x C-z] to exit @hemlock and then "@f[(ed)]" -to re-enter it. - -Before you quit, make sure you have saved all your changes. @binding[C-u C-x -C-b] will display a list of all modified buffers. If you exit using @bf[C-x -M-z], then @hemlock will save all modified buffers with associated files. - -If you lose changes to a file due to a crash or accidental failure to save, -look for backup ("@i[file]@f[.BAK]") or checkpoint ("@i[file]@f[.CKP]") files -in the same directory where the file was. - -If the screen changes unexpectedly, you may have accidentally typed an -incorrect command. Use @binding[Home l] to see what it was. If you are -not familiar with the command, use @binding[Home c] to see what it is so that -you know what damage has been done. Many interesting commands can be found -in this fashion. This is an example of the much-underrated learning -technique known as "Learning by serendipitous malcoordination". Who would -ever think of looking for a command that deletes all files in the current -directory? - -If you accidentally type a "killing" command such as @binding[C-w], you can -get the lost text back using @binding[C-y]. The @hid[Undo] command is also -useful for recovering from this sort of problem. -@end[itemize] - -@defhvar[var "Region Query Size", val {30}] -@index[large region] -Various commands ask for confirmation before modifying a region containing more -than this number of lines. If this is @nil, then these commands refrain from -asking, no matter how large the region is. -@enddefhvar - -@defcom[com "Undo"] -This command undoes the last major modification. Killing commands and some -other commands save information about their modifications, so accidental uses -may be retracted. This command displays the name of the operation to be undone -and asks for confirmation. If the affected text has been modified between the -invocations of @hid[Undo] and the command to be undone, then the result may be -somewhat incorrect but useful. Often @hid[Undo] itself can be undone by -invoking it again. -@enddefcom - - -@section[Recursive Edits] -@label[recursive-edits] -@index[recursive edits] -Some sophisticated commands, such as @hid[Query Replace], can place you in a -@i[recursive edit]. A recursive edit is simply a recursive invocation of -@hemlock done within a command. A recursive edit is useful because it allows -arbitrary editing to be done during the execution of a command without losing -any state that the command might have. When the user exits a recursive edit, -the command that entered it proceeds as though nothing happened. @Hemlock -notes recursive edits in the @hid[Echo Area] modeline, or status line. A -counter reflects the number of pending recursive edits. - -@defcom[com "Exit Recursive Edit", bind (C-M-z)] -This command exits the current recursive edit, returning @nil. If invoked when -not in a recursive edit, then this signals an user error. -@enddefcom - -@defcom[com "Abort Recursive Edit", bind (@bf<C-]>)] -This command causes the command which invoked the recursive edit to get an -error. If not in a recursive edit, this signals an user error. -@enddefcom - - -@section[User Errors] -@index[beeping] -@index[errors, user] -When in the course of editing, @hemlock is unable to do what it thinks you want -to do, then it brings this to your attention by a beep or a screen flash -(possibly accompanied by an explanatory echo area message such as @w<"@f[No -next line.]">.) Although the exact attention-getting mechanism may vary on the -output device and variable settings, this is always called @i[beeping]. - -Whatever the circumstances, you had best try something else since @hemlock, -being far more stupid than you, is far more stubborn. @hemlock is an -extensible editor, so it is always possible to change the command that -complained to do what you wanted it to do. - -@section[Internal Errors] - -@index[errors, internal]A message of this form may appear in the echo -area, accompanied by a beep: -@begin[programexample] -Internal error: -Wrong type argument, NIL, should have been of type SIMPLE-VECTOR. -@end[programexample] -If the error message is a file related error such as the following, then -you have probably done something illegal which @hemlock did not catch, -but was detected by the file system: -@begin[programexample] -Internal error: -No access to "/lisp2/emacs/teco.mid" -@end[programexample] -Otherwise, you have found a bug. Try to avoid the behavior that resulted -in the error and report the problem to your system maintainer. Since @llisp -has fairly robust error recovery mechanisms, probably no damage has been -done. - -If a truly abominable error from which @hemlock cannot recover occurs, -then you will be thrown into the @llisp debugger. At this point it would be -a good idea to save any changes with @f[save-all-buffers] and then start -a new @llisp. - -@index[save-all-buffers, function]The @llisp function @f[save-all-buffers] may -be used to save modified buffers in a seriously broken @hemlock. To use this, -type "@f[(save-all-buffers)]" to the top-level ("@f[* ]") or debugger -("@f<1] >") prompt and confirm saving of each buffer that should be saved. -Since this function will prompt in the "@f[Lisp]" window, it isn't very useful -when called inside of @hemlock. diff --git a/docs/hem/user/lisp.mss b/docs/hem/user/lisp.mss deleted file mode 100644 index fc749caa9313f9e06f51ccbceb3bb99987156583..0000000000000000000000000000000000000000 --- a/docs/hem/user/lisp.mss +++ /dev/null @@ -1,822 +0,0 @@ -@comment{-*- Dictionary: /afs/cs/project/clisp/scribe/hem/hem; Mode: spell; Package: Hemlock -*-} -@chap[Interacting With Lisp] -@index[lisp, interaction with] - -Lisp encourages highly interactive programming environments by requiring -decisions about object type and function definition to be postponed until run -time. @hemlock supports interactive programming in @llisp by providing -incremental redefinition and environment examination commands. @hemlock also -uses Unix TCP sockets to support multiple Lisp processes, each of which may be -on any machine. - - -@section[Eval Servers] -@label[eval-servers] -@index[eval servers] - -@hemlock runs in the editor process and interacts with other Lisp processes -called @i[eval servers]. A user's Lisp program normally runs in an eval -server process. The separation between editor and eval server has several -advantages: -@begin[itemize] -The editor is protected from any bad things which may happen while debugging a -Lisp program. - -Editing may occur while running a Lisp program. - -The eval server may be on a different machine, removing the load from the -editing machine. - -Multiple eval servers allow the use of several distinct Lisp environments. -@end[itemize] -Instead of providing an interface to a single Lisp environment, @hemlock -coordinates multiple Lisp environments. - - -@subsection[The Current Eval Server] -@index[current eval server] -Although @hemlock can be connected to several eval servers simultaneously, one -eval server is designated as the @i[current eval server]. This is the eval -server used to handle evaluation and compilation requests. Eval servers are -referred to by name so that there is a convenient way to discriminate between -servers when the editor is connected to more than one. The current eval server -is normally globally specified, but it may also be shadowed locally in specific -buffers. - -@defcom[com "Set Eval Server"] -@defcom1[com "Set Buffer Eval Server"] -@defcom1[com "Current Eval Server"] -@hid[Set Eval Server] prompts for the name of an eval server and makes it the -the current eval server. @hid[Set Buffer Eval Server] is the same except that -is sets the eval server for the current buffer only. @hid[Current Eval Server] -displays the name of the current eval server in the echo area, taking any -buffer eval server into consideration. See also @comref[Set Compile Server]. -@enddefcom - - -@subsection[Slaves] -@index[slave buffers] -@index[slaves] -For now, all eval servers are @i[slaves]. A slave is a Lisp process that uses -a typescript (see page @pageref[typescripts]) to run its top-level -@f[read-eval-print] loop in a @hemlock buffer. We refer to the buffer that a -slave uses for I/O as its @i[interactive] or @i[slave] buffer. The name of the -interactive buffer is the same as the eval server's name. - -@index[background buffers] -@hemlock creates a @i[background] buffer for each eval server. The background -buffer's name is @w<@hid[Background ]@i{name}>, where @i[name] is the name of -the eval server. Slaves direct compiler warning output to the background -buffer to avoid cluttering up the interactive buffer. - -@hemlock locally sets @hid[Current Eval Server] in interactive and background -buffers to their associated slave. When in a slave or background buffer, eval -server requests will go to the associated slave, regardless of the global value -of @hid[Current Eval Server]. - -@defcom[com "Select Slave", bind (C-M-c)] -This command changes the current buffer to the current eval server's -interactive buffer. If the current eval server is not a slave, then it beeps. -If there is no current eval server, then this creates a slave (see section -@ref[slave-creation]). If a prefix argument is supplied, then this creates a -new slave regardless of whether there is a current eval server. This command -is the standard way to create a slave. - -The slave buffer is a typescript (see page @pageref[typescripts]) the slave -uses for its top-level @f[read-eval-print] loop. -@enddefcom - -@defcom[com "Select Background", bind (C-M-C)] -This command changes the current buffer to the current eval server's background -buffer. If there is no current eval server, then it beeps. -@enddefcom - - -@subsection[Slave Creation and Destruction] -@label[slave-creation] -When @hemlock first starts up, there is no current eval server. If there is no -a current eval server, commands that need to use the current eval server will -create a slave as the current eval server. - -If an eval server's Lisp process terminates, then we say the eval server is -dead. @hemlock displays a message in the echo area, interactive, and -background buffers whenever an eval server dies. If the user deletes an -interactive or background buffer, the associated eval server effectively -becomes impotent, but @hemlock does not try to kill the process. If a command -attempts to use a dead eval server, then the command will beep and display a -message. - -@defhvar[var "Confirm Slave Creation", val {t}] -If this variable is true, then @hemlock always prompts the user for -confirmation before creating a slave. -@enddefhvar - -@defhvar[var "Ask About Old Servers", val {t}] -If this variable is true, and some slave already exists, @hemlock prompts the -user for the name of an existing server when there is no current server, -instead of creating a new one. -@enddefhvar - -@defcom[com "Editor Server Name"] -This command echos the editor server's name, the machine and port of the -editor, which is suitable for use with the Lisp processes -slave switch. -See section @ref[slave-switch]. -@enddefcom - -@defcom[com "Accept Slave Connections"] -This command cause @hemlock to accept slave connections, and it displays the -editor server's name, which is suitable for use with the Lisp processes -slave -switch. See section @ref[slave-switch]. Supplying an argument causes this -command to inhibit slave connections. -@enddefcom - -@defhvar[var "Slave Utility", val {"/usr/misc/.lisp/bin/lisp"}] -@defhvar1[var "Slave Utility Switches"] -A slave is started by running the program @hid[Slave Utility Name] with -arguments specified by the list of strings @hid[Slave Utility Switches]. This -is useful primarily when running customized Lisp systems. For example, -setting @hid[Slave Utility Switches] to @f[("-core" "my.core")] will cause -"@f[/usr/hqb/my.core]" to be used instead of the default core image. - -The @f[-slave] switch and the editor name are always supplied as arguments, and -should remain unspecified in @hid[Slave Utility Switches]. -@enddefhvar - -@defcom[com "Kill Slave"] -@defcom1[com "Kill Slave and Buffers"] -@hid[Kill Slave] prompts for a slave name, aborts any operations in the slave, -tells the slave to @f[quit], and shuts down the connection to the specified -eval server. This makes no attempt to assure the eval server actually dies. - -@hid[Kill Slave and Buffers] is the same as @hid[Kill Slave], but it also -deletes the interactive and background buffers. -@enddefcom - - -@subsection[Eval Server Operations] - -@label[operations] -@index[eval server operations]@index[operations, eval server] -@hemlock handles requests for compilation or evaluation by queuing an -@i[operation] on the current eval server. Any number of operations may be -queued, but each eval server can only service one operation at a time. -Information about the progress of operations is displayed in the echo area. - -@defcom[com "Abort Operations", bind (C-c a)] -This command aborts all operations on the current eval server, either queued or -in progress. Any operations already in the @f[Aborted] state will be flushed. -@enddefcom - -@defcom[com "List Operations", bind (C-c l)] -This command lists all operations which have not yet completed. Along with a -description of the operation, the state and eval server is displayed. The -following states are used: -@begin[description] -@f[Unsent]@\The operation is in local queue in the editor, and hasn't been sent -yet. - -@f[Pending]@\The operation has been sent, but has not yet started execution. - -@f[Running]@\The operation is currently being processed. - -@f[Aborted]@\The operation has been aborted, but the eval server has not yet -indicated termination. -@end[description] -@enddefcom - - -@section[Typescripts] -@label[typescripts] -@index[typescripts] - -Both slave buffers and background buffers are typescripts. The typescript -protocol allows other processes to do stream-oriented interaction in a @hemlock -buffer similar to that of a terminal. When there is a typescript in a buffer, -the @hid[Typescript] minor mode is present. Some of the commands described in -this section are also used by @hid[Eval] mode (page @pageref[eval-mode].) - -Typescripts are simple to use. @hemlock inserts output from the process into -the buffer. To give the process input, use normal editing to insert the input -at the end of the buffer, and then type @bf[Return] to confirm sending the -input to the process. - -@defcom[com "Confirm Typescript Input", - stuff (bound to @bf[Return] in @hid[Typescript] mode)] -@defhvar1[var "Unwedge Interactive Input Confirm", val {t}] -This command sends text that has been inserted at the end of the current buffer -to the process reading on the buffer's typescript. Before sending the text, -@hemlock moves the point to the end of the buffer and inserts a newline. - -Input may be edited as much as is desired before it is confirmed; the result -of editing input after it has been confirmed is unpredictable. For this reason, -it is desirable to postpone confirming of input until it is actually complete. -The @hid[Indent New Line] command is often useful for inserting newlines -without confirming the input. - -If the process reading on the buffer's typescript is not waiting for input, -then the text is queued instead of being sent immediately. Any number of -inputs may be typed ahead in this fashion. @hemlock makes sure that the inputs -and outputs get interleaved correctly so that when all input has been read, the -buffer looks the same as it would have if the input had not been typed ahead. - -If the buffer's point is before the start of the input area, then various -actions can occur. When set, @hid[Unwedge Interactive Input Confirm] causes -@hemlock to ask the user if it should fix the input buffer which typically -results in ignoring any current input and refreshing the input area at the end -of the buffer. This also has the effect of throwing the slave Lisp to top -level, which aborts any pending operations or queued input. This is the only -way to be sure the user is cleanly set up again after messing up the input -region. When this is @nil, @hemlock simply beeps and tells the user in the -@hid[Echo Area] that the input area is invalid. -@enddefcom - -@defcom[com "Kill Interactive Input", - stuff (bound to @bf[M-i] in @hid[Typescript] and @hid[Eval] modes)] -This command kills any input that would have been confirmed by @bf[Return]. -@enddefcom - -@defcom[com "Next Interactive Input", - stuff (bound to @bf[M-n] in @hid[Typescript] and @hid[Eval] modes)] -@defcom1[com "Previous Interactive Input", - stuff (bound to @bf[M-p] in @hid[Typescript] and @hid[Eval] modes)] -@defcom1[com "Search Previous Interactive Input", - stuff (bound to @bf[M-P] in @hid[Typescript] and @hid[Eval] modes)] -@defhvar1[var "Interactive History Length", val {10}] -@defhvar1[var "Minimum Interactive Input Length", val {2}] -@index[history, typescript] -@Hemlock maintains a history of interactive inputs. @hid[Next Interactive -Input] and @hid[Previous Interactive Input] step forward and backward in the -history, inserting the current entry in the buffer. The prefix argument is -used as a repeat count. - -@hid[Search Previous Interactive Input] searches backward through the -interactive history using the current input as a search string. Consecutive -invocations repeat the previous search. - -@hid[Interactive History Length] determines the number of entries with which -@hemlock creates the buffer-specific histories. @Hemlock only adds an input -region to the history if its number of characters exceeds @hid[Minimum -Interactive Input Length]. -@enddefcom - -@defcom[com "Reenter Interactive Input", - stuff (bound to @bf[C-Return] in @hid[Typescript] and @hid[Eval] modes)] - This copies to the end of the buffer the form to the left of the buffer's -point. When the current region is active, this copies it instead. This is -sometimes easier to use to get a previous input that is either so far back that -it has fallen off the history or is visible and more readily @i[yanked] than -gotten with successive invocations of the history commands. -@enddefcom - -@defcom[com "Interactive Beginning of Line", - stuff (bound to @bf[C-a] in @hid[Typescript] and @hid[Eval] modes)] -This command is identical to @hid[Beginning of Line] unless there is no -prefix argument and the point is on the same line as the start of the current -input; then it moves to the beginning of the input. This is useful since it -skips over any prompt which may be present. -@enddefcom - -@defhvar[var "Input Wait Alarm", val {:loud-message}] -@defhvar1[var "Slave GC Alarm", val {:message}] -@hid[Input Wait Alarm] determines what action to take when a slave Lisp goes -into an input wait on a typescript that isn't currently displayed in any -window. @hid[Slave GC Alarm] determines what action to take when a slave -notifies that it is GC'ing. - -The following are legal values: -@begin[description] -@kwd[loud-message]@\Beep and display a message in the echo area indicating -which buffer is waiting for input. - -@kwd[message]@\Display a message, but don't beep. - -@nil@\Don't do anything. -@end[description] -@enddefhvar - -@defcom[com "Typescript Slave BREAK", bind (Typescript: H-b)] -@defcom1[com "Typescript Slave to Top Level", bind (Typescript: H-g)] -@defcom1[com "Typescript Slave Status", bind (Typescript: H-s)] -Some typescripts have associated information which these commands access -allowing @hemlock to control the process which uses the typescript. - -@hid[Typescript Slave BREAK] puts the current process in a break loop so that -you can be debug it. This is similar in effect to an interrupt signal (@f[^C] -or @f[^\] in the editor process). - -@hid[Typescript Slave to Top Level] causes the current process to throw to the -top-level @f[read-eval-print] loop. This is similar in effect to a quit signal -(@f[^\]). - -@hid[Typescript Slave Status] causes the current process to print status -information on @var[error-output]: -@lisp -; Used 0:06:03, 3851 faults. In: SYSTEM:SERVE-EVENT -@endlisp -The message displays the process run-time, the total number of page faults and -the name of the currently running function. This command is useful for -determining whether the slave is in an infinite loop, waiting for input, or -whatever. -@enddefcom - - -@section[The Current Package] -@label[lisp-package] -@index[package] -The current package is the package which Lisp interaction commands use. The -current package is specified on a per-buffer basis, and defaults to "@f[USER]". -If the current package does not exist in the eval server, then it is created. -If evaluation is being done in the editor process and the current package -doesn't exist, then the value of @f[*package*] is used. The current package is -displayed in the modeline (see section @ref[modelines].) Normally the package -for each file is specified using the @f[Package] file option (see page -@pageref[file-options].) - -When in a slave buffer, the current package is controlled by the value of -@var[package] in that Lisp process. Modeline display of the current package -is inhibited in this case. - -@defcom[com "Set Buffer Package"] -This command prompts for the name of a package to make the local package in the -current buffer. If the current buffer is a slave, background, or eval buffer, -then this sets the current package in the associated eval server or editor -Lisp. When in an interactive buffer, do not use @f[in-package]; use this -command instead. -@enddefcom - - -@section[Compiling and Evaluating Lisp Code] - -@index[compilation]@index[evaluation]These commands can greatly speed up -the edit/debug cycle since they enable incremental reevaluation or -recompilation of changed code, avoiding the need to compile and load an -entire file. - -@defcom[com "Evaluate Expression", bind (M-Escape)] -This command prompts for an expression and prints the result of its evaluation -in the echo area. If an error happens during evaluation, the evaluation is -simply aborted, instead of going into the debugger. This command doesn't -return until the evaluation is complete. -@enddefcom - -@defcom[com "Evaluate Defun", bind (C-x C-e)] -@defcom1[com "Evaluate Region"] -@defcom1[com "Evaluate Buffer"] -These commands evaluate text out of the current buffer, reading the current -defun, the region and the entire buffer, respectively. The result of the -evaluation of each form is displayed in the echo area. If the region is -active, then @hid[Evaluate Defun] evaluates the current region, just like -@hid[Evaluate Region]. -@enddefcom - -@defcom[com "Macroexpand Expression", bind (C-M)] -This command shows the macroexpansion of the next expression in the null -environment in a pop-up window. With an argument, it uses @f[macroexpand] -instead of @f[macroexpand-1]. -@enddefcom - -@defcom[com "Re-evaluate Defvar"] -This command is similar to @hid[Evaluate Defun]. It is used for force the -re-evaluation of a @f[defvar] init form. If the current top-level form is a -@f[defvar], then it does a @f[makunbound] on the variable, and evaluates the -form. -@enddefcom - -@defcom[com "Compile Defun", bind (C-x C-c)] -@defcom1[com "Compile Region"] -These commands compile the text in the current defun and the region, -respectively. If the region is active, then @hid[Compile Defun] compiles the -current region, just like @hid[Compile Region]. -@enddefcom - -@defcom[com "Load File"] -@defhvar1[var "Load Pathname Defaults", val {nil}] -This command prompts for a file and loads it into the current eval server using -@f[load]. @hid[Load Pathname Defaults] contains the default pathname for this -command. This variable is set to the file loaded; if it is @nil, then there is -no default. This command also uses the @hid[Remote Compile File] variable. -@enddefcom - - -@section[Compiling Files] -These commands are used to compile source ("@f[.lisp]") files, producing binary -("@f[.fasl]") output files. Note that unlike the other compiling and evalating -commands, this does not have the effect of placing the definitions in the -environment; to do so, the binary file must be loaded. - -@defcom[com "Compile Buffer File", bind (C-x c)] -@defhvar1[var "Compile Buffer File Confirm", val {t}] -This command asks for confirmation, then saves the current buffer (when -modified) and compiles the associated file. The confirmation prompt indicates -intent to save and compile or just compile. If the buffer wasn't modified, and -a comparison of the write dates for the source and corresponding binary -("@f[.fasl]") file suggests that recompilation is unnecessary, the confirmation -also indicates this. A prefix argument overrides this test and forces -recompilation. Since there is a complete log of output in the background -buffer, the creation of the normal error output ("@f[.err]") file is inhibited. - -Setting @hid[Compile Buffer File Confirm] to @nil inhibits confirmation, except -when the binary is up to date and a prefix argument is not supplied. -@enddefcom - -@defcom[com "Compile File"] -This command prompts for a file and compiles that file, providing a convenient -way to compile a file that isn't in any buffer. Unlike -@hid[Compile Buffer File], this command doesn't do any consistency checks such -as checking whether the source is in a modified buffer or the binary is up to -date. -@enddefcom - -@defcom[com "Compile Group"] -@defcom1[com "List Compile Group"] -@label[compile-group-command]@index[group, compilation]@hid[Compile Group] does -a @hid[Save All Files] and then compiles every "@f[.lisp]" file for which the -corresponding "@f[.fasl]" file is older or nonexistent. The files are compiled -in the order in which they appear in the group definition. A prefix argument -forces compilation of all "@f[.lisp]" files. - -@hid[List Compile Group] lists any files that would be compiled by -@hid[Compile Group]. All Modified files are saved before checking to generate -a consistent list. -@enddefcom - -@defcom[com "Set Compile Server"] -@defcom1[com "Set Buffer Compile Server"] -@defcom1[com "Current Compile Server"] -These commands are analogous to @hid[Set Eval Server], @comref[Set Buffer Eval -Server] and @hid[Current Eval Server], but they determine the eval server used -for file compilation requests. If the user specifies a compile server, then -the file compilation commands send compilation requests to that server instead -of the current eval server. - -Having a separate compile server makes it easy to do compilations in the -background while continuing to interact with your eval server and editor. The -compile server can also run on a remote machine relieving your active -development machine of the compilation effort. -@enddefcom - -@defcom[com "Next Compiler Error", bind (H-n)] -@defcom1[com "Previous Compiler Error", bind (H-p)] -These commands provides a convenient way to inspect compiler errors. First it -splits the current window if there is only one window present. @hemlock -positions the current point in the first window at the erroneous source code -for the next (or previous) error. Then in the second window, it displays the -error beginning at the top of the window. Given an argument, this command -skips that many errors. -@enddefcom - -@defcom[com "Flush Compiler Error Information"] -This command relieves the current eval server of all infomation about errors -encountered while compiling. This is convenient if you have been compiling a -lot, but you were ignoring errors and warnings. You don't want to step through -all the old errors, so you can use this command immediately before compiling a -file whose errors you intend to edit. -@enddefcom - - -@defhvar[var "Remote Compile File", val {nil}] -When true, this variable causes file compilations to be done using the RFS -remote file system mechanism by prepending "@f[/../]@i[host]" to the file being -compiled. This allows the compile server to be run on a different machine, but -requires that the source be world readable. If false, commands use source -filenames directly. Do NOT use this to compile files in AFS. -@enddefhvar - - -@section[Querying the Environment] -@index[documentation, lisp] -These commands are useful for obtaining various random information from the -Lisp environment. - -@defcom[com "Describe Function Call", bind (C-M-A)] -@defcom1[com "Describe Symbol", bind (C-M-S)] -@hid[Describe Function Call] uses the current eval server to describe the -symbol found at the head of the currently enclosing list, displaying the output -in a pop-up window. @hid[Describe Symbol] is the same except that it describes -the symbol at or before the point. These commands are primarily useful for -finding the documentation for functions and variables. If there is no -currently valid eval server, then this command uses the editor Lisp's -environment instead of trying to spawn a slave. -@enddefcom - - -@section[Editing Definitions] -The Lisp compiler annotates each compiled function object with the source -file that the function was originally defined from. The definition editing -commands use this information to locate and edit the source for functions -defined in the environment. - -@defcom[com "Edit Definition"] -@defcom1[com "Goto Definition", bind (C-M-F)] -@defcom1[com "Edit Command Definition"] -@hid[Edit Definition] prompts for the name of a function, and then uses the -current eval server to find out in which file the function is defined. If -something other than @f[defun] or @f[defmacro] defined the function, then this -simply reads in the file, without trying to find its definition point within -the file. If the function is uncompiled, then this looks for it in the current -buffer. If there is no currently valid eval server, then this command uses the -editor Lisp's environment instead of trying to spawn a slave. - -@hid[Goto Definition] edits the definition of the symbol at the beginning of -the current list. - -@hid[Edit Command Definition] edits the definition of a @hemlock command. By -default, this command does a keyword prompt for the command name (as in an -extended command). If a prefix argument is specified, then instead prompt for -a key and edit the definition of the command bound to that key. -@enddefcom - -@defcom[com "Add Definition Directory Translation"] -@defcom1[com "Delete Definition Directory Translation"] -The defining file is recorded as an absolute pathname. The definition editing -commands have a directory translation mechanism that allow the sources to be -found when they are not in the location where compilation was originally done. -@hid[Add Definition Directory Translation] prompts for two directory -namestrings and causes the first to be mapped to the second. Longer (more -specific) directory specifications are matched before shorter (more general) -ones. - -@hid[Delete Definition Directory Translation] prompts for a directory -namestring and deletes it from the directory translation table. -@enddefcom - -@defhvar[var "Editor Definition Info", val {nil}] -When this variable is true, the editor Lisp is used to determine definition -editing information, otherwise the current eval server is used. This variable -is true in @hid[Eval] and @hid[Editor] modes. -@enddefhvar - - -@section[Debugging] -These commands manipulate the slave when it is in the debugger and provide -source editing based on the debugger's current frame. These all affect the -@hid[Current Eval Server]. - - -@subsection[Changing Frames] - -@defcom[com "Debug Down", bind (C-M-H-d)] -This command moves down one debugger frame. -@enddefcom - -@defcom[com "Debug Up", bind (C-M-H-u)] -This command moves up one debugger frame. -@enddefcom - -@defcom[com "Debug Top", bind (C-M-H-t)] -This command moves to the top of the debugging stack. -@enddefcom - -@defcom[com "Debug Bottom", bind (C-M-H-b)] -This command moves to the bottom of the debugging stack. -@enddefcom - -@defcom[com "Debug Frame", bind (C-M-H-f)] -This command moves to the absolute debugger frame number indicated by the -prefix argument. -@enddefcom - - -@subsection[Getting out of the Debugger] - -@defcom[com "Debug Quit", bind (C-M-H-q)] -This command throws to top level out of the debugger in the @hid[Current Eval -Server]. -@enddefcom - -@defcom[com "Debug Go", bind (C-M-H-g)] -This command tries the @f[continue] restart in the @hid[Current Eval Server]. -@enddefcom - -@defcom[com "Debug Abort", bind (C-M-H-a)] -This command executes the ABORT restart in the @hid[Current Eval Server]. -@enddefcom - -@defcom[com "Debug Restart", bind (C-M-H-r)] -This command executes the restart indicated by the prefix argument in the -@hid[Current Eval Server]. The debugger enumerates the restart cases upon -entering it. -@enddefcom - - -@subsection[Getting Information] - -@defcom[com "Debug Help", bind (C-M-H-h)] -This command in prints the debugger's help text. -@enddefcom - -@defcom[com "Debug Error", bind (C-M-H-e)] -This command prints the error condition and restart cases displayed upon -entering the debugger. -@enddefcom - -@defcom[com "Debug Backtrace", bind (C-M-H-B)] -This command executes the debugger's @f[backtrace] command. -@enddefcom - -@defcom[com "Debug Print", bind (C-M-H-p)] -This command prints the debugger's current frame in the same fashion as the -frame motion commands. -@enddefcom - -@defcom[com "Debug Verbose Print", bind (C-M-H-P)] -This command prints the debugger's current frame without elipsis. -@enddefcom - -@defcom[com "Debug Source", bind (C-M-H-s)] -This command prints the source form for the debugger's current frame. -@enddefcom - -@defcom[com "Debug Verbose Source"] -This command prints the source form for the debugger's current frame with -surrounding forms for context. -@enddefcom - -@defcom[com "Debug List Locals", bind (C-M-H-l)] -This prints the local variables for the debugger's current frame. -@enddefcom - - -@subsection[Editing Sources] - -@defcom[com "Debug Edit Source", bind (C-M-H-S)] -This command attempts to place you at the source location of the debugger's -current frame. Not all debugger frames represent function's that were compiled -with the appropriate debug-info policy. This beeps with a message if it is -unsuccessful. -@enddefcom - - -@subsection[Miscellaneous] - -@defcom[com "Debug Flush Errors", bind (C-M-H-F)] -This command toggles whether the debugger ignores errors or recursively enters -itself. -@enddefcom - - - - -@section[Manipulating the Editor Process] -When developing @hemlock customizations, it is useful to be able to manipulate -the editor Lisp environment from @hemlock. - -@defcom[com "Editor Describe", bind (Home t, C-_ t)] -This command prompts for an expression, and then evaluates and describes it -in the editor process. -@enddefcom - -@defcom[com "Room"] -Call the @f[room] function in the editor process, displaying information -about allocated storage in a pop-up window. -@enddefcom - -@defcom[com "Editor Load File"] -This command is analogous to @comref[Load File], but loads the file into the -editor process. -@enddefcom - - -@subsection[Editor Mode] -When @hid[Editor] mode is on, alternate versions of the Lisp interaction -commands are bound in place of the eval server based commands. These commands -manipulate the editor process instead of the current eval server. Turning on -editor mode in a buffer allows incremental development of code within the -running editor. - -@defcom[com "Editor Mode"] -This command turns on @hid[Editor] minor mode in the current buffer. If it is -already on, it is turned off. @hid[Editor] mode may also be turned on using -the @f[Mode] file option (see page @pageref[file-options].) -@enddefcom - -@defcom[com "Editor Compile Defun", - stuff (bound to @bf[C-x C-c] in @hid[Editor] mode)] -@defcom1[com "Editor Compile Region"] -@defcom1[com "Editor Evaluate Buffer"] -@defcom1[com "Editor Evaluate Defun", - stuff (bound to @bf[C-x C-e] in @hid[Editor] mode)] -@defcom1[com "Editor Evaluate Region"] -@defcom1[com "Editor Macroexpand Expression", bind (Editor: C-M)] -@defcom1[com "Editor Re-evaluate Defvar"] -@defcom1[com "Editor Describe Function Call", - stuff (bound to @bf[C-M-A] in @hid[Editor] mode)] -@defcom1[com "Editor Describe Symbol", - stuff (bound to @bf[C-M-S] in @hid[Editor] mode)] -These commands are similar to the standard commands, but modify or examine the -Lisp process that @hemlock is running in. Terminal I/O is done on the -initial window for the editor's Lisp process. Output is directed to a pop-up -window or the editor's window instead of to the background buffer. -@enddefcom - -@defcom[com "Editor Compile Buffer File"] -@defcom1[com "Editor Compile File"] -@defcom1[com "Editor Compile Group"] -In addition to compiling in the editor process, these commands differ from the -eval server versions in that they direct output to the the -@hid[Compiler Warnings] buffer. -@enddefcom - -@defcom[com "Editor Evaluate Expression", - stuff (bound to @bf[M-Escape] in @hid[Editor] mode and @bf[C-M-Escape])] -This command prompts for an expression and evaluates it in the editor process. -The results of the evaluation are displayed in the echo area. -@enddefcom - - -@subsection[Eval Mode] -@label[eval-mode] -@index[modes, eval]@hid[Eval] mode is a minor mode that simulates a @f[read] -@f[eval] @f[print] loop running within the editor process. Since Lisp -program development is usually done in a separate eval server process (see page -@pageref[eval-servers]), @hid[Eval] mode is used primarily for debugging code -that must run in the editor process. @hid[Eval] mode shares some commands with -@hid[Typescript] mode: see section @ref[typescripts]. - -@hid[Eval] mode doesn't completely support terminal I/O: it binds -@var[standard-output] to a stream that inserts into the buffer and -@var[standard-input] to a stream that signals an error for all operations. -@hemlock cannot correctly support the interactive evaluation of forms that read -from the @hid[Eval] interactive buffer. - -@defcom[com "Select Eval Buffer"] -This command changes to the @hid[Eval] buffer, creating one if it doesn't -already exist. The @hid[Eval] buffer is created with @hid[Lisp] as the major -mode and @hid[Eval] and @hid[Editor] as minor modes. -@enddefcom - -@defcom[com "Confirm Eval Input", - stuff (bound to @bf[Return] in @hid[Eval] mode)] -This command evaluates all the forms between the end of the last output and -the end of the buffer, inserting the results of their evaluation in the buffer. -This beeps if the form is incomplete. Use @binding[Linefeed] to insert line -breaks in the middle of a form. - -This command uses @hid[Unwedge Interactive Input Confirm] in the same way -@hid[Confirm Interactive Input] does. -@enddefcom - -@defcom[com "Abort Eval Input", - stuff (bound to @bf[M-i] in @hid[Eval] mode)] -This command moves the the end of the buffer and prompts, ignoring any -input already typed in. -@enddefcom - - -@subsection[Error Handling] -@index[error handling] -When an error happens inside of @hemlock, @hemlock will trap the error and -display the error message in the echo area, possibly along with the -"@f[Internal error:]" prefix. If you want to debug the error, type @bf[?]. -This causes the prompt "@f[Debug:]" to appear in the echo area. The following -commands are recognized: -@begin[description] -@bf[d]@\Enter a break-loop so that you can use the Lisp debugger. -Proceeding with "@f[go]" will reenter @hemlock and give the "@f[Debug:]" -prompt again. - -@bf[e]@\Display the original error message in a pop-up window. - -@bf[b]@\Show a stack backtrace in a pop-up window. - -@bf[q, Escape]@\Quit from this error to the nearest command loop. - -@bf[r]@\Display a list of the restart cases and prompt for the number of a -@f[restart-case] with which to continue. Restarting may result in prompting in -the window in which Lisp started. -@end[description] - -Only errors within the editor process are handled in this way. Errors during -eval server operations are handled using normal terminal I/O on a typescript in -the eval server's slave buffer or background buffer (see page -@pageref[operations]). Errors due to interaction in a slave buffer will cause -the debugger to be entered in the slave buffer. - - -@section[Command Line Switches] -@label[slave-switch] -Two command line switches control the initialization of editor and eval servers -for a Lisp process: -@begin[description] -@f<-edit>@\ -@label[edit-switch] -This switch starts up @hemlock. If there is a non-switch command line word -immediately following the program name, then the system interprets it as a file -to edit. For example, given -@Begin[ProgramExample] -lisp file.txt -edit -@End[ProgramExample] -Lisp will go immediately into @hemlock finding the file @f[file.txt]. - -@f<-slave [>@i[name]@f<]>@\ - This switch causes the Lisp process to become a slave of the editor process -@i[name]. An editor Lisp determines @i[name] when it allows connections from -slaves. Once the editor chooses a name, it keeps the same name until the -editor's Lisp process terminates. Since the editor can automatically create -slaves on its own machine, this switch is useful primarily for creating slaves -that run on a different machine. @f[hqb]'s machine is @f[ME.CS.CMU.EDU], and -he wants want to run a slave on @f[SLAVE.CS.CMU.EDU], then he should use the -@hid[Accept Slave Connections] command, telnet to the machine, and invoke Lisp -supplying @f[-slave] and the editor's name. The command displays the editor's -name. -@end[description] diff --git a/docs/hem/user/mail.mss b/docs/hem/user/mail.mss deleted file mode 100644 index 6d1c7a7b9a62768093fd0bd939bdcaab4f901e67..0000000000000000000000000000000000000000 --- a/docs/hem/user/mail.mss +++ /dev/null @@ -1,1343 +0,0 @@ -@comment{-*- Dictionary: /afs/cs/project/clisp/scribe/hem/hem; Mode: spell; Package: Hemlock -*-} -@chap[The Mail Interface] -@section[Introduction to Mail in Hemlock] - -@index[MH interface]@label[introduction] -@hemlock provides an electronic mail handling facility via an interface to the -public domain @i[Rand MH Message Handling System]. This chapter assumes that -the user is familiar with the basic features and operation of @mh, but it -attempts to make allowances for beginners. Later sections of this chapter -discuss setting up @mh, profile components and special files for formatting -outgoing mail headers, and backing up protected mail directories on a -workstation. For more information on @mh, see the @i[Rand MH Message Handling -System Tutorial] and the @i[Rand MH Message Handling System Manual]. - -The @hemlock interface to @mh provides a means for generating header (@f[scan]) -lines for messages and displaying these headers in a @hid[Headers] buffer. -This allows the user to operate on the @i[current message] as indicated by the -position of the cursor in the @hid[Headers] buffer. The user can read, reply -to, forward, refile, or perform various other operations on the current -message. A user typically generates a @hid[Headers] buffer with the commands -@hid[Message Headers] or @hid[Incorporate and Read New Mail], and multiple such -buffers may exist simultaneously. - -Reading a message places its text in a @hid[Message] buffer. In a manner -similar to a @hid[Headers] buffer, this allows the user to operate on that -message. Most @hid[Headers] buffer commands behave the same in a @hid[Message] -buffer. For example, the @hid[Reply to Message] command has the same effect in -both @hid[Headers] mode and @hid[Message] mode. It creates a @hid[Draft] -buffer and makes it the current buffer so that the user may type a reply to the -current message. - -The @hid[Send Message] command originates outgoing mail. It generates a -@hid[Draft] buffer in which the user composes a mail message. Each @hid[Draft] -buffer has an associated pathname, so the user can save the buffer to a file as -necessary. Invoking @hid[Send Message] in a @hid[Headers] or @hid[Message] -buffer associates the @hid[Draft] buffer with a @hid[Message] buffer. This -allows the user to easily refer to the message being replied to with the -command @hid[Goto Message Buffer]. After the user composes a draft message, he -can deliver the message by invoking the @hid[Deliver Message] command in the -@hid[Draft] buffer (which deletes both the this buffer and any associated -@hid[Message] buffer), or he can delay this action. Invoking @hid[Deliver -Message] when not in a @hid[Draft] buffer causes it to prompt for a draft -message ID, allowing previously composed and saved messages to be delivered -(even across distinct Lisp invocations). - -@index[virtual message deletion] -The @hemlock mail system provides a mechanism for @i[virtual message deletion]. -That is, the @hid[Delete Message] command does not immediately delete a message -but merely flags the message for future deletion. This allows the user to -undelete the messages with the @hid[Undelete Message] command. The -@hid[Expunge Messages] command actually removes messages flagged for deletion. -After expunging a deleted message, @hid[Undelete Messages] can no longer -retrieve it. Commands that read messages by sequencing through a @hid[Headers] -buffer typically ignore those marked for deletion, which makes for more fluid -reading if a first pass has been made to delete uninteresting messages. - -After handling messages in a @hid[Headers] buffer, there may be messages -flagged for deletion and possibly multiple @hid[Message] buffers lying around. -There is a variety of commands that help @i[terminate] a mail session. -@hid[Expunge Messages] will flush the messages to be deleted, leaving the -buffer in an updated state. @hid[Delete Headers Buffer and Message Buffers] -will delete the @hid[Headers] buffer and its corresponding @hid[Message] -buffers. @hid[Quit Headers] is a combination of these two commands in that it -first expunges messages and then deletes all the appropriate buffers. - -One does not have to operate only on messages represented in a @hid[Headers] -buffer. This is merely the nominal mode of interaction. There are commands -that prompt for a folder, an @mh message specification (for example, "@f[1 3 6 -last]", "@f[1-3 5 6]", "@f[all]", "@f[unseen]"), and possibly a @f[pick] -expression. @f[Pick] expressions allow messages to be selected based on header -field pattern matching, body text searching, and date comparisons; these can be -specified using either a Unix shell-like/switch notation or a Lisp syntax, -according to one's preference. See section @ref[scanning] for more details. - -A @i[mail-drop] is a file where a Unix-based mail system stores all messages a -user receives. The user's mail handling program then fetches these from the -mail-drop, allowing the user to operate on them. Traditionally one locates his -mail-drop and mail directory on a mainframe machine because the information on -mainframes is backed up on magnetic tape at least once per day. Since @hemlock -only runs under CMU @clisp on workstations, and one's mail directory is not -usually world writable, it is not possible to adhere to a standard arrangement. -Since @mh provides for a remote mail-drop, and CMU's Remote File System has a -feature allowing authentication across a local area network, one can use -@hemlock to fetch his mail from a mainframe mail-drop (where it is backed up -before @hemlock grabs it) and store it on his workstation. Reading mail on a -workstation is often much faster and more comfortable because typically it is a -single user machine. Section @ref[backing-up] describes how to back up one's -mail directory from a workstation to a mainframe. - - -@section[Constraints on MH to use Hemlock's Interface] - -@index[constraints for mail interface]@label[constraints] -There are a couple constaints placed on the user of the @hemlock interface to -@mh. The first is that there must be a draft folder specified in one's @mh -profile to use any command that sends mail. Also, to read new mail, there must -be an @f[Unseen-Sequence:] component in one's @mh profile. The default @mh -profile does not specify these components, so they must be added by the user. -The next section of this chapter describes how to add these components. -Another constraint is that @hemlock requires its own @f[scan] line format to -display headers lines in a @hid[Headers] buffer. See the description of the -variable @hid[MH Scan Line Form] for details. - - -@section[Setting up MH] - -@index[setting up the mail interface]@label[setting-up] -@index[mail profile]@index[MH profile] -Get an @mh default profile and mail directory by executing the @mh @f[folder] -utility in a Unix shell. When it asks if it should make the "@f[inbox]" -folder, answer "@b[yes]". This creates a file called "@f[.mh_profile]" in the -user's home directory and a directory named "@f[Mail]". - -Edit the "@f[.mh_profile]" file inserting two additional lines. To send mail -in @hemlock, the user must indicate a draft folder by adding a -@f[Draft-Folder:] line with a draft folder name @dash "@f[drafts]" is a common -name: -@begin[example] -Draft-Folder: drafts -@end[example] - -Since the mail-drop exists on a remote machine, the following line must -also be added: -@begin[example] -MailDrop: /../<hostname>/usr/spool/mail/<username> -@end[example] - -Since the user's mail-drop is on a separate machine from his mail directory -(and where the user runs @hemlock), it is necessary to issue the following -command from the Unix shell (on the workstation). This only needs to be done -once. -@begin[programexample] -/usr/cs/etc/rfslink -host <hostname> /usr/spool/mail/<username> -@end[programexample] -Note that @b[<hostname>] is not a full ARPANET domain-style name. Use an -abbreviated CMU host name (for example, "@b[spice]" not -"@b[spice.cs.cmu.edu]"). - - -@section[Profile Components and Customized Files] - -@subsection[Profile Components] - -@label[Profile] -The following are short descriptions about profile components that are either -necessary to using @hemlock's interface to @mh or convenient for using @mh in -general: - -@begin[description] -@f[Path:]@\ -This specifies the user's mail directory. It can be either a full pathname or -a pathname relative to the user's home directory. This component is -@i[necessary] for using @mh. - -@f[MailDrop:]@\ -This is used to specify one's remote mail-drop. It is @i[necessary] for -@hemlock only when using a mail-drop other than "@f[/usr/spool/mail/<user>]" on -the local machine. - -@f[Folder-Protect:], @f[Msg-Protect:]@\ -These are set to 700 and 600 respectively to keep others from reading one's -mail. At one time the default values were set for public visibility of mail -folders. Though this is no longer true, these can be set for certainty. The -700 protection allows only user read, write, and execute (list access for -directories), and 600 allows only user read and write. These are not necessary -for either @mh or the @hemlock interface. - -@f[Unseen-Sequence:]@\ -When mail is incorporated, new messages are added to this sequence, and as -these messages are read they are removed from it. This allows the user at any -time to invoke an @mh program on all the unseen messges of a folder easily. An -example definition is: -@begin[example] -Unseen-Sequence: unseen -@end[example] -Specifying an unseen-sequence is @i[necessary] to use @hemlock's -interface to @mh. - -@f[Alternate-Mailboxes:]@\ -This is not necessary for either @mh or the @hemlock interface. This -component tells @mh which addresses that it should recognize as the user. This -is used for @f[scan] output formatting when the mail was sent by the user. It -is also used by @f[repl] when it sets up headers to know who the user is for -inclusion or exclusion from @b[cc]: lists. This is case sensitive and takes -wildcards. One example is: -@begin[example] -Alternate-Mailboxes: *FRED*, *Fred*, *fred* -@end[example] - -@f[Draft-Folder:]@\ -This makes multiple draft creation possible and trivial to use. Just supply a -folder name (for example, "@f[drafts]"). Specifying a draft-folder is -@i[necessary] to use @hemlock's interface to @mh. - -@f[repl: -cc all -nocc me -fcc out-copy]@\ -This tells the @f[repl] utility to include everyone but the user in the -@b[cc:] list when replying to mail. It also makes @f[repl] keep an copy of the -message the user sends. This is mentioned because one probably wants to reply -to everyone receiving a piece of mail except oneself. Unlike other utilities -that send mail, @f[repl] stores personal copies of outgoing mail based on a -command line switch. Other @mh utilities use different mechanisms. This line -is not necessary to use either @mh or the @hemlock interface. - -@f[rmmproc: /usr/cs/bin/rm]@\ -This is not necessary to use @hemlock's interface to @mh, but due to -@hemlock's virtual message deletion feature, this causes messages to be deleted -from folder directories in a cleaner fashion when they actually get removed. -Note that setting this makes @f[rmm] more treacherous if used in the Unix -shell. -@end[description] -@; - - -@subsection[Components Files] -@index[components] -@label[components-files] -@i[Components] files are templates for outgoing mail header fields that specify -position and sometimes values for specified fields. Example files are shown -for each one discussed here. These should exist in the user's mail directory. - -For originating mail there is a components file named "@f[components]", and it -is used by the @mh utility @f[comp]. An example follows: -@begin[example] - To: - cc: - fcc: out-copy - Subject: - -------- -@end[example] -This example file differs from the default by including the @f[fcc:] line. -This causes @mh to keep a copy of the outgoing draft message. Also, though it -isn't visible here, the @f[To:], @f[cc:], and @f[Subject:] lines have a space -at the end. - -@index[forwarding components] -The "@f[forwcomps]" components file is a template for the header fields of any -forwarded message. Though it may be different, our example is the same as the -previous one. These are distinct files for @mh's purposes, and it is more -flexible since the user might not want to keep copies of forwarded messages. - -@index[reply components] -The "@f[replcomps]" components file is a template for the header fields of any -draft message composed when replying to a message. An example -follows: -@begin[example] - %(lit)%(formataddr %<{reply-to}%|%<{from}%|%{sender}%>%>)\ - %<(nonnull)%(void(width))%(putaddr To: )\n%>\ - %(lit)%(formataddr{to})%(formataddr{cc})%(formataddr(me))\ - %(formataddr{resent-to})\ - %<(nonnull)%(void(width))%(putaddr cc: )\n%>\ - %<{fcc}Fcc: %{fcc}\n%>\ - %<{subject}Subject: Re: %{subject}\n%>\ - %<{date}In-reply-to: Your message of \ - %<(nodate{date})%{date}%|%(tws{date})%>.%<{message-id} - %{message-id}%>\n%>\ - -------- -@end[example] -This example file differs from the default by including the @b[resent-to:] -field (in addition to the @b[to:] and @b[cc:] fields) of the message being -replied to in the @b[cc:] field of the draft. This is necessary for replying -to all recipients of a distributed message. Keeping a copy of the outgoing -draft message works a little differently with reply components. @mh expects a -switch which the user can put in his profile (see section @ref[Profile] of this -chapter), and using the @mh formatting language, this file tests for the -@f[fcc] value as does the standard file. - - -@section[Backing up the Mail Directory] -@index[backing up mail directories] -@label[backing-up] -The easiest method of backing up a protected mail directory is to copy it into -an Andrew File System (AFS) directory since these are backed up daily as with -mainframes. The only problem with this is that the file servers may be down -when one wants to copy his mail directory since, at the time of this writing, -these servers are still under active development; however, they are becoming -more robust daily. One can read about the current AFS status in the file -@f[/../fac/usr/gripe/doc/vice/status]. - -Using AFS, one could keep his actual mail directory (not a copy thereof) in his -AFS home directory which eliminates the issue of backing it up. This is -additionally beneficial if the user does not use the same workstation everyday -(that is, he does not have his own but shares project owned machines). Two -problems with this arrangement result from the AFS being a distributed file -system. Besides the chance that the server will be down when the user wants to -read mail, performance degrades since messages must always be referenced across -the local area network. - -Facilities' official mechanism for backing up protected directories is called -@f[sup]. This is awkward to use and hard to set up, but a subsection here -describes a particular arrangement suitable for the user's mail directory. - - -@subsection[Andrew File System] -If the user choses to use AFS, he should get copies of @i[Getting Started with -the Andrew File System] and @i[Protecting AFS files and directories]. To use -AFS, send mail to Gripe requesting an account. When Gripe replies with a -password, change it to be the same as the account's password on the -workstation. This causes the user to be authenticated into AFS when he logs -into his workstation (that is, he is automatically logged into his AFS -account). To change the password, first log into the AFS account: -@begin[programexample] -log <AFS userid> -@end[programexample] -Then issue the @f[vpasswd] command. - -All of the example command lines in this section assume the user has -@f[/usr/misc/bin] on his Unix shell @f[PATH] environment variable. - -@paragraph[Copy into AFS:] - -Make an AFS directory to copy into: -@begin[programexample] -mkdir /afs/cs.cmu.edu/user/<AFS userid>/mail-backup -@end[programexample] - -This will be readable by everyone, so protect it with the following: -@begin[programexample] -fs sa /afs/cs.cmu.edu/user/<AFSuserid>/mail-backup System:AnyUser none -@end[programexample] - -Once the AFS account and directory to backup into have been established, the -user needs a means to recursively copy his mail directory updating only those -file that have changed and deleting those that no longer exist. To do this, -issue the following command: -@begin[programexample] -copy -2 -v -R <mail directory> <AFS backup directory> -@end[programexample] -Do not terminate either of these directory specifications with a @f[/]. The -@f[-v] switch causes @f[copy] to output a line for copy and deletion, so this -may be eliminated if the user desires. - -@paragraph[Mail Directory Lives in AFS:] - -Assuming the AFS account has been established, and the user has followed the -directions in @ref[setting-up], now make an AFS directory to serve as the mail -directory: -@begin[programexample] -mkdir /afs/cs.cmu.edu/user/<AFS userid>/Mail -@end[programexample] - -This will be readable by everyone, so protect it with the following: -@begin[programexample] -fs sa /afs/cs.cmu.edu/user/<AFSuserid>/Mail System:AnyUser none -@end[programexample] - -Tell @mh where the mail directory is by modifying the profile's -"@f[.mh_profile]" (see section @ref[setting-up]) @f[Path:] component (see -section @ref[Profile]): -@begin[programexample] -Path: /afs/cs.cmu.edu/user/<AFS userid>/Mail -@end[programexample] - - -@subsection[Sup to a Mainframe] -To use @f[sup] the user must set up a directory named "@f[sup]" on the -workstation in the user's home directory. This contains different directories -for the various trees that will be backed up, so there will be a "@f[Mail]" -directory. This directory will contain two files: "@f[crypt]" and "@f[list]". -The "@f[crypt]" file contains one line, terminated with a new line, that -contains a single word @dash an encryption key. "@f[list]" contains one line, -terminated with a new line, that contains two words @dash "@b[upgrade Mail]". - -On the user's mainframe, a file must be created that will be supplied to the -@f[sup] program. It should contain the following line to backup the mail -directory: - -@begin[example] -Mail delete host=<workstation> hostbase=/usr/<user> base=/usr/<user> \ -crypt=WordInCryptFile login=<user> password=LoginPasswordOnWorkstation -@end[example] -Warning: @i[This file contains the user's password and should be -protected appropriately.] - -The following Unix shell command issued on the mainframe will backup the -mail directory: - -@begin[programexample] - sup <name of the sup file used in previous paragraph> -@end[programexample] - -As a specific example, assume user "@f[fred]" has a workstation called -"@f[fred]", and his mainframe is the "@f[gpa]" machine where he has another -user account named "@f[fred]". The password on his workstation is -"@f[purple]". On his workstation, he creates the directory -"@f[/usr/fred/sup/Mail/]" with the two files "@f[crypt]" and "@f[list]". -The file "@f[/usr/fred/sup/Mail/crypt]" contains only the encryption key: -@programexample[steppenwolf] -The file "@f[/usr/fred/sup/Mail/list]" contains the command to upgrade the -"@f[Mail]" directory: -@programexample[upgrade Mail] - -On the "@f[gpa]" machine, the file "@f[/usr/fred/supfile]" contains the -following line: -@begin[programexample] -Mail delete host=fred hostbase=/usr/fred base=/usr/fred \ -crypt=steppenwolf login=fred password=purple -@end[programexample] -This file is protected on "@f[gpa]", so others cannot see @f[fred's] password -on his workstation. - -On the gpa-vax, issuing -@begin[programexample] - sup /usr/fred/supfile -@end[programexample] -to the Unix shell will update the @mh mail directory from @f[fred's] -workstation deleting any files that exist on the gpa that do not exist on the -workstation. - -For a more complete description of the features of @f[sup], see the @i[UNIX -Workstation Owner's Guide] and @i[The SUP Software Upgrade Protocol]. - -@section[Introduction to Commands and Variables] - -@index[mail commands]@index[mail variables]@label[mhcommands] -Unless otherwise specified, any command which prompts for a folder name will -offer the user a default. Usually this is @mh's idea of the current folder, -but sometimes it is the folder name associated with the current buffer if there -is one. When prompting for a message, any valid @mh message expression may be -entered (for example, "@f[1 3 6]", "@f[1-3 5 6]", "@f[unseen]", "@f[all]"). -Unless otherwise specified, a default will be offered (usually the current -message). - -Some commands mention specific @mh utilities, so the user knows how the -@hemlock command affects the state of @mh and what profile components and -special formatting files will be used. @hemlock runs the @mh utility programs -from a directory indicated by the following variable: - -@defhvar[var "MH Utility Pathname", val {"/usr/misc/.mh/bin/"}] -@mh utility names are merged with this pathname to find the executable -files. -@enddefhvar - - -@section[Scanning and Picking Messages] -@label[scanning] -As pointed out in the introduction of this chapter, users typically generate -headers or @f[scan] listings of messages with @hid[Message Headers], using -commands that operate on the messages represented by the headers. @hid[Pick -Headers] (bound to @bf[h] in @hid[Headers] mode) can be used to narrow down (or -further select over) the headers in the buffer. - -A @f[pick] expression may be entered using either a Lisp syntax or a Unix -shell-like/switch notation as described in the @mh documentation. The Lisp -syntax is as follows: - -@begin[example] - <exp> ::= {(not <exp>) | (and <exp>*) | (or <exp>*) - | (cc <pattern>) | (date <pattern>) - | (from <pattern>) | (search <pattern>) - | (subject <pattern>) | (to <pattern>) - | (-- <component> <pattern>) - | (before <date>) | (after <date>) - | (datefield <field>)} - - <pattern> ::= {<string> | <symbol>} - - <component> ::= {<string> | <symbol>} - - <date> ::= {<string> | <symbol> | <number>} - - <field> ::= <string> -@end[example] - -Anywhere the user enters a @f[<symbol>], its symbol name is used as a string. -Since @hemlock @f[read]s the expression without evaluating it, single quotes -("@bf[']") are unnecessary. From the @mh documentation, - -@begin[itemize] - A @f[<pattern>] is a Unix @f[ed] regular expression. When using a string to - input these, remember that @f[\] is an escape character in Common Lisp. - - A @f[<component>] is a header field name (for example, @b[reply-to] or - @b[resent-to]). - - A @f[<date>] is an @i[822]-style specification, a day of the week, - "@b[today]", "@b[yesterday]", "@b[tomorrow]", or a number indicating @i[n] - days ago. The @i[822] standard is basically: - @begin[example] - dd mmm yy hh:mm:ss zzz - @end[example] - which is a two digit day, three letter month (first letter capitalized), two - digit year, two digit hour (@f[00] through @f[23]), two digit minute, two - digit second (this is optional), and a three letter zone (all capitalized). - For - example: - @begin[example] - 21 Mar 88 16:00 EST - @end[example] - - A @f[<field>] is an alternate @f[Date:] field to use with @f[(before - <date>)] and @f[(after <date>)] such as @f[BB-Posted:] or - @f[Delivery-Date:]. - - Using @f[(before <date>)] and @f[(after <date>)] causes date field parsing, - while @f[(date <pattern>)] does string pattern matching. -@end[itemize] - -Since a @f[<pattern>] may be a symbol or string, it should be noted that the -symbol name is probably all uppercase characters, and @mh will match these -only against upper case. @mh will match lowercase characters against lower -and upper case. Some examples are: -@begin[example] - ;;; All messages to Gripe. - (to "gripe") - - ;;; All messages to Gripe or about Hemlock. - (or (to "gripe") (subject "hemlock")) - - ;;; All messages to Gripe with "Hemlock" in the body. - (and (to "gripe") (search "hemlock")) -@end[example] - -Matching of @f[<component>] fields is case sensitive, so this example will -@f[pick] over all messages that have been replied to. -@example[(or (-- "replied" "") (-- "Replied" ""))] - - -@defhvar[var "MH Scan Line Form", val {"library:mh-scan"}] -This is a pathname of a file containing an @mh format expression used for -header lines. - -The header line format must display the message ID as the first non-whitespace -item. If the user uses the virtual message deletion feature which is on by -default, there must be a space three characters to the right of the message ID. -This location is used on header lines to note that a message is flagged for -deletion. The second space after the message ID is used for notating answered -or replied-to messages. -@enddefhvar - -@defcom[com "Message Headers", bind (C-x r)] -This command prompts for a folder, message (defaulting to "@b[all]"), and an -optional @f[pick] expression. Typically this will simply be used to generate -headers for an entire folder or sequence, and the @f[pick] expression will not -be used. A new @hid[Headers] buffer is made, and the output of @f[scan] on the -messages indicated is inserted into the buffer. The current window is used, -the buffer's point is moved to the first header, and the @hid[Headers] buffer -becomes current. The current value of the @hemlock @hid[Fill Column] variable -is supplied to @f[scan] as the @f[-width] switch. The buffer name is set to a -string of the form @w<"@f[Headers <folder> <msgs> <pick expression>]">, so the -modeline will show what is in the buffer. If no @f[pick] expression was -supplied, none will be shown in the buffer's name. As described in the -introduction to this section, the expression may be entered using either a Lisp -syntax or a Unix shell-like/switch notation. -@enddefcom - -@defhvar[var "MH Lisp Expression", val {t}] -When this is set, @mh expression prompts are read in a Lisp syntax. Otherwise, -the input is of the form of a Unix shell-like/switch notation as described in -the @mh documentation. -@enddefhvar - -@defcom[com "Pick Headers", stuff (bound to @bf[h] in @hid[Headers] mode) ] -This command is only valid in a @hid[Headers] buffer. It prompts for a -@f[pick] expression, and the messages shown in the buffer are supplied to -@f[pick] with the expression. The resulting messages are @f[scan]'ed, deleting -the previous contents of the buffer. The current value of @hid[Fill Column] is -used for the @f[scan]'ing. The buffer's point is moved to the first header. -The buffer's name is set to a string of the form @w<"@f[Headers <folder> <msgs -picked over> <pick expression>]">, so the modeline will show what is in the -buffer. As described in the introduction to this section, the expression may -be entered using either a Lisp syntax or a Unix shell-like/switch notation. -@enddefcom - -@defcom[com "Headers Help", bind (Headers: ?)] -This command displays documentation on @hid[Headers] mode. -@enddefcom - - -@section[Reading New Mail] - -@index[reading new mail]@label[reading-new-mail] - -@defcom[com "Incorporate and Read New Mail", stuff (bound to @bf[C-x i] globally and @bf[i] in @hid[Headers] and @hid[Message] modes) ] -This command incorporates new mail into @hid[New Mail Folder] and creates a -@hid[Headers] buffer with the new messages. An unseen-sequence must be define -in the user's @mh profile to use this. Any headers generated due to -@hid[Unseen Headers Message Spec] are inserted as well. The buffer's point is -positioned on the headers line representing the first unseen message of the -newly incorporated mail. -@enddefcom - -@defcom[com "Incorporate New Mail" ] -This command incorporates new mail into @hid[New Mail Folder], displaying -@f[inc] output in a pop-up window. This is similar to @hid[Incorporate and -Read New Mail] except that no @hid[Headers] buffer is generated. -@enddefcom - -@defhvar[var "New Mail Folder", val {"+inbox"}] -This is the folder into which @mh incorporates new mail. -@enddefhvar - -@defhvar[var "Unseen Headers Message Spec", val {nil}] -This is an @mh message specification that is suitable for any message prompt. -When incorporating new mail and after expunging messages, @hemlock uses this -specification in addition to the unseen-sequence name that is taken from the -user's @mh profile to generate headers for the unseen @hid[Headers] buffer. -This value is a string. -@enddefhvar - -@defhvar[var "Incorporate New Mail Hook", val {nil}] -This is a list of functions which are invoked immediately after new mail is -incorporated. The functions should take no arguments. -@enddefhvar - -@defhvar[var "Store Password", val {nil}] -When this is set, the user is only prompted once for his password, and the -password is stored for future use. -@enddefhvar - -@defhvar[var "Authenticate Incorporation", val {nil}] -@defhvar1[var "Authentication User Name", val {nil}] -When @hid[Authenticate Incorporation] is set, incorporating new mail prompts -for a password to access a remote mail-drop. - -When incorporating new mail accesses a remote mail-drop, @hid[Authentication -User Name] is the user name supplied for authentication on the remote machine. -If this is @nil, @hemlock uses the local name. -@enddefhvar - - -@section[Reading Messages] -@index[reading messages] -@label[reading-messages] -This section describes basic commands that show the current, next, and previous -messages, as well as a couple advanced commands. @hid[Show Message] (bound to -@bf[SPACE] in @hid[Headers] mode) will display the message represented by the -@f[scan] line the @hemlock cursor is on. Deleted messages are considered -special, and the more conveniently bound commands for viewing the next and -previous messages (@hid[Next Undeleted Message] bound to @bf[n] and -@hid[Previous Undeleted Message] bound to @bf[p], both in @hid[Headers] and -@hid[Message] modes) will ignore them. @hid[Next Message] and @hid[Previous -Message] (bound to @bf[M-n] and @bf[M-p] in @hid[Headers] and @hid[Message] -modes) may be invoked if reading a message is desired regardless of whether it -has been deleted. - - -@defcom[com "Show Message", stuff (bound to @bf[SPACE] and @bf[.] in @hid[Headers] mode) ] - This command, when invoked in a @hid[Headers] buffer, displays the current -message (the message the cursor is on), by replacing any previous message that -has not been preserved with @hid[Keep Message]. The current message is also -removed from the unseen sequence. The @hid[Message] buffer becomes the current -buffer using the current window. The buffer's point will be moved to the -beginning of the buffer, and the buffer's name will be set to a string of the -form @w<"@f[Message <folder> <msg-id>]">. - -The @hid[Message] buffer is read-only and may not be modified. The command -@hid[Goto Headers Buffer] issued in the @hid[Message] buffer makes the -associated @hid[Headers] buffer current. - -When not in a @hid[Headers] buffer, this command prompts for a folder and -message. A unique @hid[Message] buffer is obtained, and its name is set to a -string of the form @w<"@f[Message <folder> <msg-id>]">. The buffer's point is -moved to the beginning of the buffer, and the current window is used to display -the message. - -Specifying multiple messages inserts all the messages into the same buffer. If -the user wishes to show more than one message, it is expected that he will -generate a @hid[headers] buffer with the intended messages, and then use the -message sequencing commands described below. -@enddefcom - -@defcom[com "Next Message", stuff (bound to @bf[M-n] in @hid[Headers] and @hid[Message] modes) ] - This command is only meaningful in a @hid[Headers] buffer or a @hid[Message] -buffer associated with a @hid[Headers] buffer. In a @hid[Headers] buffer, the -point is moved to the next message, and if there is one, it is shown as -described in the @hid[Show Message] command. - -In a @hid[Message] buffer, the message after the currently visible message is -displayed. This clobbers the buffer's contents. Note, if the @hid[Message] -buffer is associated with a @hid[Draft] buffer, invoking this command breaks -that association. Using @hid[Keep Message] preserves the @hid[Message] buffer -and any association with a @hid[Draft] buffer. - -The @hid[Message] buffer's name is set as described in the @hid[Show Message] -command. -@enddefcom - -@defcom[com "Previous Message", stuff (bound to @bf[M-p] in @hid[Headers] and @hid[Message] modes) ] - This command is only meaningful in a @hid[Headers] buffer or a @hid[Message] -buffer associated with a @hid[Headers] buffer. In a @hid[Headers] buffer, the -point is moved to the previous message, and if there is one, it is shown as -described in the @hid[Show Message] command. - -In a @hid[Message] buffer, the message before the currently visible message is -displayed. This clobbers the buffer's contents. Note, if the @hid[Message] -buffer is associated with a @hid[Draft] buffer, invoking this command breaks -that association. Using @hid[Keep Message] preserves the @hid[Message] buffer -and any association with a @hid[Draft] buffer. - -The @hid[Message] buffer's name is set as described in the @hid[Show Message] -command. -@enddefcom - -@defcom[com "Next Undeleted Message", stuff (bound to @bf[n] in @hid[Headers] and @hid[Message] modes) ] - This command is only meaningful in a @hid[Headers] buffer or a @hid[Message] -buffer associated with a @hid[Headers] buffer. In a @hid[Headers] buffer, the -point is moved to the next undeleted message, and if there is one, it is shown -as described in the @hid[Show Message] command. - -In a @hid[Message] buffer, the first undeleted message after the currently -visible message is displayed. This clobbers the buffer's contents. Note, if -the @hid[Message] buffer is associated with a @hid[Draft] buffer, invoking this -command breaks that association. The @hid[Keep Message] command preserves the -@hid[Message] buffer and any association with a @hid[Draft] buffer. - -The @hid[Message] buffer's name is set as described in the @hid[Show Message] -command. -@enddefcom - -@defcom[com "Previous Undeleted Message", stuff (bound to @bf[p] in @hid[Headers] and @hid[Message] modes) ] - This command is only meaningful in a @hid[Headers] buffer or a @hid[Message] -buffer associated with a @hid[Headers] buffer. In a @hid[Headers] buffer, the -point is moved to the previous undeleted message, and if there is one, it is -shown as described in the @hid[Show Message] command. - -In a @hid[Message] buffer, the first undeleted message before the currently -visible message is displayed. This clobbers the buffer's contents. Note, if -the @hid[Message] buffer is associated with a @hid[Draft] buffer, invoking this -command breaks that association. The @hid[Keep Message] command preserves the -@hid[Message] buffer and any association with a @hid[Draft] buffer. - -The @hid[Message] buffer's name is set as described in the @hid[Show Message] -command. -@enddefcom - -@defcom[com "Scroll Message", stuff (bound to @bf[SPACE] and @bf[C-v] in @hid[Message] mode) ] -@defhvar1[var "Scroll Message Showing Next", val {t}] - This command scrolls the current window down through the current message. If -the end of the message is visible and @hid[Scroll Message Showing Next] is not -@nil, then show the next undeleted message. -@enddefcom - -@defcom[com "Keep Message" ] -This command can only be invoked in a @hid[Message] buffer. It causes the -@hid[Message] buffer to continue to exist when the user invokes commands to -view other messages either within the kept @hid[Message] buffer or its -associated @hid[Headers] buffer. This is useful for getting two messages into -different buffers. It is also useful for retaining @hid[Message] buffers which -would otherwise be deleted when an associated draft message is delivered. -@enddefcom - -@defcom[com "Message Help", bind (Message: ?)] -This command displays documentation on @hid[Message] mode. -@enddefcom - - -@section[Sending Messages] -@index[sending messages] -@label[sending-messages] -The most useful commands for sending mail are @hid[Send Message] (bound to -@bf[m] and @bf[s] in @hid[Headers] and @hid[Message] modes), @hid[Reply to -Message] (bound to @bf[r] in @hid[Headers] mode), and @hid[Reply to Message in -Other Window] (bound to @bf[r] in @hid[Message] mode). These commands set up a -@hid[Draft] buffer and associate a @hid[Message] buffer with the draft when -possible. To actually deliver the message to its recipient(s), use -@hid[Deliver Message] (bound to @bf[H-s] in @hid[Draft] mode). To abort -sending mail, use @hid[Delete Draft and Buffer] (bound to @bf[H-q] in -@hid[Draft] mode). If one wants to temporarily stop composing a draft with the -intention of finishing it later, then the @hid[Save File] command (bound to -@bf[C-x C-s]) will save the draft to the user's draft folder. - -@hid[Draft] buffers have a special @hemlock minor mode called @hid[Draft] mode. -The major mode of a @hid[Draft] buffer is taken from the @hid[Default Modes] -variable. The user may wish to arrange that @hid[Text] mode (and possibly -@hid[Fill] mode or @hid[Save] mode) be turned on whenever @hid[Draft] mode is -set. For a further description of how to manipulate modes in @hemlock see the -@i[Hemlock Command Implementor's Manual]. - - -@defcom[com "Send Message", stuff (bound to @bf[s] and @bf[m] in @hid[Headers] and @hid[Message] modes and @bf[C-x m] globally) ] - This command, when invoked in a @hid[Headers] buffer, creates a unique -@hid[Draft] buffer and a unique @hid[Message] buffer. The current message is -inserted in the @hid[Message] buffer, and the @hid[Draft] buffer is displayed -in the current window. The @hid[Draft] buffer's point is moved to the end of -the line containing @f[To:] if it exists. The name of the draft message file -is used to produce the buffer's name. A pathname is associated with the -@hid[Draft] buffer so that @hid[Save File] can be used to incrementally save a -composition before delivering it. The @f[comp] utility will be used to -allocate a draft message in the user's @mh draft folder and to insert the -proper header components into the draft message. Both the @hid[Draft] and -@hid[Message] buffers are associated with the @hid[Headers] buffer, and the -@hid[Draft] buffer is associated with the @hid[Message] buffer. - -When invoked in a @hid[Message] buffer, a unique @hid[Draft] buffer is created, -and these two buffers are associated. If the @hid[Message] buffer is -associated with a @hid[Headers] buffer, this association is propagated to the -@hid[Draft] buffer. Showing other messages while in this @hid[Headers] buffer -will not affect this @hid[Message] buffer. - -When not in a @hid[Headers] or @hid[Message] buffer, this command does the same -thing as described in the previous two cases, but there are no @hid[Message] or -@hid[Headers] buffer manipulations. - -@hid[Deliver Message] will deliver the draft to its intended recipient(s). - -The @hid[Goto Headers Buffer] command, when invoked in a @hid[Draft] or -@hid[Message] buffer, makes the associated @hid[Headers] buffer current. The -@hid[Goto Message Buffer] command, when invoked in a @hid[Draft] buffer, makes -the associated @hid[Message] buffer current. -@enddefcom - -@defcom[com "Reply to Message", stuff (bound to @bf[r] in @hid[Headers] mode) ] -@defcom1[com "Reply to Message in Other Window", stuff (bound to @bf[r] in @hid[Message] mode) ] -@defhvar1[var "Reply to Message Prefix Action"] - @hid[Reply to Message], when invoked in a @hid[Headers] buffer, creates a -unique @hid[Draft] buffer and a unique @hid[Message] buffer. The current -message is inserted in the @hid[Message] buffer, and the @hid[Draft] buffer is -displayed in the current window. The draft components are set up in reply to -the message, and the @hid[Draft] buffer's point is moved to the end of the -buffer. The name of the draft message file is used to produce the buffer's -name. A pathname is associated with the @hid[Draft] buffer so that @hid[Save -File] can be used to incrementally save a composition before delivering it. -The @f[repl] utility will be used to allocate a draft message file in the -user's @mh draft folder and to insert the proper header components into the -draft message. Both the @hid[Draft] and @hid[Message] buffers are associated -with the @hid[Headers] buffer, and the @hid[Draft] buffer is associated with -the @hid[Message] buffer. - -When invoked in a @hid[Message] buffer, a unique @hid[Draft] buffer is set up -using the message in the buffer as the associated message. Any previous -association between the @hid[Message] buffer and a @hid[Draft] buffer is -removed. Any association of the @hid[Message] buffer with a @hid[Headers] -buffer is propagated to the @hid[Draft] buffer. - -When not in a @hid[Headers] buffer or @hid[Message] buffer, this command -prompts for a folder and message to reply to. This message is inserted into a -unique @hid[Message] buffer, and a unique @hid[Draft] buffer is created as in -the previous two cases. There is no association of either the @hid[Message] -buffer or the @hid[Draft] buffer with a @hid[Headers] buffer. - -When a prefix argument is supplied, @hid[Reply to Message Prefix Action] is -considered with respect to supplying carbon copy switches to @f[repl]. This -variable's value is one of @b[:cc-all], :@b[no-cc-all], or @nil. See section -@ref[Styles] for examples of how to use this. - -@hid[Reply to Message in Other Window] is identical to @hid[Reply to Message], -but the current window is split showing the @hid[Draft] buffer in the new -window. The split window displays the @hid[Message] buffer. - -@hid[Deliver Message] will deliver the draft to its intended recipient(s). - -The @hid[Goto Headers Buffer] commmand, when invoked in a @hid[Draft] or -@hid[Message] buffer, makes the associated @hid[Headers] buffer current. The -@hid[Goto Message Buffer] command, when invoked in a @hid[Draft] buffer, makes -the associated @hid[Message] buffer current. -@enddefcom - -@defcom[com "Forward Message", stuff (bound to @bf[f] in @hid[Headers] and @hid[Message] modes) ] - This command, when invoked in a @hid[Headers] buffer, creates a unique -@hid[Draft] buffer. The current message is inserted in the draft by using the -@f[forw] utility, and the @hid[Draft] buffer is shown in the current window. -The name of the draft message file is used to produce the buffer's name. A -pathname is associated with the @hid[Draft] buffer so that @hid[Save File] can -be used to incrementally save a composition before delivering it. The -@hid[Draft] buffer is associated with the @hid[Headers] buffer, but no -@hid[Message] buffer is created since the message is already a part of the -draft. - -When invoked in a @hid[Message] buffer, a unique @hid[Draft] buffer is set up -inserting the message into the @hid[Draft] buffer. The @hid[Message] buffer is -not associated with the @hid[Draft] buffer because the message is already a -part of the draft. However, any association of the @hid[Message] buffer with a -@hid[Headers] buffer is propagated to the @hid[Draft] buffer. - -When not in a @hid[Headers] buffer or @hid[Message] buffer, this command -prompts for a folder and message to forward. A @hid[Draft] buffer is created -as described in the previous two cases. - -@hid[Deliver Message] will deliver the draft to its intended recipient(s). -@enddefcom - -@defcom[com "Deliver Message", stuff (bound to @bf[H-s] and @bf[H-c] in @hid[Draft] mode) ] -@defhvar1[var "Deliver Message Confirm", val {nil}] - This command, when invoked in a @hid[Draft] buffer, saves the file and uses -the @mh @f[send] utility to deliver the draft. If the draft is a reply to some -message, then @f[anno] is used to annotate that message with a "@f[replied]" -component. Any @hid[Headers] buffers containing the replied-to message are -updated with an "@b[A]" placed in the appropriate headers line two characters -after the message ID. Before doing any of this, confirmation is asked for -based on @hid[Deliver Message Confirm]. - -When not in a @hid[Draft] buffer, this prompts for a draft message ID and -invokes @f[send] on that draft message to deliver it. Sending a draft in this -way severs any association that draft may have had with a message being replied -to, so no annotation will occur. -@enddefcom - -@defcom[com "Delete Draft and Buffer", stuff (bound to @bf[H-q] in @hid[Draft] mode) ] -This command, when invoked in a @hid[Draft] buffer, deletes the draft message -file and the buffer. This also deletes any associated message buffer unless -the user preserved it with @hid[Keep Message]. -@enddefcom - -@defcom[com "Remail Message", stuff (bound to @bf[H-r] in @hid[Headers] and @hid[Message] modes) ] - This command, when invoked in a @hid[Headers] or @hid[Message] buffer, prompts -for resend @f[To:] and resend @f[Cc:] addresses, remailing the current message. -When invoked in any other kind of buffer, this command prompts for a folder and -message as well. @mh's @f[dist] sets up a draft folder message which is then -modified. The above mentioned addresses are inserted on the @f[Resent-To:] and -@f[Resent-Cc:] lines. Then the message is delivered. - -There is no mechanism for annotating messages as having been remailed. -@enddefcom - -@defcom[com "Draft Help", bind (Draft: H-?)] -This command displays documentation on @hid[Draft] mode. -@enddefcom - - -@section[Convenience Commands for Message and Draft Buffers] -@index[message buffer commands] -@index[draft buffer commands] -@index[convenience commands for mail interface] -@label[convenience-coms] -This section describes how to switch from a @hid[Message] or @hid[Draft] buffer -to its associated @hid[Headers] buffer, or from a @hid[Draft] buffer to its -associated @hid[Message] buffer. There are also commands for various styles of -inserting text from a @hid[Message] buffer into a @hid[Draft] buffer. - -@defcom[com "Goto Headers Buffer", stuff (bound to @bf[^] in @hid[Message] mode and @bf[H-^] in @hid[Draft] mode) ] -This command, when invoked in a @hid[Message] or @hid[Draft] buffer with an -associated @hid[Headers] buffer, places the associated @hid[Headers] buffer in -the current window. - -The cursor is moved to the headers line of the associated message. -@enddefcom - -@defcom[com "Goto Message Buffer", stuff (bound to @bf[H-m] in @hid[Draft] mode) ] -This command, when invoked in a @hid[Draft] buffer with an associated -@hid[Message] buffer, places the associated @hid[Message] buffer in the current -window. -@enddefcom - -@defcom[com "Insert Message Region", stuff (bound to @bf[H-y] in appropriate modes) ] -@defhvar1[var "Message Insertion Prefix", val {" "}] -@defhvar1[var "Message Insertion Column", val {75}] -This command, when invoked in a @hid[Message] or @hid[News-Message] (where it -is bound) buffer that has an associated @hid[Draft] or @hid[Post] buffer, -copies the current active region into the @hid[Draft] or @hid[Post] buffer. It -is filled using @hid[Message Insertion Prefix] (which defaults to three spaces) -and @hid[Message Insertion Column]. If an argument is supplied, the filling is -inhibited. -@enddefcom - -@defcom[com "Insert Message Buffer", stuff (bound to @bf[H-y] in appropriate modes) ] -@defhvar1[var "Message Buffer Insertion Prefix", val {" "}] -This command, when invoked in a @hid[Draft] or @hid[Post] (where it is bound) -buffer with an associated @hid[Message] or @hid[News-Message] buffer, or when -in a @hid[Message] (or @hid[News-Message]) buffer that has an associated -@hid[Draft] buffer, inserts the @hid[Message] buffer into the @hid[Draft] (or -@hid[Post]) buffer. Each inserted line is modified by prefixing it with -@hid[Message Buffer Insertion Prefix] (which defaults to four spaces) . If an -argument is supplied, the prefixing is inhibited. -@enddefcom - -@defcom[com "Edit Message Buffer", stuff (bound to @bf[e] in @hid[Message] mode) ] -This command puts the current @hid[Message] buffer in @hid[Text] mode and makes -it writable (@hid[Message] buffers are normally read-only). The pathname of -the file which the message is in is associated with the buffer making saving -possible. A recursive edit is entered, and the user is allowed to make changes -to the message. When the recursive edit is exited, if the buffer is modified, -the user is asked if the changes should be saved. The buffer is marked -unmodified, and the pathname is disassociated from the buffer. The buffer -otherwise returns to its previous state as a @hid[Message] buffer. If the -recursive edit is aborted, the user is not asked to save the file, and the -buffer remains changed though it is marked unmodified. -@enddefcom - - -@section[Deleting Messages] -@index[deleting messages] -@label[deleting] -The main command described in this section is @hid[Headers Delete Message] -(bound to @bf[k] in @hid[Headers] and @hid[Message] modes). A useful command -for reading new mail is @hid[Delete Message and Show Next] (bound to @bf[d] in -@hid[Message] mode) which deletes the current message and shows the next -undeleted message. - -Since messages are by default deleted using a virtual message deletion -mechanism, @hid[Expunge Messages] (bound to @bf[!] in @hid[Headers] mode) -should be mentioned here. This is described in section @ref[terminating]. - - -@defhvar[var "Virtual Message Deletion", val {t}] -When set, @hid[Delete Message] adds a message to the "@f[hemlockdeleted]" -sequence; otherwise, @f[rmm] is invoked on the message immediately. -@enddefhvar - -@defcom[com "Delete Message" ] -This command prompts for a folder, messages, and an optional @f[pick] -expression. When invoked in a @hid[Headers] buffer of the specified folder, -the prompt for a message specification will default to the those messages in -that @hid[Headers] buffer. - -When the variable @hid[Virtual Message Deletion] is set, this command merely -flags the messages for deletion by adding them to the "@f[hemlockdeleted]" -sequence. Then this updates any @hid[Headers] buffers representing the folder. -It notates each headers line referring to a deleted message with a "@b[D]" in -the third character position after the message ID. - -When @hid[Virtual Message Deletion] is not set, @f[rmm] is invoked on the -message, and each headers line referring to the deleted message is deleted from -its buffer -@enddefcom - -@defcom[com "Headers Delete Message", stuff (bound to @bf[k] in @hid[Headers] and @hid[Message] modes) ] -This command, when invoked in a @hid[Headers] buffer, deletes the message on -the current line as described in @hid[Delete Message]. - -When invoked in a @hid[Message] buffer, the message displayed in it is deleted -as described in @hid[Delete Message]. -@enddefcom - -@defcom[com "Delete Message and Show Next", stuff (bound to @bf[k] in @hid[Headers] and @hid[Message] modes) ] -This command is only valid in a @hid[Headers] buffer or a @hid[Message] buffer -associated with some @hid[Headers] buffer. The current message is deleted as -with the @hid[Delete Message] command. Then the next message is shown as with -@hid[Next Undeleted Message]. -@enddefcom - -@defcom[com "Delete Message and Down Line", stuff (bound to @bf[d] in @hid[Headers mode])] -This command, when invoked in a @hid[Headers] buffer, deletes the message on -the current line. Then the point is moved to the next non-blank line. -@enddefcom - -@defcom[com "Undelete Message" ] -This command is only meaningful when @hid[Virtual Message Deletion] is set. -This prompts for a folder, messages, and an optional @f[pick] expression. When -in a @hid[Headers] buffer of the specified folder, the messages prompt defaults -to those messages in the buffer. All @hid[Headers] buffers representing the -folder are updated. Each headers line referring to an undeleted message is -notated by replacing the "@b[D]" in the third character position after the -message ID with a space. -@enddefcom - -@defcom[com "Headers Undelete Message", stuff (bound to @bf[u] in @hid[Headers] and @hid[Message] modes) ] -This command is only meaningful when @hid[Virtual Message Deletion] is set. -When invoked in a @hid[Headers] buffer, the message on the current line is -undeleted as described in @hid[Undelete Message]. - -When invoked in a @hid[Message] buffer, the message displayed in it is -undeleted as described in @hid[Undelete Message]. -@enddefcom - - -@section[Folder Operations] - -@index[folder operations]@label[folder] -@defcom[com "List Folders" ] -This command displays a list of all current mail folders in the user's -top-level mail directory in a @hemlock pop-up window. -@enddefcom - -@defcom[com "Create Folder"] -This command prompts for and creates a folder. If the folder already exists, -an error is signaled. -@enddefcom - -@defcom[com "Delete Folder" ] -This command prompts for a folder and uses @f[rmf] to delete it. Note that no -confirmation is asked for. -@enddefcom - - -@section[Refiling Messages] - -@index[refiling messages]@label[refiling] -@defcom[com "Refile Message" ] -This command prompts for a folder, messages, an optional @f[pick] expression, -and a destination folder. When invoked in a @hid[Headers] buffer of the -specified folder, the message prompt offers a default of those messages in the -buffer. If the destination folder does not exist, the user is asked to create -it. The resulting messages are refiled with the @f[refile] utility. All -@hid[Headers] buffers for the folder are updated. Each line referring to a -refiled message is deleted from its buffer. -@enddefcom - -@defcom[com "Headers Refile Message", stuff (bound to @bf[o] in @hid[Headers] and @hid[Message] modes) ] -This command, when invoked in a @hid[Headers] buffer, prompts for a destination -folder, refiling the message on the current line with @f[refile]. If the -destination folder does not exist, the user is asked to create it. Any -@hid[Headers] buffers containing messages for that folder are updated. Each -headers line referring to the refiled message is deleted from its buffer. - -When invoked in a @hid[Message] buffer, that message is refiled as described -above. -@enddefcom - - -@section[Marking Messages] -@index[marking messages] -@label[marking] -@defcom[com "Mark Message" ] -This command prompts for a folder, message, and sequence and adds (deletes) the -message specification to (from) the sequence. By default this adds the -message, but if an argument is supplied, this deletes the message. When -invoked in a @hid[Headers] buffer or @hid[Message] buffer, this only prompts -for a sequence and uses the current message. -@enddefcom - - -@section[Terminating Headers Buffers] -@label[terminating] -The user never actually @i[exits] the mailer. He can leave mail buffers lying -around while conducting other editing tasks, selecting them and continuing his -mail handling whenever. There still is a need for various methods of -terminating or cleaning up @hid[Headers] buffers. The two most useful commands -in this section are @hid[Expunge Messages] and @hid[Quit Headers]. - - -@defhvar[var "Expunge Messages Confirm", val {t}] -When this is set, @hid[Quit Headers] and @hid[Expunge Messages] will ask for -confirmation before expunging messages and packing the folder's message ID's. -@enddefhvar - -@defhvar[var "Temporary Draft Folder", val {nil}] -This is a folder name where @mh @f[fcc:] messages are kept with the intention -that this folder's messages will be deleted and expunged whenever messages from -any folder are expunged (for example, when @hid[Expunge Messages] or @hid[Quit -Headers] is invoked. -@enddefhvar - -@defcom[com "Expunge Messages", stuff (bound to @bf[!] in @hid[Headers] mode) ] -This command deletes messages @f[mark]'ed for deletion, and compacts the -folder's message ID's. If there are messages to expunge, ask the user for -confirmation, displaying the folder name. This can be inhibited by setting -@hid[Expunge Messages Confirm] to @nil. When @hid[Temporary Draft Folder] is -not @nil, this command deletes and expunges that folder's messages regardless -of the folder in which the user invokes it, and a negative response to the -request for confirmation inhibits this. - -When invoked in a @hid[Headers] buffer, the messages in that folder's -"@f[hemlockdeleted]" sequence are deleted by invoking @f[rmm]. Then the ID's -of the folder's remaining messages are compacted using the @f[folder] utility. -Since headers must be regenerated due to renumbering or reassigning message -ID's, and because @hid[Headers] buffers become inconsistent after messages are -deleted, @hemlock must regenerate all the headers for the folder. Multiple -@hid[Headers] buffers for the same folder are then collapsed into one buffer, -deleting unnecessary duplicates. Any @hid[Message] buffers associated with -these @hid[Headers] buffers are deleted. - -If there is an unseen @hid[Headers] buffer for the folder, it is handled -separately from the @hid[Headers] buffers described above. @hemlock tries to -update it by filling it only with remaining unseen message headers. -Additionally, any headers generated due to @hid[Unseen Headers Message Spec] -are inserted. If there are no headers, unseen or otherwise, the buffer is left -blank. - -Any @hid[Draft] buffer set up as a reply to a message in the folder is affected -as well since the associated message has possibly been deleted. When a draft -of this type is delivered, no message will be annotated as having been replied -to. - -When invoked in a @hid[Message] buffer, this uses its corresponding folder as -the folder argument. The same updating as described above occurs. - -In any other type of buffer, a folder is prompted for. -@enddefcom - -@defcom[com "Quit Headers", stuff (bound to @bf[q] in @hid[Headers] and @hid[Message] modes) ] -This command affects the current @hid[Headers] buffer. When there are deleted -messages, ask the user for confirmation on expunging the messages and packing -the folder's message ID's. This prompting can be inhibited by setting -@hid[Expunge Messages Confirm] to @nil. After deleting and packing, this -deletes the buffer and all its associated @hid[Message] buffers. - -Other @hid[Headers] buffers regarding the same folder are handled as described -in @hid[Expunge Messages], but the buffer this command is invoked in is always -deleted. - -When @hid[Temporary Draft Folder] is not @nil, this folder's messages are -deleted and expunged regardless of the folder in which the user invokes this -command. A negative response to the above mentioned request for confirmation -inhibits this. -@enddefcom - -@defcom[com "Delete Headers Buffer and Message Buffers" ] -This command prompts for a @hid[Headers] buffer to delete along with its -associated @hid[Message] buffers. Any associated @hid[Draft] buffers are left -intact, but their corresponding @hid[Message] buffers will be deleted. When -invoked in a @hid[Headers] buffer or a @hid[Message] buffer associated with a -@hid[Headers] buffer, that @hid[Headers] buffer is offered as a default. -@enddefcom - - -@section[Miscellaneous Commands] -@label[miscellaneous mail commands] -@label[miscellaneous] - -@defcom[com "List Mail Buffers", stuff (bound to @bf[l] in @hid[Headers] and @hid[Message] modes @bf[H-l] in @hid[Draft] mode) ] -This command shows a list of all mail @hid[Message], @hid[Headers], and -@hid[Draft] buffers. - -If a @hid[Message] buffer has an associated @hid[Headers] buffer, it is -displayed to the right of the @hid[Message] buffer's name. - -If a @hid[Draft] buffer has an associated @hid[Message] buffer, it is displayed -to the right of the @hid[Draft] buffer's name. If a @hid[Draft] buffer has no -associated @hid[Message] buffer, but it is associated with a @hid[Headers] -buffer, then the name of the @hid[Headers] buffer is displayed to the right of -the @hid[Draft] buffer. - -For each buffer listed, if it is modified, then an asterisk is displayed before -the name of the buffer. -@enddefcom - - -@section[Styles of Usage] -@index[styles of mail interface usage] -@label[Styles] -This section discusses some styles of usage or ways to make use of some of the -features of @hemlock's interface to @mh that might not be obvious. In each -case, setting some variables and/or remembering an extra side effect of a -command will lend greater flexibility and functionality to the user. - -@subsection[Unseen Headers Message Spec] -The unseen @hid[Headers] buffer by default only shows unseen headers which is -adequate for one folder, simple mail handling. Some people use their @hid[New -Mail Folder] only for incoming mail, refiling or otherwise dispatching a -message immediately. Under this mode it is easy to conceive of the user not -having time to respond to a message, but he would like to leave it in this -folder to remind him to take care of it. Using the @hid[Unseen Headers Message -Spec] variable, the user can cause all the messages the @hid[New Mail Folder] to -be inserted into the unseen @hid[Headers] buffer whenever just unseen headers -would be. This way he sees all the messages that require immediate attention. - -To achieve the above effect, @hid[Unseen Headers Message Spec] should be set to -the string @f["all"]. This variable can be set to any general @mh message -specification (see section @ref[mhcommands] of this chapter), so the user can -include headers of messages other than those that have not been seen without -having to insert all of them. For example, the user could set the variable to -@f["flagged"] and use the @hid[Mark Message] command to add messages he's -concerned about to the @f["flagged"] sequence. Then the user would see new -mail and interesting mail in his unseen @hid[Headers] buffer, but he doesn't -have to see everything in his @hid[New Mail Folder]. - - -@subsection[Temporary Draft Folder] -Section @ref[components-files] of this chapter discusses how to make @mh keep -personal copies of outgoing mail. The method described will cause a copy of -every outgoing message to be saved forever and requires the user to go through -his @f[Fcc:] folder, weeding out those he does not need. The @hid[Temporary -Draft Folder] variable can name a folder whose messages will be deleted and -expunged whenever any folder's messages are expunged. By naming this folder in -the @mh profile and components files, copies of outgoing messages can be saved -temporarily. They will be cleaned up automatically, but the user still has a -time frame in which he can permanently save a copy of an outgoing message. -This folder can be visited with @hid[Message Headers], and messages can be -refiled just like any other folder. - - -@subsection[Reply to Message Prefix Action] -Depending on the kinds of messages one tends to handle, the user may find -himself usually replying to everyone who receives a certain message, or he may -find that this is only desired occasionally. In either case, the user -can set up his @mh profile to do one thing by default, using the @hid[Reply -to Message Prefix Action] variable in combination with a prefix argument to the -@hid[Reply to Message] command to get the other effect. - -For example, the following line in one's @mh profile will cause @mh to reply to -everyone receiving a certain message (except for the user himself since he -saves personal copies with the @f[-fcc] switch): -@begin[programexample] -repl: -cc all -nocc me -fcc out-copy -@end[programexample] -This user can set @hid[Reply to Message Prefix Action] to be @f[:no-cc-all]. -Then whenever he invokes @hid[Reply to Message] with a prefix argument, instead -of replying to everyone, the draft will be set up in reply only to the person -who sent the mail. - -As an alternative example, not specifying anything in one's @mh profile and -setting this variable to @f[:cc-all] will have a default effect of replying -only to the sender of a piece of mail. Then invoking @hid[Reply to Message] -with a prefix argument will cause everyone who received the mail to get a copy -of the reply. If the user does not want a @f[cc:] copy, then he can add -@f[-nocc me] as a default switch and value in his @mh profile. - - -@newpage -@section[Wallchart] - -@tabclear -@tabdivide(3) - -@begin[format, spacing 1.5] - -@Begin[Center] @b[Global bindings:] @End[Center] - -@hid[Incorporate and Read New Mail]@\@\@bf[C-x i] -@hid[Send Message]@\@\@bf[C-x m] -@hid[Message Headers]@\@\@bf[C-x r] - - -@Begin[Center] @b[Headers and Message modes bindings:] @End[Center] - -@hid[Next Undeleted Message]@\@\@bf[n] -@hid[Previous Undeleted Message]@\@\@bf[p] -@hid[Send Message]@\@\@bf[s], @bf[m] -@hid[Forward Message]@\@\@bf[f] -@hid[Headers Delete Message]@\@\@bf[k] -@hid[Headers Undelete Message]@\@\@bf[u] -@hid[Headers Refile Message]@\@\@bf[o] -@hid[List Mail Buffers]@\@\@bf[l] -@hid[Quit Headers]@\@\@bf[q] -@hid[Incorporate and Read New Mail]@\@\@bf[i] -@hid[Next Message]@\@\@bf[M-n] -@hid[Previous Message]@\@\@bf[M-p] -@hid[Beginning of Buffer]@\@\@bf[<] -@hid[End of Buffer]@\@\@bf[>] - - -@Begin[Center] @b[Headers mode bindings:] @End[Center] - -@hid[Delete Message and Down Line]@\@\@bf[d] -@hid[Pick Headers]@\@\@bf[h] -@hid[Show Message]@\@\@bf[space], @bf[.] -@hid[Reply to Message]@\@\@bf[r] -@hid[Expunge Messages]@\@\@bf[!] - - -@Begin[Center] @b[Message mode bindings:] @End[Center] - -@hid[Delete Message and Show Next]@\@\@bf[d] -@hid[Goto Headers Buffer]@\@\@bf[^] -@hid[Scroll Message]@\@\@bf[space] -@hid[Scroll Message]@\@\@bf[C-v] -@hid[Scroll Window Up]@\@\@bf[backspace], @bf[delete] -@hid[Reply to Message in Other Window]@\@bf[r] -@hid[Edit Message Buffer]@\@\@bf[e] -@hid[Insert Message Region]@\@\@bf[H-y] - - -@Begin[Center] @b[Draft mode bindings:] @End[Center] - -@hid[Goto Headers Buffer]@\@\@bf[H-^] -@hid[Goto Message Buffer]@\@\@bf[H-m] -@hid[Deliver Message]@\@\@bf[H-s], @bf[H-c] -@hid[Insert Message Buffer]@\@\@bf[H-y] -@hid[Delete Draft and Buffer]@\@\@bf[H-q] -@hid[List Mail Buffers]@\@\@bf[H-l] - -@end[format] -@tabclear diff --git a/docs/hem/user/netnews.mss b/docs/hem/user/netnews.mss deleted file mode 100644 index cc3b2d59da3c19b4a678b029b569a865904873e2..0000000000000000000000000000000000000000 --- a/docs/hem/user/netnews.mss +++ /dev/null @@ -1,488 +0,0 @@ -@comment{-*- Dictionary: /afs/cs/project/clisp/docs/hem/hem; Mode: spell; Package: Hemlock -*-} - -@chap[The Hemlock Netnews Interface] -@section[Introduction to Netnews in Hemlock] - - -@hemlock provides a facility for reading bulletin boards through the -NetNews Transfer Protocol (NNTP). You can easily read Netnews, reply to -news posts, post messages, etc. The news reading interface is consistent -with that of the @hemlock mailer, and most Netnews commands function in the -same manner as their mailer counterparts. - -Netnews can be read in one of two different modes. The first mode, invoked -by the @hid(Netnews) command, allows the user to read new messages in -groups which the user has specified. This method of reading netnews will -track the highest numbered message in each newsgroup and only show new -messages which have arrived since then. The @hid(Netnews Browse) command -invokes the other method of reading netnews. This mode displays a list of -all newsgroups, and the user may choose to read messages in any of them. -By default, the news reader will not track the latest message read when -browsing, and it will always display the last few messages. - - -@section[Setting Up Netnews] - -To start reading bulletin boards from @hemlock you probably need to create a -file containing the newsgroups you want to read. - -@defhvar[var "Netnews Group File", val {".hemlock-groups"}] - When you invoke the @hid(Netnews) command, @hemlock merges the value of - this variable with your home directory and looks there for a list of - groups (one per line) to read. -@enddefhvar - -@defhvar[var "Netnews Database File", val{".hemlock-netnews"}] -When you invoke the @hid(Netnews) command, @hemlock merges the value of -this variable with your home directory. This file maintains a pointer to -the highest numbered message read in each group in @hid(Netnews Group -File). -@enddefhvar - -@defcom[com "List All Groups"] - When you invoke this command, @hemlock creates a buffer called - @hid(Netnews Groups) and inserts the names of all accessible Netnews - groups into it alphabetically. You may find this useful if you choose to set - up your @hid(Netnews Group File) manually. -@enddefcom - -@defhvar[var "Netnews NNTP Server", val{"netnews.srv.cs.cmu.edu"}] -This variable stores the host name of the machine which @hemlock will use -as the NNTP server. -@enddefhvar - -@defhvar[var "Netnews NNTP Timeout Period", val{30}] -This is the number of seconds @hemlock will wait trying to connect to the -NNTP server. If a connection is not made within this time period, the -connection will time out and an error will be signalled. -@enddefhvar - -@subsection[News-Browse Mode] - - @hid(News-Browse) mode provides an easy method of adding groups to - your @hid(Netnews Group File). - -@defcom[com "Netnews Browse"] - This command sets up a buffer in @hid{News-Browse} mode with all - available groups listed one per line. Groups may be read or added - to your group file using various commands in this mode. -@enddefcom - -@defcom[com "Netnews Browse Add Group To File", stuff (bound to @bf[a] in @hid[News-Browse] mode)] -@defcom1[com "Netnews Browse Pointer Add Group to File"] -@hid(Netnews Browse Add Group to File) adds the group under the point to -your group file, and @hid(Netnews Browse Pointer Add Group To File) adds -the group under the mouse pointer without moving the point. -@enddefcom - -@defcom[com "Netnews Browse Read Group", stuff (bound to @bf[space] in @hid[News-Browse] mode)] -@defcom1[com "Netnews Browse Pointer Read Group"] -@hid(Netnews Browse Read Group) and @hid(Netnews Browse Pointer Read Group) -read the group under the cursor and the group under the mouse pointer, -respectively. These commands neither use nor modify the contents of your -@hid(Netnews Database File); they will always present the last few messages -in the newsgroup, regardless of the last message read. @hid(Netnews Browse -Pointer Read Group) does not modify the position of the point. -@enddefcom - -@defcom[com "Netnews Quit Browse"] - This command exits @hid(News-Browse) mode. -@enddefcom - -The @hid(Next Line) and @hid(Previous Line) commands are conveniently bound to -@bf[n] and @bf[p] in this mode. - -@section[Starting Netnews] - -Once your @hid(Netnews Group File) is set up, you may begin reading netnews. - -@defcom[com "Netnews"] - This command is the main entry point for reading bulletin boards in - @hemlock. Without an argument, the system looks for what bulletin boards to - read in the value of @hid(Netnews Group File) and reads each of them in - succession. @hemlock keeps a pointer to the last message you read in each - of these groups in your @hid(Netnews Database File). Bulletin boards may - be added to your @hid(Netnews Group File) manually or by using - the @hid(Netnews Browse) facility. With an argument, @hemlock prompts the - user for the name of a bulletin board and reads it. -@enddefcom - -@defcom[com "Netnews Look at Group"] - This command prompts for a group and reads it, ignoring the information - in your @hid(Netnews Database File). -@enddefcom - -When you read a group, @hemlock creates a buffer that contains important -header information for the messages in that group. There are four fields -in each header, one each for the @i(date), @i(lines), @i(from), and -@i(subject). The @i(date) field shows when the message was sent, the -@i(lines) field displays how long the message is in lines, the @i(from) -field shows who sent the message, and the @i(subject) field displays the -subject of this message. If a field for a message is not available, @f(NA) -will appear instead. You may alter the length of each of these fields by -modifying the following @hemlock variables: - -@defhvar[var "Netnews Before Date Field Pad", val 1] - How many spaces should be inserted before the date in @hid(News-Headers) - buffers. -@enddefhvar - -@defhvar[var "Netnews Date Field Length", val 6] -@defhvar1[var "Netnews Line Field Length", val 3] -@defhvar1[var "Netnews From Field Length", val 20] -@defhvar1[var "Netnews Subject Field Length", val 43] - These variables control how long the @i(date), @i(line), @i(from), and - @i(subject) fields should be in @hid{News-Headers} buffers. -@enddefhvar - -@defhvar[var "Netnews Field Padding", val 2] - How many spaces should be left between the Netnews @i(date), @i(from), - @i(lines), and @i(subject) fields after padding to the required length. -@enddefhvar - -For increased speed, @hemlock only inserts headers for a subset of the -messages in each group. If you have never read a certain group, and the -value of @hid(Netnews New Group Style) is @f(:from-end) (the default), -@hemlock inserts some number of the last messages in the group, determined -by the value of @hid(Netnews Batch Count). If the value of @hid(Netnews -New Group Style) is @f(:from-start), @hemlock will insert the first batch -of messages in the group. If you have read a group before, @hemlock will -insert the batch of messages following the highest numbered message that -you had read previously. - -@defhvar[var "Netnews Start Over Threshold", val {350}] - If the number of new messages in a group exceeds the value of this - variable and @hid(Netnews New Group Style) is @f(:from-end), @hemlock asks - if you would like to start reading this group from the end. -@enddefhvar - -You may at any time go beyond the messages that are visible using the -@hid(Netnews Next Line), @hid(Netnews Previous Line), -@hid(Netnews Headers Scroll Window Up), and -@hid(Netnews Headers Scroll Down) commands in @hid(News-Headers) mode, -or the @hid(Netnews Next Article) and @hid(Netnews Previous Article) -commands in @hid(News-Message) mode. - -@defhvar[var "Netnews Fetch All Headers", val {nil}] -This variable determines whether Netnews will fetch all headers immediately -upon entering a new group. -@enddefhvar - -@defhvar[var "Netnews Batch Count", val {50}] - This variable determines how many headers the Netnews facility will fetch - at a time. -@enddefhvar - -@defhvar[var "Netnews New Group Style", val {:from-end}] -This variable determines what happens when you read a group that you have -never read before. When it is @f(:from-start), the @hid(Netnews) command -will read from the beginning of a new group forward. When it is @f(:from-end), -the default, @hid(Netnews) will read the group from the end backward. -@enddefhvar - -@section[Reading Messages] - -From a @hid{News-Headers} buffer, you may read messages, reply to messages -via the @hemlock mailer, or reply to messages via post. Some commands are -also bound to ease getting from one header to another. - -@defcom[com "Netnews Show Article", stuff (bound to @bf[space] in @hid{News-Headers} mode)] -@defhvar1[var "Netnews Read Style", val {:multiple}] -@defhvar1[var "Netnews Headers Proportion", val {0.25}] -This command puts the body of the message header under the current point -into a @hid{News-Message} buffer. If the value of @hid(Netnews Read -Style) is @f(:single), @hemlock changes to the @hid{News-Message} -buffer. If it is @f(:multiple), then @hemlock splits the current window -into two windows, one for headers and one for message bodies. The headers -window takes up a proportion of the current window based on the value of -@hid(Netnews Headers Proportion). If the window displaying the -@hid(News-Headers) buffer has already been split, and the message -currently displayed in the @hid(News-Message) window is the same as the -one under the current point, this command behaves just like @hid(Netnews -Message Scroll Down). -@enddefcom - -@defhvar[var "Netnews Message Header Fields", val {nil}] - When this variable is @nil, all available fields are displayed in the - header of a message. Otherwise, this variable should containt a list of - fields to include in message headers. If an element of this - list is an atom, then it should be the string name of a field. If it is - a cons, then the car should be the string name of a field, and the cdr - should be the length to which this field should be limited. Any string - name is acceptable, and fields that do not exist are ignored. -@enddefhvar - -@defcom[com "Netnews Show Whole Header", stuff (bound to @bf[w] in @hid{News-Headers} and @hid{News-Message} modes.)] -This command displays the entire header for the message currently being -read. This is to undo the effects of @hid{Netnews Message Header Fields} -for the current message. -@enddefcom - -@defcom[com "Netnews Next Line", stuff (bound to @bf[C-n] and @bf[Downarrow] in @hid{News-Headers} mode)] -@defhvar1[var "Netnews Last Header Style", val {:next-headers}] -This command moves the current point to the next line. If you are on the -last visible message, and there are more in the current group, headers for -these messages will be inserted. If you are on the last header and there -are no more messages in this group, then @hemlock will take some action -based on the value of @hid(Netnews Last Header Style). If the value of -this variable is @f(:feep), @hemlock feeps you indicating there are no -more messages. If the value is @f(:next-headers), @hemlock reads in the -headers for the next group in your @hid(Netnews Group File). If the value -is @f(:next-article), @hemlock goes on to the next group and shows you -the first unread message. -@enddefcom - -@defcom[com "Netnews Previous Line", stuff (bound to @bf[C-p] and @bf[Uparrow] in @hid{News-Headers} mode)] -This command moves the current point to the previous line. If you are on -the first visible header, and there are more previous messages, @hemlock -inserts the headers for these messages. -@enddefcom - -@defcom[com "Netnews Headers Scroll Window Down", stuff (bound to @bf[C-v] in @hid{News-Headers} mode)] -@defcom1[com "Netnews Headers Scroll Window Up", stuff (bound to @bf[M-v] in @hid{News-Headers} mode)] - These commands scroll the headers window up or down one screenfull. If the - end of the buffer is visible, @hemlock inserts the next batch of headers. -@enddefcom - -@defcom[com "Netnews Next Article", stuff (bound to @bf[n] in @hid{News-Message} and @hid{News-Headers} modes)] -@defcom1[com "Netnews Previous Article", stuff (bound to @bf[p] in @hid{News-Message} and @hid{News-Headers} modes)] - These commands insert the next or previous message into a message buffer. -@enddefcom - -@defcom[com "Netnews Message Scroll Down", stuff (bound to @bf[space] in @hid{News-Message} mode)] -@defhvar1[var "Netnews Scroll Show Next Message", val {t}] -If the end of the current message is visible, @hemlock feeps the user if -the value of @hid(Netnews Scroll Show Next Message) is non-@nil, or it -inserts the next message into this message buffer if that variable is @nil. -If the end of the message is not visible, then @hemlock shows the next -screenfull of the current message. -@enddefcom - -@defcom[com "Netnews Message Quit", stuff (bound to @bf[q] in @hid{News-Message} mode)] - This command deletes the current message buffer and makes the associated - @hid{News-Headers} buffer current. -@enddefcom - -@defcom[com "Netnews Goto Headers Buffer", stuff (bound to @bf[H-h] in @hid{News-Message} mode)] - This command, when invoked from a @hid(News-Message) buffer with an - associated @hid(News-Headers) buffer, places the associated - @hid(News-Headers) buffer into the current window. -@enddefcom - -@defcom[com "Netnews Message Keep Buffer", stuff (bound to @bf[k] in @hid{News-Message} mode)] - By default, @hemlock uses one buffer to display all messages in a group, - one at a time. This command tells @hemlock to keep the current message - buffer intact and start reading messages in another buffer. -@enddefcom - -@defcom[com "Netnews Select Message Buffer", stuff (bound to @bf[H-m] in @hid{News-Headers} and @hid{Post} modes.)] - In @hid{News-Headers} mode, this command selects the buffer - containing the last message read. In @hid{Post} mode, it selects the - associated @hid{News-Message} buffer, if there is one. -@enddefcom - -@defcom[com "Netnews Append to File", stuff (bound to @bf[a] in @hid{News-Headers} and @hid{News-Message} modes.)] -@defhvar1[var "Netnews Message File", val {"netnews-messages.txt"}] -This command prompts for a file which the current message will be appended -to. The default file is the value of @hid(Netnews Message File) merged -with your home directory. -@enddefcom - -@defcom[com "Netnews Headers File Message", stuff (bound to @bf[o] in @hid{News-Headers} mode)] -This command prompts for a mail folder and files the message under the -point into it. If the folder does not exist, @hemlock will ask if it should -be created. -@enddefcom - -@defcom[com "Netnews Message File Message", stuff (bound to @bf[o] in @hid{News-Message} mode)] -This command prompts for a mail folder and files the current message there. -If the folder does not exist, @hemlock will ask if it should be created. -@enddefcom - -@defcom[com "Fetch All Headers", stuff (bound to @bf[f] in @hid{Netnews Headers} mode)] - In a forward reading @hid(Netnews headers) buffer, this command inserts - all headers after the last visible one into the headers buffer. If - @hemlock is reading this group backward, the system inserts all headers - before the first visible one into the headers buffer. -@enddefcom - -@defcom[com "Netnews Go to Next Group", stuff (bound to @bf[g] in @hid{News-Headers} and @hid{News-Message} modes.)] -This command goes to the next group in your @hid(Netnews Group File). -Before going on, it sets the group pointer in @hid(Netnews Database -Filename) to the last message you read. With an argument, the command does -not modify the group pointer for the current group. -@enddefcom - -@defcom[com "Netnews Quit Starting Here", stuff (bound to @bf[.] in @hid{News-Headers} and @hid{News-Message} modes)] - This command goes to the next group in your @hid(Netnews Group File), - setting the netnews pointer for this group to the message before the one - under the current point, so the next time you read this group, the message - indicated by the point will appear first. -@enddefcom - -@defcom[com "Netnews Group Punt Messages", stuff (bound to @bf[G] in @hid{News-Headers} mode)] - This command goes on to the next bulletin board in your group - file. Without an argument, the system sets the pointer for the current - group to the last message. With an argument, @hemlock sets the - pointer to the last visible message in the group. -@enddefcom - -@defcom[com "Netnews Exit", stuff (bound to @bf[q] in @hid{News-Headers} mode)] -@defhvar1[var "Netnews Exit Confirm", val {t}] - This command cleans up and deletes the @hid(News-Headers) buffer and - all associated @hid(News-Message) buffers. If the value of - @hid(Netnews Exit Confirm) is @nil, then @hemlock will not prompt before - exiting. -@enddefcom - -@section[Replying to Messages] - -The @hemlock Netnews interface also provides an easy way of replying to -messages through the @hemlock Mailer or via @hid{Post} mode. - -@defcom[com "Netnews Reply to Sender"] - When you invoke this command, @hemlock creates a @hid(Draft) buffer and - tries to fill in the @i(to) and @i(subject) fields of the draft. For - the @i(to) field, @hemlock looks at the @i(reply-to) field of the - message you are replying to, or failing that, the @i(from) field. If - the @i(subject) field does not start with @f(Re:), @hemlock inserts this - string, signifying that this is a reply. -@enddefcom - -@defcom[com "Netnews Reply to Sender in Other Window", stuff (bound to @bf[r] in @hid{News-Headers} and @hid{News-Message}.)] -This command splits the current window, placing the message you are -replying to in the top window and a new @hid{Draft} buffer in the bottom -one. This command fills in the header fields in the same manner as -@hid(Netnews Reply to Sender). -@enddefcom - -@defcom[com "Netnews Reply to Group"] -This command creates a @hid{Post} buffer with the @i(newsgroups) field set -to the current group and the @i(subject) field constructed in the same way -as in @hid(Netnews Reply to Sender). -@enddefcom - -@defcom[com "Netnews Reply to Group in Other Window", stuff (bound to @bf[R] in @hid{News-Headers} and @hid{News-Message}.)] - This command splits the current window, placing the message you are - replying to in the top window and a new @hid{Post} buffer in the bottom - one. This command will fill in the header fields in the same manner as - @hid(Netnews Reply to Group). -@enddefcom - -@defcom[com "Netnews Post Message", stuff (bound to @bf[C-x P])] - This command creates a @hid{Post} buffer. If you are in a - @hid(News-Headers) or @hid{News-Message} buffer, @hemlock fills in the - @i(newsgroups) field with the current group. -@enddefcom - -@defcom[com "Netnews Forward Message", stuff (bound to @bf[f] in @hid{News-Headers} and @hid{News-Message} modes.)] -This command creates a @hid{Post} buffer. If you are in a @hid{Netnews -Headers} or @hid{News-Message} buffer, @hemlock will put the text of the -current message into the buffer along with lines delimiting the forwarded -message. -@enddefcom - -@defcom[com "Netnews Goto Post Buffer", stuff (bound to @bf[H-p] in @hid{News-Message} mode)] - This command, when invoked in a @hid(News-Message) or @hid(Draft) buffer - with an associated @hid(News-Headers) buffer, places the associated - @hid(News-Headers) buffer into the current window. -@enddefcom - -@defcom[com "Netnews Goto Draft Buffer", stuff (bound to @bf[H-d] in @hid{News-Message} mode)] - This command, when invoked in a @hid(News-Message) buffer with an - associated @hid(Draft) buffer, places the @hid(Draft) buffer into the - current window. -@enddefcom - -@section[Posting Messages] - -@defcom[com "Netnews Deliver Post", stuff (bound to @bf[H-s] in @hid{Post} mode)] -@defhvar1[var "Netnews Deliver Post Confirm", val "t"] -This command delivers the contents of a @hid(Post) buffer to the NNTP -server. If @hid(Netnews Deliver Post Confirm) is @f(t), @hemlock will ask for -confirmation before posting the message. @hemlock feeps you if NNTP does -not accept the message. -@enddefcom - -@defcom[com "Netnews Abort Post", stuff (bound to @bf[H-q] in @hid{Post} mode)] - This command deletes the current @hid(Post) buffer. -@enddefcom - - -As in the mailer, when replying to a message you can be excerpt sections of -it using @hid(Insert Message Buffer) and @hid(Insert Message Region) in -@hid(Post) and @hid(News-Message) modes, respectively. You can also use -these commands when replying to a message via mail in a @hid(Draft) buffer. -In all cases, the same binding is used: @bf[H-y]. - -@newpage -@section[Wallchart] - -@tabclear -@tabdivide(5) - -@begin[format, spacing 1.5] - - -@Begin[Center] @b[Global bindings:] @End[Center] - -@hid[Netnews Post Message]@\@\@bf[C-x P] - - -@Begin[Center] @b[News-Headers and News-Message modes bindings:] @End[Center] - -@hid[Netnews Next Article]@\@\@\@bf[n] -@hid[Netnews Previous Article]@\@\@bf[p] -@hid[Netnews Go to Next Group]@\@\@bf[g] -@hid[Netnews Group Punt Messages]@\@\@bf[G] -@hid[List All Groups]@\@\@\@bf[l] -@hid[Netnews Append to File]@\@\@bf[a] -@hid[Netnews Forward Message]@\@\@bf[f] -@hid[Netnews Reply to Sender in Other Window]@\@\@bf[r] -@hid[Netnews Reply to Group in Other Window]@\@\@bf[R] -@hid[Netnews Quit Starting Here]@\@\@bf[.] - -@Begin[Center] @b[News-Headers mode bindings:] @End[Center] - -@hid[Netnews Show Article]@\@\@bf[Space] -@hid[Netnews Previous Line]@\@\@bf[C-p], @bf[Uparrow] -@hid[Netnews Next Line]@\@\@\@bf[C-n], @bf[Downarrow] -@hid[Netnews Headers Scroll Window Down]@\@\@bf[C-v] -@hid[Netnews Headers Scroll Window Up]@\@\@bf[M-v] -@hid[Netnews Select Message Buffer]@\@\@bf[H-m] -@hid[Netnews Exit]@\@\@\@bf[q] -@hid[Netnews Headers File Message]@\@\@bf[o] - - -@Begin[Center] @b[News-Message mode bindings:] @End[Center] - -@hid[Netnews Message Scroll Down]@\@\@bf[Space] -@hid[Scroll Window Up]@\@\@\@bf[Backspace] -@hid[Netnews Goto Headers Buffer]@\@\@bf[H-h], @bf[^] -@hid[Netnews Message Keep Buffer]@\@\@bf[k] -@hid[Netnews Message Quit]@\@\@bf[q] -@hid[Netnews Message File Message]@\@\@bf[o] -@hid[Netnews Goto Post Buffer]@\@\@bf[H-p] -@hid[Netnews Goto Draft Buffer]@\@\@bf[H-d] -@hid[Insert Message Region]@\@\@bf[H-y] - - -@Begin[Center] @b[Post mode bindings:] @End[Center] - -@hid[Netnews Select Message Buffer]@\@\@bf[H-m] -@hid[Netnews Deliver Post]@\@\@bf[H-s] -@hid[Netnews Abort Post]@\@\@\@bf[H-q] -@hid[Insert Message Buffer]@\@\@bf[H-y] - - -@Begin[Center] @b[News-Browse mode bindings:] @End[Center] - -@hid[Netnews Quit Browse]@\@\@bf[q] -@hid[Netnews Browse Add Group To File]@\@\@bf[a] -@hid[Netnews Browse Read Group]@\@\@bf[Space] -@hid[Next Line]@\@\@\@bf[n] -@hid[Previous Line]@\@\@\@bf[p] - - -@end[format] -@tabclear diff --git a/docs/hem/user/special-modes.mss b/docs/hem/user/special-modes.mss deleted file mode 100644 index 262b44bf8f93ea28f5c31ebdb089eda6b1c4846c..0000000000000000000000000000000000000000 --- a/docs/hem/user/special-modes.mss +++ /dev/null @@ -1,738 +0,0 @@ -@comment{-*- Dictionary: bld:scribe/hem/hem; Mode: spell; Package: Hemlock -*-} -@chap[Special Modes] - -@section[Dired Mode] -@label[dired] -@index[directory editing] - -@hemlock provides a directory editing mechanism. The user can flag files and -directories for deletion, undelete flagged files, and with a keystroke read in -files and descend into directories. In some implementations, it also supports -copying, renaming, and a simple wildcard feature. - - -@subsection[Inspecting Directories] -@defcom[com "Dired", bind (C-x C-M-d)] -This command prompts for a directory and fills a buffer with a verbose listing -of that directory. When the prefix argument is supplied, this includes Unix -dot files. If a dired buffer already exists for the directory, this switches -to the buffer and makes sure it displays dot files if appropriate. -@enddefcom - -@defcom[com "Dired with Pattern", bind (C-x C-M-d)] -This command prompts for a directory and a pattern that may contain at most one -wildcard, an asterisk, and it fills a buffer with a verbose listing of the -files in the directory matching the pattern. When the prefix argument is -supplied, this includes Unix dot files. If a dired buffer already exists for -this directory, this switches to the buffer and makes sure it displays dot -files if appropriate. -@enddefcom - -@defcom[com "Dired from Buffer Pathname"] -This command invokes @hid[Dired] on the directory name of the current buffer's -pathname. -@enddefcom - -@defcom[com "Dired Help", bind (Dired: ?)] -This command pops up a help window listing the various @hid[Dired] commands. -@enddefcom - -@defcom[com "Dired View File", bind (Dired: Space)] -@defcom1[com "Dired Edit File", bind (Dired: e)] -These command read in the file on the current line with the point. If the line -describes a directory instead of a file, then this command effectively invokes -@hid[Dired] on the specification. This associates the file's buffer with the -@hid[Dired] buffer. - -@hid[Dired View File] reads in the file as if by @hid[View File], and -@hid[Dired Edit File] as if by @hid[Find File]. - -@hid[Dired View File] always reads into a newly created buffer, warning if the -file already exists in some buffer. -@enddefcom - -@defcom[com "Dired Up Directory", bind (Dired: ^)] -This command invokes @hid[Dired] on the directory up one level from the current -@hid[Dired] buffer. This is useful for going backwards after repeatedly -invoking @hid[Dired View File] and descending into a series of subdirectories. -Remember, @hid[Dired] only generates directory listings when no buffer contains -a dired for the specified directory. -@enddefcom - -@defcom[com "Dired Update Buffer", bind (Dired: H-u)] -This command is useful when the user knows the directory in the current -@hid[Dired] buffer has changed. @hemlock cannot know the directory structure -has changed, but the user can explicitly update the buffer with this command -instead of having to delete it and invoke @hid[Dired] again. -@enddefcom - -@defcom[com "Dired Next File"] -@defcom1[com "Dired Previous File"] -These commands move to next or previous undeleted file. -@enddefcom - - -@subsection[Deleting Files] -@defcom[com "Dired Delete File and Down Line", bind (Dired: d)] -This command marks for deletion the file on the current line with the point and -moves point down a line. -@enddefcom - -@defcom[com "Dired Delete File with Pattern", bind (Dired: D)] -This command prompts for a name pattern that may contain at most one wildcard, -an asterisk, and marks for deletion all the names matching the pattern. -@enddefcom - -@defcom[com "Dired Delete File", bind (Dired: C-d)] -This command marks for deletion the file on the current line with the point -without moving the point. -@enddefcom - - -@subsection[Undeleting Files] -@defcom[com "Dired Undelete File and Down Line", bind (Dired: u)] -This command unmarks for deletion the file on the current line with the point -and moves point down a line. -@enddefcom - -@defcom[com "Dired Undelete File with Pattern", bind (Dired: U)] -This command prompts for a name pattern that may contain at most one wildcard, -an asterisk, and unmarks for deletion all the names matching the pattern. -@enddefcom - -@defcom[com "Dired Undelete File", bind (Dired: C-u)] -This command unmarks for deletion the file on the current line with the point -without moving the point. -@enddefcom - - -@subsection[Expunging and Quitting] -@defcom[com "Dired Expunge Files", bind (Dired: !)] -@defhvar1[var "Dired File Expunge Confirm", val {t}] -@defhvar1[var "Dired Directory Expunge Confirm", val {t}] -This command deletes files marked for deletion, asking the user for -confirmation once for all the files flagged. It recursively deletes any marked -directories, asking the user for confirmation once for all those marked. -@hid[Dired File Expunge Confirm] and @hid[Dired Directory Expunge Confirm] when -set to @nil individually inhibit the confirmation prompting for the appropriate -deleting. -@enddefcom - -@defcom[com "Dired Quit", bind (Dired: q)] -This command expunges any marked files or directories as if by @hid[Expunge -Dired Files] before deleting the @hid[Dired] buffer. -@enddefcom - - -@subsection[Copying Files] -@defcom[com "Dired Copy File", bind (Dired: c)] -This command prompts for a destination specification and copies the file on the -line with the point. When prompting, the current line's specification is the -default, which provides some convenience in supplying the destination. The -destination is either a directory specification or a file name, and when it is -the former, the source is copied into the directory under its current file name -and extension. -@enddefcom - -@defcom[com "Dired Copy with Wildcard", bind (Dired: C)] -This command prompts for a name pattern that may contain at most one wildcard, -an asterisk, and copies all the names matching the pattern. When prompting for -a destination, this provides the @hid[Dired] buffer's directory as a default. -The destination is either a directory specification or a file name with a -wildcard. When it is the former, all the source files are copied into the -directory under their current file names and extensions. When it is the later, -each sources file's substitution for the wildcard causing it to match the first -pattern replaces the wildcard in the destination pattern; for example, you -might want to copy @f["*.txt"] to @f["*.text"]. -@enddefcom - -@defhvar[var "Dired Copy File Confirm", val {t}] -@label[copy-confirm] -This variable controls interaction with the user when it is not obvious what -the copying process should do. This takes one of the following values: -@Begin[Description] -@true@\ -When the destination specification exists, the copying process stops and asks -the user if it should overwrite the destination. - -@nil@\ -The copying process always copies the source file to the destination -specification without interacting with the user. - -@kwd[update]@\ -When the destination specification exists, and its write date is newer than -the source's write date, then the copying process stops and asks the user if it -should overwrite the destination. -@End[Description] -@enddefhvar - - -@subsection[Renaming Files] -@defcom[com "Dired Rename File", bind (Dired: r)] -Rename the file or directory under the point -@enddefcom - -@defcom[com "Dired Rename with Wildcard", bind (Dired: R)] -Rename files that match a pattern containing ONE wildcard. -@enddefcom - -@defhvar[var "Dired Rename File Confirm", val {t}] -When non-nil, @hid[Dired] will query before clobbering an existing file. -@enddefhvar - - -@section[View Mode] -@hid[View] mode provides for scrolling through a file read-only, terminating -the buffer upon reaching the end. - -@defcom[com "View File"] -This command reads a file into a new buffer as if by "Visit File", but -read-only. Bindings exist for scrolling and backing up in a single key stroke. -@enddefcom - -@defcom[com "View Help", bind (View: ?)] -This command shows a help message for @hid[View] mode. -@enddefcom - -@defcom[com "View Edit File", bind (View: e)] -This commands makes a buffer in @hid[View] mode a normal editing buffer, -warning if the file exists in another buffer simultaneously. -@enddefcom - -@defcom[com "View Scroll Down", bind (View: Space)] -@defhvar1[var "View Scroll Deleting Buffer", val {t}] -This command scrolls the current window down through its buffer. If the end of -the file is visible, then this deletes the buffer if @hid[View Scroll Deleting -Buffer] is set. If the buffer is associated with a @hid[Dired] buffer, this -returns there instead of to the previous buffer. -@enddefcom - -@defcom[com "View Return", bind (View: ^)] -@defcom1[com "View Quit", bind (View: q)] -These commands invoke a function that returns to the buffer that created the -current buffer in @hid[View] mode. Sometimes this function does nothing, but -it is useful for returning to @hid[Dired] buffers and similar @hemlock -features. - -After invoking the viewing return function if there is one, @hid[View Quit] -deletes the buffer that is current when the user invokes it. -@enddefcom - -Also, bound in @hid[View] mode are the following commands: -@Begin[Description] -@binding[backspace], @binding[delete]@\Scrolls the window up. - -@binding[<]@\Goes to the beginning of the buffer. - -@binding[>]@\Goes to the end of the buffer. -@End[Description] - - -@section[Process Mode] -@Label[process] -@Index[shells] -@Index[processes] - -@hid[Process] mode allows the user to execute a Unix process within a @hemlock -buffer. These commands and default bindings cater to running Unix shells in -buffers. For example, @hid[Stop Buffer Subprocess] is bound to @binding[H-z] -to stop the process you are running in the shell instead of binding @hid[Stop -Main Process] to this key which would stop the shell itself. - -@defcom[com "Shell", bind (C-M-s)] -@defhvar1[var "Shell Utility", val {"/bin/csh"}] -@defhvar1[var "Shell Utility Switches", val {@nil}] -@defhvar1[var "Current Shell"] -@defhvar1[var "Ask about Old Shells"] -This command executes the process determined by the values of @hid(Shell -Utility) and @hid(Shell Utility Switches) in a new buffer named @f["Shell n"] -where @f["n"] is some distinguishing integer. - -@hid[Current Shell] is a @hemlock variable that holds to the current shell -buffer. When @hid[Shell] is invoked, if there is a @hid[Current Shell], the -command goes to that buffer. - -When there is no @hid[Current Shell], but shell buffers do exist, if @hid[Ask -about Old Shells] is set, the @hid[Shell] command prompts for one of them, -setting @hid[Current Shell] to the indicated shell, and goes to the buffer. - -Invoking @hid[Shell] with an argument forces the creation of a new shell -buffer. - -@hid[Shell Utility] is the string name of the process to execute. - -@hid[Shell Utility Switches] is a string containing the default command line -arguments to @hid[Shell Utility]. This is a string since the utility is -typically @f["/bin/csh"], and this string can contain I/O redirection and other -shell directives. -@enddefcom - -@defcom[com "Shell Command Line in Buffer"] -This command prompts for a buffer and a shell command line. It then runs a -shell, giving it the command line, in the buffer. -@enddefcom - -@defcom[com "Set Current Shell"] -This command sets the value of @hid[Current Shell]. -@enddefcom - -@defcom[com "Stop Main Process"] -This command stops the process running in the current buffer by sending a -@f[:SIGTSTP] to that process. With an argument, stops the process using -@f[:SIGSTOP]. -@enddefcom - -@defcom[com "Continue Main Process"] -If the process in the current buffer is stopped, this command continues it. -@enddefcom - -@defcom[com "Kill Main Process"] -@defhvar1[var "Kill Process Confirm", val {t}] -This command prompts for confirmation and kills the process running in the -current buffer. - -Setting this variable to @nil inhibits @hemlock's prompting for confirmation. -@enddefcom - -@defcom[com "Stop Buffer Subprocess", stuff (bound to @bf[H-z] in @hid[Process] mode)] -This command stops the foreground subprocess of the process in the current -buffer, similar to the effect of @binding[C-Z] in a shell. -@enddefcom - -@defcom[com "Kill Buffer Subprocess"] -This command kills the foreground subprocess of the process in the current -buffer. -@enddefcom - -@defcom[com "Interrupt Buffer Subprocess", stuff (bound to @bf[H-c] in @hid[Process] mode)] -This command interrupts the foreground subprocess of the process in the -current buffer, similar to the effect of @binding[C-C] in a shell. -@enddefcom - -@defcom[com "Quit Buffer Subprocess", stuff (bound to @bf[H-\] in @hid[Process] mode)] -This command dumps the core of the foreground subprocess of the processs in -the current buffer, similar to the effect of @binding[C-\] in a shell. -@enddefcom - -@defcom[com "Send EOF to Process", stuff (bound to @bf[H-d] in @hid[Process] mode)] -This command sends the end of file character to the process in the current -buffer, similar to the effect of @binding[C-D] in a shell. -@enddefcom - -@defcom[com "Confirm Process Input", stuff (bound to @bf[Return] in @hid[Process] mode)] -This command sends the text the user has inserted at the end of a process -buffer to the process in that buffer. Resulting output is inserted at the end -of the process buffer. -@enddefcom - -The user may edit process input using commands that are shared with -@hid[Typescript] mode, see section @ref[typescripts]. - - -@section[Bufed Mode] -@hemlock provides a mechanism for managing buffers as an itemized list. -@hid[Bufed] supports conveniently deleting several buffers at once, saving -them, going to one, etc., all in a key stroke. - -@defcom[com "Bufed", bind (C-x C-M-b)] -This command creates a list of buffers in a buffer supporting operations such -as deletion, saving, and selection. If there already is a @hid[Bufed] buffer, -this just goes to it. -@enddefcom - -@defcom[com "Bufed Help"] -This command pops up a display of @hid[Bufed] help. -@enddefcom - -@defcom[com "Bufed Delete", bind (Bufed: C-d, C-D, D, d)] -@defhvar1[var "Virtual Buffer Deletion", val {t}] -@defhvar1[var "Bufed Delete Confirm", val {t}] -@hid[Bufed Delete] deletes the buffer on the current line. - -When @hid[Virtual Buffer Deletion] is set, this merely flags the buffer for -deletion until @hid[Bufed Expunge] or @hid[Bufed Quit] executes. - -Whenever these commands actually delete a buffer, if @hid[Bufed Delete Confirm] -is set, then @hemlock prompts the user for permission; if more than one buffer -is flagged for deletion, this only prompts once. For each modified buffer, -@hemlock asks to save the buffer before deleting it. -@enddefcom - -@defcom[com "Bufed Undelete", bind (Bufed: U, u)] -This command undeletes the buffer on the current line. -@enddefcom - -@defcom[com "Bufed Expunge", bind (Bufed: !)] -This command expunges any buffers marked for deletion regarding @hid[Bufed -Delete Confirm]. -@enddefcom - -@defcom[com "Bufed Quit", bind (Bufed: q)] -This command kills the @hid[Bufed] buffer, expunging any buffers marked for -deletion. -@enddefcom - -@defcom[com "Bufed Goto", bind (Bufed: Space)] -This command selects the buffer on the current line, switching to it. -@enddefcom - -@defcom[com "Bufed Goto and Quit", bind (Bufed: S-leftdown)] -This command goes to the buffer under the pointer, quitting @hid[Bufed]. It -supplies a function for @hid[Generic Pointer Up] which is a no-op. -@enddefcom - -@defcom[com "Bufed Save File", bind (Bufed: s)] -This command saves the buffer on the current line. -@enddefcom - - -@section[Completion] -This is a minor mode that saves words greater than three characters in length, -allowing later completion of those words. This is very useful for the often -long identifiers used in Lisp programs. As you type a word, such as a Lisp -symbol when in @hid[Lisp] mode, and you progress to typing the third letter, -@hemlock displays a possible completion in the status line. You can then -rotate through the possible completions or type some more letters to narrow -down the possibilities. If you choose a completion, you can also rotate -through the possibilities in the buffer instead of in the status line. -Choosing a completion or inserting a character that delimits words moves the -word forward in the ring of possible completions, so the next time you enter -its initial characters, @hemlock will prefer it over less recently used -completions. - -@defcom[com "Completion Mode"] -This command toggles @hid[Completion] mode in the current buffer. -@enddefcom - -@defcom[com "Completion Self Insert"] -This command is like @hid[Self Insert], but it also checks for possible -completions displaying any result in the status line. This is bound to most of -the key-events with corresponding graphic characters. -@enddefcom - -@defcom[com "Completion Complete Word", bind (Completion: End)] -This command selects the currently displayed completion if there is one, -guessing the case of the inserted text as with @hid[Query Replace]. Invoking -this immediately in succession rotates through possible completions in the -buffer. If there is no currently displayed completion on a first invocation, -this tries to find a completion from text immediately before the point and -displays the completion if found. -@enddefcom - -@defcom[com "Completion Rotate Completions", bind (Completion: M-End)] -This command displays the next possible completion in the status line. If -there is no currently displayed completion, this tries to find a completion -from text immediately before the point and displays the completion if found. -@enddefcom - -@defcom[com "List Possible Completions"] -This command lists all the possible completions for the text immediately before -the point in a pop-up display. Sometimes this is more useful than rotating -through several completions to see if what you want is available. -@enddefcom - -@defhvar[var "Completion Bucket Size", val {20}] -Completions are stored in buckets determined by the first three letters of a -word. This variable limits the number of completions saved for each combination -of the first three letters of a word. If you have many identifier in some -module beginning with the same first three letters, you'll need increase this -variable to accommodate all the names. -@enddefhvar - - -@defcom[com "Save Completions"] -@defcom1[com "Read Completions"] -@defhvar1[var "Completion Database Filename", val {nil}] -@hid[Save Completions] writes the current completions to the file -@hid[Completion Database Filename]. It writes them, so @hid[Read Completions] -can read them back in preserving the most-recently-used order. If the user -supplies an argument, then this prompts for a pathname. - -@hid[Read Completions] reads completions saved in @hid[Completion Database -Filename]. It moves any current completions to a less-recently-used status, -and it removes any in a given bucket that exceed the limit @hid[Completion -Bucket Size]. -@enddefcom - -@defcom[com "Parse Buffer for Completions"] -This command passes over the current buffer putting each valid completion word -into the database. This is a good way of picking up many useful completions -upon visiting a new file for which there are no saved completions. -@enddefcom - - -@section[CAPS-LOCK Mode] - -@hid[CAPS-LOCK] is a minor mode in which @hemlock that inserts all alphabetic -characters as uppercase letters. - -@defcom[com "Caps Lock Mode"] -This command toggles @hid[CAPS-LOCK] mode for the current buffer; it is most -useful when bound to a key, so you can enter and leave @hid[CAPS-LOCK] mode -casually. -@enddefcom - -@defcom[com "Self Insert Caps Lock"] -This command inserts the uppercase version of the character corresponding to -the last key-event typed. -@enddefcom - - - -@section[Overwrite Mode] - -@hid[Overwrite] mode is a minor mode which is useful for creating figures and -tables out of text. In this mode, typing a key-event with a corresponding -graphic character replaces the character at the point instead of inserting the -character. @hid[Quoted Insert] can be used to insert characters normally. - -@defcom[com "Overwrite Mode"] -This command turns on @hid[Overwrite] mode in the current buffer. If it is -already on, then it is turned off. A positive argument turns @hid[Overwrite] -mode on, while zero or a negative argument turns it off. -@enddefcom - -@defcom[com "Self Overwrite"] -This command replaces the next character with the character corresponding to -the key-event used to invoke the command. After replacing the character, this -moves past it. If the next character is a tab, this first expands the tab into -the appropriate number of spaces, replacing just the next space character. -At the end of the line, it inserts the -character instead of clobbering the newline. - -This is bound to key-events with corresponding graphic characters in -@hid[Overwrite] mode. -@enddefcom - -@defcom[com "Overwrite Delete Previous Character", - stuff (bound to @bf[Delete] and @bf[Backspace] in @hid[Overwrite] mode)] -This command replaces the previous character with a space and moves backwards. -This deletes tabs and newlines. -@enddefcom - - -@section[Word Abbreviation] -@index[word abbreviation] -Word abbreviation provides a way to speed the typing of frequently used words -and phrases. When in @hid[Abbrev] mode, typing a word delimiter causes the -previous word to be replaced with its @i[expansion] if there is one currently -defined. The expansion for an abbrev may be any string, so this mode can be -used for abbreviating programming language constructs and other more obscure -uses. For example, @hid[Abbrev] mode can be used to automatically correct -common spelling mistakes and to enforce consistent capitalization of -identifiers in programs. - -@i[Abbrev] is an abbreviation for @i[abbreviation], which is used for -historical reasons. Obviously the original writer of @hid[Abbrev] mode hated -to type long words and could hardly use @hid[Abbrev] mode while writing -@hid[Abbrev] mode. - -A word abbrev can be either global or local to a major mode. A global word -abbrev is defined no matter what the current major mode is, while a mode word -abbrev is only defined when its mode is the major mode in the current buffer. -Mode word abbrevs can be used to prevent abbrev expansion in inappropriate -contexts. - - -@subsection[Basic Commands] - -@defcom[com "Abbrev Mode"] -This command turns on @hid[Abbrev] mode in the current buffer. If @hid[Abbrev] -mode is already on, it is turned off. @hid[Abbrev] mode must be on for the -automatic expansion of word abbrevs to occur, but the abbreviation commands are -bound globally and may be used at any time. -@enddefcom - -@defcom[com "Abbrev Expand Only", - stuff (bound to word-delimiters in @hid[Abbrev] mode)] -This is the word abbrev expansion command. If the word before the point is a -defined word abbrev, then it is replaced with its expansion. The replacement -is done using the same case-preserving heuristic as is used by -@hid[Query Replace]. This command is globally bound to @binding[M-Space] so -that abbrevs can be expanded when @hid[Abbrev] mode is off. An undesirable -expansion may be inhibited by using @binding[C-q] to insert the delimiter. -@enddefcom - -@defcom[com "Inverse Add Global Word Abbrev", bind (C-x -)] -@defcom1[com "Inverse Add Mode Word Abbrev", bind (C-x C-h, C-x Backspace)] -@hid[Inverse Add Global Word Abbrev] prompts for a string and makes it the -global word abbrev expansion for the word before the point. - -@hid[Inverse Add Mode Word Abbrev] is identical to -@hid[Inverse Add Global Word Abbrev] except that it defines an expansion which -is local to the current major mode. -@enddefcom - -@defcom[com "Make Word Abbrev"] -This command defines an arbitrary word abbreviation. It prompts for the mode, -abbreviation and expansion. If the mode @f["Global"] is specified, then it -makes a global abbrev. -@enddefcom - -@defcom[com "Add Global Word Abbrev", bind (C-x +)] -@defcom1[com "Add Mode Word Abbrev", bind (C-x C-a)] -@hid[Add Global Word Abbrev] prompts for a word and defines it to be a global -word abbreviation. The prefix argument determines which text is used as the -expansion: -@begin[description] -@i[no prefix argument]@\The word before the point is used as the expansion of -the abbreviation. - -@i[zero prefix argument]@\The text in the region is used as the expansion of the -abbreviation. - -@i[positive prefix argument]@\That many words before the point are made the -expansion of the abbreviation. - -@i[negative prefix argument]@\Do the same thing as -@hid[Delete Global Word Abbrev] instead of defining an abbreviation. -@end[description] - -@hid[Add Mode Word Abbrev] is identical to @hid[Add Global Word Abbrev] except -that it defines or deletes mode word abbrevs in the current major mode. -@enddefcom - -@defcom[com "Word Abbrev Prefix Mark", bind (M-")] -This command allows @hid[Abbrev Expand Only] to recognize abbreviations when -they have prefixes attached. First type the prefix, then use this command. A -hyphen (@f[-]) will be inserted in the buffer. Now type the abbreviation and -the word delimiter. @hid[Abbrev Expand Only] will expand the abbreviation and -remove the hyphen. - -Note that there is no need for a suffixing command, since -@hid[Abbrev Expand Only] may be used explicitly by typing @binding[M-Space]. -@enddefcom - -@defcom[com "Unexpand Last Word", bind (C-x u)] -This command undoes the last word abbrev expansion. If repeated, undoes its -own effect. -@enddefcom - - -@subsection[Word Abbrev Files] -A word abbrev file is a file which holds word abbrev definitions. Word abbrev -files allow abbrevs to be saved so that they may be used across many editing -sessions. - -@defhvar[var "Abbrev Pathname Defaults", val {(pathname "abbrev.defns")}] -This is sticky default for the following commands. When they prompt for a file -to write, they offer this and set it for the next time one of them executes. -@enddefhvar - -@defcom[com "Read Word Abbrev File"] -This command reads in a word abbrev file, adding all the definitions to those -currently defined. If a definition in the file is different from the current -one, the current definition is replaced. -@enddefcom - -@defcom[com "Write Word Abbrev File"] -This command prompts for a file and writes all currently defined word abbrevs -out to it. -@enddefcom - -@defcom[com "Append to Word Abbrev File"] -This command prompts for a word abbrev file and appends any new definitions to -it. An abbrev is new if it has been defined or redefined since the last use of -this command. Definitions made by reading word abbrev files are not -considered. -@enddefcom - - -@subsection[Listing Word Abbrevs] -@defcom[com "List Word Abbrevs"] -@defcom1[com "Word Abbrev Apropos"] -@hid[List Word Abbrevs] displays a list of each defined word abbrev, with its -mode and expansion. - -@hid[Word Abbrev Apropos] is similar, except that it only displays abbrevs -which contain a specified string, either in the definition, expansion or mode. -@enddefcom - -@subsection[Editing Word Abbrevs] -Word abbrev definition lists are edited by editing the text representation -of the definitions. Word abbrev files may be edited directly, like any other -text file. The set of abbrevs currently defined in @hemlock may be edited -using the commands described in this section. - -The text representation of a word abbrev is fairly simple. Each definition -begins at the beginning of a line. Each line has three fields which are -separated by ASCII tab characters. The fields are the abbreviation, the mode -of the abbreviation and the expansion. The mode is represented as the mode -name inside of parentheses. If the abbrev is global, then the mode field is -empty. The expansion is represented as a quoted string since it may contain -any character. The string is quoted with double-quotes (@f["]); double-quotes -in the expansion are represented by doubled double-quotes. The expansion may -contain newline characters, in which case the definition will take up more than -one line. - -@defcom[com "Edit Word Abbrevs"] -This command inserts the current word abbrev definitions into the -@hid[Edit Word Abbrevs] buffer and then enters a recursive edit on the buffer. -When the recursive edit is exited, the definitions in the buffer become the new -current abbrev definitions. -@enddefcom - -@defcom[com "Insert Word Abbrevs"] -This command inserts at the point the text representation of the currently -defined word abbrevs. -@enddefcom - -@defcom[com "Define Word Abbrevs"] -This command interprets the text of the current buffer as a word abbrev -definition list, adding all the definitions to those currently defined. -@enddefcom - - -@subsection[Deleting Word Abbrevs] -The user may delete word abbrevs either individually or collectively. -Individual abbrev deletion neutralizes single abbrevs which have outlived their -usefulness; collective deletion provides a clean slate from which to initiate -abbrev definitions. - -@defcom[com "Delete All Word Abbrevs"] -This command deletes all word abbrevs which are currently defined. -@enddefcom - -@defcom[com "Delete Global Word Abbrev"] -@defcom1[com "Delete Mode Word Abbrev"] -@hid[Delete Global Word Abbrev] prompts for a word abbreviation and deletes its -global definition. If given a prefix argument, deletes all global abbrev -definitions. - -@hid[Delete Mode Word Abbrev] is identical to @hid[Delete Global Word Abbrev] -except that it deletes definitions in the current major mode. -@enddefcom - - -@section[Lisp Library] -This is an implementation dependent feature. The Lisp library is a collection -of local hacks that users can submit and share that is maintained by the Lisp -group. These commands help peruse the catalog or description files and figure -out how to load the entries. - -@defcom[com "Lisp Library"] -This command finds all the library entries and lists them in a buffer. The -following commands describe and load those entries. -@enddefcom - -@defcom[com "Describe Library Entry", bind (Lisp-Lib: space)] -@defcom1[com "Describe Pointer Library Entry", bind (Lisp-Lib: leftdown)] -@defcom1[com "Load Library Entry", bind (Lisp-Lib: rightdown)] -@defcom1[com "Load Pointer Library Entry", bind (Lisp-Lib: l)] -@defcom1[com "Editor Load Library Entry"] -@defcom1[com "Editor Load Pointer Library Entry"] -@hid[Load Library Entry] and @hid[Load Pointer Library Entry] load the library -entry indicated by the line on which the point lies or where the user clicked -the pointer, respectively. These load the entry into the current slave Lisp. - -@hid[Editor Load Library Entry] and @hid[Editor Load Pointer Library Entry] are -the same, but they load the entry into the editor Lisp. -@enddefcom - -@defcom[com "Exit Lisp Library", bind (Lisp-Lib: q)] -This command deletes the @hid[Lisp Library] buffer. -@enddefcom - -@defcom[com "Lisp Library Help", bind (Lisp-Lib: ?)] -This command pops up a help window listing @hid[Lisp-Lib] commands. -@enddefcom diff --git a/docs/hem/user/user.mss b/docs/hem/user/user.mss deleted file mode 100644 index b7c2bd6ec2a11abb4990594944c5bff86e198da1..0000000000000000000000000000000000000000 --- a/docs/hem/user/user.mss +++ /dev/null @@ -1,2003 +0,0 @@ -@make[Manual] @comment{-*- Dictionary: /afs/cs/project/clisp/scribe/hem/hem; Mode: spell; Package: Hemlock -*-} -@Device[postscript] -@Style(Spacing = 1.2 lines) -@Style(StringMax = 5000) -@Use(Database "/afs/cs/project/clisp/docs/database/") -@Style(FontFamily=TimesRoman) -@Style(Date="March 1952") -@style(DOUBLESIDED) -@Libraryfile[ArpaCredit] -@libraryfile[hem] -@Libraryfile[Spice] -@Libraryfile[Uttir] - -@String(REPORTTITLE "Hemlock User's Manual") - -@comment<@begin[TitlePage] -@begin[TitleBox] -> -@blankspace(1.3inches) -@heading[Hemlock User's Manual] - -@center[@b<Bill Chiles> -@b<Robert A. MacLachlan> - - -@b<@value[date]> - -@b<CMU-CS-89-133-R1> -] -@comment<@end[TitleBox]> -@blankspace(2lines) -@begin[Center] -School of Computer Science -Carnegie Mellon University -Pittsburgh, PA 15213 -@end[Center] -@blankspace[2lines] - -@begin[Center] -This is a revised version of Technical Report CMU-CS-87-158. -@end[Center] - -@heading<Abstract> -@begin(Text, indent 0) -This document describes the @Hemlock text editor, version M3.2. @Hemlock is a -customizable, extensible text editor whose initial command set closely -resembles that of ITS/TOPS-20 @Emacs. @Hemlock is written in CMU Common Lisp -and has been ported to other implementations. -@end(Text) - -@begin[ResearchCredit] -@ArpaCredit[Contract=Basic87-90] -@end[ResearchCredit] -@comment<@end[TitlePage]> - - -@commandstring(mh = "@f1(MH)") -@commandstring(dash = "@Y[M]") - -@comment[This tabclear is necessary since the definition macros don't - take care of the own tabbing needs] -@tabclear - - -@comment[@chap (Introduction)] -@include(intro) - - -@comment[@chap (Basic Commands)] -@include(commands) - - - -@chap[Files, Buffers, and Windows] - -@section[Introduction] - -@index[files] -@index[buffers] -@index[windows] -@hemlock provides three different abstractions which are used in combination to -solve the text-editing problem, while other editors tend to mash these ideas -together into two or even one. -@begin[description] -File@\A file provides permanent storage of text. @hemlock has commands -to read files into buffers and write buffers out into files. - -Buffer@\A buffer provides temporary storage of text and a capability to -edit it. A buffer may or may not have a file associated with it; if it -does, the text in the buffer need bear no particular relation to the text -in the file. In addition, text in a buffer may be displayed in any number -of windows, or may not be displayed at all. - -Window@\A window displays some portion of a buffer on the screen. There -may be any number of windows on the screen, each of which may display any -position in any buffer. It is thus possible, and often useful, to have -several windows displaying different places in the same buffer. -@end[description] - - -@section[Buffers] -In addition to some text, a buffer has several other user-visible attributes: -@begin[description] -A name@\ -A buffer is identified by its name, which allows it to be selected, destroyed, -or otherwise manipulated. - -A collection of modes@\ -The modes present in a buffer alter the set of commands available and -otherwise alter the behavior of the editor. For details see page -@pageref[modes]. - -A modification flag @\ -This flag is set whenever the text in a buffer is modified. It is often -useful to know whether a buffer has been changed, since if it has it should -probably be saved in its associated file eventually. - -A write-protect flag @\ -If this flag is true, then any attempt to modify the buffer will result in an -error. -@end[description] - -@defcom[com "Select Buffer", bind (C-x b)] -This command prompts for the name of a existing buffer and makes that buffer -the @i[current buffer]. The newly selected buffer is displayed in the -current window, and editing commands now edit the text in that buffer. -Each buffer has its own point, thus the point will be in the place it was -the last time the buffer was selected. When prompting for the buffer, the -default is the buffer that was selected before the current one. -@enddefcom - -@defcom[com "Select Previous Buffer", bind (C-M-l)] -@defcom1[com "Circulate Buffers", bind (C-M-L)] -With no prefix argument, @hid[Select Previous Buffer] selects the buffer that -has been selected most recently, similar to @binding[C-x b Return]. If given a -prefix argument, then it does the same thing as @hid[Circulate Buffers]. - -@hid[Circulate Buffers] moves back into successively earlier buffers in the -buffer history. If the previous command was not @hid[Circulate Buffers] or -@hid[Select Previous Buffer], then it does the same thing as -@hid[Select Previous Buffer], otherwise it moves to the next most recent -buffer. The original buffer at the start of the excursion is made the previous -buffer, so @hid[Select Previous Buffer] will always take you back to where you -started. - -These commands are generally used together. Often @hid[Select Previous Buffer] -will take you where you want to go. If you don't end up there, then using -@hid[Circulate Buffers] will do the trick. -@enddefcom - -@defcom[com "Create Buffer", bind (C-x M-b)] -This command is very similar to @hid[Select Buffer], but the buffer need not -already exist. If the buffer does not exist, a new empty buffer is created -with the specified name. -@enddefcom - -@defcom[com "Kill Buffer", bind (C-x k)] -This command is used to make a buffer go away. There is no way to restore -a buffer that has been accidentally deleted, so the user is given a chance -to save the hapless buffer if it has been modified. This command is poorly -named, since it has nothing to do with killing text. -@enddefcom - -@defcom[com "List Buffers", bind (C-x C-b)] -This command displays a list of all existing buffers in a pop-up window. A -"@f[*]" is displayed before the name of each modified buffer. A buffer with no -associated file is represented by the buffer name followed by the number of -lines in the buffer. A buffer with an associated file are is represented by -the name and type of the file, a space, and the device and directory. If the -buffer name doesn't match the associated file, then the buffer name is also -displayed. When given a prefix argument, this command lists only the modified -buffers. -@enddefcom - -@defcom[com "Buffer Not Modified", bind (M-~)] -This command resets the current buffer's modification flag @dash @i[it does not -save any changes]. This is primarily useful in cases where a user accidentally -modifies a buffer and then undoes the change. Resetting the modified flag -indicates that the buffer has no changes that need to be written out. -@enddefcom - -@defcom[com "Check Buffer Modified", bind (C-x ~)] -This command displays a message indicating whether the current buffer is modified. -@enddefcom - -@defcom[com "Set Buffer Read-Only"] -This command changes the flag that allows the current buffer to be modified. -If a buffer is read-only, any attempt to modify it will result in an error. The -buffer may be made writable again by repeating this command. -@enddefcom - -@defcom[com "Set Buffer Writable"] -This command ensures the current buffer is modifiable. -@enddefcom - -@defcom[com "Insert Buffer"] -This command prompts for the name of a buffer and inserts its contents at the -point, pushing a buffer mark before inserting. The buffer inserted is -unaffected. -@enddefcom - -@defcom[com "Rename Buffer"] -This command prompts for a new name for the current buffer, which defaults -to a name derived from the associated filename. -@enddefcom - - -@section[Files] -@index[files] -These commands either read a file into the current buffer or write it out to -some file. Various other bookkeeping operations are performed as well. - -@defcom[com "Find File", bind (C-x C-f)] -This is the command normally used to get a file into @hemlock. It prompts -for the name of a file, and if that file has already been read in, selects -that buffer; otherwise, it reads file into a new buffer whose name is -derived from the name of the file. If the file does not exist, then the -buffer is left empty, and @w<"@f[(New File)]"> is displayed in the echo area; -the file may then be created by saving the buffer. - -The buffer name created is in the form @w<"@i[name] @i[type] @i[directory]">. -This means that the filename "@f[/sys/emacs/teco.mid]" has -@w<"@f[Teco Mid /Sys/Emacs/]"> as its the corresponding buffer name. The -reason for rearranging the fields in this fashion is that it facilitates -recognition since the components most likely to differ are placed first. If -the buffer cannot be created because it already exists, but has another file in -it (an unlikely occurrence), then the user is prompted for the buffer to use, -as by @hid[Create Buffer]. - -@hid[Find File] takes special action if the file has been modified on disk -since it was read into @hemlock. This usually happens when several people are -simultaneously editing a file, an unhealthy circumstance. If the buffer is -unmodified, @hid[Find File] just asks for confirmation before reading in the -new version. If the buffer is modified, then @hid[Find File] beeps and prompts -for a single key-event to indicate what action to take. It recognizes -the following key-events: -@begin[description] -@binding[Return, Space, y]@\ - Prompt for a file in which to save the current buffer and then read in the -file found to be modified on disk. - -@binding[Delete, Backspace, n]@\ - Forego reading the file. - -@binding[r]@\ - Read the file found to be modified on disk into the buffer containing the -earlier version with modifications. This loses all changes you had in the -buffer. -@end[description] -@enddefcom - -@defcom[com "Save File", bind (C-x C-s)] -This command writes the current buffer out to its associated file and -resets the buffer modification flag. If there is no associated file, then -the user is prompted for a file, which is made the associated file. If -the buffer is not modified, then the user is asked whether to actually -write it or not. - -If the file has been modified on disk since the last time it was read, -@hid[Save File] prompts for confirmation before overwriting the file. -@enddefcom - -@defcom[com "Save All Files", bind (C-x C-m)] -@defcom1[com "Save All Files and Exit", bind (C-x M-z)] -@defhvar1[var "Save All Files Confirm", val {t}] -@hid[Save All Files] does a @hid[Save File] on all buffers which have an -associated file. @hid[Save All Files and Exit] does the same thing and then -exits @hemlock. - -When @hid[Save All Files Confirm] is true, these commands will ask for -confirmation before saving a file. -@enddefcom - -@defcom[com "Visit File", bind (C-x C-v)] -This command prompts for a file and reads it into the current buffer, -setting the associated filename. Since the old contents of the buffer are -destroyed, the user is given a chance to save the buffer if it is modified. -As for @hid[Find File], the file need not actually exist. This command warns -if some other buffer also contains the file. -@enddefcom - -@defcom[com "Write File", bind (C-x C-w)] This command prompts for a file -and writes the current buffer out to it, changing the associated filename -and resetting the modification flag. When the buffer's associated file is -specified this command does the same thing as @hid[Save File]. @enddefcom - -@defcom[com "Backup File"] -This command is similar to @hid[Write File], but it neither sets the -associated filename nor clears the modification flag. This is useful for -saving the current state somewhere else, perhaps on a reliable machine. - -Since @hid[Backup File] doesn't update the write date for the buffer, -@hid[Find File] and @hid[Save File] will get all upset if you back up -a buffer on any file that has been read into @hemlock. -@enddefcom - -@defcom[com "Revert File"] -@defhvar1[var "Revert File Confirm", val {t}] -This command replaces the text in the current buffer with the contents of the -associated file or the checkpoint file for that file, whichever is more recent. -The point is put in approximately the same place that it was before the file -was read. If the original file is reverted to, then clear the modified flag, -otherwise leave it set. If a prefix argument is specified, then always revert -to the original file, ignoring any checkpoint file. - -If the buffer is modified and @hid[Revert File Confirm] is true, then the user -is asked for confirmation. -@enddefcom - -@defcom[com "Insert File", bind (C-x C-r)] -This command prompts for a file and inserts it at the point, pushing a buffer -mark before inserting. -@enddefcom - -@defcom[com "Write Region"] -This command prompts for a file and writes the text in the region out to it. -@enddefcom - -@defhvar[var "Add Newline at EOF on Writing File", val {:ask-user}] -This variable controls whether some file writing commands add a newline at the -end of the file if the last line is non-empty. -@begin[description] -@f[:ask-user]@\Ask the user whether to add a newline. - -@f[t]@\Automatically add a newline and inform the user. - -@nil@\Never add a newline and do not ask. -@end[description] -Some programs will lose the text on the last line or get an -error when the last line does not have a newline at the end. -@enddefhvar - -@defhvar[var "Keep Backup Files", val {nil}] -Whenever a file is written by @hid[Save File] and similar commands, the old -file is renamed by appending "@f[.BAK]" to the name, ensuring that some version -of the file will survive a system crash during the write. If set to true, this -backup file will not deleted even when the write successfully completes. -@enddefhvar - - -@subsection[Auto Save Mode] - -@hid[Save] mode protects against loss of work in system crashes by periodically -saving modified buffers in checkpoint files. - -@defcom[com "Auto Save Mode"] -This command turns on @hid[Save] mode if it is not on, and turns off when it is -on. @hid[Save] mode is on by default. -@enddefcom - -@defhvar[var "Auto Save Checkpoint Frequency", val {120}] -@defhvar1[var "Auto Save Key Count Threshold", val {256}] -These variables determine how often modified buffers in @hid[Save] mode will be -checkpointed. Checkpointing is done after -@hid[Auto Save Checkpoint Frequency] seconds, or after -@hid[Auto Save Key Count Threshold] keystrokes that modify the buffer -(whichever comes first). Either kind of checkpointing may be disabled by -setting the corresponding variable to @nil. -@enddefhvar - -@defhvar[var "Auto Save Cleanup Checkpoints", val {t}] -If this variable is true, then any checkpoint file for a buffer will be deleted -when the buffer is successfully saved in its associated file. -@enddefhvar - -@defhvar[var "Auto Save Filename Pattern", val {"~A~A.CKP"}] -@defhvar1[var "Auto Save Pathname Hook", val {make-unique-save-pathname}] -These variables determine the naming of checkpoint files. -@hid[Auto Save Filename Pattern] is a format string used to name the checkpoint -files for buffers with associated files. Format is called with two arguments: -the directory and file namestrings of the associated file. - -@hid[Auto Save Pathname Hook] is a function called by @hid[Save] mode to get a -checkpoint pathname when there is no pathname associated with a buffer. It -should take a buffer as its argument and return either a pathname or @nil. If -a pathname is returned, then it is used as the name of the checkpoint file. If -the function returns @nil, or if the hook variable is @nil, then @hid[Save] -mode is turned off in the buffer. The default value for this variable returns -a pathname in the default directory of the form "@w<@f[save-]@i[number]>", -where @i[number] is a number used to make the file unique. -@enddefhvar - - -@subsection[Filename Defaulting and Merging] -@index[merging, filename] -@index[defaulting, filename] -@index[filename defaulting] -@label[merging] -@index[pathnames] -When @hemlock prompts for the name of a file, it always offers a default. -Except for a few commands that have their own defaults, filename defaults are -computed in a standard way. If it exists, the associated file for the current -buffer is used as the default, otherwise a more complex mechanism creates a -default. - -@defhvar[var "Pathname Defaults", val {(pathname "gazonk.del")}] -@defhvar1[var "Last Resort Pathname Defaults Function"] -@defhvar1[var "Last Resort Pathname Defaults", val {(pathname "gazonk")}] -These variables control the computation of default filename defaults when the -current buffer has no associated file. - -@hid[Pathname Defaults] holds a "sticky" filename default. Commands that -prompt for files set this to the file specified, and the value is used as a -basis for filename defaults. It is undesirable to offer the unmodified value -as a default, since it is usually the name of an existing file that we don't -want to overwrite. If the current buffer's name is all alphanumeric, then the -default is computed by substituting the buffer name for the the name portion of -@hid[Pathname Defaults]. Otherwise, the default is computed by calling -@hid[Last Resort Pathname Defaults Function] with the buffer as an argument. - -The default value of @hid[Last Resort Pathname Defaults Function] merges -@hid[Last Resort Pathname Defaults] with @hid[Pathname Defaults]. -Unlike @hid[Pathname Defaults], @hid[Last Resort Pathname Defaults] is not -modified by file commands, so setting it to a silly name ensures that real -files aren't inappropriately offered as defaults. -@enddefhvar - -When a default is present in the prompt for a file, @hemlock @i[merges] the -given input with the default filename. The semantics of merging, described in -the Common Lisp manual, is somewhat involved, but @hemlock has a few rules it -uses: -@begin[enumerate] -If @hemlock can find the user's input as a file on the @f["default:"] search -list, then it forgoes merging with the displayed default. Basically, the -system favors the files in your current working directory over those found by -merging with the defaults offered in the prompt. - -Merging comes in two flavors, just merge with the displayed default's directory -or just merge with the displayed default's @f[file-namestring]. If the user -only responds with a directory specification, without any name or type -information, then @hemlock merges the default's @f[file-namestring]. If the -user responds with any name or type information, then @hemlock only merges with -the default's directory. Specifying relative directories in this second -situation coordinates with the displayed defaults, not the current working -directory. -@end[enumerate] - - -@subsection[Type Hooks and File Options] -@index[mode comment] -@index[type hooks] -When a file is read either by @hid[Find File] or @hid[Visit File], @hemlock -attempts to guess the correct mode in which to put the buffer, based on the -file's @i[type] (the part of the filename after the last dot). Any default -action may be overridden by specifying the mode in the file's @i[file -options].@index[modes]@index[package] - -@label[file-options]@index[file options] -The user specifies file options with a special syntax on the first line of a -file. If the first line contains the string "@f[-*-]", then @hemlock -interprets the text between the first such occurrence and the second, which -must be contained in one line , as a list of @w{"@f<@i[option]: @i[value]>"} -pairs separated by semicolons. The following is a typical example: -@begin[programexample] -;;; -*- Mode: Lisp, Editor; Package: Hemlock -*- -@end[programexample] - -These options are currently defined: -@begin[description] -Dictionary@\The argument is the filename of a spelling dictionary associated -with this file. The handler for this option merges the argument with the -name of this file. See @comref[Set Buffer Spelling Dictionary]. - -Log@\The argument is the name of the change log file associated with this file -(see page @pageref[log-files]). The handler for this option merges the -argument with the name of this file. - -Mode@\The argument is a comma-separated list of the names of modes to turn on -in the buffer that the file is read into. - -Package@\The argument is the name of the package to be used for reading code in -the file. This is only meaningful for Lisp code (see page -@pageref[lisp-package].) - -Editor@\The handler for this option ignores its argument and turns on -@hid[Editor] mode (see @comref[Editor Mode]). - -@end[description] -If the option list contains no "@f[:]" then the entire string is used as -the name of the major mode for the buffer. - -@defcom[com "Process File Options"] -This command processes the file options in the current buffer as described -above. This is useful when the options have been changed or when a file is -created. -@enddefcom - - -@section[Windows] -@index[windows] - -@hemlock windows display a portion of a buffer's text. See the section on -@i[window groups], @ref[groups], for a discussion of managing windows on bitmap -device. - -@defcom[com "New Window", bind (C-x C-n)] -This command prompts users for a new window which they can place anywhere on -the screen. This window is in its own group. This only works with bitmap -devices. -@enddefcom - -@defcom[com "Split Window", bind (C-x 2)] -This command splits the current window roughly in half to make two windows. If -the current window is too small to be split, the command signals a user error. -@enddefcom - -@defcom[com "Next Window", bind (C-x n)] -@defcom1[com "Previous Window", bind (C-x p)] -These commands make the next or previous window the new current window, often -changing the current buffer in the process. When a window is created, it is -arbitrarily made the next window of the current window. The location of the -next window is, in general, unrelated to that of the current window. -@enddefcom - -@defcom[com "Delete Window", bind (C-x C-d, C-x d)] -@defcom1[com "Delete Next Window", bind (C-x 1)] -@hid[Delete Window] makes the current window go away, making the next window -current. @hid[Delete Next Window] deletes the next window, leaving the current -window unaffected. - -On bitmap devices, if there is only one window in the group, either command -deletes the group, making some window in another group the current window. If -there are no other groups, they signal a user error. -@enddefcom - -@defcom[com "Go to One Window"] -This command deletes all window groups leaving one with the @hid[Default -Initial Window X], @hid[Default Initial Window Y], @hid[Default Initial Window -Width], and @hid[Default Initial Window Height]. This remaining window -retains the contents of the current window. -@enddefcom - -@defcom[com "Line to Top of Window", bind (M-!)] -@defcom1[com "Line to Center of Window", bind (M-#)] -@index[scrolling]@hid[Line to Top of Window] scrolls the current window up -until the current line is at the top of the screen. - -@hid[Line to Center of Window] attempts to scroll the current window so that -the current line is vertically centered. -@enddefcom - -@defcom[com "Scroll Next Window Down", bind (C-M-v)] -@defcom1[com "Scroll Next Window Up", bind (C-M-V)] -These commands are the same as @hid[Scroll Window Up] and -@hid[Scroll Window Down] except that they operate on the next window. -@enddefcom - -@defcom[com "Refresh Screen", bind {C-l}] -This command refreshes all windows, which is useful if the screen got trashed, -centering the current window about the current line. When the user supplies a -positive argument, it scrolls that line to the top of the window. When the -argument is negative, the line that far from the bottom of the window is moved -to the bottom of the window. In either case when an argument is supplied, this -command only refreshes the current window. -@enddefcom - - -@chap[Editing Documents] -@index[documents, editing] -Although @hemlock is not dedicated to editing documents as word processing -systems are, it provides a number of commands for this purpose. If @hemlock is -used in conjunction with a text-formatting program, then its lack of complex -formatting commands is no liability. - - -@defcom[com "Text Mode"] -This commands puts the current buffer into "Text" mode. -@enddefcom - - -@section[Sentence Commands] -@index[sentence commands] -A sentence is defined as a sequence of characters ending with a period, -question mark or exclamation point, followed by either two spaces or a newline. -A sentence may also be terminated by the end of a paragraph. Any number of -closing delimiters, such as brackets or quotes, may be between the punctuation -and the whitespace. This somewhat complex definition of a sentence is used so -that periods in abbreviations are not misinterpreted as sentence ends. - -@defcom[com "Forward Sentence", bind {M-a}] -@defcom1[com "Backward Sentence", bind {M-e}] -@index[motion, sentence]@hid[Forward Sentence] moves the point forward -past the next sentence end. @hid[Backward Sentence] moves to the beginning -of the current sentence. A prefix argument may be used as a repeat count. -@enddefcom - -@defcom[com "Forward Kill Sentence", bind {M-k}] -@defcom1[com "Backward Kill Sentence", bind (C-x Delete, C-x Backspace)] -@index[killing, sentence]@hid[Forward Kill Sentence] kills text from the -point through to the end of the current sentence. @hid[Backward Kill Sentence] -kills from the point to the beginning of the current sentence. A -prefix argument may be used as a repeat count. -@enddefcom - -@defcom[com "Mark Sentence"] -This command puts the point at the beginning and the mark at the end of the -next or current sentence. -@enddefcom - - -@section[Paragraph Commands] - -@index[paragraph commands]A paragraph may be delimited by a blank line or a -line beginning with "@f[']" or "@f[.]", in which case the delimiting line is -not part of the paragraph. Other characters may be paragraph delimiters in -some modes. A line with at least one leading whitespace character may also -introduce a paragraph and is considered to be part of the paragraph. Any -fill-prefix which is present on a line is disregarded for the purpose of -locating a paragraph boundary. - -@defcom[com "Forward Paragraph", bind (@bf<M-]>)] -@defcom1[com "Backward Paragraph", bind (M-[)] -@index[motion, paragraph]@index[paragraph, motion]@hid[Forward Paragraph] -moves to the end of the current or next paragraph. @hid[Backward Paragraph] -moves to the beginning of the current or previous paragraph. A prefix -argument may be used as a repeat count. -@enddefcom - -@defcom[com "Mark Paragraph", bind {M-h}] -This command puts the point at the beginning and the mark at the end of the -current paragraph. -@enddefcom - -@defhvar[var "Paragraph Delimiter Function", val {default-para-delim-function}] -This variable holds a function that takes a mark as its argument and returns -true when the line it points to should break the paragraph. -@enddefhvar - -@section[Filling] - -@index[filling]@index[formatting]Filling is a coarse text-formatting -process which attempts to make all the lines roughly the same length, but -doesn't vary the amount of space between words. Editing text may leave -lines with all sorts of strange lengths; filling this text will return it -to a moderately aesthetic form. - -@defcom[com "Set Fill Column", bind (C-x f)] -This command sets the fill column to the column that the point is currently at, -or the one specified by the absolute value of prefix argument, if it is -supplied. The fill column is the column past which no text is permitted to -extend. -@enddefcom - -@defcom[com "Set Fill Prefix", bind (C-x .)] -This command sets the fill prefix to the text from the beginning of the -current line to the point. The fill-prefix is a string which filling commands -leave at the beginning of every line filled. This feature is useful for -filling indented text or comments. -@enddefcom - -@defhvar[var "Fill Column", val {75}] -@defhvar1[var "Fill Prefix", val {nil}] -These variables hold the value of the fill prefix and fill column, thus -setting these variables will change the way filling is done. If -@hid[Fill Prefix] is @nil, then there is no fill prefix. -@enddefcom - -@defcom[com "Fill Paragraph", bind {M-q}] -@index[paragraph, filling]This command fills the text in the current or next -paragraph. The point is not moved. -@enddefcom - -@defcom[com "Fill Region", bind {M-g}] -@index[region, filling]This command fills the text in the region. Since -filling can mangle a large quantity of text, this command asks for confirmation -before filling a large region (see @hid[Region Query Size].) -@enddefcom - - -@defcom[com "Auto Fill Mode"] -@index[modes, auto fill]This command turns on or off the @hid[Fill] -minor mode in the current buffer. When in @hid[Fill] mode, @bf[Space], -@bf[Return] and @bf[Linefeed] are rebound to commands that check whether -the point is past the fill column and fill the current line if it is. -This enables typing text without having to break the lines manually. - -If a prefix argument is supplied, then instead of toggling, the sign -determines whether @hid[Fill] mode is turned off; a positive argument -argument turns in on, and a negative one turns it off. -@enddefcom - -@defcom[com "Auto Fill Linefeed", stuff (bound to @bf[Linefeed] in @hid[Fill] mode)] -@defcom1[com "Auto Fill Return", stuff (bound to @bf[Return] in @hid[Fill] mode)] -@hid[Auto Fill Linefeed] fills the current line if it needs it and then goes to -a new line and inserts the fill prefix. @hid[Auto Fill Return] is similar, but -does not insert the fill prefix on the new line. -@enddefcom - -@defcom[com "Auto Fill Space", stuff (bound to @bf[Space] in @hid[Fill] mode)] -If no prefix argument is supplied, this command inserts a space and -fills the current line if it extends past the fill column. If the argument is -zero, then it fills the line if needed, but does not insert a space. If the -argument is positive, then that many spaces are inserted without filling. -@enddefcom - -@defhvar[var "Auto Fill Space Indent", val {nil}] -This variable determines how lines are broken by the auto fill commands. If it -is true, new lines are created using the @hid[Indent New Comment Line] command, -otherwise the @hid[New Line] command is used. Language modes should define -this variable to be true so that auto fill mode can be used on code. -@enddefhvar - - -@section[Scribe Mode] - -@hid[Scribe] mode provides a number of facilities useful for editing Scribe -documents. It is also sufficiently parameterizable to be adapted to other -similar syntaxes. - -@defcom[com "Scribe Mode"] -@index[modes, scribe]This command puts the current buffer in @hid[Scribe] mode. -Except for special Scribe commands, the only difference between @hid[Scribe] -mode and @hid[Text] mode is that the rules for determining paragraph breaks are -different. In @hid[Scribe] mode, paragraphs delimited by Scribe commands are -normally placed on their own line, in addition to the normal paragraph breaks. -The main reason for doing this is that it prevents @hid[Fill Paragraph] from -mashing these commands into the body of a paragraph. -@enddefcom - -@defcom[com "Insert Scribe Directive", stuff (@bf[C-h] in @hid[Scribe] mode)] -This command prompts for a key-event to determine which Scribe directive to -insert. Directives are inserted differently depending on their kind: -@begin[description] -@i[environment]@\ -The current or next paragraph is enclosed in a begin-end pair: -@f<@@begin[@i{directive}]> @i[paragraph] @f<@@end[@i{directive}]>. If the -current region is active, then this command encloses the region instead of the -paragraph it would otherwise chose. - -@i[command]@\ -The previous word is enclosed by @f<@@@i[directive][@i[word]]>. If the -previous word is already enclosed by a use of the same command, then the -beginning of the command is extended backward by one word. -@end[description] - -Typing @bf[Home] or @bf[C-_] to this command's prompt will display a list of -all the defined key-events on which it dispatches. -@enddefcom - -@defcom[com "Add Scribe Directive"] -This command adds to the database of directives recognized by the -@hid[Insert Scribe Directive] command. It prompts for the directive's name, -the kind of directive (environment or command) and the key-event on which to -dispatch. -@enddefcom - -@defcom[com "Add Scribe Paragraph Delimiter"] -@defcom1[com "List Scribe Paragraph Delimiters"] -@hid[Add Scribe Paragraph Delimiter] prompts for a string to add to the list of -formatting commands that delimit paragraphs in @hid[Scribe] mode. If the user -supplies a prefix argument, then this command removes the string as a -delimiter. - -@hid[List Scribe Paragraph Delimiters] displays in a pop-up window the Scribe -commands that delimit paragraphs. -@enddefcom - -@defhvar[var "Escape Character", val {#\@@}] -@defhvar1[var "Close Paren Character", val {#\]}] -@defhvar1[var "Open Paren Character", val {#\[}] -These variables determine the characters used when a Scribe directive is -inserted. -@enddefhvar - -@defcom[com "Scribe Insert Bracket"] -@defhvar1[var "Scribe Bracket Table"] -@hid[Scribe Insert Bracket] inserts a bracket (@bf[>], @bf[}], @bf[)], or -@bf<]>), that caused its invocation, and then shows the matching bracket. - -@hid[Scribe Bracket Table] holds a @f[simple-vector] indexed by character -codes. If a character is a bracket, then the entry for its @f[char-code] -should be the opposite bracket. If a character is not a bracket, then the -entry should be @nil. -@enddefcom - - -@section[Spelling Correction] -@index[spelling correction] -@hemlock has a spelling correction facility based on the dictionary for the ITS -spell program. This dictionary is fairly small, having only 45,000 word or so, -which means it fits on your disk, but it also means that many reasonably common -words are not in the dictionary. A correct spelling for a misspelled word will -be found if the word is in the dictionary and is only erroneous in that it has -a wrong character, a missing character, an extra character or a transposition -of two characters. - - -@defcom[com "Check Word Spelling", bind (M-$)] -This command looks up the previous or current word in the dictionary and -attempts to correct the spelling if it is misspelled. There are four possible -results of invoking this command: -@begin[enumerate] -This command displays the message "@f[Found it.]" in the echo area. This means -it found the word in the dictionary exactly as given. - -This command displays the message "@f[Found it because of @i[word].]", where -@i[word] is some other word with the same root but a different ending. The -word is no less correct than if the first message is given, but an additional -piece of useless information is supplied to make you feel like you are using a -computer. - -The command prompts with "@f[Correction choice:]" in the echo area and lists -possible correct spellings associated with numbers in a pop-up display. Typing -a number selects the corresponding correction, and the command replaces the -erroneous word, preserving case as though by @hid[Query Replace]. Typing -anything else rejects all the choices. - -This commands displays the message "@f[Word not found.]". The word is not in -the dictionary and possibly spelled correctly anyway. Furthermore, no -similarly spelled words were found to offer as possible corrections. If this -happens, it is worth trying some alternate spellings since one of them might -be close enough to some known words that this command could display. -@end[enumerate] -@enddefcom - -@defcom[com "Correct Buffer Spelling"] -This command scans the entire buffer looking for misspelled words and offers to -correct them. It creates a window into the @hid[Spell Corrections] buffer, and -in this buffer it maintains a log of any actions taken by the user. When this -finds an unknown word, it prompts for a key-event. The user has the following -options: -@begin[description] -@bf[a]@\ - Ignore this word. If the command finds the word again, it will prompt again. - -@bf[i]@\ - Insert this word in the dictionary. - -@bf[c]@\ - Choose one of the corrections displayed in the @hid[Spell Corrections] window -by specifying the correction number. If the same misspelling is encountered -again, then the command will make the same correction automatically, leaving a -note in the log window. - -@bf[r]@\ - Prompt for a word to use instead of the misspelled one, remembering the -correction as with @bf[c]. - -@binding[C-r]@\ - Go into a recursive edit at the current position, and resume checking when the -recursive edit is exited. -@end[description] -After this command completes, it deletes the log window leaving the buffer -around for future reference. -@enddefcom - -@defhvar[var "Spell Ignore Uppercase", val {nil}] -@index[case sensitivity] -If this variable is true, then @hid[Auto Check Word Spelling] and @hid[Correct -Buffer Spelling] will ignore unknown words that are all uppercase. This is -useful for acronyms and cryptic formatter directives. -@enddefhvar - -@defcom[com "Add Word to Spelling Dictionary", bind (C-x $)] -This command adds the previous or current word to the spelling dictionary. -@enddefcom - -@defcom[com "Remove Word from Spelling Dictionary"] -This command prompts for a word to remove from the spelling dictionary. Due to -the dictionary representation, removal of a word in the initial spelling -dictionary will remove all words with the same root. The user is asked for -confirmation before removing a root word with valid suffix flags. -@enddefcom - -@defcom[com "List Incremental Spelling Insertions"] -This command displays the incremental spelling insertions for the current -buffer's associated spelling dictionary file. -@enddefcom - -@defcom[com "Read Spelling Dictionary"] -This command adds some words from a file to the spelling dictionary. The -format of the file is a list of words, one on each line. -@enddefcom - -@defcom[com "Save Incremental Spelling Insertions"] -This command appends incremental dictionary insertions to a file. Any words -added to the dictionary since the last time this was done will be appended to -the file. Except for @hid[Augment Spelling Dictionary], all the commands that -add words to the dictionary put their insertions in this list. The file is -prompted for unless @hid[Set Buffer Spelling Dictionary] has been executed in -the buffer. -@enddefcom - -@defcom[com "Set Buffer Spelling Dictionary"] -This command Prompts for the dictionary file to associate with the current -buffer. If the specified dictionary file has not been read for any other -buffer, then it is read. Incremental spelling insertions from this buffer -can be appended to this file with @hid[Save Incremental Spelling -Insertions]. If a buffer has an associated spelling dictionary, then -saving the buffer's associated file also saves any incremental dictionary -insertions. The @w<"@f[Dictionary: ]@i[file]"> file option may also be -used to specify the dictionary for a buffer (see section -@ref[file-options]). -@enddefcom - -@defhvar[var "Default User Spelling Dictionary", val {nil}] -This variable holds the pathname of a dictionary to read the first time -@hid[Spell] mode is entered in a given editing session. When -@hid[Set Buffer Spelling Dictionary] or the "@f[dictionary]" file option is -used to specify a dictionary, this default one is read also. It defaults to -nil. -@enddefhvar - - -@subsection[Auto Spell Mode] -@hid[Auto Spell Mode] checks the spelling of each word as it is typed. -When an unknown word is typed the user is notified and allowed to take a -number of actions to correct the word. - -@defcom[com "Auto Spell Mode"] -This command turns @hid[Spell] mode on or off in the current buffer. -@enddefcom - -@defcom[com "Auto Check Word Spelling", - stuff (bound to word delimiters in @hid[Spell] mode)] -@defhvar1[var "Check Word Spelling Beep", val {t}] -@defhvar1[var "Correct Unique Spelling Immediately", val {t}] -This command checks the spelling of the word before the point, doing nothing if -the word is in the dictionary. If the word is misspelled but has a known -correction previously supplied by the user, then this command corrects the -spelling. If there is no correction, then this displays a message in the echo -area indicating the word is unknown. An unknown word detected by this command -may be corrected using the @hid[Correct Last Misspelled Word] command. This -command executes in addition to others bound to the same key; for example, if -@hid[Fill] mode is on, any of its commands bound to the same keys as this -command also run. - -If @hid[Check Word Spelling Beep] is true, then this command will beep when an -unknown word is found. If @hid[Correct Unique Spelling Immediately] is true, -then this command will immediately attempt to correct any unknown word, -automatically making the correction if there is only one possible. -@enddefhvar - -@defcom[com "Undo Last Spelling Correction", bind (C-x a)] -@defhvar1[var "Spelling Un-Correct Prompt for Insert", val {nil}] -@hid[Undo Last Spelling Correction] undoes the last incremental spelling -correction. The "correction" is replaced with the old word, and the old word -is inserted in the dictionary. Any automatic replacement for the old word is -eliminated. When @hid[Spelling Un-Correct Prompt for Insert] is true, the user -is asked to confirm the insertion into the dictionary. -@enddefcom - -@defcom[com "Correct Last Misspelled Word", bind (M-:)] -This command places the cursor after the last misspelled word detected by the -@hid[Auto Check Word Spelling] command and then prompts for a key-event on -which it dispatches: -@begin[description] -@bf[c]@\ - Display possible corrections in a pop-up window, and prompt for the one to -make according to the corresponding displayed digit or letter. - -@i[any digit]@\ - Similar to @bf[c] @i[digit], but immediately makes the correction, dispensing -with display of the possible corrections. This is shorter, but only works when -there are less than ten corrections. - -@bf[i]@\ - Insert the word in the dictionary. - -@bf[r]@\ - Replace the word with another. - -@binding[Backspace, Delete, n]@\ - Skip this word and try again on the next most recently misspelled word. - -@binding[C-r]@\ - Enter a recursive edit at the word, exiting the command when the recursive -edit is exited. - -@binding[Escape]@\ - Exit and forget about this word. -@end[description] -As in @hid[Correct Buffer Spelling], the @bf[c] and @bf[r] commands add the -correction to the known corrections. -@enddefcom - - - -@chap[Managing Large Systems] - -@hemlock provides three tools which help to manage large systems: -@begin[enumerate] -File groups, which provide several commands that operate on all the files -in a possibly large collection, instead of merely on a single buffer. - -A source comparison facility with semi-automatic merging, which can be used -to compare and merge divergent versions of a source file. - -A change log facility, which maintains a single file containing a record of the -edits done on a system. -@end[enumerate] - - -@section[File Groups] - -@index[file groups]@index[searching, group]@index[replacing, group] -A file group is a set of files, upon which various editing operations can be -performed. The files in a group are specified by a file in the following -format: -@begin[itemize] -Any line which begins with one "@f[@@]" is ignored. - -Any line which does not begin with an "@f[@@]" is the name of a file in the -group. - -A line which begins with "@f[@@@@]" specifies another file having this -syntax, which is recursively examined to find more files in the group. -@end[itemize] -This syntax is used for historical reasons. Although any number of file groups -may be read into @hemlock, there is only one @i[active group], which is the -file group implicitly used by all of the file group commands. -Page @pageref[compile-group-command] describes the @hid[Compile Group] command. - -@defcom[com "Select Group"] -This command prompts for the name of a file group to make the active group. -If the name entered is not the name of a group whose definition has been -read, then the user is prompted for the name of a file to read the group -definition from. The name of the default pathname is the name of the -group, and the type is "@f[upd]". -@enddefcom - -@defcom[com "Group Query Replace"] -This command prompts for target and replacement strings and then executes an -interactive string replace on each file in the active group. This reads in -each file as if @hid[Find File] were used and processes it as if @hid[Query -Replace] were executing. -@enddefcom - -@defcom[com "Group Replace"] -This is like @hid[Group Query Replace] except that it executes a -non-interactive replacement, similar to @hid[Replace String]. -@enddefcom - -@defcom[com "Group Search"] -This command prompts for a string and then searches for it in each file in the -active group. This reads in each file as if @hid[Find File] were used. When -it finds an occurrence, it prompts the user for a key-event indicating what -action to take. The following commands are defined: -@begin[description] -@binding[Escape, Space, y]@\ - Exit @hid[Group Search]. - -@binding[Delete, Backspace, n]@\ - Continue searching for the next occurrence of the string. - -@binding[!]@\ - Continue the search at the beginning of the next file, skipping the remainder -of the current file. - -@binding[C-r]@\ - Go into a recursive edit at the current location, and continue the search when -it is exited. -@end[description] -@enddefcom - -@defhvar[var "Group Find File", val {nil}] -The group searching and replacing commands read each file into its own buffer -using @hid[Find File]. Since this may result in large amounts of memory being -consumed by unwanted buffers, this variable controls whether to delete the -buffer after processing it. When this variable is false, the default, the -commands delete the buffer if it did not previously exist; however, regardless -of this variable, if the user leaves the buffer modified, the commands will not -delete it. -@enddefhvar - -@defhvar[var "Group Save File Confirm", val {t}] -If this variable is true, the group searching and replacing commands ask for -confirmation before saving any modified file. The commands attempt to save -each file processed before going on to the next one in the group. -@enddefhvar - - -@section[Source Comparison] -@index[buffer, merging] -@index[buffer, comparison] -@index[source comparison] - -These commands can be used to find exactly how the text in two buffers differs, -and to generate a new version that combines features of both versions. - -@defhvar[var "Source Compare Default Destination", val {"Differences"}] -This is a sticky default buffer name to offer when comparison commands prompt -for a buffer in which to insert the results. -@enddefhvar - -@defcom[com "Compare Buffers"] -This command prompts for three buffers and then does a buffer comparison. -The first two buffers must exist, as they are the buffers to be compared. -The last buffer, which is created if it does not exist, is the buffer to -which output is directed. The output buffer is selected during the -comparison so that its progress can be monitored. There are various variables -that control exactly how the comparison is done. - -If a prefix argument is specified, then only only the lines in the the regions -of the two buffers are compared. -@enddefcom - -@defcom[com "Buffer Changes"] -This command compares the contents of the current buffer with the disk version -of the associated file. It reads the file into the buffer -@hid[Buffer Changes File], and generates the comparison in the buffer -@hid[Buffer Changes Result]. As with @hid[Compare Buffers], the output buffer -is displayed in the current window. -@enddefcom - -@defcom[com "Merge Buffers"] -This command functions in a very similar fashion to @hid[Compare Buffers], the -difference being that a version which is a combination of the two buffers being -compared is generated in the output buffer. This copies text that is identical -in the two comparison buffers to the output buffer. When it encounters a -difference, it displays the two differing sections in the output buffer and -prompts the user for a key-event indicating what action to take. The following -commands are defined: -@begin[description] -@bf[1]@\ - Use the first version of the text. - -@bf[2]@\ - Use the second version. - -@bf[b]@\ - Insert the string @w<"@f[**** MERGE LOSSAGE ****]"> followed by both versions. -This is useful if the differing sections are too complex, or it is unclear -which is the correct version. If you cannot make the decision conveniently at -this point, you can later search for the marking string above. - -@binding[C-r]@\ - Do a recursive edit and ask again when the edit is exited. -@end[description] -@enddefcom - - -@defhvar[var "Source Compare Ignore Case", val {nil}] -@index[case sensitivity] -If this variable is non-@nil, @hid[Compare Buffers] and @hid[Merge Buffers] -will do comparisons case-insensitively. -@enddefhvar - -@defhvar[var "Source Compare Ignore Indentation", val {nil}] -If this variable is non-@nil, @hid[Compare Buffers] and @hid[Merge Buffers] -ignore initial whitespace when comparing lines. -@enddefhvar - -@defhvar[var "Source Compare Ignore Extra Newlines", val {t}] -If this variable is true, @hid[Compare Buffers] and @hid[Merge Buffers] -will treat all groups of newlines as if they were a single newline. -@enddefhvar - -@defhvar[var "Source Compare Number of Lines", val {3}] -This variable controls the number of lines @hid[Compare Buffers] and -@hid[Merge Buffers] will compare when resynchronizing after a difference -has been encountered. -@enddefhvar - - -@section[Change Logs] -@label[log-files] -@index[edit history] -@index[change log] - -The @hemlock change log facility encourages the recording of changes to a -system by making it easy to do so. The change log is kept in a separate file -so that it doesn't clutter up the source code. The name of the log for a file -is specified by the @f[Log] file option (see page @pageref[file-options].) - -@defcom[com "Log Change"] -@defhvar1[var "Log Entry Template"] -@hid[Log Change] makes a new entry in the change log associated with the file. -Any changes in the current buffer are saved, and the associated log file is -read into its own buffer. The name of the log file is determined by merging -the name specified in the @f[Log] option with the current buffer's file name, -so it is not usually necessary to put the full name there. After inserting a -template for the log entry at the beginning of the buffer, the command enters a -recursive edit (see page @pageref[recursive-edits]) so that the text of the -entry may be filled in. When the user exits the recursive edit, the log file -is saved. - -The variable @hid[Log Entry Template] determines the format of the change log -entry. Its value is a @clisp @f[format] control string. The format string is -passed three string arguments: the full name of the file, the creation date for -the file and the name of the file author. If the creation date is not -available, the current date is used. If the author is not available then @nil -is passed. If there is an @f[@@] in the template, then it is deleted and the -point is left at that position. -@enddefcom - - - -@comment[@chap (Special Modes)] -@include(special-modes) - - - -@chap[Editing Programs] - - -@section[Comment Manipulation] -@index[comment manipulation] -@hemlock has commenting commands which can be used in almost any language. The -behavior of these commands is determined by several @hemlock variables which -language modes should define appropriately. - -@defcom[com "Indent for Comment", bind (M-;)] -@index[indentation, comment]@label[comment-indentation] -This is the most basic commenting command. If there is already a comment on -the current line, then this moves the point to the start of the comment. If -there no comment, this creates an empty one. - -This command normally indents the comment to start at @hid[Comment Column]. -The comment indents differently in the following cases: -@begin[enumerate] -If the comment currently starts at the beginning of the line, or if the last -character in the @hid[Comment Start] appears three times, then the comment -remains unmoved. - -If the last character in the @hid[Comment Start] appears two times, then the -comment is indented like a line of code. - -If text on the line prevents the comment occurring in the desired position, -this places the comment at the end of the line, separated from the text by a -space. -@end[enumerate] -Although the rules about replication in the comment start are oriented toward -Lisp commenting styles, you can exploit these properties in other languages. - -When given a prefix argument, this command indents any existing comment on that -many consecutive lines. This is useful for fixing up the indentation of a -group of comments. -@enddefcom - -@defcom[com "Indent New Comment Line", bind {M-j, M-Linefeed}] -This commend ends the current comment and starts a new comment on a blank line, -indenting the comment the same way that @hid[Indent for Comment] does. -When not in a comment, this command is the same as @hid[Indent New Line]. -@enddefcom - -@defcom[com "Up Comment Line", bind {M-p}] -@defcom1[com "Down Comment Line", bind {M-n}] -These commands are similar to @hid[Previous Line] or @hid[Next Line] -followed by @hid[Indent for Comment]. Any empty comment on the current line is -deleted before moving to the new line. -@enddefcom - -@defcom[com "Kill Comment", bind (C-M-;)] -This command kills any comment on the current line. When given a prefix -argument, it kills comments on that many consecutive lines. @hid[Undo] will -restore the unmodified text. -@enddefcom - -@defcom[com "Set Comment Column", bind (C-x ;)] -This command sets the comment column to its prefix argument. If used without a -prefix argument, it sets the comment column to the column the point is at. -@enddefcom - -@defhvar[var "Comment Start", val {nil}] -@defhvar1[var "Comment End", val {nil}] -@defhvar1[var "Comment Begin", val {nil}] -@defhvar1[var "Comment Column", val {0}] -These variables determine the behavior of the comment commands. -@begin[description] -@hid[Comment Start]@\The string which indicates the start of a comment. If -this is @nil, then there is no defined comment syntax. - -@hid[Comment End]@\The string which ends a comment. If this is @nil, then -the comment is terminated by the end of the line. - -@hid[Comment Begin]@\The string inserted to begin a new comment. - -@hid[Comment Column]@\The column that normal comments start at. -@end[description] -@enddefcom - - -@section[Indentation] -@label[indentation] -@index[indentation] -Nearly all programming languages have conventions for indentation or leading -whitespace at the beginning of lines. The @hemlock indentation facility is -integrated into the command set so that it interacts well with other features -such as filling and commenting. - -@defcom[com "Indent", bind (Tab, C-i)] -This command indents the current line. With a prefix argument, indents that -many lines and moves down. Exactly what constitutes indentation depends on the -current mode (see @hid[Indent Function]). -@enddefcom - -@defcom[com "Indent New Line", bind (Linefeed)] -This command starts a new indented line. Deletes any whitespace before the -point and inserts indentation on a blank line. The effect of this is similar -to @binding[Return] followed by @binding[Tab]. The prefix argument is passed -to @hid[New Line], which is used to insert the blank line. -@enddefcom - -@defcom[com "Indent Region", bind (C-M-\)] -This command indents every line in the region. It may be undone with -@hid[Undo]. -@enddefcom - -@defcom[com "Back to Indentation", bind {M-m, C-M-m}] -@index[motion, indentation] -This command moves point to the first non-whitespace character on the current -line. -@enddefcom - -@defcom[com "Delete Indentation", bind (M-^, C-M-^)] -@hid[Delete Indentation] joins the current line with the previous one, deleting -excess whitespace. This operation is the inverse of the @bf[Linefeed] command -in most modes. Usually this leaves one space between the two joined lines, but -there are several exceptions. - -The non-whitespace immediately surrounding the deleted line break determine the -amount of space inserted. -@begin[enumerate] -If the preceding character is an "@f[(]" or the following character is a -"@f[)]", then this inserts no space. - -If the preceding character is a newline, then this inserts no space. This will -happen if the previous line was blank. - -If the preceding character is a sentence terminator, then this inserts two -spaces. -@end[enumerate] - -When given a prefix argument, this command joins the current and next lines, -rather than the previous and current lines. -@enddefcom - -@defcom[com "Quote Tab", bind (M-Tab)] -This command inserts a tab character. -@enddefcom - -@defcom[com "Indent Rigidly", bind (C-x Tab, C-x C-i)] -This command changes the indentation of all the lines in the region. Each -line is moved to the right by the number of spaces specified by the prefix -argument, which defaults to eight. A negative prefix argument moves lines -left. -@enddefcom - -@defcom[com "Center Line"] -This indents the current line so that it is centered between the left margin -and @hvarref[Fill Column]. If a prefix argument is supplied, then it is used -as the width instead of @hid[Fill Column]. -@enddefcom - -@defhvar[var "Indent Function", val {tab-to-tab-stop}] -The value of this variable determines how indentation is done, and it is a -function which is passed a mark as its argument. The function should indent -the line which the mark points to. The function may move the mark around on -the line. The mark will be @f[:left-inserting]. The default simply inserts a -tab character at the mark. -@enddefhvar - -@defhvar[var "Indent with Tabs", val {indent-using-tabs}] -@defhvar1[var "Spaces per Tab", val {8}] -@hid[Indent with Tabs] holds a function that takes a mark and a number of -spaces. The function will insert a maximum number of tabs and a minimum number -of spaces at mark to move the specified number of columns. The default -definition uses @hid[Spaces per Tab] to determine the size of a tab. @i[Note,] -@hid[Spaces per Tab] @i[is not used everywhere in @hemlock yet, so changing -this variable could have unexpected results.] -@enddefhvar - - -@section[Language Modes] - -@hemlock@comment{}'s language modes are currently fairly crude, but probably -provide better programming support than most non-extensible editors. - -@defcom[com "Pascal Mode"] -@index[indentation, pascal]@index[modes, pascal]This command sets the current -buffer's major mode to @hid[Pascal]. @hid[Pascal] mode borrows parenthesis -matching from Scribe mode and indents lines under the previous line. -@enddefcom - - -@chap[Editing Lisp] -@index[lisp, editing] -@hemlock provides a large number of powerful commands for editing Lisp code. -It is possible for a text editor to provide a much higher level of support for -editing Lisp than ordinary programming languages, since its syntax is much -simpler. - - -@section[Lisp Mode] -@index[lisp mode] -@index[modes, lisp] -@hid[Lisp] mode is a major mode used for editing Lisp code. Although most -Lisp specific commands are globally bound, @hid[Lisp] mode is necessary to -enable Lisp indentation, commenting, and parenthesis-matching. Whenever the -user or some @hemlock mechanism turns on @hid[Lisp] mode, the mode's setup -includes locally setting @hid[Current Package] (see section @ref[lisp-package]) -in that buffer if its value is non-existent there; the value used is -@f["USER"]. - -@defcom[com "Lisp Mode"] -This command sets the major mode of the current buffer to @hid[Lisp]. -@enddefcom - - -@section[Form Manipulation] -@index[form manipulation] -These commands manipulate Lisp forms, the printed representations of Lisp -objects. A form is either an expression balanced with respect to parentheses -or an atom such as a symbol or string. - -@defcom[com "Forward Form", bind (C-M-f)] -@defcom1[com "Backward Form", bind (C-M-b)] -@index[motion, form]@hid[Forward Form] moves to the end of the current or -next form, while @hid[Backward Form] moves to the beginning of the current -or previous form. A prefix argument is treated as a repeat count. -@enddefcom - -@defcom[com "Forward Kill Form", bind (C-M-k)] -@defcom1[com "Backward Kill Form", bind (C-M-Delete, C-M-Backspace)] -@index[killing, form]@hid[Forward Kill Form] kills text from the point to -the end of the current form. If at the end of a list, but inside the close -parenthesis, then kill the close parenthesis. @hid[Backward Kill Form] is -the same, except it goes in the other direction. A prefix argument is -treated as a repeat count. -@enddefcom - -@defcom[com "Mark Form", bind (C-M-@@)] -This command sets the mark at the end of the current or next form. -@enddefcom - -@defcom[com "Transpose Forms", bind (C-M-t)] -This command transposes the forms before and after the point and moves -forward. A prefix argument is treated as a repeat count. If the prefix -argument is negative, then the point is moved backward after the -transposition is done, reversing the effect of the equivalent positive -argument. -@enddefcom - -@defcom[com "Insert ()", bind {M-(}] -This command inserts an open and a close parenthesis, leaving the point -inside the open parenthesis. If a prefix argument is supplied, then the -close parenthesis is put at the end of the form that many forms from the -point. -@enddefcom - -@defcom[com "Extract Form"] -This command replaces the current containing list with the next form. The -entire affected area is pushed onto the kill ring. If an argument is supplied, -that many upward levels of list nesting is replaced by the next form. This is -similar to @hid[Extract List], but this command is more generally useful since -it works on any kind of form; it is also more intuitive since it operates on -the next form as many @hid[Lisp] mode commands do. -@enddefcom - - -@section[List Manipulation] - -@index[list manipulation]List commands are similar to form commands, but -they only pay attention to lists, ignoring any atomic objects that may -appear. These commands are useful because they can skip over many symbols -and move up and down in the list structure. - -@defcom[com "Forward List", bind (C-M-n)] -@defcom1[com "Backward List", bind (C-M-p)] -@index[motion, list]@hid[Forward List] moves the point to immediately -after the end of the next list at the current level of list structure. If -there is not another list at the current level, then it moves up past -the end of the containing list. -@hid[Backward List] is identical, except that it moves backward and leaves -the point at the beginning of the list. The prefix argument is used as a -repeat count. -@enddefcom - -@defcom[com "Forward Up List", bind {C-M-@bf<)>}] -@defcom1[com "Backward Up List", bind (C-M-@bf<(>, C-M-u)] -@hid[Forward Up List] moves to after the end of the enclosing list. -@hid[Backward Up List] moves to the beginning. The prefix argument is used -as a repeat count. -@enddefcom - -@defcom[com "Down List", bind (C-M-d)] -This command moves to just after the beginning of the next list. The -prefix argument is used as a repeat count. -@enddefcom - -@defcom[com "Extract List", bind (C-M-x)] -This command "extracts" the current list from the list which contains it. -The outer list is deleted, leaving behind the current list. The entire -affected area is pushed on the kill ring, so that this possibly catastrophic -operation can be undone. The prefix argument is used as a repeat count. -@enddefcom - - - -@section[Defun Manipulation] - -@index[defun manipulation]A @i[defun] is a list whose open parenthesis is -against the left margin. It is called this because an occurrence of the -@f[defun] top level form usually satisfies this definition, but -other top level forms such as a @f[defstruct] and @f[defmacro] work just as -well. - -@defcom[com "End of Defun", bind (@bf<C-M-e, C-M-]>)] -@defcom1[com "Beginning of Defun", bind (C-M-a, C-M-[)] -@index[motion, defun]@hid[End of Defun] moves to the end of the current -or next defun. @hid[Beginning of Defun] moves to the beginning of the -current or previous defun. @hid[End of Defun] will not work if the -parentheses are not balanced. -@enddefcom - -@defcom[com "Mark Defun", bind (C-M-h)] -This command puts the point at the beginning and the mark at the end of the -current or next defun. -@enddefcom - - - -@section[Indentation] - -@index[indentation, lisp] -One of the most important features provided by @hid[Lisp] mode is automatic -indentation of Lisp code. Since unindented Lisp is unreadable, poorly indented -Lisp is hard to manage, and inconsistently indented Lisp is subtly misleading. -See section @ref[indentation] for a description of the general-purpose -indentation commands. @hid[Lisp] mode uses these indentation rules: -@begin[itemize] -If in a semicolon (@f[;]) comment, then use the standard comment indentation -rules. See page @pageref[comment-indentation]. - -If in a quoted string, then indent to the column one greater than the column -containing the opening double quote. This is exactly what you want in function -documentation strings and wrapping @f[error] strings. - -If there is no enclosing list, then use no indentation. - -If enclosing list resembles a call to a known macro or special-form, then the -first few arguments are given greater indentation and the first body form is -indented two spaces. If the first special argument is on the same line as the -beginning of the form, then following special arguments will be indented to the -start of the first special argument, otherwise all special arguments are -indented four spaces. - -If the previous form starts on its own line, then the indentation is copied -from that form. This rule allows the default indentation to be overridden: -once a form has been manually indented to the user's satisfaction, subsequent -forms will be indented in the same way. - -If the enclosing list has some arguments on the same line as the form start, -then subsequent arguments will be indented to the start of the first argument. - -If the enclosing list has no argument on the same line as the form start, then -arguments will be indented one space. -@end[itemize] - - -@defcom[com "Indent Form", bind (C-M-q)] -This command indents all the lines in the current form, leaving the point -unmoved. This is undo-able. -@enddefcom - -@defcom[com "Fill Lisp Comment Paragraph", - stuff <bound to @bf[M-q] in @hid[Lisp] mode>] -@defhvar1[var "Fill Lisp Comment Paragraph Confirm", val {t}] -This fills a flushleft or indented Lisp comment. This also fills Lisp string -literals using the proper indentation as a filling prefix. When invoked -outside of a comment or string, this tries to fill all contiguous lines -beginning with the same initial, non-empty blankspace. When filling a comment, -the current line is used to determine a fill prefix by taking all the initial -whitespace on the line, the semicolons, and any whitespace following the -semicolons. - -When invoked outside of a comment or string, this command prompts for -confirmation before filling. It is useful to use this for filling long -@f[export] lists or other indented text or symbols, but since this is a less -common use, this command tries to make sure that is what you wanted. Setting -@hid[Fill Lisp Comment Paragraph Confirm] to @nil inhibits the confirmation -prompt. -@enddefcom - -@defcom[com "Defindent", bind (C-M-#)] -This command prompts for the number of special arguments to associate with -the symbol at the beginning of the current or containing list. -@enddefcom - -@defhvar[var "Indent Defanything", val {2}] -This is the number of special arguments implicitly assumed to be supplied in -calls to functions whose names begin with "@f[def]". If set to @nil, this -feature is disabled. -@enddefhvar - -@defcom[com "Move Over )", bind {M-)}] -This command moves past the next close parenthesis and then does the equivalent -of @hid[Indent New Line]. -@enddefcom - - -@section[Parenthesis Matching] - -@index[parenthesis matching]Another very important facility provided by -@hid[Lisp] mode is @i[parenthesis matching]. Two different styles of -parenthesis matching are supported: highlighting and pausing. - -@defhvar[var "Highlight Open Parens", val {t}] -@defhvar1[var "Open Paren Highlighting Font", val {nil}] -When @hid[Highlight Open Parens] is true, and a close paren is immediately -before the point, then @hemlock displays the matching open paren in @hid[Open -Paren Highlighting Font]. - -@hid[Open Paren Highlighting Font] is the string name of the font used for -paren highlighting. Only the "@f[(]" character is used in this font. If null, -then a reasonable default is chosen. The highlighting font is read at -initialization time, so this variable must be set before the editor is first -entered to have any effect. -@enddefhvar - -@defcom[com "Lisp Insert )", stuff <bound to @bf[)] in @hid[Lisp] mode>] -@defhvar1[var "Paren Pause Period", val {0.5}] -This command inserts a close parenthesis and then attempts to display the -matching open parenthesis by placing the cursor on top of it for -@hid[Paren Pause Period] seconds. If there is no matching parenthesis then -beep. If the matching parenthesis is off the top of the screen, then the line -on which it appears is displayed in the echo area. Paren pausing may be -disabled by setting @hid[Paren Pause Period] to @nil. -@enddefcom - -The initial values shown for @hid[Highlight Open Parens] and @hid[Paren Pause -Period] are only approximately correct. Since paren highlighting is only -meaningful in Lisp mode, @hid[Highlight Open Parens] is false globally, and -has a mode-local value of @true in Lisp mode. It it redundant to do both -kinds of paren matching, so there is also a binding of @hid[Paren Pause Period] -to @false in Lisp mode. - -Paren highlighting is only supported under @windows, so the above defaults are -conditional on the device type. If @hemlock is started on a terminal, the -initialization code makes Lisp mode bindings of @false and @f[0.5] for -@hid[Highlight Open Parens] and @hid[Paren Pause Period]. Since these -alternate default bindings are made at initialization time, the only way to -affect them is to use the @f[after-editor-initializations] macro. - - -@section[Parsing Lisp] -Lisp mode has a fairly complete knowledge of Lisp syntax, but since it does -not use the reader, and must work incrementally, it can be confused by legal -constructs. Lisp mode totally ignores the read-table, so user-defined read -macros have no effect on the editor. In some cases, the values the @hid[Lisp -Syntax] character attribute can be changed to get a similar effect. - -Lisp commands consistently treat semicolon (@f[;]) style comments as -whitespace when parsing, so a Lisp command used in a comment will affect the -next (or previous) form outside of the comment. Since @f[#| ... |#] comments -are not recognized, they can used to comment out code, while still allowing -Lisp editing commands to be used. - -Strings are parsed similarly to symbols. When within a string, the next form -is after the end of the string, and the previous form is the beginning of the -string. - - -@defhvar[var "Defun Parse Goal", val {2}] -@defhvar1[var "Maximum Lines Parsed", val {500}] -@defhvar1[var "Minimum Lines Parsed", val {50}] -In order to save time, Lisp mode does not parse the entire buffer every time -a Lisp command is used. Instead, it uses a heuristic to guess the region of -the buffer that is likely to be interesting. These variables control the -heuristic. - -Normally, parsing begins and ends on defun boundaries (an open parenthesis at -the beginning of a line). @hid[Defun Parse Goal] specifies the number of -defuns before and after the point to parse. If this parses fewer lines than -@hid[Minimum Lines Parsed], then parsing continues until this lower limit is -reached. If we cannot find enough defuns within @hid[Maximum Lines Parsed] -lines then we stop on the farthest defun found, or at the point where we -stopped if no defuns were found. - -When the heuristic fails, and does not parse enough of the buffer, then -commands usually act as though a syntax error was detected. If the parse -starts in a bad place (such as in the middle of a string), then Lisp commands -will be totally confused. Such problems can usually be eliminated by -increasing the values of some of these variables. -@enddefhvar - -@defhvar[var "Parse Start Function", val {start-of-parse-block}] -@defhvar1[var "Parse End Function", val {end-of-parse-block}] -These variables determine the region of the buffer parsed. The values are -functions that take a mark and move it to the start or end of the parse region. -The default values implement the heuristic described above. -@enddefhvar - - - -@comment[@chap(Interacting With Lisp)] -@include(lisp) - - -@comment[@chap(Mail Interface)] -@include(mail) - - -@comment[@chap(Netnews Interface)] -@include(netnews) - - - -@chap[System Interface] - -@hemlock provides a number of commands that access operating system resources -such as the filesystem and print servers. These commands offer an alternative -to leaving the editor and using the normal operating system command language -(such as the Unix shell), but they are implementation dependent. Therefore, -they might not even exist in some implementations. - - -@section[File Utility Commands] -This section describes some general file operation commands and quick directory -commands. - -See section @ref[dired] for a description @hemlock's directory editing -mechanism, @hid[Dired] mode. - -@defcom[com "Copy File"] -This command copies a file, allowing one wildcard in the filename. It prompts -for source and destination specifications. - -If these are both directories, then the copying process is recursive on the -source, and if the destination is in the subdirectory structure of the source, -the recursion excludes this portion of the directory tree. Use -@f[dir-spec-1/*] to copy only the files in a source directory without -recursively descending into subdirectories. - -If the destination specification is a directory, and the source is a file, then -it is copied into the destination with the same filename. - -The copying process copies files maintaining the source's write date. - -See the description of @hid[Dired Copy File Confirm], page -@pageref[copy-confirm], for controlling user interaction when the destination -exists. -@enddefcom - -@defcom[com "Rename File"] -This command renames a file, allowing one wildcard in the filename. It prompts -for source and destination specifications. - -If the destination is a directory, then the renaming process moves file(s) -indicated by the source into the directory with their original filenames. - -For Unix-based implementations, if you want to rename a directory, do not -specify the trailing slash in the source specification. -@enddefcom - -@defcom[com "Delete File"] -This command prompts for the name of a file and deletes it. -@enddefcom - -@defcom[com "Directory", bind (C-x C-d)] -@defcom1[com "Verbose Directory", bind (C-x C-D)] -These commands prompt for a pathname (which may contain wildcards), and display -a directory listing in a pop-up window. If a prefix argument is supplied, then -normally hidden files such as Unix dot-files will also be displayed. -@hid[Directory] uses a compact, multiple-column format; -@hid[Verbose Directory] displays one file on a line, with information about -protection, size, etc. -@enddefcom - - -@section[Printing] - -@defcom[com "Print Region"] -@defcom1[com "Print Buffer"] -@defcom1[com "Print File"] -@hid[Print Region] and @hid[Print Buffer] print the contents of the current -region and the current buffer, respectively. @hid[Print File] prompts for a -the name of a file and prints that file. Any error messages will be displayed -in the echo area. -@enddefcom - -@defhvar[var "Print Utility", val {"/usr/cs/bin/lpr"}] -@defhvar1[var "Print Utility Switches", val {()}] -@hid[Print Utility] is the program the print commands use to send files to the -printer. The program should act like @f[lpr]: if a filename is given as an -argument, it should print that file, and if no name appears, standard input -should be assumed. @hid[Print Utility Switches] is a list of strings -specifying the options to pass to the program. -@enddefhvar - - -@section[Scribe] -@defcom[com "Scribe Buffer File", - stuff (bound to @bf[C-x c] in @hid[Scribe] mode)] -@defhvar1[var "Scribe Buffer File Confirm", val {t}] -@defcom1[com "Scribe File"] -@hid[Scribe Buffer File] invokes @hid[Scribe Utility] on the file associated -with the current buffer. That process's default directory is the directory of -the file. The process sends its output to the @hid[Scribe Warnings] buffer. -Before doing anything, this asks the user to confirm saving and formatting the -file. This prompting can be inhibited with "Scribe Buffer File Confirm". - -@hid[Scribe File] invokes @hid[Scribe Utility] on a file supplied by the user -in the same manner as describe above. -@enddefcom - -@defhvar[var "Scribe Utility", val {"/usr/misc/bin/scribe"}] -@defhvar1[var "Scribe Utility Switches"] -@hid[Scribe Utility] is the program the Scribe commands use to compile the text -formatting. @hid[Scribe Utility Switches] is a list of strings whose contents -would be contiguous characters, other than space, had the user invoked this -program on a command line outside of @hemlock. Do not include the name of the -file to compile in this variable; the Scribe commands supply this. -@enddefhvar - -@defcom[com "Select Scribe Warnings", bind (Scribe: C-M-C)] -This command makes the @hid[Scribe Warnings] buffer current if it exists. -@enddefcom - - -@section[Miscellaneous] - -@defcom[com "Manual Page"] -This command displays a Unix manual page in a buffer which is in @hid[View] -mode. When given an argument, this puts the manual page in a pop-up display. -@enddefcom - -@defcom[com "Unix Filter Region"] -This command prompts for a UNIX program and then passes the current region to -the program as standard input. The standard output from the program is used to -replace the region. This command is undoable. -@enddefcom - - - -@chap[Simple Customization] - -@index[customization]@hemlock can be customized and extended to a very -large degree, but in order to do much of this a knowledge of Lisp is -required. These advanced aspects of customization are discussed in the -@i[Hemlock Command Implementor's Manual], while simpler methods of -customization are discussed here. - - -@section[Keyboard Macros] -@index[keyboard macros] -Keyboard macros provide a facility to turn a sequence of commands into one -command. - -@defcom[com "Define Keyboard Macro", bind {C-x (}] -@defcom1[com "End Keyboard Macro", bind {C-x )}] -@hid[Define Keyboard Macro] starts the definition of a keyboard macro. The -commands which are invoked up until @hid[End Keyboard Macro] is invoked -become the definition for the keyboard macro, thus replaying the keyboard -macro is synonymous with invoking that sequence of commands. -@enddefcom - -@defcom[com "Last Keyboard Macro", bind (C-x e)] -This command is the keyboard macro most recently defined; invoking it will -replay the keyboard macro. The prefix argument is used as a repeat count. -@enddefcom - -@defcom[com "Define Keyboard Macro Key", bind (C-x M-(; )] -@defhvar1[var "Define Keyboard Macro Key Confirm", val {t}] -This command prompts for a key before going into a mode for defining keyboard -macros. After defining the macro @hemlock binds it to the key. If the key is -already bound, @hemlock asks for confirmation before clobbering the binding; -this prompting can be inhibited by setting @hid[Define Keyboard Macro Key -Confirm] to @nil. -@enddefcom - -@defcom[com "Keyboard Macro Query", bind (C-x q)] -This command conditionalizes the execution of a keyboard macro. When invoked -during the definition of a macro, it does nothing. When the macro replays, it -prompts the user for a key-event indicating what action to take. The following -commands are defined: -@begin[description] -@binding[Escape]@\ - Exit all repetitions of this keyboard macro. More than one may have been -specified using a prefix argument. - -@binding[Space, y]@\ - Proceed with the execution of the keyboard macro. - -@binding[Delete, Backspace, n]@\ - Skip the remainder of the keyboard macro and go on to the next repetition, if -any. - -@binding[!]@\ - Do all remaining repetitions of the keyboard macro without prompting. - -@binding[.]@\ - Complete this repetition of the macro and then exit without doing any of the -remaining repetitions. - -@binding[C-r]@\ - Do a recursive edit and then prompt again. -@end[description] -@enddefcom - -@defcom[com "Name Keyboard Macro"] -This command prompts for the name of a command and then makes the -definition for that command the same as @hid[Last Keyboard Macro]'s current -definition. The command which results is not clobbered when another -keyboard macro is defined, so it is possible to keep several keyboard -macros around at once. The resulting command may also be bound to a key -using @hid[Bind Key], in the same way any other command is. -@enddefcom - -Many keyboard macros are not for customization, but rather for one-shot -use, a typical example being performing some operation on each line of a file. -To add "@f[del ]" to the beginning and "@f[.*]" to the end of every line in -in a buffer, one could do this: -@begin[programexample] -C-x ( d e l Space C-e . * C-n C-a C-x ) C-u 9 9 9 C-x e -@end[programexample] -First a keyboard macro is defined which performs the desired operation on -one line, and then the keyboard macro is invoked with a large prefix -argument. The keyboard macro will not actually execute that many times; -when the end of the buffer is reached the @binding[C-n] will get an error -and abort the execution. - - -@section[Binding Keys] -@index[key bindings] -@label[binding-keys] - -@defcom[com "Bind Key"] -This command prompts for a command, a key and a kind of binding to make, -and then makes the specified binding. The following kinds of bindings are -allowed: -@begin[description] -@i[buffer]@\Prompts for a buffer and then makes a key binding which is -only present when that buffer is the current buffer. - -@i[mode]@\Prompts for the name of a mode and then makes a key binding which -is only in present when that mode is active in the current buffer. - -@i[global]@\Makes a global key binding which is in effect when there is -no applicable mode or buffer key binding. This is the default. -@end[description] -@enddefcom - -@defcom[com "Delete Key Binding"] -This command prompts for a key binding the same way that @hid[Bind Key] -does and makes the specified binding go away. -@enddefcom - -@section[Hemlock Variables] - -@label[vars]@index[variables, hemlock]@index[hemlock variables]A number -of commands use @hemlock variables as flags to control their behavior. Often -you can get a command to do what you want by setting a variable. Generally the -default value for a variable is chosen to be the safest value for novice users. - -@defcom[com "Set Variable"] -This command prompts for the name of a @hemlock variable and an expression, -then sets the current value of the variable to the result of the evaluation of -the expression. -@enddefcom - - -@defcom[com "Defhvar"] -Like @hid[Set Variable], this command prompts for the name of a @hemlock -variable and an expression. Like @hid[Bind Key], this command prompts for a -place: mode, buffer or local. The result of evaluating the expression is -defined to be the value of the named variable in the specified place. - -This command is most useful for making mode or buffer local bindings of -variables. Redefining a variable in a mode or buffer will create a -customization that takes effect only when in that mode or buffer. - -Unlike @hid[Set Variable], the variable name need not be the name of an -existing variable: new variables may be defined. If the variable is already -defined in the current environment, @hemlock copies the documentation and hooks -to the new definition. -@enddefcom - - -@section[Init Files] -@index[init files] -@hemlock customizations are normally put in @hemlock's initialization file, -"@f[hemlock-init.lisp]", or when compiled "@f[hemlock-init.fasl]". When -starting up Lisp, use the @f[-hinit] switch to indicate a particular file. The -contents of the init file must be Lisp code, but there is a fairly -straightforward correspondence between the basic customization commands and the -equivalent Lisp code. Rather than describe these functions in depth here, a -brief example follows: -@begin[programexample] -;;; -*- Mode: Lisp; Package: Hemlock -*- - -;;; It is necessary to specify that the customizations go in -;;; the hemlock package. -(in-package 'hemlock) - -;;; Bind @hid[Kill Previous Word] to @binding[M-h]. -(bind-key "Kill Previous Word" '#(#\m-h)) -;;; -;;; Bind @hid[Extract List] to @binding[C-M-?] when in @hid[Lisp] mode. -(bind-key "Extract List" '#(#\c-m-?) :mode "Lisp") - -;;; Make @binding[C-w] globally unbound. -(delete-key-binding '#(#\c-w)) - -;;; Make string searches case-sensitive. -(setv string-search-ignore-case nil) -;;; -;;; Make "Query Replace" replace strings literally. -(setv case-replace nil) -@end[programexample] -For a detailed description of these functions, see the @i[Hemlock Command -Implementor's Manual]. diff --git a/docs/internals/architecture.tex b/docs/internals/architecture.tex deleted file mode 100644 index cbee09078d60c0ddcc77496982fa9d9cf285077d..0000000000000000000000000000000000000000 --- a/docs/internals/architecture.tex +++ /dev/null @@ -1,306 +0,0 @@ -\part{System Architecture}% -*- Dictionary: int:design -*- - -\chapter{Package and File Structure} - -\section{RCS and build areas} - -The CMU CL sources are maintained using RCS in a hierarchical directory -structure which supports: -\begin{itemize} -\item shared RCS config file across a build area, - -\item frozen sources for multiple releases, and - -\item separate system build areas for different architectures. -\end{itemize} - -Since this organization maintains multiple copies of the source, it is somewhat -space intensive. But it is easy to delete and later restore a copy of the -source using RCS snapshots. - -There are three major subtrees of the root \verb|/afs/cs/project/clisp|: -\begin{description} -\item[rcs] holds the RCS source (suffix \verb|,v|) files. - -\item[src] holds ``checked out'' (but not locked) versions of the source files, -and is subdivided by release. Each release directory in the source tree has a -symbolic link named ``{\tt RCS}'' which points to the RCS subdirectory of the -corresponding directory in the ``{\tt rcs} tree. At top-level in a source tree -is the ``{\tt RCSconfig}'' file for that area. All subdirectories also have a -symbolic link to this RCSconfig file, allowing the configuration for an area to -be easily changed. - -\item[build] compiled object files are placed in this tree, which is subdivided -by machine type and version. The CMU CL search-list mechanism is used to allow -the source files to be located in a different tree than the object files. C -programs are compiled by using the \verb|tools/dupsrcs| command to make -symbolic links to the corresponding source tree. -\end{description} - -On order to modify an file in RCS, it must be checked out with a lock to -produce a writable working file. Each programmer checks out files into a -personal ``play area'' subtree of \verb|clisp/hackers|. These tree duplicate -the structure of source trees, but are normally empty except for files actively -being worked on. - -See \verb|/afs/cs/project/clisp/pmax_mach/alpha/tools/| for -various tools we use for RCS hacking: -\begin{description} -\item[rcs.lisp] Hemlock (editor) commands for RCS file manipulation - -\item[rcsupdate.c] Program to check out all files in a tree that have been -modified since last checkout. - -\item[updates] Shell script to produce a single listing of all RCS log - entries in a tree since a date. - -\item[snapshot-update.lisp] Lisp program to generate a shell script which -generates a listing of updates since a particular RCS snapshot ({\tt RCSSNAP}) -file was created. -\end{description} - -You can easily operate on all RCS files in a subtree using: -\begin{verbatim} -find . -follow -name '*,v' -exec <some command> {} \; -\end{verbatim} - -\subsection{Configuration Management} - -config files are useful, especially in combinarion with ``{\tt snapshot}''. You -can shapshot any particular version, giving an RCSconfig that designates that -configuration. You can also use config files to specify the system as of a -particular date. For example: -\begin{verbatim} -<3-jan-91 -\end{verbatim} -in the the config file will cause the version as of that 3-jan-91 to be checked -out, instead of the latest version. - -\subsection{RCS Branches} - -Branches and named revisions are used together to allow multiple paths of -development to be supported. Each separate development has a branch, and each -branch has a name. This project uses branches in two somewhat different cases -of divergent development: -\begin{itemize} -\item For systems that we have imported from the outside, we generally assign a -``{\tt cmu}'' branch for our local modifications. When a new release comes -along, we check it in on the trunk, and then merge our branch back in. - -\item For the early development and debugging of major system changes, where -the development and debugging is expected to take long enough that we wouldn't -want the trunk to be in an inconsistent state for that long. -\end{itemize} - -\section{Releases} - -We name releases according to the normal alpha, beta, default convention. -Alpha releases are frequent, intended primarily for internal use, and are thus -not subject to as high high documentation and configuration management -standards. Alpha releases are designated by the date on which the system was -built; the alpha releases for different systems may not be in exact -correspondence, since they are built at different times. - -Beta and default releases are always based on a snapshot, ensuring that all -systems are based on the same sources. A release name is an integer and a -letter, like ``15d''. The integer is the name of the source tree which the -system was built from, and the letter represents the release from that tree: -``a'' is the first release, etc. Generally the numeric part increases when -there are major system changes, whereas changes in the letter represent -bug-fixes and minor enhancements. - -\section{Source Tree Structure} - -A source tree (and the master ``{\tt rcs}'' tree) has subdirectories for each -major subsystem: -\begin{description} -\item[{\tt assembly/}] Holds the CMU CL source-file assembler, and has machine -specific subdirectories holding assembly code for that architecture. - -\item[{\tt clx/}] The CLX interface to the X11 window system. - -\item[{\tt code/}] The Lisp code for the runtime system and standard CL -utilities. - -\item[{\tt compiler/}] The Python compiler. Has architecture-specific -subdirectories which hold backends for different machines. The {\tt generic} -subdirectory holds code that is shared across most backends. - -\item[{\tt hemlock/}] The Hemlock editor. - -\item[{\tt ldb/}] The C runtime system code and low-level ``Lisp DeBugger''. - -\item[{\tt pcl/}] CMU version of the PCL implementation of CLOS. - -\item[{\tt tools/}] System building command files and source management tools. -\end{description} - - -\section{Package structure} - -Goals: with the single exception of LISP, we want to be able to export from the -package that the code lives in. - -\begin{description} -\item[Mach, CLX...] --- These Implementation-dependent system-interface -packages provide direct access to specific features available in the operating -system environment, but hide details of how OS communication is done. - -\item[system] contains code that must know about the operating system -environment: I/O, etc. Hides the operating system environment. Provides OS -interface extensions such as {\tt print-directory}, etc. - -\item[kernel] hides state and types used for system integration: package -system, error system, streams (?), reader, printer. Also, hides the VM, in -that we don't export anything that reveals the VM interface. Contains code -that needs to use the VM and SYSTEM interface, but is independent of OS and VM -details. This code shouldn't need to be changed in any port of CMU CL, but -won't work when plopped into an arbitrary CL. Uses SYSTEM, VM, EXTENSIONS. We -export "hidden" symbols related to implementation of CL: setf-inverses, -possibly some global variables. - -The boundary between KERNEL and VM is fuzzy, but this fuzziness reflects the -fuzziness in the definition of the VM. We can make the VM large, and bring -everything inside, or we make make it small. Obviously, we want the VM to be -as small as possible, subject to efficiency constraints. Pretty much all of -the code in KERNEL could be put in VM. The issue is more what VM hides from -KERNEL: VM knows about everything. - -\item[lisp] Originally, this package had all the system code in it. The -current ideal is that this package should have {\it no} code in it, and only -exist to export the standard interface. Note that the name has been changed by -x3j13 to common-lisp. - -\item[extensions] contains code that any random user could have written: list -operations, syntactic sugar macros. Uses only LISP, so code in EXTENSIONS is -pure CL. Exports everything defined within that is useful elsewhere. This -package doesn't hide much, so it is relatively safe for users to use -EXTENSIONS, since they aren't getting anything they couldn't have written -themselves. Contrast this to KERNEL, which exports additional operations on -CL's primitive data structures: PACKAGE-INTERNAL-SYMBOL-COUNT, etc. Although -some of the functionality exported from KERNEL could have been defined in CL, -the kernel implementation is much more efficient because it knows about -implementation internals. Currently this package contains only extensions to -CL, but in the ideal scheme of things, it should contain the implementations of -all CL functions that are in KERNEL (the library.) - -\item[VM] hides information about the hardware and data structure -representations. Contains all code that knows about this sort of thing: parts -of the compiler, GC, etc. The bulk of the code is the compiler back-end. -Exports useful things that are meaningful across all implementations, such as -operations for examining compiled functions, system constants. Uses COMPILER -and whatever else it wants. Actually, there are different {\it machine}{\tt --VM} packages for each target implementation. VM is a nickname for whatever -implementation we are currently targeting for. - - -\item[compiler] hides the algorithms used to map Lisp semantics onto the -operations supplied by the VM. Exports the mechanisms used for defining the -VM. All the VM-independent code in the compiler, partially hiding the compiler -intermediate representations. Uses KERNEL. - -\item[eval] holds code that does direct execution of the compiler's ICR. Uses -KERNEL, COMPILER. Exports debugger interface to interpreted code. - -\item[debug-internals] presents a reasonable, unified interface to -manipulation of the state of both compiled and interpreted code. (could be in -KERNEL) Uses VM, INTERPRETER, EVAL, KERNEL. - -\item[debug] holds the standard debugger, and exports the debugger -\end{description} - -\chapter{System Building} - -It's actually rather easy to build a CMU CL core with exactly what you want in -it. But to do this you need two things: the source and a working CMU CL. - -Basically, you use the working copy of CMU CL to compile the sources, -then run a process call ``genesis'' which builds a ``kernel'' core. -You then load whatever you want into this kernel core, and save it. - -In the \verb|tools/| directory in the sources there are several files that -compile everything, and build cores, etc. The first step is to compile the C -startup code. - -{\bf Note:} {\it the various scripts mentioned below have hard-wired paths in -them set up for our directory layout here at CMU. Anyone anywhere else will -have to edit them before they will work.} - -\section{Compiling the C Startup Code} - -There is a circular dependancy between ldb/lisp.h and ldb/ldb.map that causes -bootstrapping problems. To the easiest way to get around this problem is to -make a fake ldb.map file that has nothing in it by a version number: -\begin{verbatim} - % echo "Map file for ldb version 0" > ldb.map -\end{verbatim} -and then run genesis with NIL for the list of files: -\begin{verbatim} - * (load ".../compiler/generic/genesis") - * (lisp::genesis nil ".../ldb/ldb.map" "/dev/null" - ".../ldb/lisp.map" ".../ldb/lisp.h") -\end{verbatim} -It will generate -a whole bunch of warnings about things being undefined, but ignore -that, because it will also generate a correct lisp.h. You can then -compile ldb producing a correct ldb.map: -\begin{verbatim} - % make -\end{verbatim} -and the use \verb|tools/do-worldbuild| and \verb|tools/mk-lisp| to build -\verb|kernel.core| and \verb|lisp.core| (see section \ref[building-cores].) - -\section{Compiling the Lisp Code} - -The \verb|tools| directory contains various lisp and C-shell utilities for -building CMU CL: -\begin{description} -\item[compile-all*] Will compile lisp files and build a kernel core. It has -numerous command-line options to control what to compile and how. Try -help to -see a description. It runs a separate Lisp process to compile each -subsystem. Error output is generated in files with ``{\tt .log}'' extension in -the root of the build area. - -\item[setup.lisp] Some lisp utilities used for compiling changed files in batch -mode and collecting the error output Sort of a crude defsystem. Loads into the -``user'' package. See {\tt with-compiler-log-file} and {\tt comf}. - -\item[{\it foo}com.lisp] Each system has a ``\verb|.lisp|'' file in -\verb|tools/| which compiles that system. -\end{description} - -\section{Building Core Images} -\label{building-cores} -Both the kernel and final core build are normally done using shell script -drivers: -\begin{description} -\item[do-worldbuild*] Builds a kernel core for the current machine. The -version to build is indicated by an optional argument, which defaults to -``alpha''. The \verb|kernel.core| file is written either in the \verb|ldb/| -directory in the build area, or in \verb|/usr/tmp/|. The directory which -already contains \verb|kernel.core| is chosen. You can create a dummy version -with e.g. ``touch'' to select the initial build location. - -\item[mk-lisp*] Builds a full core, with conditional loading of subsystems. -The version is the first argument, which defaults to ``alpha''. Any additional -arguments are added to the \verb|*features*| list, which controls system -loading (among other things.) The \verb|lisp.core| file is written in the -current working directory. -\end{description} - -These scripts load Lisp command files. When \verb|tools/worldbuild.lisp| is -loaded, it calls genesis with the correct arguments to build a kernel core. -Similarly, \verb|worldload.lisp| -builds a full core. Adding certain symbols to \verb|*features*| before -loading worldload.lisp suppresses loading of different parts of the -system. These symbols are: -\begin{description} -\item[:no-compiler] don't load the compiler. -\item[:no-clx] don't load CLX. -\item[:no-hemlock] don't load hemlock. -\item[:no-pcl] don't load PCL. -\end{description} - -Note: if you don't load the compiler, you can't (successfully) load the -pretty-printer or pcl. And if you compiled hemlock with CLX loaded, you can't -load it without CLX also being loaded. diff --git a/docs/internals/back.tex b/docs/internals/back.tex deleted file mode 100644 index edeff4674c11d0942a52cb924adcbe972e3c5537..0000000000000000000000000000000000000000 --- a/docs/internals/back.tex +++ /dev/null @@ -1,725 +0,0 @@ -% -*- Dictionary: design -*- - -\chapter{Copy propagation} - -File: {\tt copyprop} - -This phase is optional, but should be done whenever speed or space is more -important than compile speed. We use global flow analysis to find the reaching -definitions for each TN. This information is used here to eliminate -unnecessary TNs, and is also used later on by loop invariant optimization. - -In some cases, VMR conversion will unnecessarily copy the value of a TN into -another TN, since it may not be able to tell that the initial TN has the same -value at the time the second TN is referenced. This can happen when ICR -optimize is unable to eliminate a trivial variable binding, or when the user -does a setq, or may also result from creation of expression evaluation -temporaries during VMR conversion. Whatever the cause, we would like to avoid -the unnecessary creation and assignment of these TNs. - -What we do is replace TN references whose only reaching definition is a Move -VOP with a reference to the TN moved from, and then delete the Move VOP if the -copy TN has no remaining references. There are several restrictions on copy -propagation: -\begin{itemize} -\item The TNs must be ``ordinary'' TNs, not restricted or otherwise -unusual. Extending the life of restricted (or wired) TNs can make register -allocation impossible. Some other TN kinds have hidden references. - -\item We don't want to defeat source-level debugging by replacing named -variables with anonymous temporaries. - -\item We can't delete moves that representation selected might want to change -into a representation conversion, since we need the primitive types of both TNs -to select a conversion. -\end{itemize} - -Some cleverness reduces the cost of flow analysis. As for lifetime analysis, -we only need to do flow analysis on global packed TNs. We can't do the real -local TN assignment pass before this, since we allocate TNs afterward, so we do -a pre-pass that marks the TNs that are local for our purposes. We don't care -if block splitting eventually causes some of them to be considered global. - -Note also that we are really only are interested in knowing if there is a -unique reaching definition, which we can mash into our flow analysis rules by -doing an intersection. Then a definition only appears in the set when it is -unique. We then propagate only definitions of TNs with only one write, which -allows the TN to stand for the definition. - - -\chapter{Representation selection} - -File: {\tt represent} - -Some types of object (such as {\tt single-float}) have multiple possible -representations. Multiple representations are useful mainly when there is a -particularly efficient non-descriptor representation. In this case, there is -the normal descriptor representation, and an alternate non-descriptor -representation. - -This possibility brings up two major issues: -\begin{itemize} -\item The compiler must decide which representation will be most efficient for -any given value, and - -\item Representation conversion code must be inserted where the representation -of a value is changed. -\end{itemize} -First, the representations for TNs are selected by examining all the TN -references and attempting to minimize reference costs. Then representation -conversion code is introduced. - -This phase is in effect a pre-pass to register allocation. The main reason for -its existence is that representation conversions may be farily complex (e.g. -involving memory allocation), and thus must be discovered before register -allocation. - - -VMR conversion leaves stubs for representation specific move operations. -Representation selection recognizes {\tt move} by name. Argument and return -value passing for call VOPs is controlled by the {\tt :move-arguments} option -to {\tt define-vop}. - -Representation selection is also responsible for determining what functions use -the number stack. If any representation is chosen which could involve packing -into the {\tt non-descriptor-stack} SB, then we allocate the NFP register -throughout the component. As an optimization, permit the decision of whether a -number stack frame needs to be allocated to be made on a per-function basis. -If a function doesn't use the number stack, and isn't in the same tail-set as -any function that uses the number stack, then it doesn't need a number stack -frame, even if other functions in the component do. - - -\chapter{Lifetime analysis} - -File: {\tt life} - -This phase is a preliminary to Pack. It involves three passes: - -- A pre-pass that computes the DEF and USE sets for live TN analysis, while - also assigning local TN numbers, splitting blocks if necessary. \#\#\# But -not really... - -- A flow analysis pass that does backward flow analysis on the - component to find the live TNs at each block boundary. - -- A post-pass that finds the conflict set for each TN. - -\#| -Exploit the fact that a single VOP can only exhaust LTN numbers when there are -large more operands. Since more operand reference cannot be interleaved with -temporary reference, the references all effectively occur at the same time. -This means that we can assign all the more args and all the more results the -same LTN number and the same lifetime info. -|\# - - -\section{Flow analysis} - -It seems we could use the global-conflicts structures during compute the -inter-block lifetime information. The pre-pass creates all the -global-conflicts for blocks that global TNs are referenced in. The flow -analysis pass just adds always-live global-conflicts for the other blocks the -TNs are live in. In addition to possibly being more efficient than SSets, this -would directly result in the desired global-conflicts information, rather that -having to create it from another representation. - -The DFO sorted per-TN global-conflicts thread suggests some kind of algorithm -based on the manipulation of the sets of blocks each TN is live in (which is -what we really want), rather than the set of TNs live in each block. - -If we sorted the per-TN global-conflicts in reverse DFO (which is just as good -for determining conflicts between TNs), then it seems we could scan though the -conflicts simultaneously with our flow-analysis scan through the blocks. - -The flow analysis step is the following: - If a TN is always-live or read-before-written in a successor block, then we - make it always-live in the current block unless there are already - global-conflicts recorded for that TN in this block. - -The iteration terminates when we don't add any new global-conflicts during a -pass. - -We may also want to promote TNs only read within a block to always-live when -the TN is live in a successor. This should be easy enough as long as the -global-conflicts structure contains this kind of info. - -The critical operation here is determining whether a given global TN has global -conflicts in a given block. Note that since we scan the blocks in DFO, and the -global-conflicts are sorted in DFO, if we give each global TN a pointer to the -global-conflicts for the last block we checked the TN was in, then we can -guarantee that the global-conflicts we are looking for are always at or after -that pointer. If we need to insert a new structure, then the pointer will help -us rapidly find the place to do the insertion.] - - -\section{Conflict detection} - -[\#\#\# Environment, :more TNs.] - -This phase makes use of the results of lifetime analysis to find the set of TNs -that have lifetimes overlapping with those of each TN. We also annotate call -VOPs with information about the live TNs so that code generation knows which -registers need to be saved. - -The basic action is a backward scan of each block, looking at each TN-Ref and -maintaining a set of the currently live TNs. When we see a read, we check if -the TN is in the live set. If not, we: - -- Add the TN to the conflict set for every currently live TN, - -- Union the set of currently live TNs with the conflict set for the TN, and - -- Add the TN to the set of live TNs. - -When we see a write for a live TN, we just remove it from the live set. If we -see a write to a dead TN, then we update the conflicts sets as for a read, but -don't add the TN to the live set. We have to do this so that the bogus write -doesn't clobber anything. - -[We don't consider always-live TNs at all in this process, since the conflict -of always-live TNs with other TNs in the block is implicit in the -global-conflicts structures. - -Before we do the scan on a block, we go through the global-conflicts structures -of TNs that change liveness in the block, assigning the recorded LTN number to -the TN's LTN number for the duration of processing of that block.] - - -Efficiently computing and representing this information calls for some -cleverness. It would be prohibitively expensive to represent the full conflict -set for every TN with sparse sets, as is done at the block-level. Although it -wouldn't cause non-linear behavior, it would require a complex linked structure -containing tens of elements to be created for every TN. Fortunately we can -improve on this if we take into account the fact that most TNs are "local" TNs: -TNs which have all their uses in one block. - -First, many global TNs will be either live or dead for the entire duration of a -given block. We can represent the conflict between global TNs live throughout -the block and TNs local to the block by storing the set of always-live global -TNs in the block. This reduces the number of global TNs that must be -represented in the conflicts for local TNs. - -Second, we can represent conflicts within a block using bit-vectors. Each TN -that changes liveness within a block is assigned a local TN number. Local -conflicts are represented using a fixed-size bit-vector of 64 elements or so -which has a 1 for the local TN number of every TN live at that time. The block -has a simple-vector which maps from local TN numbers to TNs. Fixed-size -vectors reduce the hassle of doing allocations and allow operations to be -open-coded in a maximally tense fashion. - -We can represent the conflicts for a local TN by a single bit-vector indexed by -the local TN numbers for that block, but in the global TN case, we need to be -able to represent conflicts with arbitrary TNs. We could use a list-like -sparse set representation, but then we would have to either special-case global -TNs by using the sparse representation within the block, or convert the local -conflicts bit-vector to the sparse representation at the block end. Instead, -we give each global TN a list of the local conflicts bit-vectors for each block -that the TN is live in. If the TN is always-live in a block, then we record -that fact instead. This gives us a major reduction in the amount of work we -have to do in lifetime analysis at the cost of some increase in the time to -iterate over the set during Pack. - -Since we build the lists of local conflict vectors a block at a time, the -blocks in the lists for each TN will be sorted by the block number. The -structure also contains the local TN number for the TN in that block. These -features allow pack to efficiently determine whether two arbitrary TNs -conflict. You just scan the lists in order, skipping blocks that are in only -one list by using the block numbers. When we find a block that both TNs are -live in, we just check the local TN number of one TN in the local conflicts -vector of the other. - -In order to do these optimizations, we must do a pre-pass that finds the -always-live TNs and breaks blocks up into small enough pieces so that we don't -run out of local TN numbers. If we can make a block arbitrarily small, then we -can guarantee that an arbitrarily small number of TNs change liveness within -the block. We must be prepared to make the arguments to unbounded arg count -VOPs (such as function call) always-live even when they really aren't. This is -enabled by a panic mode in the block splitter: if we discover that the block -only contains one VOP and there are still too many TNs that aren't always-live, -then we promote the arguments (which we'd better be able to do...). - -This is done during the pre-scan in lifetime analysis. We can do this because -all TNs that change liveness within a block can be found by examining that -block: the flow analysis only adds always-live TNs. - - -When we are doing the conflict detection pass, we set the LTN number of global -TNs. We can easily detect global TNs that have not been locally mapped because -this slot is initially null for global TNs and we null it out after processing -each block. We assign all Always-Live TNs to the same local number so that we -don't need to treat references to them specially when making the scan. - -We also annotate call VOPs that do register saving with the TNs that are live -during the call, and thus would need to be saved if they are packed in -registers. - -We adjust the costs for TNs that need to be saved so that TNs costing more to -save and restore than to reference get packed on the stack. We would also like -more often saved TNs to get higher costs so that they are packed in more -savable locations. - - -\chapter{Packing} - -File: {\tt pack} - -\#| - -Add lifetime/pack support for pre-packed save TNs. - -Fix GTN/VMR conversion to use pre-packed save TNs for old-cont and return-PC. -(Will prevent preference from passing location to save location from ever being -honored?) - -We will need to make packing of passing locations smarter before we will be -able to target the passing location on the stack in a tail call (when that is -where the callee wants it.) Currently, we will almost always pack the passing -location in a register without considering whether that is really a good idea. -Maybe we should consider schemes that explicitly understand the parallel -assignment semantics, and try to do the assignment with a minimum number of -temporaries. We only need assignment temps for TNs that appear both as an -actual argument value and as a formal parameter of the called function. This -only happens in self-recursive functions. - -Could be a problem with lifetime analysis, though. The write by a move-arg VOP -would look like a write in the current env, when it really isn't. If this is a -problem, then we might want to make the result TN be an info arg rather than a -real operand. But this would only be a problem in recursive calls, anyway. -[This would prevent targeting, but targeting across passing locations rarely -seems to work anyway.] [\#\#\# But the :ENVIRONMENT TN mechanism would get -confused. Maybe put env explicitly in TN, and have it only always-live in that -env, and normal in other envs (or blocks it is written in.) This would allow -targeting into environment TNs. - -I guess we would also want the env/PC save TNs normal in the return block so -that we can target them. We could do this by considering env TNs normal in -read blocks with no successors. - -ENV TNs would be treated totally normally in non-env blocks, so we don't have -to worry about lifetime analysis getting confused by variable initializations. -Do some kind of TN costing to determine when it is more trouble than it is -worth to allocate TNs in registers. - -Change pack ordering to be less pessimal. Pack TNs as they are seen in the LTN -map in DFO, which at least in non-block compilations has an effect something -like packing main trace TNs first, since control analysis tries to put the good -code first. This could also reduce spilling, since it makes it less likely we -will clog all registers with global TNs. - -If we pack a TN with a specified save location on the stack, pack in the -specified location. - -Allow old-cont and return-pc to be kept in registers by adding a new "keep -around" kind of TN. These are kind of like environment live, but are only -always-live in blocks that they weren't referenced in. Lifetime analysis does -a post-pass adding always-live conflicts for each "keep around" TN to those -blocks with no conflict for that TN. The distinction between always-live and -keep-around allows us to successfully target old-cont and return-pc to passing -locations. MAKE-KEEP-AROUND-TN (ptype), PRE-PACK-SAVE-TN (tn scn offset). -Environment needs a KEEP-AROUND-TNS slot so that conflict analysis can find -them (no special casing is needed after then, they can be made with :NORMAL -kind). VMR-component needs PRE-PACKED-SAVE-TNS so that conflict analysis or -somebody can copy conflict info from the saved TN. - - - -Note that having block granularity in the conflict information doesn't mean -that a localized packing scheme would have to do all moves at block boundaries -(which would clash with the desire the have saving done as part of this -mechanism.) All that it means is that if we want to do a move within the -block, we would need to allocate both locations throughout that block (or -something). - - - - - -Load TN pack: - -A location is out for load TN packing if: - -The location has TN live in it after the VOP for a result, or before the VOP -for an argument, or - -The location is used earlier in the TN-ref list (after) the saved results ref -or later in the TN-Ref list (before) the loaded argument's ref. - -To pack load TNs, we advance the live-tns to the interesting VOP, then -repeatedly scan the vop-refs to find vop-local conflicts for each needed load -TN. We insert move VOPs and change over the TN-Ref-TNs as we go so the TN-Refs -will reflect conflicts with already packed load-TNs. - -If we fail to pack a load-TN in the desired SC, then we scan the Live-TNs for -the SB, looking for a TN that can be packed in an unbounded SB. This TN must -then be repacked in the unbounded SB. It is important the load-TNs are never -packed in unbounded SBs, since that would invalidate the conflicts info, -preventing us from repacking TNs in unbounded SBs. We can't repack in a finite -SB, since there might have been load TNs packed in that SB which aren't -represented in the original conflict structures. - -Is it permissible to "restrict" an operand to an unbounded SC? Not impossible -to satisfy as long as a finite SC is also allowed. But in practice, no -restriction would probably be as good. - -We assume all locations can be used when an sc is based on an unbounded sb. - -] - - -TN-Refs are be convenient structures to build the target graph out of. If we -allocated space in every TN-Ref, then there would certainly be enough to -represent arbitrary target graphs. Would it be enough to allocate a single -Target slot? If there is a target path though a given VOP, then the Target of -the write ref would be the read, and vice-versa. To find all the TNs that -target us, we look at the TN for the target of all our write refs. - -We separately chain together the read refs and the write refs for a TN, -allowing easy determination of things such as whether a TN has only a single -definition or has no reads. It would also allow easier traversal of the target -graph. - -Represent per-location conflicts as vectors indexed by block number of -per-block conflict info. To test whether a TN conflicts on a location, we -would then have to iterate over the TNs global-conflicts, using the block -number and LTN number to check for a conflict in that block. But since most -TNs are local, this test actually isn't much more expensive than indexing into -a bit-vector by GTN numbers. - -The big win of this scheme is that it is much cheaper to add conflicts into the -conflict set for a location, since we never need to actually compute the -conflict set in a list-like representation (which requires iterating over the -LTN conflicts vectors and unioning in the always-live TNs). Instead, we just -iterate over the global-conflicts for the TN, using BIT-IOR to combine the -conflict set with the bit-vector for that block in that location, or marking -that block/location combination as being always-live if the conflict is -always-live. - -Generating the conflict set is inherently more costly, since although we -believe the conflict set size to be roughly constant, it can easily contain -tens of elements. We would have to generate these moderately large lists for -all TNs, including local TNs. In contrast, the proposed scheme does work -proportional to the number of blocks the TN is live in, which is small on -average (1 for local TNs). This win exists independently from the win of not -having to iterate over LTN conflict vectors. - - -[\#\#\# Note that since we never do bitwise iteration over the LTN conflict -vectors, part of the motivation for keeping these a small fixed size has been -removed. But it would still be useful to keep the size fixed so that we can -easily recycle the bit-vectors, and so that we could potentially have maximally -tense special primitives for doing clear and bit-ior on these vectors.] - -This scheme is somewhat more space-intensive than having a per-location -bit-vector. Each vector entry would be something like 150 bits rather than one -bit, but this is mitigated by the number of blocks being 5-10x smaller than the -number of TNs. This seems like an acceptable overhead, a small fraction of the -total VMR representation. - -The space overhead could also be reduced by using something equivalent to a -two-dimensional bit array, indexed first by LTN numbers, and then block numbers -(instead of using a simple-vector of separate bit-vectors.) This would -eliminate space wastage due to bit-vector overheads, which might be 50% or -more, and would also make efficient zeroing of the vectors more -straightforward. We would then want efficient operations for OR'ing LTN -conflict vectors with rows in the array. - -This representation also opens a whole new range of allocation algorithms: ones -that store allocate TNs in different locations within different portions of the -program. This is because we can now represent a location being used to hold a -certain TN within an arbitrary subset of the blocks the TN is referenced in. - - - - - - - - - -Pack goals: - -Pack should: - -Subject to resource constraints: - -- Minimize use costs - -- "Register allocation" - Allocate as many values as possible in scarce "good" locations, - attempting to minimize the aggregate use cost for the entire program. - -- "Save optimization" - Don't allocate values in registers when the save/restore costs exceed - the expected gain for keeping the value in a register. (Similar to - "opening costs" in RAOC.) [Really just a case of representation - selection.] - - -- Minimize preference costs - Eliminate as many moves as possible. - - -"Register allocation" is basically an attempt to eliminate moves between -registers and memory. "Save optimization" counterbalances "register -allocation" to prevent it from becoming a pessimization, since saves can -introduce register/memory moves. - -Preference optimization reduces the number of moves within an SC. Doing a good -job of honoring preferences is important to the success of the compiler, since -we have assumed in many places that moves will usually be optimized away. - -The scarcity-oriented aspect of "register allocation" is handled by a greedy -algorithm in pack. We try to pack the "most important" TNs first, under the -theory that earlier packing is more likely to succeed due to fewer constraints. - -The drawback of greedy algorithms is their inability to look ahead. Packing a -TN may mess up later "register allocation" by precluding packing of TNs that -are individually "less important", but more important in aggregate. Packing a -TN may also prevent preferences from being honored. - - - -Initial packing: - - -Pack all TNs restricted to a finite SC first, before packing any other TNs. - -One might suppose that Pack would have to treat TNs in different environments -differently, but this is not the case. Pack simply assigns TNs to locations so -that no two conflicting TNs are in the same location. In the process of -implementing call semantics in conflict analysis, we cause TNs in different -environments not to conflict. In the case of passing TNs, cross environment -conflicts do exist, but this reflects reality, since the passing TNs are -live in both the caller and the callee. Environment semantics has already been -implemented at this point. - -This means that Pack can pack all TNs simultaneously, using one data structure -to represent the conflicts for each location. So we have only one conflict set -per SB location, rather than separating this information by environment -environment. - - -Load TN packing: - -We create load TNs as needed in a post-pass to the initial packing. After TNs -are packed, it may be that some references to a TN will require it to be in a -SC other than the one it was packed in. We create load-TNs and pack them on -the fly during this post-pass. - -What we do is have an optional SC restriction associated with TN-refs. If we -pack the TN in an SC which is different from the required SC for the reference, -then we create a TN for each such reference, and pack it into the required SC. - -In many cases we will be able to pack the load TN with no hassle, but in -general we may need to spill a TN that has already been packed. We choose a -TN that isn't in use by the offending VOP, and then spill that TN onto the -stack for the duration of that VOP. If the VOP is a conditional, then we must -insert a new block interposed before the branch target so that the value TN -value is restored regardless of which branch is taken. - -Instead of remembering lifetime information from conflict analysis, we rederive -it. We scan each block backward while keeping track of which locations have -live TNs in them. When we find a reference that needs a load TN packed, we try -to pack it in an unused location. If we can't, we unpack the currently live TN -with the lowest cost and force it into an unbounded SC. - -The per-location and per-TN conflict information used by pack doesn't -need to be updated when we pack a load TN, since we are done using those data -structures. - -We also don't need to create any TN-Refs for load TNs. [??? How do we keep -track of load-tn lifetimes? It isn't really that hard, I guess. We just -remember which load TNs we created at each VOP, killing them when we pass the -loading (or saving) step. This suggests we could flush the Refs thread if we -were willing to sacrifice some flexibility in explicit temporary lifetimes. -Flushing the Refs would make creating the VMR representation easier.] - -The lifetime analysis done during load-TN packing doubles as a consistency -check. If we see a read of a TN packed in a location which has a different TN -currently live, then there is a packing bug. If any of the TNs recorded as -being live at the block beginning are packed in a scarce SB, but aren't current -in that location, then we also have a problem. - -The conflict structure for load TNs is fairly simple, the load TNs for -arguments and results all conflict with each other, and don't conflict with -much else. We just try packing in targeted locations before trying at random. - - - -\chapter{Code generation} - -This is fairly straightforward. We translate VOPs into instruction sequences -on a per-block basis. - -After code generation, the VMR representation is gone. Everything is -represented by the assembler data structures. - - -\chapter{Assembly} - -In effect, we do much of the work of assembly when the compiler is compiled. - -The assembler makes one pass fixing up branch offsets, then squeezes out the -space left by branch shortening and dumps out the code along with the load-time -fixup information. The assembler also deals with dumping unboxed non-immediate -constants and symbols. Boxed constants are created by explicit constructor -code in the top-level form, while immediate constants are generated using -inline code. - -[\#\#\# The basic output of the assembler is: - A code vector - A representation of the fixups along with indices into the code vector for - the fixup locations - A PC map translating PCs into source paths - -This information can then be used to build an output file or an in-core -function object. -] - -The assembler is table-driven and supports arbitrary instruction formats. As -far as the assembler is concerned, an instruction is a bit sequence that is -broken down into subsequences. Some of the subsequences are constant in value, -while others can be determined at assemble or load time. - -Assemble Node Form* - Allow instructions to be emitted during the evaluation of the Forms by - defining Inst as a local macro. This macro caches various global - information in local variables. Node tells the assembler what node - ultimately caused this code to be generated. This is used to create the - pc=>source map for the debugger. - -Assemble-Elsewhere Node Form* - Similar to Assemble, but the current assembler location is changed to - somewhere else. This is useful for generating error code and similar - things. Assemble-Elsewhere may not be nested. - -Inst Name Arg* - Emit the instruction Name with the specified arguments. - -Gen-Label -Emit-Label (Label) - Gen-Label returns a Label object, which describes a place in the code. - Emit-Label marks the current position as being the location of Label. - - - -\chapter{Dumping} - -So far as input to the dumper/loader, how about having a list of Entry-Info -structures in the VMR-Component? These structures contain all information -needed to dump the associated function objects, and are only implicitly -associated with the functional/XEP data structures. Load-time constants that -reference these function objects should specify the Entry-Info, rather than the -functional (or something). We would then need to maintain some sort of -association so VMR conversion can find the appropriate Entry-Info. -Alternatively, we could initially reference the functional, and then later -clobber the reference to the Entry-Info. - -We have some kind of post-pass that runs after assembly, going through the -functions and constants, annotating the VMR-Component for the benefit of the -dumper: - Resolve :Label load-time constants. - Make the debug info. - Make the entry-info structures. - -Fasl dumper and in-core loader are implementation (but not instruction set) -dependent, so we want to give them a clear interface. - -open-fasl-file name => fasl-file - Returns a "fasl-file" object representing all state needed by the dumper. - We objectify the state, since the fasdumper should be reentrant. (but - could fail to be at first.) - -close-fasl-file fasl-file abort-p - Close the specified fasl-file. - -fasl-dump-component component code-vector length fixups fasl-file - Dump the code, constants, etc. for component. Code-Vector is a vector - holding the assembled code. Length is the number of elements of Vector - that are actually in use. Fixups is a list of conses (offset . fixup) - describing the locations and things that need to be fixed up at load time. - If the component is a top-level component, then the top-level lambda will - be called after the component is loaded. - -load-component component code-vector length fixups - Like Fasl-Dump-Component, but directly installs the code in core, running - any top-level code immediately. (???) but we need some way to glue - together the componenents, since we don't have a fasl table. - - - -Dumping: - -Dump code for each component after compiling that component, but defer dumping -of other stuff. We do the fixups on the code vectors, and accumulate them in -the table. - -We have to grovel the constants for each component after compiling that -component so that we can fix up load-time constants. Load-time constants are -values needed my the code that are computed after code generation/assembly -time. Since the code is fixed at this point, load-time constants are always -represented as non-immediate constants in the constant pool. A load-time -constant is distinguished by being a cons (Kind . What), instead of a Constant -leaf. Kind is a keyword indicating how the constant is computed, and What is -some context. - -Some interesting load-time constants: - - (:label . <label>) - Is replaced with the byte offset of the label within the code-vector. - - (:code-vector . <component>) - Is replaced by the component's code-vector. - - (:entry . <function>) - (:closure-entry . <function>) - Is replaced by the function-entry structure for the specified function. - :Entry is how the top-level component gets a handle on the function - definitions so that it can set them up. - -We also need to remember the starting offset for each entry, although these -don't in general appear as explicit constants. - -We then dump out all the :Entry and :Closure-Entry objects, leaving any -constant-pool pointers uninitialized. After dumping each :Entry, we dump some -stuff to let genesis know that this is a function definition. Then we dump all -the constant pools, fixing up any constant-pool pointers in the already-dumped -function entry structures. - -The debug-info *is* a constant: the first constant in every constant pool. But -the creation of this constant must be deferred until after the component is -compiled, so we leave a (:debug-info) placeholder. [Or maybe this is -implicitly added in by the dumper, being supplied in a VMR-component slot.] - - - Work out details of the interface between the back-end and the - assembler/dumper. - - Support for multiple assemblers concurrently loaded? (for byte code) - - We need various mechanisms for getting information out of the assembler. - - We can get entry PCs and similar things into function objects by making a - Constant leaf, specifying that it goes in the closure, and then - setting the value after assembly. - - We have an operation Label-Value which can be used to get the value of a - label after assembly and before the assembler data structures are - deallocated. - - The function map can be constructed without any special help from the - assembler. Codegen just has to note the current label when the function - changes from one block to the next, and then use the final value of these - labels to make the function map. - - Probably we want to do the source map this way too. Although this will - make zillions of spurious labels, we would have to effectively do that - anyway. - - With both the function map and the source map, getting the locations right - for uses of Elsewhere will be a bit tricky. Users of Elsewhere will need - to know about how these maps are being built, since they must record the - labels and corresponding information for the elsewhere range. It would be - nice to have some cooperation from Elsewhere so that this isn't necessary, - otherwise some VOP writer will break the rules, resulting in code that is - nowhere. - - The Debug-Info and related structures are dumped by consing up the - structure and making it be the value of a constant. - - Getting the code vector and fixups dumped may be a bit more interesting. I - guess we want a Dump-Code-Vector function which dumps the code and fixups - accumulated by the current assembly, returning a magic object that will - become the code vector when it is dumped as a constant. -] diff --git a/docs/internals/compiler-overview.tex b/docs/internals/compiler-overview.tex deleted file mode 100644 index 74182cd550d07d7bc187912d94d722f0792c5a7a..0000000000000000000000000000000000000000 --- a/docs/internals/compiler-overview.tex +++ /dev/null @@ -1,540 +0,0 @@ -\chapter{Compiler Overview} % -*- Dictionary: design -*- - -The structure of the compiler may be broadly characterized by describing the -compilation phases and the data structures that they manipulate. The steps in -the compilation are called phases rather than passes since they don't -necessarily involve a full pass over the code. The data structure used to -represent the code at some point is called an {\it intermediate -representation.} - -Two major intermediate representations are used in the compiler: -\begin{itemize} - -\item The Implicit Continuation Representation (ICR) represents the lisp-level -semantics of the source code during the initial phases. Partial evaluation and -semantic analysis are done on this representation. ICR is roughly equivalent -to a subset of Common Lisp, but is represented as a flow-graph rather than a -syntax tree. Phases which only manipulate ICR comprise the "front end". It -would be possible to use a different back end such as one that directly -generated code for a stack machine. - -\item The Virtual Machine Representation (VMR) represents the implementation of -the source code on a virtual machine. The virtual machine may vary depending -on the the target hardware, but VMR is sufficiently stylized that most of the -phases which manipulate it are portable. -\end{itemize} - -Each phase is briefly described here. The phases from ``local call analysis'' -to ``constraint propagation'' all interact; for maximum optimization, they -are generally repeated until nothing new is discovered. The source files which -primarily contain each phase are listed after ``Files: ''. -\begin{description} - -\item[ICR conversion] -Convert the source into ICR, doing macroexpansion and simple source-to-source -transformation. All names are resolved at this time, so we don't have to worry -about name conflicts later on. Files: {\tt ir1tran, srctran, typetran} - -\item[Local call analysis] Find calls to local functions and convert them to -local calls to the correct entry point, doing keyword parsing, etc. Recognize -once-called functions as lets. Create {\it external entry points} for -entry-point functions. Files: {\tt locall} - -\item[Find components] -Find flow graph components and compute depth-first ordering. Separate -top-level code from run-time code, and determine which components are top-level -components. Files: {\tt dfo} - -\item[ICR optimize] A grab-bag of all the non-flow ICR optimizations. Fold -constant functions, propagate types and eliminate code that computes unused -values. Special-case calls to some known global functions by replacing them -with a computed function. Merge blocks and eliminate IF-IFs. Substitute let -variables. Files: {\tt ir1opt, ir1tran, typetran, seqtran, vm/vm-tran} - -\item[Type constraint propagation] -Use global flow analysis to propagate information about lexical variable -types. Eliminate unnecessary type checks and tests. Files: {\tt constraint} - -\item[Type check generation] -Emit explicit ICR code for any necessary type checks that are too complex to be -easily generated on the fly by the back end. Files: {\tt checkgen} - -\item[Event driven operations] -Various parts of ICR are incrementally recomputed, either eagerly on -modification of the ICR, or lazily, when the relevant information is needed. -\begin{itemize} -\item Check that type assertions are satisfied, marking places where type -checks need to be done. - -\item Locate let calls. - -\item Delete functions and variables with no references -\end{itemize} -Files: {\tt ir1util}, {\tt ir1opt} - -\item[ICR finalize] -This phase is run after all components have been compiled. It scans the -global variable references, looking for references to undefined variables -and incompatible function redefinitions. Files: {\tt ir1final}, {\tt main}. - -\item[Environment analysis] -Determine which distinct environments need to be allocated, and what -context needed to be closed over by each environment. We detect non-local -exits and set closure variables. We also emit cleanup code as funny -function calls. This is the last pure ICR pass. Files: {\tt envanal} - -\item[Global TN allocation (GTN)] -Iterate over all defined functions, determining calling conventions -and assigning TNs to local variables. Files: {\tt gtn} - -\item[Local TN allocation (LTN)] -Use type and policy information to determine which VMR translation to use -for known functions, and then create TNs for expression evaluation -temporaries. We also accumulate some random information needed by VMR -conversion. Files: {\tt ltn} - -\item[Control analysis] -Linearize the flow graph in a way that minimizes the number of branches. The -block-level structure of the flow graph is basically frozen at this point. -Files: {\tt control} - -\item[Stack analysis] -Maintain stack discipline for unknown-values continuation in the presence -of local exits. Files: {\tt stack} - -\item[Entry analysis] -Collect some back-end information for each externally callable function. - -\item[VMR conversion] Convert ICR into VMR by translating nodes into VOPs. -Emit type checks. Files: {\tt ir2tran, vmdef} - -\item[Copy propagation] Use flow analysis to eliminate unnecessary copying of -TN values. Files: {\tt copyprop} - -\item[Representation selection] -Look at all references to each TN to determine which representation has the -lowest cost. Emit appropriate move and coerce VOPS for that representation. - -\item[Lifetime analysis] -Do flow analysis to find the set of TNs whose lifetimes -overlap with the lifetimes of each TN being packed. Annotate call VOPs with -the TNs that need to be saved. Files: {\tt life} - -\item[Pack] -Find a legal register allocation, attempting to minimize unnecessary moves. -Files: {\tt pack} - -\item[Code generation] -Call the VOP generators to emit assembly code. Files: {\tt codegen} - -\item[Pipeline reorganization] On some machines, move memory references -backward in the code so that they can overlap with computation. On machines -with delayed branch instructions, locate instructions that can be moved into -delay slots. Files: {\tt assem-opt} - -\item[Assembly] -Resolve branches and convert in to object code and fixup information. -Files: {\tt assembler} - -\item[Dumping] Convert the compiled code into an object file or in-core -function. Files: {\tt debug-dump}, {\tt dump}, {\tt vm/core} - -\end{description} - -\chapter{The Implicit Continuation Representation} - -The set of special forms recognized is exactly that specified in the Common -Lisp manual. Everything that is described as a macro in CLTL is a macro. - -Large amounts of syntactic information are thrown away by the conversion to an -anonymous flow graph representation. The elimination of names eliminates the -need to represent most environment manipulation special forms. The explicit -representation of control eliminates the need to represent BLOCK and GO, and -makes flow analysis easy. The full Common Lisp LAMBDA is implemented with a -simple fixed-arg lambda, which greatly simplifies later code. - -The elimination of syntactic information eliminates the need for most of the -"beta transformation" optimizations in Rabbit. There are no progns, no -tagbodys and no returns. There are no "close parens" which get in the way of -determining which node receives a given value. - -In ICR, computation is represented by Nodes. These are the node types: -\begin{description} -\item[if] Represents all conditionals. - -\item[set] Represents a {\tt setq}. - -\item[ref] Represents a constant or variable reference. - -\item[combination] Represents a normal function call. - -\item[MV-combination] Represents a {\tt multiple-value-call}. This is used to -implement all multiple value receiving forms except for {\tt -multiple-value-prog1}, which is implicit. - -\item[bind] -This represents the allocation and initialization of the variables in -a lambda. - -\item[return] -This collects the return value from a lambda and represents the -control transfer on return. - -\item[entry] Marks the start of a dynamic extent that can have non-local exits -to it. Dynamic state can be saved at this point for restoration on re-entry. - -\item[exit] Marks a potentially non-local exit. This node is interposed -between the non-local uses of a continuation and the {\tt dest} so that code to -do a non-local exit can be inserted if necessary. -\end{description} - -Some slots are shared between all node types (via defstruct inheritance.) This -information held in common between all nodes often makes it possible to avoid -special-casing nodes on the basis of type. This shared information is -primarily concerned with the order of evaluation and destinations and -properties of results. This control and value flow is indicated in the node -primarily by pointing to continuations. - -The {\tt continuation} structure represents information sufficiently related -to the normal notion of a continuation that naming it so seems sensible. -Basically, a continuation represents a place in the code, or alternatively the -destination of an expression result and a transfer of control. These two -notions are bound together for the same reasons that they are related in the -standard functional continuation interpretation. - -A continuation may be deprived of either or both of its value or control -significance. If the value of a continuation is unused due to evaluation for -effect, then the continuation will have a null {\tt dest}. If the {\tt next} -node for a continuation is deleted by some optimization, then {\tt next} will -be {\tt :none}. - - [\#\#\# Continuation kinds...] - -The {\tt block} structure represents a basic block, in the the normal sense. -Control transfers other than simple sequencing are represented by information -in the block structure. The continuation for the last node in a block -represents only the destination for the result. - -It is very difficult to reconstruct anything resembling the original source -from ICR, so we record the original source form in each node. The location of -the source form within the input is also recorded, allowing for interfaces such -as "Edit Compiler Warnings". See section \ref{source-paths}. - -Forms such as special-bind and catch need to have cleanup code executed at all -exit points from the form. We represent this constraint in ICR by annotating -the code syntactically within the form with a Cleanup structure describing what -needs to be cleaned up. Environment analysis determines the cleanup locations -by watching for a change in the cleanup between two continuations. We can't -emit cleanup code during ICR conversion, since we don't know which exits will -be local until after ICR optimizations are done. - -Special binding is represented by a call to the funny function %Special-Bind. -The first argument is the Global-Var structure for the variable bound and the -second argument is the value to bind it to. - -Some subprimitives are implemented using a macro-like mechanism for translating -%PRIMITIVE forms into arbitrary lisp code. Subprimitives special-cased by VMR -conversion are represented by a call to the funny function %%Primitive. The -corresponding Template structure is passed as the first argument. - -We check global function calls for syntactic legality with respect to any -defined function type function. If the call is illegal or we are unable to -tell if it is legal due to non-constant keywords, then we give a warning and -mark the function reference as :notinline to force a full call and cause -subsequent phases to ignore the call. If the call is legal and is to a known -function, then we annotate the Combination node with the Function-Info -structure that contains the compiler information for the function. - - -\section{Tail sets} -\#| -Probably want to have a GTN-like function result equivalence class mechanism -for ICR type inference. This would be like the return value propagation being -done by Propagate-From-Calls, but more powerful, less hackish, and known to -terminate. The ICR equivalence classes could probably be used by GTN, as well. - -What we do is have local call analysis eagerly maintain the equivalence classes -of functions that return the same way by annotating functions with a Tail-Info -structure shared between all functions whose value could be the value of this -function. We don't require that the calls actually be tail-recursive, only -that the call deliver its value to the result continuation. [\#\#\# Actually -now done by ICR-OPTIMIZE-RETURN, which is currently making ICR optimize -mandatory.] - -We can then use the Tail-Set during ICR type inference. It would have a type -that is the union across all equivalent functions of the types of all the uses -other than in local calls. This type would be recomputed during optimization -of return nodes. When the type changes, we would propagate it to all calls to -any of the equivalent functions. How do we know when and how to recompute the -type for a tail-set? Recomputation is driven by type propagation on the result -continuation. - -This is really special-casing of RETURN nodes. The return node has the type -which is the union of all the non-call uses of the result. The tail-set is -found though the lambda. We can then recompute the overall union by taking the -union of the type per return node, rather than per-use. - - -How do result type assertions work? We can't intersect the assertions across -all functions in the equivalence class, since some of the call combinations may -not happen (or even be possible). We can intersect the assertion of the result -with the derived types for non-call uses. - -When we do a tail call, we obviously can't check that the returned value -matches our assertion. Although in principle, we would like to be able to -check all assertions, to preserve system integrity, we only need to check -assertions that we depend on. We can afford to lose some assertion information -as long as we entirely lose it, ignoring it for type inference as well as for -type checking. - -Things will work out, since the caller will see the tail-info type as the -derived type for the call, and will emit a type check if it needs a stronger -result. - -A remaining question is whether we should intersect the assertion with -per-RETURN derived types from the very beginning (i.e. before the type check -pass). I think the answer is yes. We delay the type check pass so that we can -get our best guess for the derived type before we decide whether a check is -necessary. But with the function return type, we aren't committing to doing -any type check when we intersect with the type assertion; the need to type -check is still determined in the type check pass by examination of the result -continuation. - -What is the relationship between the per-RETURN types and the types in the -result continuation? The assertion is exactly the Continuation-Asserted-Type -(note that the asserted type of result continuations will never change after -ICR conversion). The per-RETURN derived type is different than the -Continuation-Derived-Type, since it is intersected with the asserted type even -before Type Check runs. Ignoring the Continuation-Derived-Type probably makes -life simpler anyway, since this breaks the potential circularity of the -Tail-Info-Type will affecting the Continuation-Derived-Type, which affects... - -When a given return has no non-call uses, we represent this by using -*empty-type*. This consistent with the interpretation that a return type of -NIL means the function can't return. - - -\section{Hairy function representation} - -Non-fixed-arg functions are represented using Optional-Dispatch. An -Optional-Dispatch has an entry-point function for each legal number of -optionals, and one for when extra args are present. Each entry point function -is a simple lambda. The entry point function for an optional is passed the -arguments which were actually supplied; the entry point function is expected to -default any remaining parameters and evaluate the actual function body. - -If no supplied-p arg is present, then we can do this fairly easily by having -each entry point supply its default and call the next entry point, with the -last entry point containing the body. If there are supplied-p args, then entry -point function is replaced with a function that calls the original entry -function with T's inserted at the position of all the supplied args with -supplied-p parameters. - -We want to be a bit clever about how we handle arguments declared special when -doing optional defaulting, or we will emit really gross code for special -optionals. If we bound the arg specially over the entire entry-point function, -then the entry point function would be caused to be non-tail-recursive. What -we can do is only bind the variable specially around the evaluation of the -default, and then read the special and store the final value of the special -into a lexical variable which we then pass as the argument. In the common case -where the default is a constant, we don't have to special-bind at all, since -the computation of the default is not affected by and cannot affect any special -bindings. - -Keyword and rest args are both implemented using a LEXPR-like "more args" -convention. The More-Entry takes two arguments in addition to the fixed and -optional arguments: the argument context and count. (ARG <context> <n>) -accesses the N'th additional argument. Keyword args are implemented directly -using this mechanism. Rest args are created by calling %Listify-Rest-Args with -the context and count. - -The More-Entry parses the keyword arguments and passes the values to the main -function as positional arguments. If a keyword default is not constant, then -we pass a supplied-p parameter into the main entry and let it worry about -defaulting the argument. Since the main entry accepts keywords in parsed form, -we can parse keywords at compile time for calls to known functions. We keep -around the original parsed lambda-list and related information so that people -can figure out how to call the main entry. - - -\section{ICR representation of non-local exits} - -All exits are initially represented by EXIT nodes: -How about an Exit node: - (defstruct (exit (:include node)) - value) -The Exit node uses the continuation that is to receive the thrown Value. -During optimization, if we discover that the Cont's home-lambda is the same is -the exit node's, then we can delete the Exit node, substituting the Cont for -all of the Value's uses. - -The successor block of an EXIT is the entry block in the entered environment. -So we use the Exit node to mark the place where exit code is inserted. During -environment analysis, we need only insert a single block containing the entry -point stub. - -We ensure that all Exits that aren't for a NLX don't have any Value, so that -local exits never require any value massaging. - -The Entry node marks the beginning of a block or tagbody: - (defstruct (entry (:include node)) - (continuations nil :type list)) - -It contains a list of all the continuations that the body could exit to. The -Entry node is used as a marker for the the place to snapshot state, including -the control stack pointer. Each lambda has a list of its Entries so -that environment analysis can figure out which continuations are really being -closed over. There is no reason for optimization to delete Entry nodes, -since they are harmless in the degenerate case: we just emit no code (like a -no-var let). - - -We represent CATCH using the lexical exit mechanism. We do a transformation -like this: - (catch 'foo xxx) ==> - (block \#:foo - (%catch \#'(lambda () (return-from \#:foo (%unknown-values))) 'foo) - (%within-cleanup :catch - xxx)) - -%CATCH just sets up the catch frame which points to the exit function. %Catch -is an ordinary function as far as ICR is concerned. The fact that the catcher -needs to be cleaned up is expressed by the Cleanup slots in the continuations -in the body. %UNKNOWN-VALUES is a dummy function call which represents the -fact that we don't know what values will be thrown. - -%WITHIN-CLEANUP is a special special form that instantiates its first argument -as the current cleanup when converting the body. In reality, the lambda is -also created by the special special form %ESCAPE-FUNCTION, which gives the -lambda a special :ESCAPE kind so that the back end knows not to generate any -code for it. - - -We use a similar hack in Unwind-Protect to represent the fact that the cleanup -forms can be invoked at arbitrarily random times. - (unwind-protect p c) ==> - (flet ((\#:cleanup () c)) - (block \#:return - (multiple-value-bind - (\#:next \#:start \#:count) - (block \#:unwind - (%unwind-protect \#'(lambda (x) (return-from \#:unwind x))) - (%within-cleanup :unwind-protect - (return-from \#:return p))) - (\#:cleanup) - (%continue-unwind \#:next \#:start \#:count)))) - -We use the block \#:unwind to represent the entry to cleanup code in the case -where we are non-locally unwound. Calling of the cleanup function in the -drop-through case (or any local exit) is handled by cleanup generation. We -make the cleanup a function so that cleanup generation can add calls at local -exits from the protected form. \#:next, \#:start and \#:count are state used in -the case where we are unwound. They indicate where to go after doing the -cleanup and what values are being thrown. The cleanup encloses only the -protected form. As in CATCH, the escape function is specially tagged as -:ESCAPE. The cleanup function is tagged as :CLEANUP to inhibit let conversion -(since references are added in environment analysis.) - -Notice that implementing these forms using closures over continuations -eliminates any need to special-case ICR flow analysis. Obviously we don't -really want to make heap-closures here. In reality these functions are -special-cased by the back-end according to their KIND. - - -\section{Block compilation} - -One of the properties of ICR is that supports "block compilation" by allowing -arbitrarily large amounts of code to be converted at once, with actual -compilation of the code being done at will. - - -In order to preserve the normal semantics we must recognize that proclamations -(possibly implicit) are scoped. A proclamation is in effect only from the time -of appearance of the proclamation to the time it is contradicted. The current -global environment at the end of a block is not necessarily the correct global -environment for compilation of all the code within the block. We solve this -problem by closing over the relevant information in the ICR at the time it is -converted. For example, each functional variable reference is marked as -inline, notinline or don't care. Similarly, each node contains a structure -known as a Cookie which contains the appropriate settings of the compiler -policy switches. - -We actually convert each form in the file separately, creating a separate -"initial component" for each one. Later on, these components are merged as -needed. The main reason for doing this is to cause EVAL-WHEN processing to be -interleaved with reading. - - -\section{Entry points} - -\#| - -Since we need to evaluate potentially arbitrary code in the XEP argument forms -(for type checking), we can't leave the arguments in the wired passing -locations. Instead, it seems better to give the XEP max-args fixed arguments, -with the passing locations being the true passing locations. Instead of using -%XEP-ARG, we reference the appropriate variable. - -Also, it might be a good idea to do argument count checking and dispatching -with explicit conditional code in the XEP. This would simplify both the code -that creates the XEP and the VMR conversion of XEPs. Also, argument count -dispatching would automatically benefit from any cleverness in compilation of -case-like forms (jump tables, etc). On the downside, this would push some -assumptions about how arg dispatching is done into ICR. But then we are -currently violating abstraction at least as badly in VMR conversion, which is -also supposed to be implementation independent. -|\# - -As a side-effect of finding which references to known functions can be -converted to local calls, we find any references that cannot be converted. -References that cannot be converted to a local call must evaluate to a -"function object" (or function-entry) that can be called using the full call -convention. A function that can be called from outside the component is called -an "entry-point". - -Lots of stuff that happens at compile-time with local function calls must be -done at run-time when an entry-point is called. - -It is desirable for optimization and other purposes if all the calls to every -function were directly present in ICR as local calls. We cannot directly do -this with entry-point functions, since we don't know where and how the -entry-point will be called until run-time. - -What we do is represent all the calls possible from outside the component by -local calls within the component. For each entry-point function, we create a -corresponding lambda called the external entry point or XEP. This is a -function which takes the number of arguments passed as the first argument, -followed by arguments corresponding to each required or optional argument. - -If an optional argument is unsupplied, the value passed into the XEP is -undefined. The XEP is responsible for doing argument count checking and -dispatching. - -In the case of a fixed-arg lambda, we emit a call to the %VERIFY-ARGUMENT-COUNT -funny function (conditional on policy), then call the real function on the -passed arguments. Even in this simple case, we benefit several ways from -having a separate XEP: - -- The argument count checking is factored out, and only needs to be done in - full calls. - -- Argument type checking happens automatically as a consequence of passing - the XEP arguments in a local call to the real function. This type checking - is also only done in full calls. - -- The real function may use a non-standard calling convention for the benefit - of recursive or block-compiled calls. The XEP converts arguments/return - values to/from the standard convention. This also requires little - special-casing of XEPs. - -If the function has variable argument count (represented by an -OPTIONAL-DISPATCH), then the XEP contains a COND which dispatches off of the -argument count, calling the appropriate entry-point function (which then does -defaulting). If there is a more entry (for keyword or rest args), then the XEP -obtains the more arg context and count by calling the %MORE-ARG-CONTEXT funny -function. - -All non-local-call references to functions are replaced with references to the -corresponding XEP. ICR optimization may discover a local call that was -previously a non-local reference. When we delete the reference to the XEP, we -may find that it has no references. In this case, we can delete the XEP, -causing the function to no longer be an entry-point. - - \ No newline at end of file diff --git a/docs/internals/compiler.tex b/docs/internals/compiler.tex deleted file mode 100644 index 4f8372a52ee4ba4e77fc442c7bd441efb1cb0d9f..0000000000000000000000000000000000000000 --- a/docs/internals/compiler.tex +++ /dev/null @@ -1,6 +0,0 @@ -\part{Compiler Organization} -\include{compiler-overview} -\include{front} -\include{middle} -\include{back} -\include{interface} diff --git a/docs/internals/debugger.tex b/docs/internals/debugger.tex deleted file mode 100644 index baeeaa46edf2c4e1d948ba1f3e11988c9fbc3718..0000000000000000000000000000000000000000 --- a/docs/internals/debugger.tex +++ /dev/null @@ -1,537 +0,0 @@ -% -*- Dictionary: design; Package: C -*- - -\#| -\chapter{Debugger Information} -\index{debugger information} -\label{debug-info} - -Although the compiler's great freedom in choice of function call conventions -and variable representations has major efficiency advantages, it also has -unfortunate consequences for the debugger. The debug information that we need -is even more elaborate than for conventional "compiled" languages, since we -cannot even do a simple backtrace without some debug information. However, -once having gone this far, it is not that difficult to go the extra distance, -and provide full source level debugging of compiled code. - -Full debug information has a substantial space penalty, so we allow different -levels of debug information to be specified. In the extreme case, we can -totally omit debug information. - - -\section{The Debug-Info Structure} -\index{debug-info structure} - -The Debug-Info structure directly represents information about the -source code, and points to other structures that describe the layout of -run-time data structures. - - -Make some sort of minimal debug-info format that would support at least the -common cases of level 1 (since that is what we would release), and perhaps -level 0. Actually, it seems it wouldn't be hard to crunch nearly all of the -debug-function structure and debug-info function map into a single byte-vector. -We could have an uncrunch function that restored the current format. This -would be used by the debugger, and also could be used by purify to delete parts -of the debug-info even when the compiler dumps it in crunched form. -[Note that this isn't terribly important if purify is smart about -debug-info...] -|\# - - -Compiled source map representation: - -[\#\#\# store in debug-function PC at which env is properly initialized, i.e. -args (and return-pc, etc.) in internal locations. This is where a -:function-start breakpoint would break.] - -[\#\#\# Note that that we can easily cache the form-number => source-path or -form-number => form translation using a vector indexed by form numbers that we -build during a walk.] - - - - -Instead of using source paths in the debug-info, use "form numbers". The form -number of a form is the number of forms that we walk to reach that form when -doing a pre-order walk of the source form. [Might want to use a post-order -walk, as that would more closely approximate evaluation order.] - - -We probably want to continue using source-paths in the compiler, since they are -quick to compute and to get you to a particular form. [\#\#\# But actually, I -guess we don't have to precompute the source paths and annotate nodes with -them: instead we could annotate the nodes with the actual original source form. -Then if we wanted to find the location of that form, we could walk the root -source form, looking that original form. But we might still need to enter all -the forms in a hashtable so that we can tell during IR1 conversion that a given -form appeared in the original source.] - - -Note that form numbers have an interesting property: it is quite efficient to -determine whether an arbitrary form is a subform of some other form, since the -form number of B will be > than A's number and < A's next sibling's number iff -B is a subform of A. - -This should be quite useful for doing the source=>pc mapping in the debugger, -since that problem reduces to finding the subset of the known locations that -are for subforms of the specified form. - - -Assume a byte vector with a standard variable-length integer format, something -like this: - 0..253 => the integer - 254 => read next two bytes for integer - 255 => read next four bytes for integer - -Then a compiled debug block is just a sequence of variable-length integers in a -particular order, something like this: - number of successors - ...offsets of each successor in the function's blocks vector... - first PC - [offset of first top-level form (in forms) (only if not component default)] - form number of first source form - first live mask (length in bytes determined by number of VARIABLES) - ...more <PC, top-level form offset, form-number, live-set> tuples... - -We determine the number of locations recorded in a block by the finding the -start of the next compiled debug block in the blocks vector. - -[\#\#\# Actually, only need 2 bits for number of successors {0,1,2}. We might -want to use other bits in the first byte to indicate the kind of location.] -[\#\#\# We could support local packing by having a general concept of "alternate -locations" instead of just regular and save locations. The location would have -a bit indicating that there are alternate locations, in which case we read the -number of alternate locations and then that many more SC-OFFSETs. In the -debug-block, we would have a second bit mask with bits set for TNs that are in -an alternate location. We then read a number for each such TN, with the value -being interpreted as an index into the Location's alternate locations.] - - - -It looks like using structures for the compiled-location-info is too bulky. -Instead we need some packed binary representation. - -First, let's represent a SC/offset pair with an "SC-Offset", which is an -integer with the SC in the low 5 bits and the offset in the remaining bits: - ---------------------------------------------------- - | Offset (as many bits as necessary) | SC (5 bits) | - ---------------------------------------------------- -Probably the result should be constrained to fit in a fixnum, since it will be -more efficient and gives more than enough possible offsets. - -We can the represent a compiled location like this: - single byte of boolean flags: - uninterned name - packaged name - environment-live - has distinct save location - has ID (name not unique in this fun) - name length in bytes (as var-length integer) - ...name bytes... - [if packaged, var-length integer that is package name length] - ...package name bytes...] - [If has ID, ID as var-length integer] - SC-Offset of primary location (as var-length integer) - [If has save SC, SC-Offset of save location (as var-length integer)] - - - - -But for a whizzy breakpoint facility, we would need a good source=>code map. -Dumping a complete code=>source map might be as good a way as any to represent -this, due to the one-to-many relationship between source and code locations. - -We might be able to get away with just storing the source locations for the -beginnings of blocks and maintaining a mapping from code ranges to blocks. -This would be fine both for the profiler and for the "where am I running now" -indication. Users might also be convinced that it was most interesting to -break at block starts, but I don't really know how easily people could develop -an understanding of basic blocks. - -It could also be a bit tricky to map an arbitrary user-designated source -location to some "closest" source location actually in the debug info. -This problem probably exists to some degree even with a full source map, since -some forms will never appear as the source of any node. It seems you might -have to negotiate with the user. He would mouse something, and then you would -highlight some source form that has a common prefix (i.e. is a prefix of the -user path, or vice-versa.) If they aren't happy with the result, they could -try something else. In some cases, the designated path might be a prefix of -several paths. This ambiguity might be resolved by picking the shortest path -or letting the user choose. - -At the primitive level, I guess what this means is that the structure of source -locations (i.e. source paths) must be known, and the source=>code operation -should return a list of <source,code> pairs, rather than just a list of code -locations. This allows the debugger to resolve the ambiguity however it wants. - -I guess the formal definition of which source paths we would return is: - All source paths in the debug info that have a maximal common prefix with - the specified path. i.e. if several paths have the complete specified path - as a prefix, we return them all. Otherwise, all paths with an equally - large common prefix are returned: if the path with the most in common - matches only the first three elements, then we return all paths that match - in the first three elements. As a degenerate case (which probably - shouldn't happen), if there is no path with anything in common, then we - return *all* of the paths. - - - -In the DEBUG-SOURCE structure we may ultimately want a vector of the start -positions of each source form, since that would make it easier for the debugger -to locate the source. It could just open the file, FILE-POSITION to the form, -do a READ, then loop down the source path. Of course, it could read each form -starting from the beginning, but that might be too slow. - - -Do XEPs really need Debug-Functions? The only time that we will commonly end -up in the debugger on an XEP is when an argument type check fails. But I -suppose it would be nice to be able to print the arguments passed... - - -Note that assembler-level code motion such as pipeline reorganization can cause -problems with our PC maps. The assembler needs to know that debug info markers -are different from real labels anyway, so I suppose it could inhibit motion -across debug markers conditional on policy. It seems unworthwhile to remember -the node for each individual instruction. - - -For tracing block-compiled calls: - Info about return value passing locations? - Info about where all the returns are? - -We definitely need the return-value passing locations for debug-return. The -question is what the interface should be. We don't really want to have a -visible debug-function-return-locations operation, since there are various -value passing conventions, and we want to paper over the differences. - - -Probably should be a compiler option to initialize stack frame to a special -uninitialized object (some random immediate type). This would aid debugging, -and would also help GC problems. For the latter reason especially, this should -be locally-turn-onable (off of policy? the new debug-info quality?). - - -What about the interface between the evaluator and the debugger? (i.e. what -happens on an error, etc.) Compiler error handling should be integrated with -run-time error handling. Ideally the error messages should look the same. -Practically, in some cases the run-time errors will have less information. But -the error should look the same to the debugger (or at least similar). - - - -;;;; Debugger interface: - -How does the debugger interface to the "evaluator" (where the evaluator means -all of native code, byte-code and interpreted IR1)? It seems that it would be -much more straightforward to have a consistent user interface to debugging -all code representations if there was a uniform debugger interface to the -underlying stuff, and vice-versa. - -Of course, some operations might not be supported by some representations, etc. -For example, fine-control stepping might not be available in native code. -In other cases, we might reduce an operation to the lowest common denominator, -for example fetching lexical variables by string and admitting the possibility -of ambiguous matches. [Actually, it would probably be a good idea to store the -package if we are going to allow variables to be closed over.] - -Some objects we would need: -Location: - The constant information about the place where a value is stored, - everything but which particular frame it is in. Operations: - location name, type, etc. - location-value frame location (setf'able) - monitor-location location function - Function is called whenever location is set with the location, - frame and old value. If active values aren't supported, then we - dummy the effect using breakpoints, in which case the change won't - be noticed until the end of the block (and intermediate changes - will be lost.) -debug info: - All the debug information for a component. -Frame: - frame-changed-locations frame => location* - Return a list of the locations in frame that were changed since the - last time this function was called. Or something. This is for - displaying interesting state changes at breakpoints. - save-frame-state frame => frame-state - restore-frame-state frame frame-state - These operations allow the debugger to back up evaluation, modulo - side-effects and non-local control transfers. This copies and - restores all variables, temporaries, etc, local to the frame, and - also the current PC and dynamic environment (current catch, etc.) - - At the time of the save, the frame must be for the running function - (not waiting for a call to return.) When we restore, the frame - becomes current again, effectively exiting from any frames on top. - (Of course, frame must not already be exited.) - -Thread: - Representation of which stack to use, etc. -Block: - What successors the block has, what calls there are in the block. - (Don't need to know where calls are as long as we know called function, - since can breakpoint at the function.) Whether code in this block is - wildly out of order due to being the result of loop-invariant - optimization, etc. Operations: - block-successors block => code-location* - block-forms block => (source-location code-location)* - Return the corresponding source locations and code locations for - all forms (and form fragments) in the block. - - -Variable maps: - -There are about five things that the debugger might want to know about a -variable: - - Name - Although a lexical variable's name is "really" a symbol (package and - all), in practice it doesn't seem worthwhile to require all the symbols - for local variable names to be retained. There is much less VM and GC - overhead for a constant string than for a symbol. (Also it is useful - to be able to access gensyms in the debugger, even though they are - theoretically ineffable). - - ID - Which variable with the specified name is this? It is possible to have - multiple variables with the same name in a given function. The ID is - something that makes Name unique, probably a small integer. When - variables aren't unique, we could make this be part of the name, e.g. - "FOO\#1", "FOO\#2". But there are advantages to keeping this separate, - since in many cases lifetime information can be used to disambiguate, - making qualification unnecessary. - - SC - When unboxed representations are in use, we must have type information - to properly read and write a location. We only need to know the - SC for this, which would be amenable to a space-saving - numeric encoding. - - Location - Simple: the offset in SC. [Actually, we need the save location too.] - - Lifetime - In what parts of the program does this variable hold a meaningful - value? It seems prohibitive to record precise lifetime information, - both in space and compiler effort, so we will have to settle for some - sort of approximation. - - The finest granularity at which it is easy to determine liveness is the - the block: we can regard the variable lifetime as the set of blocks - that the variable is live in. Of course, the variable may be dead (and - thus contain meaningless garbage) during arbitrarily large portions of - the block. - - Note that this subsumes the notion of which function a variable belongs - to. A given block is only in one function, so the function is - implicit. - - -The variable map should represent this information space-efficiently and with -adequate computational efficiency. - -The SC and ID can be represented as small integers. Although the ID can in -principle be arbitrarily large, it should be <100 in practice. The location -can be represented by just the offset (a moderately small integer), since the -SB is implicit in the SC. - -The lifetime info can be represented either as a bit-vector indexed by block -numbers, or by a list of block numbers. Which is more compact depends both on -the size of the component and on the number of blocks the variable is live in. -In the limit of large component size, the sparse representation will be more -compact, but it isn't clear where this crossover occurs. Of course, it would -be possible to use both representations, choosing the more compact one on a -per-variable basis. Another interesting special case is when the variable is -live in only one block: this may be common enough to be worth picking off, -although it is probably rarer for named variables than for TNs in general. - -If we dump the type, then a normal list-style type descriptor is fine: the -space overhead is small, since the shareability is high. - -We could probably save some space by cleverly representing the var-info as -parallel vectors of different types, but this would be more painful in use. -It seems better to just use a structure, encoding the unboxed fields in a -fixnum. This way, we can pass around the structure in the debugger, perhaps -even exporting it from the the low-level debugger interface. - -[\#\#\# We need the save location too. This probably means that we need two slots -of bits, since we need the save offset and save SC. Actually, we could let the -save SC be implied by the normal SC, since at least currently, we always choose -the same save SC for a given SC. But even so, we probably can't fit all that -stuff in one fixnum without squeezing a lot, so we might as well split and -record both SCs. - -In a localized packing scheme, we would have to dump a different var-info -whenever either the main location or the save location changes. As a practical -matter, the save location is less likely to change than the main location, and -should never change without the main location changing. - -One can conceive of localized packing schemes that do saving as a special case -of localized packing. If we did this, then the concept of a save location -might be eliminated, but this would require major changes in the IR2 -representation for call and/or lifetime info. Probably we will want saving to -continue to be somewhat magical.] - - -How about: - -(defstruct var-info - ;; - ;; This variable's name. (symbol-name of the symbol) - (name nil :type simple-string) - ;; - ;; The SC, ID and offset, encoded as bit-fields. - (bits nil :type fixnum) - ;; - ;; The set of blocks this variable is live in. If a bit-vector, then it has - ;; a 1 when indexed by the number of a block that it is live in. If an - ;; I-vector, then it lists the live block numbers. If a fixnum, then that is - ;; the number of the sole live block. - (lifetime nil :type (or vector fixnum)) - ;; - ;; The variable's type, represented as list-style type descriptor. - type) - -Then the debug-info holds a simple-vector of all the var-info structures for -that component. We might as well make it sorted alphabetically by name, so -that we can binary-search to find the variable corresponding to a particular -name. - -We need to be able to translate PCs to block numbers. This can be done by an -I-Vector in the component that contains the start location of each block. The -block number is the index at which we find the correct PC range. This requires -that we use an emit-order block numbering distinct from the IR2-Block-Number, -but that isn't any big deal. This seems space-expensive, but it isn't too bad, -since it would only be a fraction of the code size if the average block length -is a few words or more. - -An advantage of our per-block lifetime representation is that it directly -supports keeping a variable in different locations when in different blocks, -i.e. multi-location packing. We use a different var-info for each different -packing, since the SC and offset are potentially different. The Name and ID -are the same, representing the fact that it is the same variable. It is here -that the ID is most significant, since the debugger could otherwise make -same-name variables unique all by itself. - - - -Stack parsing: - -[\#\#\# Probably not worth trying to make the stack parseable from the bottom up. -There are too many complications when we start having variable sized stuff on -the stack. It seems more profitable to work on making top-down parsing robust. -Since we are now planning to wire the bottom-up linkage info, scanning from the -bottom to find the top frame shouldn't be too inefficient, even when there was -a runaway recursion. If we somehow jump into hyperspace, then the debugger may -get confused, but we can debug this sort of low-level system lossage using -ADB.] - - -There are currently three relevant context pointers: - -- The PC. The current PC is wired (implicit in the machine). A saved - PC (RETURN-PC) may be anywhere in the current frame. - -- The current stack context (CONT). The current CONT is wired. A saved - CONT (OLD-CONT) may be anywhere in the current frame. - -- The current code object (ENV). The current ENV is wired. When saved, - this is extra-difficult to locate, since it is saved by the caller, and is - thus at an unknown offset in OLD-CONT, rather than anywhere in the current - frame. - -We must have all of these to parse the stack. - -With the proposed Debug-Function, we parse the stack (starting at the top) like -this: - 1] Use ENV to locate the current Debug-Info - 2] Use the Debug-Info and PC to determine the current Debug-Function. - 3] Use the Debug-Function to find the OLD-CONT and RETURN-PC. - 4] Find the old ENV by searching up the stack for a saved code object - containing the RETURN-PC. - 5] Assign old ENV to ENV, OLD-CONT to CONT, RETURN-PC to PC and goto 1. - -If we changed the function representation so that the code and environment were -a single object, then the location of the old ENV would be simplified. But we -still need to represent ENV as separate from PC, since interrupts and errors -can happen when the current PC isn't positioned at a valid return PC. - -It seems like it might be a good idea to save OLD-CONT, RETURN-PC and ENV at -the beginning of the frame (before any stack arguments). Then we wouldn't have -to search to locate ENV, and we also have a hope of parsing the stack even if -it is damaged. As long as we can locate the start of some frame, we can trace -the stack above that frame. We can recognize a probable frame start by -scanning the stack for a code object (presumably a saved ENV). - - Probably we want some fairly general -mechanism for specifying that a TN should be considered to be live for the -duration of a specified environment. It would be somewhat easier to specify -that the TN is live for all time, but this would become very space-inefficient -in large block compilations. - -This mechanism could be quite useful for other debugger-related things. For -example, when debuggability is important, we could make the TNs holding -arguments live for the entire environment. This would guarantee that a -backtrace would always get the right value (modulo setqs). - -Note that in this context, "environment" means the Environment structure (one -per non-let function). At least according to current plans, even when we do -inter-routine register allocation, the different functions will have different -environments: we just "equate" the environments. So the number of live -per-environment TNs is bounded by the size of a "function", and doesn't blow up -in block compilation. - -The implementation is simple: per-environment TNs are flagged by the -:Environment kind. :Environment TNs are treated the same as :Normal TNs by -everyone except for lifetime/conflict analysis. An environment's TNs are also -stashed in a list in the IR2-Environment structure. During during the conflict -analysis post-pass, we look at each block's environment, and make all the -environment's TNs always-live in that block. - -We can implement the "fixed save location" concept needed for lazy frame -creation by allocating the save TNs as wired TNs at IR2 conversion time. We -would use the new "environment lifetime" concept to specify the lifetimes of -the save locations. There isn't any run-time overhead if we never get around -to using the save TNs. [Pack would also have to notice TNs with pre-allocated -save TNs, packing the original TN in the stack location if its FSC is the -stack.] - - -We want a standard (recognizable) format for an "escape" frame. We must make -an escape frame whenever we start running another function without the current -function getting a chance to save its registers. This may be due either to a -truly asynchronous event such as a software interrupt, or due to an "escape" -from a miscop. An escape frame marks a brief conversion to a callee-saves -convention. - -Whenever a miscop saves registers, it should make an escape frame. This -ensures that the "current" register contents can always be located by the -debugger. In this case, it may be desirable to be able to indicate that only -partial saving has been done. For example, we don't want to have to save all -the FP registers just so that we can use a couple extra general registers. - -When when the debugger see an escape frame, it knows that register values are -located in the escape frame's "register save" area, rather than in the normal -save locations. - -It would be nice if there was a better solution to this internal error concept. -One problem is that it seems there is a substantial space penalty for emitting -all that error code, especially now that we don't share error code between -errors because we want to preserve the source context in the PC. But this -probably isn't really all that bad when considered as a fraction of the code. -For example, the check part of a type check is 12 bytes, whereas the error part -is usually only 6. In this case, we could never reduce the space overhead for -type checks by more than 1/3, thus the total code size reduction would be -small. This will be made even less important when we do type check -optimizations to reduce the number of type checks. - -Probably we should stick to the same general internal error mechanism, but make -it interact with the debugger better by allocating linkage registers and -allowing proceedable errors. We could support shared error calls and -non-proceedable errors when space is more important than debuggability, but -this is probably more complexity than is worthwhile. - -We jump or trap to a routine that saves the context (allocating at most the -return PC register). We then encode the error and context in the code -immediately following the jump/trap. (On the MIPS, the error code can be -encoded in the trap itself.) The error arguments would be encoded as -SC-offsets relative to the saved context. This could solve both the -arg-trashing problem and save space, since we could encode the SC-offsets more -tersely than the corresponding move instructions. diff --git a/docs/internals/design.tex b/docs/internals/design.tex deleted file mode 100644 index 114d7d993ff83144f5704afdd42a7fa48a07d37d..0000000000000000000000000000000000000000 --- a/docs/internals/design.tex +++ /dev/null @@ -1,18 +0,0 @@ -\documentstyle[cmu-titlepage]{report} % -*- Dictionary: design -*- -\title{Design of CMU Common Lisp} -\author{Robert A. MacLachlan (ed)} -\trnumber{CMU-CS-91-???} -\abstract{This report documents internal details of the CMU Common Lisp -compiler and run-time system. CMU Common Lisp is a public domain -implementation of Common Lisp that runs on various Unix workstations.} - -\begin{document} -\maketitle -\tableofcontents -\include{architecture} -\include{compiler} -\include{retargeting} -\include{run-time} -\appendix -\include{glossary} -\end{document} diff --git a/docs/internals/environment.tex b/docs/internals/environment.tex deleted file mode 100644 index e46f48f8ee791fc9df5e5b3086065c998380330d..0000000000000000000000000000000000000000 --- a/docs/internals/environment.tex +++ /dev/null @@ -1,3 +0,0 @@ -\chapter{The Type System} - -\chapter{The Info Database} diff --git a/docs/internals/fasl.tex b/docs/internals/fasl.tex deleted file mode 100644 index b0ad30512c849dd9a53fdef27cf40a7f6b47bc58..0000000000000000000000000000000000000000 --- a/docs/internals/fasl.tex +++ /dev/null @@ -1,584 +0,0 @@ -\chapter{Fasload File Format}% -*- Dictionary: design -*- -\section{General} - -The purpose of Fasload files is to allow concise storage and rapid -loading of Lisp data, particularly function definitions. The intent -is that loading a Fasload file has the same effect as loading the -ASCII file from which the Fasload file was compiled, but accomplishes -the tasks more efficiently. One noticeable difference, of course, is -that function definitions may be in compiled form rather than -S-expression form. Another is that Fasload files may specify in what -parts of memory the Lisp data should be allocated. For example, -constant lists used by compiled code may be regarded as read-only. - -In some Lisp implementations, Fasload file formats are designed to -allow sharing of code parts of the file, possibly by direct mapping -of pages of the file into the address space of a process. This -technique produces great performance improvements in a paged -time-sharing system. Since the Mach project is to produce a -distributed personal-computer network system rather than a -time-sharing system, efficiencies of this type are explicitly {\it not} -a goal for the CMU Common Lisp Fasload file format. - -On the other hand, CMU Common Lisp is intended to be portable, as it will -eventually run on a variety of machines. Therefore an explicit goal -is that Fasload files shall be transportable among various -implementations, to permit efficient distribution of programs in -compiled form. The representations of data objects in Fasload files -shall be relatively independent of such considerations as word -length, number of type bits, and so on. If two implementations -interpret the same macrocode (compiled code format), then Fasload -files should be completely compatible. If they do not, then files -not containing compiled code (so-called "Fasdump" data files) should -still be compatible. While this may lead to a format which is not -maximally efficient for a particular implementation, the sacrifice of -a small amount of performance is deemed a worthwhile price to pay to -achieve portability. - -The primary assumption about data format compatibility is that all -implementations can support I/O on finite streams of eight-bit bytes. -By "finite" we mean that a definite end-of-file point can be detected -irrespective of the content of the data stream. A Fasload file will -be regarded as such a byte stream. - -\section{Strategy} - -A Fasload file may be regarded as a human-readable prefix followed by -code in a funny little language. When interpreted, this code will -cause the construction of the encoded data structures. The virtual -machine which interprets this code has a {\it stack} and a {\it table}, -both initially empty. The table may be thought of as an expandable -register file; it is used to remember quantities which are needed -more than once. The elements of both the stack and the table are -Lisp data objects. Operators of the funny language may take as -operands following bytes of the data stream, or items popped from the -stack. Results may be pushed back onto the stack or pushed onto the -table. The table is an indexable stack that is never popped; it is -indexed relative to the base, not the top, so that an item once -pushed always has the same index. - -More precisely, a Fasload file has the following macroscopic -organization. It is a sequence of zero or more groups concatenated -together. End-of-file must occur at the end of the last group. Each -group begins with a series of seven-bit ASCII characters terminated -by one or more bytes of all ones \verb|#xFF|; this is called the -{\it header}. Following the bytes which terminate the header is the -{\it body}, a stream of bytes in the funny binary language. The body -of necessity begins with a byte other than \verb|#xFF|. The body is -terminated by the operation {\tt FOP-END-GROUP}. - -The first nine characters of the header must be "{\tt FASL FILE}" in -upper-case letters. The rest may be any ASCII text, but by -convention it is formatted in a certain way. The header is divided -into lines, which are grouped into paragraphs. A paragraph begins -with a line which does {\it not} begin with a space or tab character, -and contains all lines up to, but not including, the next such line. -The first word of a paragraph, defined to be all characters up to but -not including the first space, tab, or end-of-line character, is the -{\it name} of the paragraph. A Fasload file header might look something like -this: -\begin{verbatim} -FASL FILE >SteelesPerq>User>Guy>IoHacks>Pretty-Print.Slisp -Package Pretty-Print -Compiled 31-Mar-1988 09:01:32 by some random luser -Compiler Version 1.6, Lisp Version 3.0. -Functions: INITIALIZE DRIVER HACK HACK1 MUNGE MUNGE1 GAZORCH - MINGLE MUDDLE PERTURB OVERDRIVE GOBBLE-KEYBOARD - FRY-USER DROP-DEAD HELP CLEAR-MICROCODE - %AOS-TRIANGLE %HARASS-READTABLE-MAYBE -Macros: PUSH POP FROB TWIDDLE -\end{verbatim} -{\it one or more bytes of \verb|#xFF|} - -The particular paragraph names and contents shown here are only intended as -suggestions. - -\section{Fasload Language} - -Each operation in the binary Fasload language is an eight-bit -(one-byte) opcode. Each has a name beginning with "{\tt FOP-}". In -the following descriptions, the name is followed by operand -descriptors. Each descriptor denotes operands that follow the opcode -in the input stream. A quantity in parentheses indicates the number -of bytes of data from the stream making up the operand. Operands -which implicitly come from the stack are noted in the text. The -notation "$\Rightarrow$ stack" means that the result is pushed onto the -stack; "$\Rightarrow$ table" similarly means that the result is added to the -table. A construction like "{\it n}(1) {\it value}({\it n})" means that -first a single byte {\it n} is read from the input stream, and this -byte specifies how many bytes to read as the operand named {\it value}. -All numeric values are unsigned binary integers unless otherwise -specified. Values described as "signed" are in two's-complement form -unless otherwise specified. When an integer read from the stream -occupies more than one byte, the first byte read is the least -significant byte, and the last byte read is the most significant (and -contains the sign bit as its high-order bit if the entire integer is -signed). - -Some of the operations are not necessary, but are rather special -cases of or combinations of others. These are included to reduce the -size of the file or to speed up important cases. As an example, -nearly all strings are less than 256 bytes long, and so a special -form of string operation might take a one-byte length rather than a -four-byte length. As another example, some implementations may -choose to store bits in an array in a left-to-right format within -each word, rather than right-to-left. The Fasload file format may -support both formats, with one being significantly more efficient -than the other for a given implementation. The compiler for any -implementation may generate the more efficient form for that -implementation, and yet compatibility can be maintained by requiring -all implementations to support both formats in Fasload files. - -Measurements are to be made to determine which operation codes are -worthwhile; little-used operations may be discarded and new ones -added. After a point the definition will be "frozen", meaning that -existing operations may not be deleted (though new ones may be added; -some operations codes will be reserved for that purpose). - -\begin{description} -\item[0:] \hspace{2em} {\tt FOP-NOP} \\ -No operation. (This is included because it is recognized -that some implementations may benefit from alignment of operands to some -operations, for example to 32-bit boundaries. This operation can be used -to pad the instruction stream to a desired boundary.) - -\item[1:] \hspace{2em} {\tt FOP-POP} \hspace{2em} $\Rightarrow$ \hspace{2em} table \\ -One item is popped from the stack and added to the table. - -\item[2:] \hspace{2em} {\tt FOP-PUSH} \hspace{2em} {\it index}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -Item number {\it index} of the table is pushed onto the stack. -The first element of the table is item number zero. - -\item[3:] \hspace{2em} {\tt FOP-BYTE-PUSH} \hspace{2em} {\it index}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -Item number {\it index} of the table is pushed onto the stack. -The first element of the table is item number zero. - -\item[4:] \hspace{2em} {\tt FOP-EMPTY-LIST} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The empty list ({\tt ()}) is pushed onto the stack. - -\item[5:] \hspace{2em} {\tt FOP-TRUTH} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The standard truth value ({\tt T}) is pushed onto the stack. - -\item[6:] \hspace{2em} {\tt FOP-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n}) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\ -The four-byte operand {\it n} specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the default package, -and the resulting symbol is both pushed onto the stack and added to the table. - -\item[7:] \hspace{2em} {\tt FOP-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\ -The one-byte operand {\it n} specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the default package, -and the resulting symbol is both pushed onto the stack and added to the table. - -\item[8:] \hspace{2em} {\tt FOP-SYMBOL-IN-PACKAGE-SAVE} \hspace{2em} {\it index}(4) -\hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n}) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\ -The four-byte {\it index} specifies a package stored in the table. -The four-byte operand {\it n} specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the specified package, -and the resulting symbol is both pushed onto the stack and added to the table. - -\item[9:] \hspace{2em} {\tt FOP-SMALL-SYMBOL-IN-PACKAGE-SAVE} \hspace{2em} {\it index}(4) -\hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em} -$\Rightarrow$ \hspace{2em} stack \& table\\ -The four-byte {\it index} specifies a package stored in the table. -The one-byte operand {\it n} specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the specified package, -and the resulting symbol is both pushed onto the stack and added to the table. - -\item[10:] \hspace{2em} {\tt FOP-SYMBOL-IN-BYTE-PACKAGE-SAVE} \hspace{2em} {\it index}(1) -\hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n}) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\ -The one-byte {\it index} specifies a package stored in the table. -The four-byte operand {\it n} specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the specified package, -and the resulting symbol is both pushed onto the stack and added to the table. - -\item[11:]\hspace{2em} {\tt FOP-SMALL-SYMBOL-IN-BYTE-PACKAGE-SAVE} \hspace{2em} {\it index}(1) -\hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em} -$\Rightarrow$ \hspace{2em} stack \& table\\ -The one-byte {\it index} specifies a package stored in the table. -The one-byte operand {\it n} specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the specified package, -and the resulting symbol is both pushed onto the stack and added to the table. - -\item[12:] \hspace{2em} {\tt FOP-UNINTERNED-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n}) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\ -Like {\tt FOP-SYMBOL-SAVE}, except that it creates an uninterned symbol. - -\item[13:] \hspace{2em} {\tt FOP-UNINTERNED-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1) -\hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack -\& table\\ -Like {\tt FOP-SMALL-SYMBOL-SAVE}, except that it creates an uninterned symbol. - -\item[14:] \hspace{2em} {\tt FOP-PACKAGE} \hspace{2em} $\Rightarrow$ \hspace{2em} table \\ -An item is popped from the stack; it must be a symbol. The package of -that name is located and pushed onto the table. - -\item[15:] \hspace{2em} {\tt FOP-LIST} \hspace{2em} {\it length}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The unsigned operand {\it length} specifies a number of -operands to be popped from the stack. These are made into a list -of that length, and the list is pushed onto the stack. -The first item popped from the stack becomes the last element of -the list, and so on. Hence an iterative loop can start with -the empty list and perform "pop an item and cons it onto the list" -{\it length} times. -(Lists of length greater than 255 can be made by using {\tt FOP-LIST*} -repeatedly.) - -\item[16:] \hspace{2em} {\tt FOP-LIST*} \hspace{2em} {\it length}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -This is like {\tt FOP-LIST} except that the constructed list is terminated -not by {\tt ()} (the empty list), but by an item popped from the stack -before any others are. Therefore {\it length}+1 items are popped in all. -Hence an iterative loop can start with -a popped item and perform "pop an item and cons it onto the list" -{\it length}+1 times. - -\item[17-24:] \hspace{2em} {\tt FOP-LIST-1}, {\tt FOP-LIST-2}, ..., {\tt FOP-LIST-8} \\ -{\tt FOP-LIST-{\it k}} is like {\tt FOP-LIST} with a byte containing {\it k} -following it. These exist purely to reduce the size of Fasload files. -Measurements need to be made to determine the useful values of {\it k}. - -\item[25-32:] \hspace{2em} {\tt FOP-LIST*-1}, {\tt FOP-LIST*-2}, ..., {\tt FOP-LIST*-8} \\ -{\tt FOP-LIST*-{\it k}} is like {\tt FOP-LIST*} with a byte containing {\it k} -following it. These exist purely to reduce the size of Fasload files. -Measurements need to be made to determine the useful values of {\it k}. - -\item[33:] \hspace{2em} {\tt FOP-INTEGER} \hspace{2em} {\it n}(4) \hspace{2em} {\it value}({\it n}) \hspace{2em} -$\Rightarrow$ \hspace{2em} stack \\ -A four-byte unsigned operand specifies the number of following -bytes. These bytes define the value of a signed integer in two's-complement -form. The first byte of the value is the least significant byte. - -\item[34:] \hspace{2em} {\tt FOP-SMALL-INTEGER} \hspace{2em} {\it n}(1) \hspace{2em} {\it value}({\it n}) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -A one-byte unsigned operand specifies the number of following -bytes. These bytes define the value of a signed integer in two's-complement -form. The first byte of the value is the least significant byte. - -\item[35:] \hspace{2em} {\tt FOP-WORD-INTEGER} \hspace{2em} {\it value}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -A four-byte signed integer (in the range $-2^{31}$ to $2^{31}-1$) follows the -operation code. A LISP integer (fixnum or bignum) with that value -is constructed and pushed onto the stack. - -\item[36:] \hspace{2em} {\tt FOP-BYTE-INTEGER} \hspace{2em} {\it value}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -A one-byte signed integer (in the range -128 to 127) follows the -operation code. A LISP integer (fixnum or bignum) with that value -is constructed and pushed onto the stack. - -\item[37:] \hspace{2em} {\tt FOP-STRING} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n}) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The four-byte operand {\it n} specifies the length of a string to -construct. The characters of the string follow, one per byte. -The constructed string is pushed onto the stack. - -\item[38:] \hspace{2em} {\tt FOP-SMALL-STRING} \hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The one-byte operand {\it n} specifies the length of a string to -construct. The characters of the string follow, one per byte. -The constructed string is pushed onto the stack. - -\item[39:] \hspace{2em} {\tt FOP-VECTOR} \hspace{2em} {\it n}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The four-byte operand {\it n} specifies the length of a vector of LISP objects -to construct. The elements of the vector are popped off the stack; -the first one popped becomes the last element of the vector. -The constructed vector is pushed onto the stack. - -\item[40:] \hspace{2em} {\tt FOP-SMALL-VECTOR} \hspace{2em} {\it n}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The one-byte operand {\it n} specifies the length of a vector of LISP objects -to construct. The elements of the vector are popped off the stack; -the first one popped becomes the last element of the vector. -The constructed vector is pushed onto the stack. - -\item[41:] \hspace{2em} {\tt FOP-UNIFORM-VECTOR} \hspace{2em} {\it n}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The four-byte operand {\it n} specifies the length of a vector of LISP objects -to construct. A single item is popped from the stack and used to initialize -all elements of the vector. The constructed vector is pushed onto the stack. - -\item[42:] \hspace{2em} {\tt FOP-SMALL-UNIFORM-VECTOR} \hspace{2em} {\it n}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The one-byte operand {\it n} specifies the length of a vector of LISP objects -to construct. A single item is popped from the stack and used to initialize -all elements of the vector. The constructed vector is pushed onto the stack. - -\item[43:] \hspace{2em} {\tt FOP-INT-VECTOR} \hspace{2em} {\it len}(4) \hspace{2em} -{\it size}(1) \hspace{2em} {\it data}($\left\lceil len*count/8\right\rceil$) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The four-byte operand {\it n} specifies the length of a vector of -unsigned integers to be constructed. Each integer is {\it size} -bits long, and is packed according to the machine's native byte ordering. -{\it size} must be a directly supported i-vector element size. Currently -supported values are 1,2,4,8,16 and 32. - -\item[44:] \hspace{2em} {\tt FOP-UNIFORM-INT-VECTOR} \hspace{2em} {\it n}(4) \hspace{2em} {\it size}(1) \hspace{2em} -{\it value}(@ceiling<{\it size}/8>) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The four-byte operand {\it n} specifies the length of a vector of unsigned -integers to construct. -Each integer is {\it size} bits big, and is initialized to the value -of the operand {\it value}. -The constructed vector is pushed onto the stack. - -\item[45:] Unused - -\item[46:] \hspace{2em} {\tt FOP-SINGLE-FLOAT} \hspace{2em} {\it data}(4) \hspace{2em} -$\Rightarrow$ \hspace{2em} stack \\ -The {\it data} bytes are read as an integer, then turned into an IEEE single -float (as though by {\tt make-single-float}). - -\item[47:] \hspace{2em} {\tt FOP-DOUBLE-FLOAT} \hspace{2em} {\it data}(8) \hspace{2em} -$\Rightarrow$ \hspace{2em} stack \\ -The {\it data} bytes are read as an integer, then turned into an IEEE double -float (as though by {\tt make-double-float}). - -\item[48:] \hspace{2em} {\tt FOP-STRUCT} \hspace{2em} {\it n}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The four-byte operand {\it n} specifies the length structure to construct. The -elements of the vector are popped off the stack; the first one popped becomes -the last element of the structure. The constructed vector is pushed onto the -stack. - -\item[49:] \hspace{2em} {\tt FOP-SMALL-STRUCT} \hspace{2em} {\it n}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The one-byte operand {\it n} specifies the length structure to construct. The -elements of the vector are popped off the stack; the first one popped becomes -the last element of the structure. The constructed vector is pushed onto the -stack. - -\item[50-52:] Unused - -\item[53:] \hspace{2em} {\tt FOP-EVAL} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -Pop an item from the stack and evaluate it (give it to {\tt EVAL}). -Push the result back onto the stack. - -\item[54:] \hspace{2em} {\tt FOP-EVAL-FOR-EFFECT} \\ -Pop an item from the stack and evaluate it (give it to {\tt EVAL}). -The result is ignored. - -\item[55:] \hspace{2em} {\tt FOP-FUNCALL} \hspace{2em} {\it nargs}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -Pop {\it nargs}+1 items from the stack and apply the last one popped -as a function to -all the rest as arguments (the first one popped being the last argument). -Push the result back onto the stack. - -\item[56:] \hspace{2em} {\tt FOP-FUNCALL-FOR-EFFECT} \hspace{2em} {\it nargs}(1) \\ -Pop {\it nargs}+1 items from the stack and apply the last one popped -as a function to -all the rest as arguments (the first one popped being the last argument). -The result is ignored. - -\item[57:] \hspace{2em} {\tt FOP-CODE-FORMAT} \hspace{2em} {\it implementation}(1) -\hspace{2em} {\it version}(1) \\ -This FOP specifiers the code format for following code objects. The operations -{\tt FOP-CODE} and its relatives may not occur in a group until after {\tt -FOP-CODE-FORMAT} has appeared; there is no default format. The {\it -implementation} is an integer indicating the target hardware and environment. -See {\tt compiler/generic/vm-macs.lisp} for the currently defined -implementations. {\it version} for an implementation is increased whenever -there is a change that renders old fasl files unusable. - -\item[58:] \hspace{2em} {\tt FOP-CODE} \hspace{2em} {\it nitems}(4) \hspace{2em} {\it size}(4) \hspace{2em} -{\it code}({\it size}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -A compiled function is constructed and pushed onto the stack. -This object is in the format specified by the most recent -occurrence of {\tt FOP-CODE-FORMAT}. -The operand {\it nitems} specifies a number of items to pop off -the stack to use in the "boxed storage" section. The operand {\it code} -is a string of bytes constituting the compiled executable code. - -\item[59:] \hspace{2em} {\tt FOP-SMALL-CODE} \hspace{2em} {\it nitems}(1) \hspace{2em} {\it size}(2) \hspace{2em} -{\it code}({\it size}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -A compiled function is constructed and pushed onto the stack. -This object is in the format specified by the most recent -occurrence of {\tt FOP-CODE-FORMAT}. -The operand {\it nitems} specifies a number of items to pop off -the stack to use in the "boxed storage" section. The operand {\it code} -is a string of bytes constituting the compiled executable code. - -\item[60-61:] Unused - -\item[62:] \hspace{2em} {\tt FOP-VERIFY-TABLE-SIZE} \hspace{2em} {\it size}(4) \\ -If the current size of the table is not equal to {\it size}, -then an inconsistency has been detected. This operation -is inserted into a Fasload file purely for error-checking purposes. -It is good practice for a compiler to output this at least at the -end of every group, if not more often. - -\item[63:] \hspace{2em} {\tt FOP-VERIFY-EMPTY-STACK} \\ -If the stack is not currently empty, -then an inconsistency has been detected. This operation -is inserted into a Fasload file purely for error-checking purposes. -It is good practice for a compiler to output this at least at the -end of every group, if not more often. - -\item[64:] \hspace{2em} {\tt FOP-END-GROUP} \\ -This is the last operation of a group. If this is not the -last byte of the file, then a new group follows; the next -nine bytes must be "{\tt FASL FILE}". - -\item[65:] \hspace{2em} {\tt FOP-POP-FOR-EFFECT} \hspace{2em} stack \hspace{2em} $\Rightarrow$ \hspace{2em} \\ -One item is popped from the stack. - -\item[66:] \hspace{2em} {\tt FOP-MISC-TRAP} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -A trap object is pushed onto the stack. - -\item[67:] Unused - -\item[68:] \hspace{2em} {\tt FOP-CHARACTER} \hspace{2em} {\it character}(3) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -The three bytes are read as an integer then converted to a character. This FOP -is currently rather useless, as extended characters are not supported. - -\item[69:] \hspace{2em} {\tt FOP-SHORT-CHARACTER} \hspace{2em} {\it character}(1) \hspace{2em} -$\Rightarrow$ \hspace{2em} stack \\ -The one byte specifies the code of a Common Lisp character object. A character -is constructed and pushed onto the stack. - -\item[70:] \hspace{2em} {\tt FOP-RATIO} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -Creates a ratio from two integers popped from the stack. -The denominator is popped first, the numerator second. - -\item[71:] \hspace{2em} {\tt FOP-COMPLEX} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\ -Creates a complex number from two numbers popped from the stack. -The imaginary part is popped first, the real part second. - -\item[72-73:] Unused - -\item[74:] \hspace{2em} {\tt FOP-FSET} \hspace{2em} \\ -Except in the cold loader (Genesis), this is a no-op with two stack arguments. -In the initial core this is used to make DEFUN functions defined at cold-load -time so that global functions can be called before top-level forms are run -(which normally installs definitions.) Genesis pops the top two things off of -the stack and effectively does (SETF SYMBOL-FUNCTION). - -\item[75:] \hspace{2em} {\tt FOP-LISP-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n}) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\ -Like {\tt FOP-SYMBOL-SAVE}, except that it creates a symbol in the LISP -package. - -\item[76:] \hspace{2em} {\tt FOP-LISP-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1) -\hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack -\& table\\ -Like {\tt FOP-SMALL-SYMBOL-SAVE}, except that it creates a symbol in the LISP -package. - -\item[77:] \hspace{2em} {\tt FOP-KEYWORD-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n}) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\ -Like {\tt FOP-SYMBOL-SAVE}, except that it creates a symbol in the -KEYWORD package. - -\item[78:] \hspace{2em} {\tt FOP-KEYWORD-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1) -\hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack -\& table\\ -Like {\tt FOP-SMALL-SYMBOL-SAVE}, except that it creates a symbol in the -KEYWORD package. - -\item[79-80:] Unused - -\item[81:] \hspace{2em} {\tt FOP-NORMAL-LOAD}\\ -This FOP is used in conjunction with the cold loader (Genesis) to read -top-level package manipulation forms. These forms are to be read as though by -the normal loaded, so that they can be evaluated at cold load time, instead of -being dumped into the initial core image. A no-op in normal loading. - -\item[82:] \hspace{2em} {\tt FOP-MAYBE-COLD-LOAD}\\ -Undoes the effect of {\tt FOP-NORMAL-LOAD}. - -\item[83:] \hspace{2em} {\tt FOP-ARRAY} \hspace{2em} {\it rank}(4) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\ -This operation creates a simple array header (used for simple-arrays with rank -/= 1). The data vector is popped off of the stack, and then {\it rank} -dimensions are popped off of the stack (the highest dimensions is on top.) - -\item[84-139:] Unused - -\item[140:] \hspace{2em} {\tt FOP-ALTER-CODE} \hspace{2em} {\it index}(4)\\ -This operation modifies the constants part of a code object (necessary for -creating certain circular function references.) It pops the new value and code -object are off of the stack, storing the new value at the specified index. - -\item[141:] \hspace{2em} {\tt FOP-BYTE-ALTER-CODE} \hspace{2em} {\it index}(1)\\ -Like {\tt FOP-ALTER-CODE}, but has only a one byte offset. - -\item[142:] \hspace{2em} {\tt FOP-FUNCTION-ENTRY} \hspace{2em} {\it index}(4) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\ -Initializes a function-entry header inside of a pre-existing code object, and -returns the corresponding function descriptor. {\it index} is the byte offset -inside of the code object where the header should be plunked down. The stack -arguments to this operation are the code object, function name, function debug -arglist and function type. - -\item[143:] Unused - -\item[144:] \hspace{2em} {\tt FOP-ASSEMBLER-CODE} \hspace{2em} {\it length}(4) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\ -This operation creates a code object holding assembly routines. {\it length} -bytes of code are read and placed in the code object, and the code object -descriptor is pushed on the stack. This FOP is only recognized by the cold -loader (Genesis.) - -\item[145:] \hspace{2em} {\tt FOP-ASSEMBLER-ROUTINE} \hspace{2em} {\it offset}(4) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\ -This operation records an entry point into an assembler code object (for use -with {\tt FOP-ASSEMBLER-FIXUP}). The routine name (a symbol) is on stack top. -The code object is underneath. The entry point is defined at {\it offset} -bytes inside the code area of the code object, and the code object is left on -stack top (allowing multiple uses of this FOP to be chained.) This FOP is only -recognized by the cold loader (Genesis.) - -\item[146:] Unused - -\item[147:] \hspace{2em} {\tt FOP-FOREIGN-FIXUP} \hspace{2em} {\it len}(1) -\hspace{2em} {\it name}({\it len}) -\hspace{2em} {\it offset}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack\\ -This operation resolves a reference to a foreign (C) symbol. {\it len} bytes -are read and interpreted as the symbol {\it name}. First the {\it kind} and the -code-object to patch are popped from the stack. The kind is a target-dependent -symbol indicating the instruction format of the patch target (at {\it offset} -bytes from the start of the code area.) The code object is left on -stack top (allowing multiple uses of this FOP to be chained.) - -\item[148:] \hspace{2em} {\tt FOP-ASSEMBLER-FIXUP} \hspace{2em} {\it offset}(4) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\ -This operation resolves a reference to an assembler routine. The stack args -are ({\it routine-name}, {\it kind} and {\it code-object}). The kind is a -target-dependent symbol indicating the instruction format of the patch target -(at {\it offset} bytes from the start of the code area.) The code object is -left on stack top (allowing multiple uses of this FOP to be chained.) - -\item[149-199:] Unused - -\item[200:] \hspace{2em} {\tt FOP-RPLACA} \hspace{2em} {\it table-idx}(4) -\hspace{2em} {\it cdr-offset}(4)\\ - -\item[201:] \hspace{2em} {\tt FOP-RPLACD} \hspace{2em} {\it table-idx}(4) -\hspace{2em} {\it cdr-offset}(4)\\ -These operations destructively modify a list entered in the table. {\it -table-idx} is the table entry holding the list, and {\it cdr-offset} designates -the cons in the list to modify (like the argument to {\tt nthcdr}.) The new -value is popped off of the stack, and stored in the {\tt car} or {\tt cdr}, -respectively. - -\item[202:] \hspace{2em} {\tt FOP-SVSET} \hspace{2em} {\it table-idx}(4) -\hspace{2em} {\it vector-idx}(4)\\ -Destructively modifies a {\tt simple-vector} entered in the table. Pops the -new value off of the stack, and stores it in the {\it vector-idx} element of -the contents of the table entry {\it table-idx.} - -\item[203:] \hspace{2em} {\tt FOP-NTHCDR} \hspace{2em} {\it cdr-offset}(4) -\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\ -Does {\tt nthcdr} on the top-of stack, leaving the result there. - -\item[204:] \hspace{2em} {\tt FOP-STRUCTSET} \hspace{2em} {\it table-idx}(4) -\hspace{2em} {\it vector-idx}(4)\\ -Like {\tt FOP-SVSET}, except it alters structure slots. - -\item[255:] \hspace{2em} {\tt FOP-END-HEADER} \\ Indicates the end of a group header, -as described above. -\end{description} diff --git a/docs/internals/front.tex b/docs/internals/front.tex deleted file mode 100644 index b55d41904aec977e89bd51af3eae93140c4c1d22..0000000000000000000000000000000000000000 --- a/docs/internals/front.tex +++ /dev/null @@ -1,943 +0,0 @@ -\chapter{ICR conversion} % -*- Dictionary: design -*- - - - -\section{Canonical forms} - -\#| - -Would be useful to have a Freeze-Type proclamation. Its primary use would to -be say that the indicated type won't acquire any new subtypes in the future. -This allows better open-coding of structure type predicates, since the possible -types that would satisfy the predicate will be constant at compile time, and -thus can be compiled as a skip-chain of EQ tests. - -Of course, this is only a big win when the subtypes are few: the most important -case is when there are none. If the closure of the subtypes is much larger -than the average number of supertypes of an inferior, then it is better to grab -the list of superiors out of the object's type, and test for membership in that -list. - -Should type-specific numeric equality be done by EQL rather than =? i.e. -should = on two fixnums become EQL and then convert to EQL/FIXNUM? -Currently we transform EQL into =, which is complicated, since we have to prove -the operands are the class of numeric type before we do it. Also, when EQL -sees one operand is a FIXNUM, it transforms to EQ, but the generator for EQ -isn't expecting numbers, so it doesn't use an immediate compare. - - -Array hackery: - - -Array type tests are transformed to %array-typep, separation of the -implementation-dependent array-type handling. This way we can transform -STRINGP to: - (or (simple-string-p x) - (and (complex-array-p x) - (= (array-rank x) 1) - (simple-string-p (%array-data x)))) - -In addition to the similar bit-vector-p, we also handle vectorp and any type -tests on which the a dimension isn't wild. -[Note that we will want to expand into frobs compatible with those that -array references expand into so that the same optimizations will work on both.] - -These changes combine to convert hairy type checks into hairy typep's, and then -convert hairyp typeps into simple typeps. - - -Do we really need non-VOP templates? It seems that we could get the desired -effect through implementation-dependent ICR transforms. The main risk would be -of obscuring the type semantics of the code. We could fairly easily retain all -the type information present at the time the tranform is run, but if we -discover new type information, then it won't be propagated unless the VM also -supplies type inference methods for its internal frobs (precluding the use of -%PRIMITIVE, since primitives don't have derive-type methods.) - -I guess one possibility would be to have the call still considered "known" even -though it has been transformed. But this doesn't work, since we start doing -LET optimizations that trash the arglist once the call has been transformed -(and indeed we want to.) - -Actually, I guess the overhead for providing type inference methods for the -internal frobs isn't that great, since we can usually borrow the inference -method for a Common Lisp function. For example, in our AREF case: - (aref x y) -==> - (let ((\#:len (array-dimension x 0))) - (%unchecked-aref x (%check-in-bounds y \#:len))) - -Now in this case, if we made %UNCHECKED-AREF have the same derive-type method -as AREF, then if we discovered something new about X's element type, we could -derive a new type for the entire expression. - -Actually, it seems that baring this detail at the ICR level is beneficial, -since it admits the possibly of optimizing away the bounds check using type -information. If we discover X's dimensions, then \#:LEN becomes a constant that -can be substituted. Then %CHECK-IN-BOUNDS can notice that the bound is -constant and check it against the type for Y. If Y is known to be in range, -then we can optimize away the bounds check. - -Actually in this particular case, the best thing to do would be if we -discovered the bound is constant, then replace the bounds check with an -implicit type check. This way all the type check optimization mechanisms would -be brought into the act. - -So we actually want to do the bounds-check expansion as soon as possible, -rather than later than possible: it should be a source-transform, enabled by -the fast-safe policy. - -With multi-dimensional arrays we probably want to explicitly do the index -computation: this way portions of the index computation can become loop -invariants. In a scan in row-major order, the inner loop wouldn't have to do -any multiplication: it would only do an addition. We would use normal -fixnum arithmetic, counting on * to cleverly handle multiplication by a -constant, and appropriate inline expansion. - -Note that in a source transform, we can't make any assumptions the type of the -array. If it turns out to be a complex array without declared dimensions, then -the calls to ARRAY-DIMENSION will have to turn into a VOP that can be affected. -But if it is simple, then the VOP is unaffected, and if we know the bounds, it -is constant. Similarly, we would have %ARRAY-DATA and %ARRAY-DISPLACEMENT -operations. %ARRAY-DISPLACEMENT would optimize to 0 if we discover the array -is simple. [This is somewhat inefficient when the array isn't eventually -discovered to be simple, since finding the data and finding the displacement -duplicate each other. We could make %ARRAY-DATA return both as MVs, and then -optimize to (VALUES (%SIMPLE-ARRAY-DATA x) 0), but this would require -optimization of trivial VALUES uses.] - -Also need (THE (ARRAY * * * ...) x) to assert correct rank. - -|\# - -A bunch of functions have source transforms that convert them into the -canonical form that later parts of the compiler want to see. It is not legal -to rely on the canonical form since source transforms can be inhibited by a -Notinline declaration. This shouldn't be a problem, since everyone should keep -their hands off of Notinline calls. - -Some transformations: - -Endp ==> (NULL (THE LIST ...)) -(NOT xxx) or (NULL xxx) => (IF xxx NIL T) - -(typep x '<simple type>) => (<simple predicate> x) -(typep x '<complex type>) => ...composition of simpler operations... -TYPEP of AND, OR and NOT types turned into conditionals over multiple TYPEP -calls. This makes hairy TYPEP calls more digestible to type constraint -propagation, and also means that the TYPEP code generators don't have to deal -with these cases. [\#\#\# In the case of union types we may want to do something -to preserve information for type constraint propagation.] - - - (apply \#'foo a b c) -==> - (multiple-value-call \#'foo (values a) (values b) (values-list c)) - -This way only MV-CALL needs to know how to do calls with unknown numbers of -arguments. It should be nearly as efficient as a special-case VMR-Convert -method could be. - - -Make-String => Make-Array -N-arg predicates associated into two-arg versions. -Associate N-arg arithmetic ops. -Expand CxxxR and FIRST...nTH -Zerop, Plusp, Minusp, 1+, 1-, Min, Max, Rem, Mod -(Values x), (Identity x) => (Prog1 x) - -All specialized aref functions => (aref (the xxx) ...) - -Convert (ldb (byte ...) ...) into internal frob that takes size and position as -separate args. Other byte functions also... - -Change for-value primitive predicates into (if <pred> t nil). This isn't -particularly useful during ICR phases, but makes life easy for VMR conversion. - -This last can't be a source transformation, since a source transform can't tell -where the form appears. Instead, ICR conversion special-cases calls to known -functions with the Predicate attribute by doing the conversion when the -destination of the result isn't an IF. It isn't critical that this never be -done for predicates that we ultimately discover to deliver their value to an -IF, since IF optimizations will flush unnecessary IFs in a predicate. - - -\section{Inline functions} - -[\#\#\# Inline expansion is especially powerful in the presence of good lisp-level -optimization ("partial evaluation"). Many "optimizations" usually done in Lisp -compilers by special-case source-to-source transforms can be had simply by -making the source of the general case function available for inline expansion. -This is especially helpful in Common Lisp, which has many commonly used -functions with simple special cases but bad general cases (list and sequence -functions, for example.) - -Inline expansion of recursive functions is allowed, and is not as silly as it -sounds. When expanded in a specific context, much of the overhead of the -recursive calls may be eliminated (especially if there are many keyword -arguments, etc.) - -[Also have MAYBE-INLINE] -] - -We only record a function's inline expansion in the global environment when the -function is in the null lexical environment, since it the expansion must be -represented as source. - -We do inline expansion of functions locally defined by FLET or LABELS even when -the environment is not null. Since the appearances of the local function must -be nested within the desired environment, it is possible to expand local -functions inline even when they use the environment. We just stash the source -form and environments in the Functional for the local function. When we -convert a call to it, we just reconvert the source in the saved environment. - -An interesting alternative to the inline/full-call dichotomy is "semi-inline" -coding. Whenever we have an inline expansion for a function, we can expand it -only once per block compilation, and then use local call to call this copied -version. This should get most of the speed advantage of real inline coding -with much less code bloat. This is especially attractive for simple system -functions such as Read-Char. - -The main place where true inline expansion would still be worth doing is where -large amounts of the function could be optimized away by constant folding or -other optimizations that depend on the exact arguments to the call. - - - -\section{Compilation policy} - -We want more sophisticated control of compilation safety than is offered in CL, -so that we can emit only those type checks that are likely to discover -something (i.e. external interfaces.) - -\#| - - -\section{Notes} - -Generalized back-end notion provides dynamic retargeting? (for byte code) - -The current node type annotations seem to be somewhat unsatisfactory, since we -lose information when we do a THE on a continuation that already has uses, or -when we convert a let where the actual result continuation has other uses. - -But the case with THE isn't really all that bad, since the test of whether -there are any uses happens before conversion of the argument, thus THE loses -information only when there are uses outside of the declared form. The LET -case may not be a big deal either. - -Note also that losing user assertions isn't really all that bad, since it won't -damage system integrity. At worst, it will cause a bug to go undetected. More -likely, it will just cause the error to be signaled in a different place (and -possibly in a less informative way). Of course, there is an efficiency hit for -losing type information, but if it only happens in strange cases, then this -isn't a big deal. - - -\chapter{Local call analysis} - -All calls to local functions (known named functions and LETs) are resolved to -the exact LAMBDA node which is to be called. If the call is syntactically -illegal, then we emit a warning and mark the reference as :notinline, forcing -the call to be a full call. We don't even think about converting APPLY calls; -APPLY is not special-cased at all in ICR. We also take care not to convert -calls in the top-level component, which would join it to normal code. Calls to -functions with rest args and calls with non-constant keywords are also not -converted. - -We also convert MV-Calls that look like MULTIPLE-VALUE-BIND to local calls, -since we know that they can be open-coded. We replace the optional dispatch -with a call to the last optional entry point, letting MV-Call magically default -the unsupplied values to NIL. - -When ICR optimizations discover a possible new local call, they explicitly -invoke local call analysis on the code that needs to be reanalyzed. - -[\#\#\# Let conversion. What is means to be a let. Argument type checking done -by caller. Significance of local call is that all callers are known, so -special call conventions may be used.] -A lambda called in only one place is called a "let" call, since a Let would -turn into one. - -In addition to enabling various ICR optimizations, the let/non-let distinction -has important environment significance. We treat the code in function and all -of the lets called by that function as being in the same environment. This -allows exits from lets to be treated as local exits, and makes life easy for -environment analysis. - -Since we will let-convert any function with only one call, we must be careful -about cleanups. It is possible that a lexical exit from the let function may -have to clean up dynamic bindings not lexically apparent at the exit point. We -handle this by annotating lets with any cleanup in effect at the call site. -The cleanup for continuations with no immediately enclosing cleanup is the -lambda that the continuation is in. In this case, we look at the lambda to see -if any cleanups need to be done. - -Let conversion is disabled for entry-point functions, since otherwise we might -convert the call from the XEP to the entry point into a let. Then later on, we -might want to convert a non-local reference into a local call, and not be able -to, since once a function has been converted to a let, we can't convert it -back. - - -A function's return node may also be deleted if it is unreachable, which can -happen if the function never returns normally. Such functions are not lets. - - -\chapter{Find components} - -This is a post-pass to ICR conversion that massages the flow graph into the -shape subsequent phases expect. Things done: - Compute the depth-first ordering for the flow graph. - Find the components (disconnected parts) of the flow graph. - -This pass need only be redone when newly converted code has been added to the -flow graph. The reanalyze flag in the component structure should be set by -people who mess things up. - -We create the initial DFO using a variant of the basic algorithm. The initial -DFO computation breaks the ICR up into components, which are parts that can be -compiled independently. This is done to increase the efficiency of large block -compilations. In addition to improving locality of reference and reducing the -size of flow analysis problems, this allows back-end data structures to be -reclaimed after the compilation of each component. - -ICR optimization can change the connectivity of the flow graph by discovering -new calls or eliminating dead code. Initial DFO determination splits up the -flow graph into separate components, but does so conservatively, ensuring that -parts that might become joined (due to local call conversion) are joined from -the start. Initial DFO computation also guarantees that all code which shares -a lexical environment is in the same component so that environment analysis -needs to operate only on a single component at a time. - -[This can get a bit hairy, since code seemingly reachable from the -environment entry may be reachable from a NLX into that environment. Also, -function references must be considered as links joining components even though -the flow graph doesn't represent these.] - -After initial DFO determination, components are neither split nor joined. The -standard DFO computation doesn't attempt to split components that have been -disconnected. - - -\chapter{ICR optimize} - -{\bf Somewhere describe basic ICR utilities: continuation-type, -constant-continuation-p, etc. Perhaps group by type in ICR description?} - -We are conservative about doing variable-for-variable substitution in ICR -optimization, since if we substitute a variable with a less restrictive type, -then we may prevent use of a "good" representation within the scope of the -inner binding. - -Note that variable-variable substitutions aren't really crucial in ICR, since -they don't create opportunities for new optimizations (unlike substitution of -constants and functions). A spurious variable-variable binding will show up as -a Move operation in VMR. This can be optimized away by reaching-definitions -and also by targeting. [\#\#\# But actually, some optimizers do see if operands -are the same variable.] - -\#| - -The IF-IF optimization can be modeled as a value driven optimization, since -adding a use definitely is cause for marking the continuation for -reoptimization. [When do we add uses? Let conversion is the only obvious -time.] I guess IF-IF conversion could also be triggered by a non-immediate use -of the test continuation becoming immediate, but to allow this to happen would -require Delete-Block (or somebody) to mark block-starts as needing to be -reoptimized when a predecessor changes. It's not clear how important it is -that IF-IF conversion happen under all possible circumstances, as long as it -happens to the obvious cases. - -[\#\#\# It isn't totally true that code flushing never enables other worthwhile -optimizations. Deleting a functional reference can cause a function to cease -being an XEP, or even trigger let conversion. It seems we still want to flush -code during ICR optimize, but maybe we want to interleave it more intimately -with the optimization pass. - -Ref-flushing works just as well forward as backward, so it could be done in the -forward pass. Call flushing doesn't work so well, but we could scan the block -backward looking for any new flushable stuff if we flushed a call on the -forward pass. - -When we delete a variable due to lack of references, we leave the variable -in the lambda-list so that positional references still work. The initial value -continuation is flushed, though (replaced with NIL) allowing the initial value -for to be deleted (modulo side-effects.) - -Note that we can delete vars with no refs even when they have sets. I guess -when there are no refs, we should also flush all sets, allowing the value -expressions to be flushed as well. - -Squeeze out single-reference unset let variables by changing the dest of the -initial value continuation to be the node that receives the ref. This can be -done regardless of what the initial value form is, since we aren't actually -moving the evaluation. Instead, we are in effect using the continuation's -locations in place of the temporary variable. - -Doing this is of course, a wild violation of stack discipline, since the ref -might be inside a loop, etc. But with the VMR back-end, we only need to -preserve stack discipline for unknown-value continuations; this ICR -transformation must be already be inhibited when the DEST of the REF is a -multiple-values receiver (EXIT, RETURN or MV-COMBINATION), since we must -preserve the single-value semantics of the let-binding in this case. - -The REF and variable must be deleted as part of this operation, since the ICR -would otherwise be left in an inconsistent state; we can't wait for the REF to -be deleted due to bing unused, since we have grabbed the arg continuation and -substituted it into the old DEST. - -The big reason for doing this transformation is that in macros such as INCF and -PSETQ, temporaries are squeezed out, and the new value expression is evaluated -directly to the setter, allowing any result type assertion to be applied to the -expression evaluation. Unlike in the case of substitution, there is no point -in inhibiting this transformation when the initial value type is weaker than -the variable type. Instead, we intersect the asserted type for the old REF's -CONT with the type assertion on the initial value continuation. Note that the -variable's type has already been asserted on the initial-value continuation. - -Of course, this transformation also simplifies the ICR even when it doesn't -discover interesting type assertions, so it makes sense to do it whenever -possible. This reduces the demands placed on register allocation, etc. - -|\# - -There are three dead-code flushing rules: - 1] Refs with no DEST may be flushed. - 2] Known calls with no dest that are flushable may be flushed. We null the - DEST in all the args. - 3] If a lambda-var has no refs, then it may be deleted. The flushed argument - continuations have their DEST nulled. - -These optimizations all enable one another. We scan blocks backward, looking -for nodes whose CONT has no DEST, then type-dispatching off of the node. If we -delete a ref, then we check to see if it is a lambda-var with no refs. When we -flush an argument, we mark the blocks for all uses of the CONT as needing to be -reoptimized. - - -\section{Goals for ICR optimizations} - -\#| - -When an optimization is disabled, code should still be correct and not -ridiculously inefficient. Phases shouldn't be made mandatory when they have -lots of non-required stuff jammed into them. - -|\# - -This pass is optional, but is desirable if anything is more important than -compilation speed. - -This phase is a grab-bag of optimizations that concern themselves with the flow -of values through the code representation. The main things done are type -inference, constant folding and dead expression elimination. This phase can be -understood as a walk of the expression tree that propagates assertions down the -tree and propagates derived information up the tree. The main complication is -that there isn't any expression tree, since ICR is flow-graph based. - -We repeat this pass until we don't discover anything new. This is a bit of -feat, since we dispatch to arbitrary functions which may do arbitrary things, -making it hard to tell if anything really happened. Even if we solve this -problem by requiring people to flag when they changed or by checking to see if -they changed something, there are serious efficiency problems due to massive -redundant computation, since in many cases the only way to tell if anything -changed is to recompute the value and see if it is different from the old one. - -We solve this problem by requiring that optimizations for a node only depend on -the properties of the CONT and the continuations that have the node as their -DEST. If the continuations haven't changed since the last pass, then we don't -attempt to re-optimize the node, since we know nothing interesting will happen. - -We keep track of which continuations have changed by a REOPTIMIZE flag that is -set whenever something about the continuation's value changes. - -When doing the bottom up pass, we dispatch to type specific code that knows how -to tell when a node needs to be reoptimized and does the optimization. These -node types are special-cased: COMBINATION, IF, RETURN, EXIT, SET. - -The REOPTIMIZE flag in the COMBINATION-FUN is used to detect when the function -information might have changed, so that we know when where are new assertions -that could be propagated from the function type to the arguments. - -When we discover something about a leaf, or substitute for leaf, we reoptimize -the CONT for all the REF and SET nodes. - -We have flags in each block that indicate when any nodes or continuations in -the block need to be re-optimized, so we don't have to scan blocks where there -is no chance of anything happening. - -It is important for efficiency purposes that optimizers never say that they did -something when they didn't, but this by itself doesn't guarantee timely -termination. I believe that with the type system implemented, type inference -will converge in finite time, but as a practical matter, it can take far too -long to discover not much. For this reason, ICR optimization is terminated -after three consecutive passes that don't add or delete code. This premature -termination only happens 2% of the time. - - -\section{Flow graph simplification} - -Things done: - Delete blocks with no predecessors. - Merge blocks that can be merged. - Convert local calls to Let calls. - Eliminate degenerate IFs. - -We take care not to merge blocks that are in different functions or have -different cleanups. This guarantees that non-local exits are always at block -ends and that cleanup code never needs to be inserted within a block. - -We eliminate IFs with identical consequent and alternative. This would most -likely happen if both the consequent and alternative were optimized away. - -[Could also be done if the consequent and alternative were different blocks, -but computed the same value. This could be done by a sort of cross-jumping -optimization that looked at the predecessors for a block and merged code shared -between predecessors. IFs with identical branches would eventually be left -with nothing in their branches.] - -We eliminate IF-IF constructs: - (IF (IF A B C) D E) ==> - (IF A (IF B D E) (IF C D E)) - -In reality, what we do is replicate blocks containing only an IF node where the -predicate continuation is the block start. We make one copy of the IF node for -each use, leaving the consequent and alternative the same. If you look at the -flow graph representation, you will see that this is really the same thing as -the above source to source transformation. - - -\section{Forward ICR optimizations} - -In the forward pass, we scan the code in forward depth-first order. We -examine each call to a known function, and: - -\begin{itemize} -\item Eliminate any bindings for unused variables. - -\item Do top-down type assertion propagation. In local calls, we propagate -asserted and derived types between the call and the called lambda. - -\item - Replace calls of foldable functions with constant arguments with the - result. We don't have to actually delete the call node, since Top-Down - optimize will delete it now that its value is unused. - -\item - Run any Optimizer for the current function. The optimizer does arbitrary - transformations by hacking directly on the IR. This is useful primarily - for arithmetic simplification and similar things that may need to examine - and modify calls other than the current call. The optimizer is responsible - for recording any changes that it makes. An optimizer can inhibit further - optimization of the node during the current pass by returning true. This - is useful when deleting the node. - -\item - Do ICR transformations, replacing a global function call with equivalent - inline lisp code. - -\item - Do bottom-up type propagation/inferencing. For some functions such as - Coerce we will dispatch to a function to find the result type. The - Derive-Type function just returns a type structure, and we check if it is - different from the old type in order to see if there was a change. - -\item - Eliminate IFs with predicates known to be true or false. - -\item - Substitute the value for unset let variables that are bound to constants, - unset lambda variables or functionals. - -\item - Propagate types from local call args to var refs. -\end{itemize} - -We use type info from the function continuation to find result types for -functions that don't have a derive-type method. - - -ICR transformation: - -ICR transformation does "source to source" transformations on known global -functions, taking advantage of semantic information such as argument types and -constant arguments. Transformation is optional, but should be done if speed or -space is more important than compilation speed. Transformations which increase -space should pass when space is more important than speed. - -A transform is actually an inline function call where the function is computed -at compile time. The transform gets to peek at the continuations for the -arguments, and computes a function using the information gained. Transforms -should be cautious about directly using the values of constant continuations, -since the compiler must preserve eqlness of named constants, and it will have a -hard time if transforms go around randomly copying constants. - -The lambda that the transform computes replaces the original function variable -reference as the function for the call. This lets the compiler worry about -evaluating each argument once in the right order. We want to be careful to -preserve type information when we do a transform, since it may be less than -obvious what the transformed code does. - -There can be any number of transforms for a function. Each transform is -associated with a function type that the call must be compatible with. A -transform is only invoked if the call has the right type. This provides a way -to deal with the common case of a transform that only applies when the -arguments are of certain types and some arguments are not specified. We always -use the derived type when determining whether a transform is applicable. Type -check is responsible for setting the derived type to the intersection of the -asserted and derived types. - -If the code in the expansion has insufficient explicit or implicit argument -type checking, then it should cause checks to be generated by making -declarations. - -A transformation may decide to pass if it doesn't like what it sees when it -looks at the args. The Give-Up function unwinds out of the transform and deals -with complaining about inefficiency if speed is more important than brevity. -The format args for the message are arguments to Give-Up. If a transform can't -be done, we just record the message where ICR finalize can find it. note. We -can't complain immediately, since it might get transformed later on. - - -\section{Backward ICR optimizations} - -In the backward pass, we scan each block in reverse order, and -eliminate any effectless nodes with unused values. In ICR this is the -only way that code is deleted other than the elimination of unreachable blocks. - - -\chapter{Type checking} - -[\#\#\# Somehow split this section up into three parts: - -- Conceptual: how we know a check is necessary, and who is responsible for - doing checks. - -- Incremental: intersection of derived and asserted types, checking for - non-subtype relationship. - -- Check generation phase. -] - - -We need to do a pretty good job of guessing when a type check will ultimately -need to be done. Generic arithmetic, for example: In the absence of -declarations, we will use use the safe variant, but if we don't know this, we -will generate a check for NUMBER anyway. We need to look at the fast-safe -templates and guess if any of them could apply. - -We compute a function type from the VOP arguments -and assertions on those arguments. This can be used with Valid-Function-Use -to see which templates do or might apply to a particular call. If we guess -that a safe implementation will be used, then we mark the continuation so as to -force a safe implementation to be chosen. [This will happen if ICR optimize -doesn't run to completion, so the icr optimization after type check generation -can discover new type information. Since we won't redo type check at that -point, there could be a call that has applicable unsafe templates, but isn't -type checkable.] - -[\#\#\# A better and more general optimization of structure type checks: in type -check conversion, we look at the *original derived* type of the continuation: -if the difference between the proven type and the asserted type is a simple -type check, then check for the negation of the difference. e.g. if we want a -FOO and we know we've got (OR FOO NULL), then test for (NOT NULL). This is a -very important optimization for linked lists of structures, but can also apply -in other situations.] - -If after ICR phases, we have a continuation with check-type set in a context -where it seems likely a check will be emitted, and the type is too -hairy to be easily checked (i.e. no CHECK-xxx VOP), then we do a transformation -on the ICR equivalent to: - (... (the hair <foo>) ...) -==> - (... (funcall \#'(lambda (\#:val) - (if (typep \#:val 'hair) - \#:val - (%type-check-error \#:val 'hair))) - <foo>) - ...) -This way, we guarantee that VMR conversion never has to emit type checks for -hairy types. - -[Actually, we need to do a MV-bind and several type checks when there is a MV -continuation. And some values types are just too hairy to check. We really -can't check any assertion for a non-fixed number of values, since there isn't -any efficient way to bind arbitrary numbers of values. (could be done with -MV-call of a more-arg function, I guess...) -] - -[Perhaps only use CHECK-xxx VOPs for types equivalent to a ptype? Exceptions -for CONS and SYMBOL? Anyway, no point in going to trouble to implement and -emit rarely used CHECK-xxx vops.] - -One potential lose in converting a type check to explicit conditionals rather -than to a CHECK-xxx VOP is that VMR code motion optimizations won't be able to -do anything. This shouldn't be much of an issue, though, since type constraint -propagation has already done global optimization of type checks. - - -This phase is optional, but should be done if anything is more important than -compile speed. - -Type check is responsible for reconciling the continuation asserted and derived -types, emitting type checks if appropriate. If the derived type is a subtype -of the asserted type, then we don't need to do anything. - -If there is no intersection between the asserted and derived types, then there -is a manifest type error. We print a warning message, indicating that -something is almost surely wrong. This will inhibit any transforms or -generators that care about their argument types, yet also inhibits further -error messages, since NIL is a subtype of every type. - -If the intersection is not null, then we set the derived type to the -intersection of the asserted and derived types and set the Type-Check flag in -the continuation. We always set the flag when we can't prove that the type -assertion is satisfied, regardless of whether we will ultimately actually emit -a type check or not. This is so other phases such as type constraint -propagation can use the Type-Check flag to detect an interesting type -assertion, instead of having to duplicate much of the work in this phase. -[\#\#\# 7 extremely random values for CONTINUATION-TYPE-CHECK.] - -Type checks are generated on the fly during VMR conversion. When VMR -conversion generates the check, it prints an efficiency note if speed is -important. We don't flame now since type constraint progpagation may decide -that the check is unnecessary. [\#\#\# Not done now, maybe never.] - -In local function call, it is the caller that is in effect responsible for -checking argument types. This happens in the same way as any other type check, -since ICR optimize propagates the declared argument types to the type -assertions for the argument continuations in all the calls. - -Since the types of arguments to entry points are unknown at compile time, we -want to do runtime checks to ensure that the incoming arguments are of the -correct type. This happens without any special effort on the part of type -check, since the XEP is represented as a local call with unknown type -arguments. These arguments will be marked as needing to be checked. - - -\chapter{Constraint propagation} - -\#| -New lambda-var-slot: - -constraints: a list of all the constraints on this var for either X or Y. - -How to maintain consistency? Does it really matter if there are constraints -with deleted vars lying around? Note that whatever mechanism we use for -getting the constraints in the first place should tend to keep them up to date. -Probably we would define optimizers for the interesting relations that look at -their CONT's dest and annotate it if it is an IF. - -But maybe it is more trouble then it is worth trying to build up the set of -constraints during ICR optimize (maintaining consistency in the process). -Since ICR optimize iterates a bunch of times before it converges, we would be -wasting time recomputing the constraints, when nobody uses them till constraint -propagation runs. - -It seems that the only possible win is if we re-ran constraint propagation -(which we might want to do.) In that case, we wouldn't have to recompute all -the constraints from scratch. But it seems that we could do this just as well -by having ICR optimize invalidate the affected parts of the constraint -annotation, rather than trying to keep them up to date. This also fits better -with the optional nature of constraint propagation, since we don't want ICR -optimize to commit to doing a lot of the work of constraint propagation. - -For example, we might have a per-block flag indicating that something happened -in that block since the last time constraint propagation ran. We might have -different flags to represent the distinction between discovering a new type -assertion inside the block and discovering something new about an if -predicate, since the latter would be cheaper to update and probably is more -common. - -It's fairly easy to see how we can build these sets of restrictions and -propagate them using flow analysis, but actually using this information seems -a bit more ad-hoc. - -Probably the biggest thing we do is look at all the refs. If have proven that -the value is EQ (EQL for a number) to some other leaf (constant or lambda-var), -then we can substitute for that reference. In some cases, we will want to do -special stuff depending on the DEST. If the dest is an IF and we proved (not -null), then we can substitute T. And if the dest is some relation on the same -two lambda-vars, then we want to see if we can show that relation is definitely -true or false. - -Otherwise, we can do our best to invert the set of restrictions into a type. -Since types hold only constant info, we have to ignore any constraints between -two vars. We can make some use of negated type restrictions by using -TYPE-DIFFERENCE to remove the type from the ref types. If our inferred type is -as good as the type assertion, then the continuation's type-check flag will be -cleared. - -It really isn't much of a problem that we don't infer union types on joins, -since union types are relatively easy to derive without using flow information. -The normal bottom-up type inference done by ICR optimize does this for us: it -annotates everything with the union of all of the things it might possibly be. -Then constraint propagation subtracts out those types that can't be in effect -because of predicates or checks. - - - -This phase is optional, but is desirable if anything is more important than -compilation speed. We use an algorithm similar to available expressions to -propagate variable type information that has been discovered by implicit or -explicit type tests, or by type inference. - -We must do a pre-pass which locates set closure variables, since we cannot do -flow analysis on such variables. We set a flag in each set closure variable so -that we can quickly tell that it is losing when we see it again. Although this -may seem to be wastefully redundant with environment analysis, the overlap -isn't really that great, and the cost should be small compared to that of the -flow analysis that we are preparing to do. [Or we could punt on set -variables...] - -A type constraint is a structure that includes sset-element and has the type -and variable. -[\#\#\# Also a not-p flag indicating whether the sense is negated.] - Each variable has a list of its type constraints. We create a -type constraint when we see a type test or check. If there is already a -constraint for the same variable and type, then we just re-use it. If there is -already a weaker constraint, then we generate both the weak constraints and the -strong constraint so that the weak constraints won't be lost even if the strong -one is unavailable. - -We find all the distinct type constraints for each variable during the pre-pass -over the lambda nesting. Each constraint has a list of the weaker constraints -so that we can easily generate them. - -Every block generates all the type constraints in it, but a constraint is -available in a successor only if it is available in all predecessors. We -determine the actual type constraint for a variable at a block by intersecting -all the available type constraints for that variable. - -This isn't maximally tense when there are constraints that are not -hierarchically related, e.g. (or a b) (or b c). If these constraints were -available from two predecessors, then we could infer that we have an (or a b c) -constraint, but the above algorithm would come up with none. This probably -isn't a big problem. - -[\#\#\# Do we want to deal with (if (eq <var> '<foo>) ...) indicating singleton -member type?] - -We detect explicit type tests by looking at type test annotation in the IF -node. If there is a type check, the OUT sets are stored in the node, with -different sets for the consequent and alternative. Implicit type checks are -located by finding Ref nodes whose Cont has the Type-Check flag set. We don't -actually represent the GEN sets, we just initialize OUT to it, and then form -the union in place. - -When we do the post-pass, we clear the Type-Check flags in the continuations -for Refs when we discover that the available constraints satisfy the asserted -type. Any explicit uses of typep should be cleaned up by the ICR optimizer for -typep. We can also set the derived type for Refs to the intersection of the -available type assertions. If we discover anything, we should consider redoing -ICR optimization, since better type information might enable more -optimizations. - - -\chapter{ICR finalize} % -*- Dictionary: design -*- - -This pass looks for interesting things in the ICR so that we can forget about -them. Used and not defined things are flamed about. - -We postpone these checks until now because the ICR optimizations may discover -errors that are not initially obvious. We also emit efficiency notes about -optimizations that we were unable to do. We can't emit the notes immediately, -since we don't know for sure whether a repeated attempt at optimization will -succeed. - -We examine all references to unknown global function variables and update the -approximate type accordingly. We also record the names of the unknown -functions so that they can be flamed about if they are never defined. Unknown -normal variables are flamed about on the fly during ICR conversion, so we -ignore them here. - -We check each newly defined global function for compatibility with previously -recorded type information. If there is no :defined or :declared type, then we -check for compatibility with any approximate function type inferred from -previous uses. - -\chapter{Environment analysis} -\#| - -A related change would be to annotate ICR with information about tail-recursion -relations. What we would do is add a slot to the node structure that points to -the corresponding Tail-Info when a node is in a TR position. This annotation -would be made in a final ICR pass that runs after cleanup code is generated -(part of environment analysis). When true, the node is in a true TR position -(modulo return-convention incompatibility). When we determine return -conventions, we null out the tail-p slots in XEP calls or known calls where we -decided not to preserve tail-recursion. - - -In this phase, we also check for changes in the dynamic binding environment -that require cleanup code to be generated. We just check for changes in the -Continuation-Cleanup on local control transfers. If it changes from -an inner dynamic context to an outer one that is in the same environment, then -we emit code to clean up the dynamic bindings between the old and new -continuation. We represent the result of cleanup detection to the back end by -interposing a new block containing a call to a funny function. Local exits -from CATCH or UNWIND-PROTECT are detected in the same way. - - -|\# - -The primary activity in environment analysis is the annotation of ICR with -environment structures describing where variables are allocated and what values -the environment closes over. - -Each lambda points to the environment where its variables are allocated, and -the environments point back. We always allocate the environment at the Bind -node for the sole non-let lambda in the environment, so there is a close -relationship between environments and functions. Each "real function" (i.e. -not a LET) has a corresponding environment. - -We attempt to share the same environment among as many lambdas as possible so -that unnecessary environment manipulation is not done. During environment -analysis the only optimization of this sort is realizing that a Let (a lambda -with no Return node) cannot need its own environment, since there is no way -that it can return and discover that its old values have been clobbered. - -When the function is called, values from other environments may need to be made -available in the function's environment. These values are said to be "closed -over". - -Even if a value is not referenced in a given environment, it may need to be -closed over in that environment so that it can be passed to a called function -that does reference the value. When we discover that a value must be closed -over by a function, we must close over the value in all the environments where -that function is referenced. This applies to all references, not just local -calls, since at other references we must have the values on hand so that we can -build a closure. This propagation must be applied recursively, since the value -must also be available in *those* functions' callers. - -If a closure reference is known to be "safe" (not an upward funarg), then the -closure structure may be allocated on the stack. - -Closure analysis deals only with closures over values, while Common Lisp -requires closures over variables. The difference only becomes significant when -variables are set. If a variable is not set, then we can freely make copies of -it without keeping track of where they are. When a variable is set, we must -maintain a single value cell, or at least the illusion thereof. We achieve -this by creating a heap-allocated "value cell" structure for each set variable -that is closed over. The pointer to this value cell is passed around as the -"value" corresponding to that variable. References to the variable must -explicitly indirect through the value cell. - -When we are scanning over the lambdas in the component, we also check for bound -but not referenced variables. - -Environment analysis emits cleanup code for local exits and markers for -non-local exits. - -A non-local exit is a control transfer from one environment to another. In a -non-local exit, we must close over the continuation that we transfer to so that -the exiting function can find its way back. We indicate the need to close a -continuation by placing the continuation structure in the closure and also -pushing it on a list in the environment structure for the target of the exit. -[\#\#\# To be safe, we would treat the continuation as a set closure variable so -that we could invalidate it when we leave the dynamic extent of the exit point. -Transferring control to a meaningless stack pointer would be apt to cause -horrible death.] - -Each local control transfer may require dynamic state such as special bindings -to be undone. We represent cleanup actions by funny function calls in a new -block linked in as an implicit MV-PROG1. - diff --git a/docs/internals/glossary.tex b/docs/internals/glossary.tex deleted file mode 100644 index 1befb2191c32a92062858ef6f420aa4b9b8c6644..0000000000000000000000000000000000000000 --- a/docs/internals/glossary.tex +++ /dev/null @@ -1,411 +0,0 @@ -\chapter{Glossary}% -*- Dictionary: int:design -*- - -% Note: in an entry, any word that is also defined should be \it -% should entries have page references as well? - -\begin{description} -\item[assert (a type)] -In Python, all type checking is done via a general type assertion -mechanism. Explicit declarations and implicit assertions (e.g. the arg to -+ is a number) are recorded in the front-end (implicit continuation) -representation. Type assertions (and thus type-checking) are "unbundled" -from the operations that are affected by the assertion. This has two major -advantages: -\begin{itemize} -\item Code that implements operations need not concern itself with checking -operand types. - -\item Run-time type checks can be eliminated when the compiler can prove that -the assertion will always be satisfied. -\end{itemize} -See also {\it restrict}. - -\item[back end] The back end is the part of the compiler that operates on the -{\it virtual machine} intermediate representation. Also included are the -compiler phases involved in the conversion from the {\it front end} -representation (or {\it ICR}). - -\item[bind node] This is a node type the that marks the start of a {\it lambda} -body in {\it ICR}. This serves as a placeholder for environment manipulation -code. - -\item[IR1] The first intermediate representation, also known as {\it ICR}, or -the Implicit Continuation Represenation. - -\item[IR2] The second intermediate representation, also known as {\it VMR}, or -the Virtual Machine Representation. - -\item[basic block] A basic block (or simply "block") has the pretty much the -usual meaning of representing a straight-line sequence of code. However, the -code sequence ultimately generated for a block might contain internal branches -that were hidden inside the implementation of a particular operation. The type -of a block is actually {\tt cblock}. The {\tt block-info} slot holds an -{\tt VMR-block} containing backend information. - -\item[block compilation] Block compilation is a term commonly used to describe -the compile-time resolution of function names. This enables many -optimizations. - -\item[call graph] -Each node in the call graph is a function (represented by a {\it flow graph}.) -The arcs in the call graph represent a possible call from one function to -another. See also {\it tail set}. - -\item[cleanup] -A cleanup is the part of the implicit continuation representation that -retains information scoping relationships. For indefinite extent bindings -(variables and functions), we can abandon scoping information after ICR -conversion, recovering the lifetime information using flow analysis. But -dynamic bindings (special values, catch, unwind protect, etc.) must be -removed at a precise time (whenever the scope is exited.) Cleanup -structures form a hierarchy that represents the static nesting of dynamic -binding structures. When the compiler does a control transfer, it can use -the cleanup information to determine what cleanup code needs to be emitted. - -\item[closure variable] -A closure variable is any lexical variable that has references outside of -its {\it home environment}. See also {\it indirect value cell}. - -\item[closed continuation] A closed continuation represents a {\tt tagbody} tag -or {\tt block} name that is closed over. These two cases are mostly -indistinguishable in {\it ICR}. - -\item[home] Home is a term used to describe various back-pointers. A lambda -variable's "home" is the lambda that the variable belongs to. A lambda's "home -environment" is the environment in which that lambda's variables are allocated. - -\item[indirect value cell] -Any closure variable that has assignments ({\tt setq}s) will be allocated in an -indirect value cell. This is necessary to ensure that all references to -the variable will see assigned values, since the compiler normally freely -copies values when creating a closure. - -\item[set variable] Any variable that is assigned to is called a "set -variable". Several optimizations must special-case set variables, and set -closure variables must have an {\it indirect value cell}. - -\item[code generator] The code generator for a {\it VOP} is a potentially -arbitrary list code fragment which is responsible for emitting assembly code to -implement that VOP. - -\item[constant pool] The part of a compiled code object that holds pointers to -non-immediate constants. - -\item[constant TN] -A constant TN is the {\it VMR} of a compile-time constant value. A -constant may be immediate, or may be allocated in the {\it constant pool}. - -\item[constant leaf] -A constant {\it leaf} is the {\it ICR} of a compile-time constant value. - -\item[combination] -A combination {\it node} is the {\it ICR} of any fixed-argument function -call (not {\tt apply} or {\tt multiple-value-call}.) - -\item[top-level component] -A top-level component is any component whose only entry points are top-level -lambdas. - -\item[top-level lambda] -A top-level lambda represents the execution of the outermost form on which -the compiler was invoked. In the case of {\tt compile-file}, this is often a -truly top-level form in the source file, but the compiler can recursively -descend into some forms ({\tt eval-when}, etc.) breaking them into separate -compilations. - -\item[component] A component is basically a sequence of blocks. Each component -is compiled into a separate code object. With {\it block compilation} or {\it -local functions}, a component will contain the code for more than one function. -This is called a component because it represents a connected portion of the -call graph. Normally the blocks are in depth-first order ({\it DFO}). - -\item[component, initial] During ICR conversion, blocks are temporarily -assigned to initial components. The "flow graph canonicalization" phase -determines the true component structure. - -\item[component, head and tail] -The head and tail of a component are dummy blocks that mark the start and -end of the {\it DFO} sequence. The component head and tail double as the root -and finish node of the component's flow graph. - -\item[local function (call)] -A local function call is a call to a function known at compile time to be -in the same {\it component}. Local call allows compile time resolution of the -target address and calling conventions. See {\it block compilation}. - -\item[conflict (of TNs, set)] -Register allocation terminology. Two TNs conflict if they could ever be -live simultaneously. The conflict set of a TN is all TNs that it conflicts -with. - -\item[continuation] -The ICR data structure which represents both: -\begin{itemize} -\item The receiving of a value (or multiple values), and - -\item A control location in the flow graph. -\end{itemize} -In the Implicit Continuation Representation, the environment is implicit in the -continuation's BLOCK (hence the name.) The ICR continuation is very similar to -a CPS continuation in its use, but its representation doesn't much resemble (is -not interchangeable with) a lambda. - -\item[cont] A slot in the {\it node} holding the {\it continuation} which -receives the node's value(s). Unless the node ends a {\it block}, this also -implicitly indicates which node should be evaluated next. - -\item[cost] Approximations of the run-time costs of operations are widely used -in the back end. By convention, the unit is generally machine cycles, but the -values are only used for comparison between alternatives. For example, the -VOP cost is used to determine the preferred order in which to try possible -implementations. - -\item[CSP, CFP] See {\it control stack pointer} and {\it control frame -pointer}. - -\item[Control stack] The main call stack, which holds function stack frames. -All words on the control stack are tagged {\it descriptors}. In all ports done -so far, the control stack grows from low memory to high memory. The most -recent call frames are considered to be ``on top'' of earlier call frames. - -\item[Control stack pointer] The allocation pointer for the {\it control -stack}. Generally this points to the first free word at the top of the stack. - -\item[Control frame pointer] The pointer to the base of the {\it control stack} -frame for a particular function invocation. The CFP for the running function -must be in a register. - -\item[Number stack] The auxiliary stack used to hold any {\it non-descriptor} -(untagged) objects. This is generally the same as the C call stack, and thus -typically grows down. - -\item[Number stack pointer] The allocation pointer for the {\it number stack}. -This is typically the C stack pointer, and is thus kept in a register. - -\item[NSP, NFP] See {\it number stack pointer}, {\it number frame pointer}. - -\item[Number frame pointer] The pointer to the base of the {\it number stack} -frame for a particular function invocation. Functions that don't use the -number stack won't have an NFP, but if an NFP is allocated, it is always -allocated in a particular register. If there is no variable-size data on the -number stack, then the NFP will generally be identical to the NSP. - -\item[Lisp return address] The name of the {\it descriptor} encoding the -"return pc" for a function call. - -\item[LRA] See {\it lisp return address}. Also, the name of the register where -the LRA is passed. - - -\item[Code pointer] A pointer to the header of a code object. The code pointer -for the currently running function is stored in the {\tt code} register. - -\item[Interior pointer] A pointer into the inside of some heap-allocated -object. Interior pointers confuse the garbage collector, so their use is -highly constrained. Typically there is a single register dedicated to holding -interior pointers. - -\item[dest] -A slot in the {\it continuation} which points the the node that receives this -value. Null if this value is not received by anyone. - -\item[DFN, DFO] See {\it Depth First Number}, {\it Depth First Order}. - -\item[Depth first number] Blocks are numbered according to their appearance in -the depth-first ordering (the {\tt block-number} slot.) The numbering actually -increases from the component tail, so earlier blocks have larger numbers. - -\item[Depth first order] This is a linearization of the flow graph, obtained by -a depth-first walk. Iterative flow analysis algorithms work better when blocks -are processed in DFO (or reverse DFO.) - - -\item[Object] In low-level design discussions, an object is one of the -following: -\begin{itemize} -\item a single word containing immediate data (characters, fixnums, etc) -\item a single word pointing to an object (structures, conses, etc.) -\end{itemize} -These are tagged with three low-tag bits as described in the section -\ref{tagging} This is synonymous with {\it descriptor}. -In other parts of the documentation, may be used more loosely to refer to a -{\it lisp object}. - -\item[Lisp object] -A Lisp object is a high-level object discussed as a data type in the Common -Lisp definition. - -\item[Data-block] -A data-block is a dual-word aligned block of memory that either manifests a -Lisp object (vectors, code, symbols, etc.) or helps manage a Lisp object on -the heap (array header, function header, etc.). - -\item[Descriptor] -A descriptor is a tagged, single-word object. It either contains immediate -data or a pointer to data. This is synonymous with {\it object}. Storage -locations that must contain descriptors are referred to as descriptor -locations. - -\item[Pointer descriptor] -A descriptor that points to a {\it data block} in memory (i.e. not an immediate -object.) - -\item[Immediate descriptor] -A descriptor that encodes the object value in the descriptor itself; used for -characters, fixnums, etc. - -\item[Word] -A word is a 32-bit quantity. - -\item[Non-descriptor] -Any chunk of bits that isn't a valid tagged descriptor. For example, a -double-float on the number stack. Storage locations that are not scanned by -the garbage collector (and thus cannot contain {\it pointer descriptors}) are -called non-descriptor locations. {\it Immediate descriptors} can be stored in -non-descriptor locations. - - -\item[Entry point] An entry point is a function that may be subject to -``unpredictable'' control transfers. All entry points are linked to the root -of the flow graph (the component head.) The only functions that aren't entry -points are {\it let} functions. When complex lambda-list syntax is used, -multiple entry points may be created for a single lisp-level function. -See {\it external entry point}. - -\item[External entry point] A function that serves as a ``trampoline'' to -intercept function calls coming in from outside of the component. The XEP does -argument syntax and type checking, and may also translate the arguments and -return values for a locally specialized calling calling convention. - -\item[XEP] An {\it external entry point}. - -\item[lexical environment] A lexical environment is a structure that is used -during VMR conversion to represent all lexically scoped bindings (variables, -functions, declarations, etc.) Each {\tt node} is annotated with its lexical -environment, primarily for use by the debugger and other user interfaces. This -structure is also the environment object passed to {\tt macroexpand}. - -\item[environment] The environment is part of the ICR, created during -environment analysis. Environment analysis apportions code to disjoint -environments, with all code in the same environment sharing the same stack -frame. Each environment has a ``{\it real}'' function that allocates it, and -some collection {\tt let} functions. Although environment analysis is the -last ICR phase, in earlier phases, code is sometimes said to be ``in the -same/different environment(s)''. This means that the code will definitely be -in the same environment (because it is in the same real function), or that is -might not be in the same environment, because it is not in the same function. - -\item[fixup] Some sort of back-patching annotation. The main sort encountered -are load-time {\it assembler fixups}, which are a linkage annotation mechanism. - -\item[flow graph] A flow graph is a directed graph of basic blocks, where each -arc represents a possible control transfer. The flow graph is the basic data -structure used to represent code, and provides direct support for data flow -analysis. See component and ICR. - -\item[foldable] An attribute of {\it known functions}. A function is foldable -if calls may be constant folded whenever the arguments are compile-time -constant. Generally this means that it is a pure function with no side -effects. - - -FSC -full call -function attribute -function - "real" (allocates environment) - meaning function-entry - more vague (any lambda?) -funny function -GEN (kill and...) -global TN, conflicts, preference -GTN (number) -IR ICR VMR ICR conversion, VMR conversion (translation) -inline expansion, call -kill (to make dead) -known function -LAMBDA -leaf -let call -lifetime analysis, live (tn, variable) -load tn -LOCS (passing, return locations) -local call -local TN, conflicts, (or just used in one block) -location (selection) -LTN (number) -main entry -mess-up (for cleanup) -more arg (entry) -MV -non-local exit -non-packed SC, TN -non-set variable -operand (to vop) -optimizer (in icr optimize) -optional-dispatch -pack, packing, packed -pass (in a transform) -passing - locations (value) - conventions (known, unknown) -policy (safe, fast, small, ...) -predecessor block -primitive-type -reaching definition -REF -representation - selection - for value -result continuation (for function) -result type assertion (for template) (or is it restriction) -restrict - a TN to finite SBs - a template operand to a primitive type (boxed...) - a tn-ref to particular SCs - -return (node, vops) -safe, safety -saving (of registers, costs) -SB -SC (restriction) -semi-inline -side-effect - in ICR - in VMR -sparse set -splitting (of VMR blocks) -SSET -SUBPRIMITIVE -successor block -tail recursion - tail recursive - tail recursive loop - user tail recursion - -template -TN -TNBIND -TN-REF -transform (source, ICR) -type - assertion - inference - top-down, bottom-up - assertion propagation - derived, asserted - descriptor, specifier, intersection, union, member type - check -type-check (in continuation) -UNBOXED (boxed) descriptor -unknown values continuation -unset variable -unwind-block, unwinding -used value (dest) -value passing -VAR -VM -VOP -XEP - -\end{description} diff --git a/docs/internals/interface.tex b/docs/internals/interface.tex deleted file mode 100644 index 8a036452f2b6c0a344f366faab684fa3e3cc2c7e..0000000000000000000000000000000000000000 --- a/docs/internals/interface.tex +++ /dev/null @@ -1,6 +0,0 @@ -\chapter{User Interface} - -\section{Error Message Utilities} - -\section{Source Paths} - diff --git a/docs/internals/internal-design.txt b/docs/internals/internal-design.txt deleted file mode 100644 index 071e1d93aaad705eee7fcf945110ccaf0c955f67..0000000000000000000000000000000000000000 --- a/docs/internals/internal-design.txt +++ /dev/null @@ -1,694 +0,0 @@ - - -;;;; Terminology. - -OBJECT - An object is one of the following: - a single word containing immediate data (characters, fixnums, etc) - a single word pointing to an object (structures, conses, etc.) - These are tagged with three low-tag bits as described in the section - "Tagging". This is synonymous with DESCRIPTOR. - -LISP OBJECT - A Lisp object is a high-level object discussed as a data type in Common - Lisp: The Language. - -DATA-BLOCK - A data-block is a dual-word aligned block of memory that either manifests a - Lisp object (vectors, code, symbols, etc.) or helps manage a Lisp object on - the heap (array header, function header, etc.). - -DESCRIPTOR - A descriptor is a tagged, single-word object. It either contains immediate - data or a pointer to data. This is synonymous with OBJECT. - -WORD - A word is a 32-bit quantity. - - - -;;;; Tagging. - -The following is a key of the three bit low-tagging scheme: - 000 even fixnum - 001 function pointer - 010 other-immediate (header-words, characters, symbol-value trap value, etc.) - 011 list pointer - 100 odd fixnum - 101 structure pointer - 110 unused - 111 other-pointer to data-blocks (other than conses, structures, - and functions) - -This taging scheme forces a dual-word alignment of data-blocks on the heap, but -this can be pretty negligible: - RATIOS and COMPLEX must have a header-word anyway since they are not a - major type. This wastes one word for these infrequent data-blocks since - they require two words for the data. - BIGNUMS must have a header-word and probably contain only one other word - anyway, so we probably don't waste any words here. Most bignums just - barely overflow fixnums, that is by a bit or two. - Single and double FLOATS? - no waste - one word wasted - SYMBOLS are dual-word aligned with the header-word. - Everything else is vector-like including code, so these probably take up - so many words that one extra one doesn't matter. - - - -;;;; GC Comments. - -Data-Blocks comprise only descriptors, or they contain immediate data and raw -bits interpreted by the system. GC must skip the latter when scanning the -heap, so it does not look at a word of raw bits and interpret it as a pointer -descriptor. These data-blocks require headers for GC as well as for operations -that need to know how to interpret the raw bits. When GC is scanning, and it -sees a header-word, then it can determine how to skip that data-block if -necessary. Header-Words are tagged as other-immediates. See the sections -"Other-Immediates" and "Data-Blocks and Header-Words" for comments on -distinguishing header-words from other-immediate data. This distinction is -necessary since we scan through data-blocks containing only descriptors just as -we scan through the heap looking for header-words introducing data-blocks. - -Data-Blocks containing only descriptors do not require header-words for GC -since the entire data-block can be scanned by GC a word at a time, taking -whatever action is necessary or appropriate for the data in that slot. For -example, a cons is referenced by a descriptor with a specific tag, and the -system always knows the size of this data-block. When GC encounters a pointer -to a cons, it can transport it into the new space, and when scanning, it can -simply scan the two words manifesting the cons interpreting each word as a -descriptor. Actually there is no cons tag, but a list tag, so we make sure the -cons is not nil when appropriate. A header may still be desired if the pointer -to the data-block does not contain enough information to adequately maintain -the data-block. An example of this is a simple-vector containing only -descriptor slots, and we attach a header-word because the descriptor pointing -to the vector lacks necessary information -- the type of the vector's elements, -its length, etc. - -There is no need for a major tag for GC forwarding pointers. Since the tag -bits are in the low end of the word, a range check on the start and end of old -space tells you if you need to move the thing. This is all GC overhead. - - - -;;;; Structures. - -Structures comprise a word for each slot in the definition in addition to one -word, a type slot which is a pointer descriptor. This points to a structure -describing the data-block as a structure, a defstruct-descriptor object. When -operating on a structure, doing a structure test can be done by simply checking -the tag bits on the pointer descriptor referencing it. As described in section -"GC Comments", data-blocks such as those representing structures may avoid -having a header-word since they are GC-scanable without any problem. This -saves two words for every structure instance. - - - -;;;; Fixnums. - -A fixnum has one of the following formats in 32 bits: - ------------------------------------------------------- - | 30 bit 2's complement even integer | 0 0 0 | - ------------------------------------------------------- -or - ------------------------------------------------------- - | 30 bit 2's complement odd integer | 1 0 0 | - ------------------------------------------------------- - -Effectively, there is one tag for immediate integers, two zeros. This buys one -more bit for fixnums, and now when these numbers index into simple-vectors or -offset into memory, they point to word boundaries on 32-bit, byte-addressable -machines. That is, no shifting need occur to use the number directly as an -offset. - -This format has another advantage on byte-addressable machines when fixnums are -offsets into vector-like data-blocks, including structures. Even though we -previously mentioned data-blocks are dual-word aligned, most indexing and slot -accessing is word aligned, and so are fixnums with effectively two tag bits. - -Two tags also allow better usage of special instructions on some machines that -can deal with two low-tag bits but not three. - -Since the two bits are zeros, we avoid having to mask them off before using the -words for arithmetic, but division and multiplication require special shifting. - - - -;;;; Other-immediates. - -An other-immediate has the following format: - ---------------------------------------------------------------- - | Data (24 bits) | Type (8 bits with low-tag) | 0 1 0 | - ---------------------------------------------------------------- - -The system uses eight bits of type when checking types and defining system -constants. This allows allows for 32 distinct other-immediate objects given -the three low-tag bits tied down. - -The system uses this format for characters, SYMBOL-VALUE unbound trap value, -and header-words for data-blocks on the heap. The type codes are laid out to -facilitate range checks for common subtypes; for example, all numbers will have -contiguous type codes which are distinct from the contiguous array type codes. -See section "Data-Blocks and Other-immediates Typing" for details. - - - -;;;; Data-Blocks and Header-Word Format. - -Pointers to data-blocks have the following format: - ---------------------------------------------------------------- - | Dual-word address of data-block (29 bits) | 1 1 1 | - ---------------------------------------------------------------- - -The word pointed to by the above descriptor is a header-word, and it has the -same format as an other-immediate: - ---------------------------------------------------------------- - | Data (24 bits) | Type (8 bits with low-tag) | 0 1 0 | - ---------------------------------------------------------------- - -This is convenient for scanning the heap when GC'ing, but it does mean that -whenever GC encounters an other-immediate word, it has to do a range check on -the low byte to see if it is a header-word or just a character (for example). -This is easily acceptable performance hit for scanning. - -The system interprets the data portion of the header-word for non-vector -data-blocks as the word length excluding the header-word. For example, the -data field of the header for ratio and complex numbers is two, one word each -for the numerator and denominator or for the real and imaginary parts. - -For vectors and data-blocks representing Lisp objects stored like vectors, the -system ignores the data portion of the header-word: - ---------------------------------------------------------------- - | Unused Data (24 bits) | Type (8 bits with low-tag) | 0 1 0 | - ---------------------------------------------------------------- - | Element Length of Vector (30 bits) | 0 0 | - ---------------------------------------------------------------- - -Using a separate word allows for much larger vectors, and it allows LENGTH to -simply access a single word without masking or shifting. Similarly, the header -for complex arrays and vectors has a second word, following the header-word, -the system uses for the fill pointer, so computing the length of any array is -the same code sequence. - - - -;;;; Data-Blocks and Other-immediates Typing. - -These are the other-immediate types. We specify them including all low eight -bits, including the other-immediate tag, so we can think of the type bits as -one type -- not an other-immediate major type and a subtype. Also, fetching a -byte and comparing it against a constant is more efficient than wasting even a -small amount of time shifting out the other-immediate tag to compare against a -five bit constant. - - Number (< 30) -00000 010 bignum 10 -00000 010 ratio 14 -00000 010 single-float 18 -00000 010 double-float 22 -00000 010 complex 26 - - Array (>= 30 code 86) - Simple-Array (>= 20 code 70) -00000 010 simple-array 30 - Vector (>= 34 code 82) -00000 010 simple-string 34 -00000 010 simple-bit-vector 38 -00000 010 simple-vector 42 -00000 010 (simple-array (unsigned-byte 2) (*)) 46 -00000 010 (simple-array (unsigned-byte 4) (*)) 50 -00000 010 (simple-array (unsigned-byte 8) (*)) 54 -00000 010 (simple-array (unsigned-byte 16) (*)) 58 -00000 010 (simple-array (unsigned-byte 32) (*)) 62 -00000 010 (simple-array single-float (*)) 66 -00000 010 (simple-array double-float (*)) 70 -00000 010 complex-string 74 -00000 010 complex-bit-vector 78 -00000 010 (array * (*)) -- general complex vector. 82 -00000 010 complex-array 86 - -00000 010 code-header-type 90 -00000 010 function-header-type 94 -00000 010 closure-header-type 98 -00000 010 funcallable-instance-header-type 102 -00000 010 unused-function-header-1-type 106 -00000 010 unused-function-header-2-type 110 -00000 010 unused-function-header-3-type 114 -00000 010 closure-function-header-type 118 -00000 010 return-pc-header-type 122 -00000 010 value-cell-header-type 126 -00000 010 symbol-header-type 130 -00000 010 base-character-type 134 -00000 010 system-area-pointer-type (header type) 138 -00000 010 unbound-marker 142 -00000 010 weak-pointer-type 146 - - - -;;;; Strings. - -All strings in the system are C-null terminated. This saves copying the bytes -when calling out to C. The only time this wastes memory is when the string -contains a multiple of eight characters, and then the system allocates two more -words (since Lisp objects are dual-word aligned) to hold the C-null byte. -Since the system will make heavy use of C routines for systems calls and -libraries that save reimplementation of higher level operating system -functionality (such as pathname resolution or current directory computation), -saving on copying strings for C should make C call out more efficient. - -The length word in a string header, see section "Data-Blocks and Header-Word -Format", counts only the characters truly in the Common Lisp string. -Allocation and GC will have to know to handle the extra C-null byte, and GC -already has to deal with rounding up various objects to dual-word alignment. - - - -;;;; Symbols and NIL. - -Symbol data-block has the following format: - ------------------------------------------------------- - | 5 (data-block words) | Symbol Type (8 bits) | - ------------------------------------------------------- - | Value Descriptor | - ------------------------------------------------------- - | Function Pointer | - ------------------------------------------------------- - | Raw Function Address | - ------------------------------------------------------- - | Setf Function | - ------------------------------------------------------- - | Property List | - ------------------------------------------------------- - | Print Name | - ------------------------------------------------------- - | Package | - ------------------------------------------------------- - -Most of these slots are self-explanatory given what symbols must do in Common -Lisp, but a couple require comments. We added the Raw Function Address slot to -speed up named call which is the most common calling convention. This is a -non-descriptor slot, but since objects are dual word aligned, the value -inherently has fixnum low-tag bits. The GC method for symbols must know to -update this slot. The Setf Function slot is currently unused, but we had an -extra slot due to adding Raw Function Address since objects must be dual-word -aligned. - -The issues with nil are that we want it to act like a symbol, and we need list -operations such as CAR and CDR to be fast on it. CMU Common Lisp solves this -by putting nil as the first object in static space, where other global values -reside, so it has a known address in the system: - ------------------------------------------------------- <-- start static - | 0 | space - ------------------------------------------------------- - | 5 (data-block words) | Symbol Type (8 bits) | - ------------------------------------------------------- <-- nil - | Value/CAR | - ------------------------------------------------------- - | Definition/CDR | - ------------------------------------------------------- - | Raw Function Address | - ------------------------------------------------------- - | Setf Function | - ------------------------------------------------------- - | Property List | - ------------------------------------------------------- - | Print Name | - ------------------------------------------------------- - | Package | - ------------------------------------------------------- - | ... | - ------------------------------------------------------- -In addition, we make the list typed pointer to nil actually point past the -header word of the nil symbol data-block. This has usefulness explained below. -The value and definition of nil are nil. Therefore, any reference to nil used -as a list has quick list type checking, and CAR and CDR can go right through -the first and second words as if nil were a cons object. - -When there is a reference to nil used as a symbol, the system adds offsets to -the address the same as it does for any symbol. This works due to a -combination of nil pointing past the symbol header-word and the chosen list and -other-pointer type tags. The list type tag is four less than the other-pointer -type tag, but nil points four additional bytes into its symbol data-block. - - - -;;;; Array Headers. - -The array-header data-block has the following format: - ---------------------------------------------------------------- - | Header Len (24 bits) = Array Rank +5 | Array Type (8 bits) | - ---------------------------------------------------------------- - | Fill Pointer (30 bits) | 0 0 | - ---------------------------------------------------------------- - | Available Elements (30 bits) | 0 0 | - ---------------------------------------------------------------- - | Data Vector (29 bits) | 1 1 1 | - ---------------------------------------------------------------- - | Displacement (30 bits) | 0 0 | - ---------------------------------------------------------------- - | Displacedp (29 bits) -- t or nil | 1 1 1 | - ---------------------------------------------------------------- - | Range of First Index (30 bits) | 0 0 | - ---------------------------------------------------------------- - . - . - . - -The array type in the header-word is one of the eight-bit patterns from section -"Data-Blocks and Other-immediates Typing", indicating that this is a complex -string, complex vector, complex bit-vector, or a multi-dimensional array. The -data portion of the other-immediate word is the length of the array header -data-block. Due to its format, its length is always five greater than the -array's number of dimensions. The following words have the following -interpretations and types: - Fill Pointer - This is a fixnum indicating the number of elements in the data vector - actually in use. This is the logical length of the array, and it is - typically the same value as the next slot. This is the second word, so - LENGTH of any array, with or without an array header, is just four bytes - off the pointer to it. - Available Elements - This is a fixnum indicating the number of elements for which there is - space in the data vector. This is greater than or equal to the logical - length of the array when it is a vector having a fill pointer. - Data Vector - This is a pointer descriptor referencing the actual data of the array. - This a data-block whose first word is a header-word with an array type as - described in sections "Data-Blocks and Header-Word Format" and - "Data-Blocks and Other-immediates Typing" - Displacement - This is a fixnum added to the computed row-major index for any array. - This is typically zero. - Displacedp - This is either t or nil. This is separate from the displacement slot, so - most array accesses can simply add in the displacement slot. The rare - need to know if an array is displaced costs one extra word in array - headers which probably aren't very frequent anyway. - Range of First Index - This is a fixnum indicating the number of elements in the first dimension - of the array. Legal index values are zero to one less than this number - inclusively. IF the array is zero-dimensional, this slot is - non-existent. - ... (remaining slots) - There is an additional slot in the header for each dimension of the - array. These are the same as the Range of First Index slot. - - - -;;;; Bignums. - -Bignum data-blocks have the following format: - ------------------------------------------------------- - | Length (24 bits) | Bignum Type (8 bits) | - ------------------------------------------------------- - | least significant bits | - ------------------------------------------------------- - . - . - . - -The elements contain the two's complement representation of the integer with -the least significant bits in the first element or closer to the header. The -sign information is in the high end of the last element. - - - - -;;;; Code Data-Blocks. - -A code data-block is the run-time representation of a "component". A component -is a connected portion of a program's flow graph that is compiled as a single -unit, and it contains code for many functions. Some of these functions are -callable from outside of the component, and these are termed "entry points". - -Each entry point has an associated user-visible function data-block (of type -FUNCTION). The full call convention provides for calling an entry point -specified by a function object. - -Although all of the function data-blocks for a component's entry points appear -to the user as distinct objects, the system keeps all of the code in a single -code data-block. The user-visible function object is actually a pointer into -the middle of a code data-block. This allows any control transfer within a -component to be done using a relative branch. - -Besides a function object, there are other kinds of references into the middle -of a code data-block. Control transfer into a function also occurs at the -return-PC for a call. The system represents a return-PC somewhat similarly to -a function, so GC can also recognize a return-PC as a reference to a code -data-block. - -It is incorrect to think of a code data-block as a concatenation of "function -data-blocks". Code for a function is not emitted in any particular order with -respect to that function's function-header (if any). The code following a -function-header may only be a branch to some other location where the -function's "real" definition is. - - -The following are the three kinds of pointers to code data-blocks: - Code pointer (labeled A below): - A code pointer is a descriptor, with other-pointer low-tag bits, pointing - to the beginning of the code data-block. The code pointer for the - currently running function is always kept in a register (CODE). In - addition to allowing loading of non-immediate constants, this also serves - to represent the currently running function to the debugger. - Return-PC (labeled B below): - The return-PC is a descriptor, with other-pointer low-tag bits, pointing - to a location for a function call. Note that this location contains no - descriptors other than the one word of immediate data, so GC can treat - return-PC locations the same as instructions. - Function (labeled C below): - A function is a descriptor, with function low-tag bits, that is user - callable. When a function header is referenced from a closure or from - the function header's self-pointer, the pointer has other-pointer low-tag - bits, instead of function low-tag bits. This ensures that the internal - function data-block associated with a closure appears to be uncallable - (although users should never see such an object anyway). - - Information about functions that is only useful for entry points is kept - in some descriptors following the function's self-pointer descriptor. - All of these together with the function's header-word are known as the - "function header". GC must be able to locate the function header. We - provide for this by chaining together the function headers in a NIL - terminated list kept in a known slot in the code data-block. - - -A code data-block has the following format: - ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ <-- A - | Header-Word count (24 bits) | %Code-Type (8 bits) | - ---------------------------------------------------------------- - | Number of code words (fixnum tag) | - ---------------------------------------------------------------- - | Pointer to first function header (other-pointer tag) | - ---------------------------------------------------------------- - | Debug information (structure tag) | - ---------------------------------------------------------------- - | First constant (a descriptor) | - ---------------------------------------------------------------- - | ... | - ---------------------------------------------------------------- - | Last constant (and last word of code header) | - ---------------------------------------------------------------- - | Some instructions (non-descriptor) | - ---------------------------------------------------------------- - | (pad to dual-word boundary if necessary) | - ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ <-- B - | Word offset from code header (24) | %Return-PC-Type (8) | - ---------------------------------------------------------------- - | First instruction after return | - ---------------------------------------------------------------- - | ... more code and return-PC header-words | - ---------------------------------------------------------------- - | (pad to dual-word boundary if necessary) | - ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ <-- C - | Offset from code header (24) | %Function-Header-Type (8) | - ---------------------------------------------------------------- - | Self-pointer back to previous word (with other-pointer tag) | - ---------------------------------------------------------------- - | Pointer to next function (other-pointer low-tag) or NIL | - ---------------------------------------------------------------- - | Function name (a string or a symbol) | - ---------------------------------------------------------------- - | Function debug arglist (a string) | - ---------------------------------------------------------------- - | Function type (a list-style function type specifier) | - ---------------------------------------------------------------- - | Start of instructions for function (non-descriptor) | - ---------------------------------------------------------------- - | More function headers and instructions and return PCs, | - | until we reach the total size of header-words + code | - | words. | - ---------------------------------------------------------------- - - -The following are detailed slot descriptions: - Code data-block header-word: - The immediate data in the code data-block's header-word is the number of - leading descriptors in the code data-block, the fixed overhead words plus - the number of constants. The first non-descriptor word, some code, - appears at this word offset from the header. - Number of code words: - The total number of non-header-words in the code data-block. The total - word size of the code data-block is the sum of this slot and the - immediate header-word data of the previous slot. The system accesses - this slot with the system constant, %Code-Code-Size-Slot, offset from the - header-word. - Pointer to first function header: - A NIL-terminated list of the function headers for all entry points to - this component. The system accesses this slot with the system constant, - %Code-Entry-Points-Slot, offset from the header-word. - Debug information: - The DEBUG-INFO structure describing this component. All information that - the debugger wants to get from a running function is kept in this - structure. Since there are many functions, the current PC is used to - locate the appropriate debug information. The system keeps the debug - information separate from the function data-block, since the currently - running function may not be an entry point. There is no way to recover - the function object for the currently running function, since this - data-block may not exist. The system accesses this slot with the system - constant, %Code-Debug-Info-Slot, offset from the header-word. - First constant ... last constant: - These are the constants referenced by the component, if there are any. - The system accesses the first constant slot with the system constant, - %Code-Constants-Offset, offset from the header-word. - - Return-PC header word: - The immediate header-word data is the word offset from the enclosing code - data-block's header-word to this word. This allows GC and the debugger - to easily recover the code data-block from a return-PC. The code at the - return point restores the current code pointer using a subtract immediate - of the offset, which is known at compile time. - - Function entry point header-word: - The immediate header-word data is the word offset from the enclosing code - data-block's header-word to this word. This is the same as for the - retrun-PC header-word. - Self-pointer back to header-word: - In a non-closure function, this self-pointer to the previous header-word - allows the call sequence to always indirect through the second word in a - user callable function. See section "Closure Format". With a closure, - indirecting through the second word gets you a function header-word. The - system ignores this slot in the function header for a closure, since it - has already indirected once, and this slot could be some random thing - that causes an error if you jump to it. This pointer has an - other-pointer tag instead of a function pointer tag, indicating it is not - a user callable Lisp object. The system accesses this slot with the - system constant, %Function-Code-Slot, offset from the function - header-word. - Pointer to next function: - This is the next link in the thread of entry point functions found in - this component. This value is NIL when the current header is the last - entry point in the component. The system accesses this slot with the - system constant, %Function-Header-Next-Slot, offset from the function - header-word. - Function name: - This function's name (for printing). If the user defined this function - with DEFUN, then this is the defined symbol, otherwise it is a - descriptive string. The system accesses this slot with the system - constant, %Function-Header-Name-Slot, offset from the function - header-word. - Function debug arglist: - A printed string representing the function's argument list, for human - readability. If it is a macroexpansion function, then this is the - original DEFMACRO arglist, not the actual expander function arglist. The - system accesses this slot with the system constant, - %Function-Header-Debug-Arglist-Slot, offset from the function - header-word. - Function type: - A list-style function type specifier representing the argument signature - and return types for this function. For example, - (FUNCTION (FIXNUM FIXNUM FIXNUM) FIXNUM) - or - (FUNCTION (STRING &KEY (:START UNSIGNED-BYTE)) STRING) - This information is intended for machine readablilty, such as by the - compiler. The system accesses this slot with the system constant, - %Function-Header-Type-Slot, offset from the function header-word. - - - -;;;; Closure Format. - -A closure data-block has the following format: - ---------------------------------------------------------------- - | Word size (24 bits) | %Closure-Type (8 bits) | - ---------------------------------------------------------------- - | Pointer to function header (other-pointer low-tag) | - ---------------------------------------------------------------- - | . | - | Environment information | - | . | - ---------------------------------------------------------------- - - -A closure descriptor has function low-tag bits. This means that a descriptor -with function low-tag bits may point to either a function header or to a -closure. The idea is that any callable Lisp object has function low-tag bits. -Insofar as call is concerned, we make the format of closures and non-closure -functions compatible. This is the reason for the self-pointer in a function -header. Whenever you have a callable object, you just jump through the second -word, offset some bytes, and go. - - - -;;;; Function call. - -Due to alignment requirements and low-tag codes, it is not possible to use a -hardware call instruction to compute the return-PC. Instead the return-PC -for a call is computed by doing an add-immediate to the start of the code -data-block. - -An advantage of using a single data-block to represent both the descriptor and -non-descriptor parts of a function is that both can be represented by a -single pointer. This reduces the number of memory accesses that have to be -done in a full call. For example, since the constant pool is implicit in a -return-PC, a call need only save the return-PC, rather than saving both the -return PC and the constant pool. - - - -;;;; Memory Layout. - -CMU Common Lisp has four spaces, read-only, static, dynamic-0, and dynamic-1. -Read-only contains objects that the system never modifies, moves, or reclaims. -Static space contains some global objects necessary for the system's runtime or -performance (since they are located at a known offset at a know address), and -the system never moves or reclaims these. However, GC does need to scan static -space for references to moved objects. Dynamic-0 and dynamic-1 are the two -heap areas for stop-and-copy GC algorithms. - -What global objects are at the head of static space??? - NIL - eval::*top-of-stack* - lisp::*current-catch-block* - lisp::*current-unwind-protect* - FLAGS (RT only) - BSP (RT only) - HEAP (RT only) - -In addition to the above spaces, the system has a control stack, binding stack, -and a number stack. The binding stack contains pairs of descriptors, a symbol -and its previous value. The number stack is the same as the C stack, and the -system uses it for non-Lisp objects such as raw system pointers, saving -non-Lisp registers, parts of bignum computations, etc. - - - -;;;; System Pointers. - -The system pointers reference raw allocated memory, data returned by foreign -function calls, etc. The system uses these when you need a pointer to a -non-Lisp block of memory, using an other-pointer. This provides the greatest -flexibility by relieving contraints placed by having more direct references -that require descriptor type tags. - -A system area pointer data-block has the following format: - ------------------------------------------------------- - | 1 (data-block words) | SAP Type (8 bits) | - ------------------------------------------------------- - | system area pointer | - ------------------------------------------------------- - -"SAP" means "system area pointer", and much of our code contains this naming -scheme. We don't currently restrict system pointers to one area of memory, but -if they do point onto the heap, it is up to the user to prevent being screwed -by GC or whatever. diff --git a/docs/internals/interpreter.tex b/docs/internals/interpreter.tex deleted file mode 100644 index c3d1c31812fb8842f8d71914d32228a1de7bbb70..0000000000000000000000000000000000000000 --- a/docs/internals/interpreter.tex +++ /dev/null @@ -1,191 +0,0 @@ -% -*- Dictionary: design; Package: C -*- - -May be worth having a byte-code representation for interpreted code. This way, -an entire system could be compiled into byte-code for debugging (the -"check-out" compiler?). - -Given our current inclination for using a stack machine to interpret IR1, it -would be straightforward to layer a byte-code interpreter on top of this. - - -Interpreter: - -Instead of having no interpreter, or a more-or-less conventional interpreter, -or byte-code interpreter, how about directly executing IR1? - -We run through the IR1 passes, possibly skipping optional ones, until we get -through environment analysis. Then we run a post-pass that annotates IR1 with -information about where values are kept, i.e. the stack slot. - -We can lazily convert functions by having FUNCTION make an interpreted function -object that holds the code (really a closure over the interpreter). The first -time that we try to call the function, we do the conversion and processing. -Also, we can easily keep track of which interpreted functions we have expanded -macros in, so that macro redefinition automatically invalidates the old -expansion, causing lazy reconversion. - -Probably the interpreter will want to represent MVs by a recognizable structure -that is always heap-allocated. This way, we can punt the stack issues involved -in trying to spread MVs. So a continuation value can always be kept in a -single cell. - -The compiler can have some special frobs for making the interpreter efficient, -such as a call operation that extracts arguments from the stack -slots designated by a continuation list. Perhaps - (values-mapcar fun . lists) -<==> - (values-list (mapcar fun . lists)) -This would be used with MV-CALL. - - -This scheme seems to provide nearly all of the advantages of both the compiler -and conventional interpretation. The only significant disadvantage with -respect to a conventional interpreter is that there is the one-time overhead of -conversion, but doing this lazily should make this quite acceptable. - -With respect to a conventional interpreter, we have major advantages: - + Full syntax checking: safety comparable to compiled code. - + Semantics similar to compiled code due to code sharing. Similar diagnostic - messages, etc. Reduction of error-prone code duplication. - + Potential for full type checking according to declarations (would require - running IR1 optimize?) - + Simplifies debugger interface, since interpreted code can look more like - compiled code: source paths, edit definition, etc. - -For all non-run-time symbol annotations (anything other than SYMBOL-FUNCTION -and SYMBOL-VALUE), we use the compiler's global database. MACRO-FUNCTION will -use INFO, rather than vice-versa. - -When doing the IR1 phases for the interpreter, we probably want to suppress -optimizations that change user-visible function calls: - -- Don't do local call conversion of any named functions (even lexical ones). - This is so that a call will appear on the stack that looks like the call in - the original source. The keyword and optional argument transformations - done by local call mangle things quite a bit. Also, note local-call - converting prevents unreferenced arguments from being deleted, which is - another non-obvious transformation. - -- Don't run source-transforms, IR1 transforms and IR1 optimizers. This way, - TRACE and BACKTRACE will show calls with the original arguments, rather - than the "optimized" form, etc. Also, for the interpreter it will - actually be faster to call the original function (which is compiled) than - to "inline expand" it. Also, this allows implementation-dependent - transforms to expand into %PRIMITIVE uses. - -There are some problems with stepping, due to our non-syntactic IR1 -representation. The source path information is the key that makes this -conceivable. We can skip over the stepping of a subform by quietly evaluating -nodes whose source path lies within the form being skipped. - -One problem with determining what value has been returned by a form. With a -function call, it is theoretically possible to precisely determine this, since -if we complete evaluation of the arguments, then we arrive at the Combination -node whose value is synonymous with the value of the form. We can even detect -this case, since the Node-Source will be EQ to the form. And we can also -detect when we unwind out of the evaluation, since we will leave the form -without having ever reached this node. - -But with macros and special-forms, there is no node whose value is the value of -the form, and no node whose source is the macro call or special form. We can -still detect when we leave the form, but we can't be sure whether this was a -normal evaluation result or an explicit RETURN-FROM. - -But does this really matter? It seems that we can print the value returned (if -any), then just print the next form to step. In the rare case where we did -unwind, the user should be able to figure it out. - -[We can look at this as a side-effect of CPS: there isn't any difference -between a "normal" return and a non-local one.] - -[Note that in any control transfer (normal or otherwise), the stepper may need -to unwind out of an arbitrary number of levels of stepping. This is because a -form in a TR position may yield its to a node arbitrarily far our.] - -Another problem is with deciding what form is being stepped. When we start -evaluating a node, we dive into code that is nested somewhere down inside that -form. So we actually have to do a loop of asking questions before we do any -evaluation. But what do we ask about? - -If we ask about the outermost enclosing form that is a subform of the the last -form that the user said to execute, then we might offer a form that isn't -really evaluated, such as a LET binding list. - -But once again, is this really a problem? It is certainly different from a -conventional stepper, but a pretty good argument could be made that it is -superior. Haven't you ever wanted to skip the evaluation of all the -LET bindings, but not the body? Wouldn't it be useful to be able to skip the -DO step forms? - -All of this assumes that nobody ever wants to step through the guts of a -macroexpansion. This seems reasonable, since steppers are for weenies, and -weenies don't define macros (hence don't debug them). But there are probably -some weenies who don't know that they shouldn't be writing macros. - -We could handle this by finding the "source paths" in the expansion of each -macro by sticking some special frob in the source path marking the place where -the expansion happened. When we hit code again that is in the source, then we -revert to the normal source path. Something along these lines might be a good -idea anyway (for compiler error messages, for example). - -The source path hack isn't guaranteed to work quite so well in generated code, -though, since macros return stuff that isn't freshly consed. But we could -probably arrange to win as long as any given expansion doesn't return two EQ -forms. - -It might be nice to have a command that skipped stepping of the form, but -printed the results of each outermost enclosed evaluated subform, i.e. if you -used this on the DO step-list, it would print the result of each new-value -form. I think this is implementable. I guess what you would do is print each -value delivered to a DEST whose source form is the current or an enclosing -form. Along with the value, you would print the source form for the node that -is computing the value. - -The stepper can also have a "back" command that "unskips" or "unsteps". This -would allow the evaluation of forms that are pure (modulo lexical variable -setting) to be undone. This is useful, since in stepping it is common that you -skip a form that you shouldn't have, or get confused and want to restart at -some earlier point. - -What we would do is remember the current node and the values of all local -variables. heap before doing each step or skip action. We can then back up -the state of all lexical variables and the "program counter". To make this -work right with set closure variables, we would copy the cell's value, rather -than the value cell itself. - -[To be fair, note that this could easily be done with our current interpreter: -the stepper could copy the environment alists.] - -We can't back up the "program counter" when a control transfer leaves the -current function, since this state is implicitly represented in the -interpreter's state, and is discarded when we exit. We probably want to ask -for confirmation before leaving the function to give users a chance to "unskip" -the forms in a TR position. - -Another question is whether the conventional stepper is really a good thing to -imitate... How about an editor-based mouse-driven interface? Instead of -"skipping" and "stepping", you would just designate the next form that you -wanted to stop at. Instead of displaying return values, you replace the source -text with the printed representation of the value. - -It would show the "program counter" by highlighting the *innermost* form that -we are about to evaluate, i.e. the source form for the node that we are stopped -at. It would probably also be useful to display the start of the form that was -used to designate the next stopping point, although I guess this could be -implied by the mouse position. - - -Such an interface would be a little harder to implement than a dumb stepper, -but it would be much easier to use. [It would be impossible for an evalhook -stepper to do this.] - - -%PRIMITIVE usage: - -Note: %PRIMITIVE can only be used in compiled code. It is a trapdoor into the -compiler, not a general syntax for accessing "sub-primitives". It's main use -is in implementation-dependent compiler transforms. It saves us the effort of -defining a "phony function" (that is not really defined), and also allows -direct communication with the code generator through codegen-info arguments. - -Some primitives may be exported from the VM so that %PRIMITIVE can be used to -make it explicit that an escape routine or interpreter stub is assuming an -operation is implemented by the compiler. diff --git a/docs/internals/lowlev.tex b/docs/internals/lowlev.tex deleted file mode 100644 index 7e6f13f357b2531612f7c6bd7a240a2c53fa2359..0000000000000000000000000000000000000000 --- a/docs/internals/lowlev.tex +++ /dev/null @@ -1,10 +0,0 @@ -\chapter{Memory Management} -\section{Stacks and Globals} -\section{Heap Layout} -\section{Garbage Collection} - -\chapter{Interface to C and Assembler} - -\chapter{Low-level debugging} - -\chapter{Core File Format} diff --git a/docs/internals/middle.tex b/docs/internals/middle.tex deleted file mode 100644 index 7adc018170dc5b520db4bc2ee93b5ef3cb60a09d..0000000000000000000000000000000000000000 --- a/docs/internals/middle.tex +++ /dev/null @@ -1,649 +0,0 @@ -% -*- Dictionary: design -*- - - -\chapter{Virtual Machine Representation Introduction} - - -\chapter{Global TN assignment} - -[\#\#\# Rename this phase so as not to be confused with the local/global TN -representation.] - -The basic mechanism for closing over values is to pass the values as additional -implicit arguments in the function call. This technique is only applicable -when: - -- the calling function knows which values the called function wants to close - over, and - -- the values to be closed over are available in the calling environment. - -The first condition is always true of local function calls. Environment -analysis can guarantee that the second condition holds by closing over any -needed values in the calling environment. - -If the function that closes over values may be called in an environment where -the closed over values are not available, then we must store the values in a -"closure" so that they are always accessible. Closures are called using the -"full call" convention. When a closure is called, control is transferred to -the "external entry point", which fetches the values out of the closure and -then does a local call to the real function, passing the closure values as -implicit arguments. - -In this scheme there is no such thing as a "heap closure variable" in code, -since the closure values are moved into TNs by the external entry point. There -is some potential for pessimization here, since we may end up moving the values -from the closure into a stack memory location, but the advantages are also -substantial. Simplicity is gained by always representing closure values the -same way, and functions with closure references may still be called locally -without allocating a closure. All the TN based VMR optimizations will apply -to closure variables, since closure variables are represented in the same way -as all other variables in VMR. Closure values will be allocated in registers -where appropriate. - -Closures are created at the point where the function is referenced, eliminating -the need to be able to close over closures. This lazy creation of closures has -the additional advantage that when a closure reference is conditionally not -done, then the closure consing will never be done at all. The corresponding -disadvantage is that a closure over the same values may be created multiple -times if there are multiple references. Note however, that VMR loop and common -subexpression optimizations can eliminate redundant closure consing. In any -case, multiple closures over the same variables doesn't seem to be that common. - -\#| -Having the Tail-Info would also make return convention determination trivial. -We could just look at the type, checking to see if it represents a fixed number -of values. To determine if the standard return convention is necessary to -preserve tail-recursion, we just iterate over the equivalent functions, looking -for XEPs and uses in full calls. -|\# - -The Global TN Assignment pass (GTN) can be considered a post-pass to -environment analysis. This phase assigns the TNs used to hold local lexical -variables and pass arguments and return values and determines the value-passing -strategy used in local calls. - -To assign return locations, we look at the function's tail-set. - -If the result continuation for an entry point is used as the continuation for a -full call, then we may need to constrain the continuation's values passing -convention to the standard one. This is not necessary when the call is known -not to be part of a tail-recursive loop (due to being a known function). - -Once we have figured out where we must use the standard value passing strategy, -we can use a more flexible strategy to determine the return locations for local -functions. We determine the possible numbers of return values from each -function by examining the uses of all the result continuations in the -equivalence class of the result continuation. - -If the tail-set type is for a fixed number of -values, then we return that fixed number of values from all the functions whose -result continuations are equated. If the number of values is not fixed, then -we must use the unknown-values convention, although we are not forced to use -the standard locations. We assign the result TNs at this time. - -We also use the tail-sets to see what convention we want to use. What we do is -use the full convention for any function that has a XEP its tail-set, even if -we aren't required to do so by a tail-recursive full call, as long as there are -no non-tail-recursive local calls in the set. This prevents us from -gratuitously using a non-standard convention when there is no reason to. - - -\chapter{Local TN assignment} - -[Want a different name for this so as not to be confused with the different -local/global TN representations. The really interesting stuff in this phase is -operation selection, values representation selection, return strategy, etc. -Maybe this phase should be conceptually lumped with GTN as "implementation -selection", since GTN determines call strategies and locations.] - -\#| - -[\#\#\# I guess I believe that it is OK for VMR conversion to dick the ICR flow -graph. An alternative would be to give VMR its very own flow graph, but that -seems like overkill. - -In particular, it would be very nice if a TR local call looked exactly like a -jump in VMR. This would allow loop optimizations to be done on loops written -as recursions. In addition to making the call block transfer to the head of -the function rather than to the return, we would also have to do something -about skipping the part of the function prolog that moves arguments from the -passing locations, since in a TR call they are already in the right frame. - - -In addition to directly indicating whether a call should be coded with a TR -variant, the Tail-P annotation flags non-call nodes that can directly return -the value (an "advanced return"), rather than moving the value to the result -continuation and jumping to the return code. Then (according to policy), we -can decide to advance all possible returns. If all uses of the result are -Tail-P, then LTN can annotate the result continuation as :Unused, inhibiting -emission of the default return code. - -[\#\#\# But not really. Now there is a single list of templates, and a given -template has only one policy.] - -In LTN, we use the :Safe template as a last resort even when the policy is -unsafe. Note that we don't try :Fast-Safe; if this is also a good unsafe -template, then it should have the unsafe policies explicitly specified. - -With a :Fast-Safe template, the result type must be proven to satisfy the -output type assertion. This means that a fast-safe template with a fixnum -output type doesn't need to do fixnum overflow checking. [\#\#\# Not right to -just check against the Node-Derived-Type, since type-check intersects with -this.] - -It seems that it would be useful to have a kind of template where the args must -be checked to be fixnum, but the template checks for overflow and signals an -error. In the case where an output assertion is present, this would generate -better code than conditionally branching off to make a bignum, and then doing a -type check on the result. - - How do we deal with deciding whether to do a fixnum overflow check? This - is perhaps a more general problem with the interpretation of result type - restrictions in templates. It would be useful to be able to discriminate - between the case where the result has been proven to be a fixnum and where - it has simply been asserted to be so. - - The semantics of result type restriction is that the result must be proven - to be of that type *except* for safe generators, which are assumed to - verify the assertion. That way "is-fixnum" case can be a fast-safe - generator and the "should-be-fixnum" case is a safe generator. We could - choose not to have a safe "should-be-fixnum" generator, and let the - unrestricted safe generator handle it. We would then have to do an - explicit type check on the result. - - In other words, for all template except Safe, a type restriction on either - an argument or result means "this must be true; if it is not the system may - break." In contrast, in a Safe template, the restriction means "If this is - not true, I will signal an error." - - Since the node-derived-type only takes into consideration stuff that can be - proved from the arguments, we can use the node-derived-type to select - fast-safe templates. With unsafe policies, we don't care, since the code - is supposed to be unsafe. - -|\# - -Local TN assignment (LTN) assigns all the TNs needed to represent the values of -continuations. This pass scans over the code for the component, examining each -continuation and its destination. A number of somewhat unrelated things are -also done at the same time so that multiple passes aren't necessary. - -- Determine the Primitive-Type for each continuation value and assigns TNs - to hold the values. - -- Use policy information to determine the implementation strategy for each - call to a known function. - -- Clear the type-check flags in continuations whose destinations have safe - implementations. - -- Determine the value-passing strategy for each continuation: known or - unknown. - -- Note usage of unknown-values continuations so that stack analysis can tell - when stack values must be discarded. - -If safety is more important that speed and space, then we consider generating -type checks on the values of nodes whose CONT has the Type-Check flag set. If -the destinatation for the continuation value is safe, then we don't need to do -a check. We assume that all full calls are safe, and use the template -information to determine whether inline operations are safe. - -This phase is where compiler policy switches have most of their effect. The -speed/space/safety tradeoff can determine which of a number of coding -strategies are used. It is important to make the policy choice in VMR -conversion rather than in code generation because the cost and storage -requirement information which drives TNBIND will depend strongly on what actual -VOP is chosen. In the case of +/FIXNUM, there might be three or more -implementations, some optimized for speed, some for space, etc. Some of these -VOPS might be open-coded and some not. - -We represent the implementation strategy for a call by either marking it as a -full call or annotating it with a "template" representing the open-coding -strategy. Templates are selected using a two-way dispatch off of operand -primitive-types and policy. The general case of LTN is handled by the -LTN-Annotate function in the function-info, but most functions are handled by a -table-driven mechanism. There are four different translation policies that a -template may have: -\begin{description} -\item[Safe] - The safest implementation; must do argument type checking. - -\item[Small] - The (unsafe) smallest implementation. - -\item[Fast] - The (unsafe) fastest implementation. - -\item[Fast-Safe] - An implementation optimized for speed, but which does any necessary - checks exclusive of argument type checking. Examples are array bounds - checks and fixnum overflow checks. -\end{description} - -Usually a function will have only one or two distinct templates. Either or -both of the safe and fast-safe templates may be omitted; if both are specified, -then they should be distinct. If there is no safe template and our policy is -safe, then we do a full call. - -We use four different coding strategies, depending on the policy: -\begin{description} -\item[Safe:] safety $>$ space $>$ speed, or -we want to use the fast-safe template, but there isn't one. - -\item[Small:] space $>$ (max speed safety) - -\item[Fast:] speed $>$ (max space safety) - -\item[Fast-Safe (and type check):] safety $>$ speed $>$ space, or we want to use -the safe template, but there isn't one. -\end{description} - -``Space'' above is actually the maximum of space and cspeed, under the theory -that less code will take less time to generate and assemble. [\#\#\# This could -lose if the smallest case is out-of-line, and must allocate many linkage -registers.] - - -\chapter{Control optimization} - -In this phase we annotate blocks with drop-throughs. This controls how code -generation linearizes code so that drop-throughs are used most effectively. We -totally linearize the code here, allowing code generation to scan the blocks -in the emit order. - -There are basically two aspects to this optimization: - 1] Dynamically reducing the number of branches taken v.s. branches not - taken under the assumption that branches not taken are cheaper. - 2] Statically minimizing the number of unconditional branches, saving space - and presumably time. - -These two goals can conflict, but if they do it seems pretty clear that the -dynamic optimization should get preference. The main dynamic optimization is -changing the sense of a conditional test so that the more commonly taken branch -is the fall-through case. The problem is determining which branch is more -commonly taken. - -The most clear-cut case is where one branch leads out of a loop and the other -is within. In this case, clearly the branch within the loop should be -preferred. The only added complication is that at some point in the loop there -has to be a backward branch, and it is preferable for this branch to be -conditional, since an unconditional branch is just a waste of time. - -In the absence of such good information, we can attempt to guess which branch -is more popular on the basis of difference in the cost between the two cases. -Min-max strategy suggests that we should choose the cheaper alternative, since -the percentagewise improvement is greater when the branch overhead is -significant with respect to the cost of the code branched to. A tractable -approximation of this is to compare only the costs of the two blocks -immediately branched to, since this would avoid having to do any hairy graph -walking to find all the code for the consequent and the alternative. It might -be worthwhile discriminating against ultra-expensive functions such as ERROR. - -For this to work, we have to detect when one of the options is empty. In this -case, the next for one branch is a successor of the other branch, making the -comparison meaningless. We use dominator information to detect this situation. -When a branch is empty, one of the predecessors of the first block in the empty -branch will be dominated by the first block in the other branch. In such a -case we favor the empty branch, since that's about as cheap as you can get. - -Statically minimizing branches is really a much more tractable problem, but -what literature there is makes it look hard. Clearly the thing to do is to use -a non-optimal heuristic algorithm. - -A good possibility is to use an algorithm based on the depth first ordering. -We can modify the basic DFO algorithm so that it chooses an ordering which -favors any drop-thrus that we may choose for dynamic reasons. When we are -walking the graph, we walk the desired drop-thru arc last, which will place it -immediately after us in the DFO unless the arc is a retreating arc. - -We scan through the DFO and whenever we find a block that hasn't been done yet, -we build a straight-line segment by setting the drop-thru to the unreached -successor block which has the lowest DFN greater than that for the block. We -move to the drop-thru block and repeat the process until there is no such -block. We then go back to our original scan through the DFO, looking for the -head of another straight-line segment. - -This process will automagically implement all of the dynamic optimizations -described above as long as we favor the appropriate IF branch when creating the -DFO. Using the DFO will prevent us from making the back branch in a loop the -drop-thru, but we need to be clever about favoring IF branches within loops -while computing the DFO. The IF join will be favored without any special -effort, since we follow through the most favored path until we reach the end. - -This needs some knowledge about the target machine, since on most machines -non-tail-recursive calls will use some sort of call instruction. In this case, -the call actually wants to drop through to the return point, rather than -dropping through to the beginning of the called function. - - -\chapter{VMR conversion} - -\#| -Single-use let var continuation substitution not really correct, since it can -cause a spurious type error. Maybe we do want stuff to prove that an NLX can't -happen after all. Or go back to the idea of moving a combination arg to the -ref location, and having that use the ref cont (with its output assertion.) -This lossage doesn't seem very likely to actually happen, though. -[\#\#\# must-reach stuff wouldn't work quite as well as combination substitute in -psetq, etc., since it would fail when one of the new values is random code -(might unwind.)] - -Is this really a general problem with eager type checking? It seems you could -argue that there was no type error in this code: - (+ :foo (throw 'up nil)) -But we would signal an error. - - -Emit explicit you-lose operation when we do a move between two non-T ptypes, -even when type checking isn't on. Can this really happen? Seems we should -treat continuations like this as though type-check was true. Maybe LTN should -leave type-check true in this case, even when the policy is unsafe. (Do a type -check against NIL?) - -At continuation use time, we may in general have to do both a coerce-to-t and a -type check, allocating two temporary TNs to hold the intermediate results. - - -VMR Control representation: - -We represent all control transfer explicitly. In particular, :Conditional VOPs -take a single Target continuation and a Not-P flag indicating whether the sense -of the test is negated. Then an unconditional Branch VOP will be emitted -afterward if the other path isn't a drop-through. - -So we linearize the code before VMR-conversion. This isn't a problem, -since there isn't much change in control flow after VMR conversion (none until -loop optimization requires introduction of header blocks.) It does make -cost-based branch prediction a bit ucky, though, since we don't have any cost -information in ICR. Actually, I guess we do have pretty good cost information -after LTN even before VMR conversion, since the most important thing to know is -which functions are open-coded. - -|\# - -VMR preserves the block structure of ICR, but replaces the nodes with a target -dependent virtual machine (VM) representation. Different implementations may -use different VMs without making major changes in the back end. The two main -components of VMR are Temporary Names (TNs) and Virtual OPerations (VOPs). TNs -represent the locations that hold values, and VOPs represent the operations -performed on the values. - -A "primitive type" is a type meaningful at the VM level. Examples are Fixnum, -String-Char, Short-Float. During VMR conversion we use the primitive type of -an expression to determine both where we can store the result of the expression -and which type-specific implementations of an operation can be applied to the -value. [Ptype is a set of SCs == representation choices and representation -specific operations] - -The VM specific definitions provide functions that do stuff like find the -primitive type corresponding to a type and test for primitive type subtypep. -Usually primitive types will be disjoint except for T, which represents all -types. - -The primitive type T is special-cased. Not only does it overlap with all the -other types, but it implies a descriptor ("boxed" or "pointer") representation. -For efficiency reasons, we sometimes want to use -alternate representations for some objects such as numbers. The majority of -operations cannot exploit alternate representations, and would only be -complicated if they had to be able to convert alternate representations into -descriptors. A template can require an operand to be a descriptor by -constraining the operand to be of type T. - -A TN can only represent a single value, so we bare the implementation of MVs at -this point. When we know the number of multiple values being handled, we use -multiple TNs to hold them. When the number of values is actually unknown, we -use a convention that is compatible with full function call. - -Everything that is done is done by a VOP in VMR. Calls to simple primitive -functions such as + and CAR are translated to VOP equivalents by a table-driven -mechanism. This translation is specified by the particular VM definition; VMR -conversion makes no assumptions about which operations are primitive or what -operand types are worth special-casing. The default calling mechanisms and -other miscellaneous builtin features are implemented using standard VOPs that -must implemented by each VM. - -Type information can be forgotten after VMR conversion, since all type-specific -operation selections have been made. - -Simple type checking is explicitly done using CHECK-xxx VOPs. They act like -innocuous effectless/unaffected VOPs which return the checked thing as a -result. This allows loop-invariant optimization and common subexpression -elimination to remove redundant checks. All type checking is done at the time -the continuation is used. - -Note that we need only check asserted types, since if type inference works, the -derived types will also be satisfied. We can check whichever is more -convenient, since both should be true. - -Constants are turned into special Constant TNs, which are wired down in a SC -that is determined by their type. The VM definition provides a function that -returns constant a TN to represent a Constant Leaf. - -Each component has a constant pool. There is a register dedicated to holding -the constant pool for the current component. The back end allocates -non-immediate constants in the constant pool when it discovers them during -translation from ICR. - -[\#\#\# Check that we are describing what is actually implemented. But this -really isn't very good in the presence of interesting unboxed -representations...] -Since LTN only deals with values from the viewpoint of the receiver, we must be -prepared during the translation pass to do stuff to the continuation at the -time it is used. - -- If a VOP yields more values than are desired, then we must create TNs to - hold the discarded results. An important special-case is continuations - whose value is discarded. These continuations won't be annotated at all. - In the case of a Ref, we can simply skip evaluation of the reference when - the continuation hasn't been annotated. Although this will eliminate - bogus references that for some reason weren't optimized away, the real - purpose is to handle deferred references. - -- If a VOP yields fewer values than desired, then we must default the extra - values to NIL. - -- If a continuation has its type-check flag set, then we must check the type - of the value before moving it into the result location. In general, this - requires computing the result in a temporary, and having the type-check - operation deliver it in the actual result location. - -- If the template's result type is T, then we must generate a boxed - temporary to compute the result in when the continuation's type isn't T. - - -We may also need to do stuff to the arguments when we generate code for a -template. If an argument continuation isn't annotated, then it must be a -deferred reference. We use the leaf's TN instead. We may have to do any of -the above use-time actions also. Alternatively, we could avoid hair by not -deferring references that must be type-checked or may need to be boxed. - - -\section{Stack analysis} - -Think of this as a lifetime problem: a values generator is a write and a values -receiver is a read. We want to annotate each VMR-Block with the unknown-values -continuations that are live at that point. If we do a control transfer to a -place where fewer continuations are live, then we must deallocate the newly -dead continuations. - -We want to convince ourselves that values deallocation based on lifetime -analysis actually works. In particular, we need to be sure that it doesn't -violate the required stack discipline. It is clear that it is impossible to -deallocate the values before they become dead, since later code may decide to -use them. So the only thing we need to ensure is that the "right" time isn't -later than the time that the continuation becomes dead. - -The only reason why we couldn't deallocate continuation A as soon as it becomes -dead would be that there is another continuation B on top of it that isn't dead -(since we can only deallocate the topmost continuation). - -The key to understanding why this can't happen is that each continuation has -only one read (receiver). If B is on top of A, then it must be the case that A -is live at the receiver for B. This means that it is impossible for B to be -live without A being live. - - -The reason that we don't solve this problem using a normal iterative flow -analysis is that we also need to know the ordering of the continuations on the -stack so that we can do deallocation. When it comes time to discard values, we -want to know which discarded continuation is on the bottom so that we can reset -SP to its start. - -[I suppose we could also decrement SP by the aggregate size of the discarded -continuations.] Another advantage of knowing the order in which we expect -continuations to be on the stack is that it allows us to do some consistency -checking. Also doing a localized graph walk around the values-receiver is -likely to be much more efficient than doing an iterative flow analysis problem -over all the code in the component (not that big a consideration.) - - - -\#| -Actually, what we do is do a backward graph walk from each unknown-values -receiver. As we go, we mark each walked block with ther ordered list of -continuations we believe are on the stack. Starting with an empty stack, we: - -- When we encounter another unknown-values receiver, we push that - continuation on our simulated stack. - -- When we encounter a receiver (which had better be for the topmost - continuation), we pop that continuation. - -- When we pop all continuations, we terminate our walk. - -[\#\#\# not quite right... It seems we may run into "dead values" during the -graph walk too. It seems that we have to check if the pushed continuation is -on stack top, and if not, add it to the ending stack so that the post-pass will -discard it.] - - - -[\#\#\# Also, we can't terminate our walk just because we hit a block previously -walked. We have to compare the the End-Stack with the values received along -the current path: if we have more values on our current walk than on the walk -that last touched the block, then we need to re-walk the subgraph reachable -from from that block, using our larger set of continuations. It seems that our -actual termination condition is reaching a block whose End-Stack is already EQ -to our current stack.] - - - - - -If at the start, the block containing the values receiver has already been -walked, the we skip the walk for that continuation, since it has already been -handled by an enclosing values receiver. Once a walk has started, we -ignore any signs of a previous walk, clobbering the old result with our own, -since we enclose that continuation, and the previous walk doesn't take into -consideration the fact that our values block underlies its own. - -When we are done, we have annotated each block with the stack current both at -the beginning and at the end of that block. Blocks that aren't walked don't -have anything on the stack either place (although they may hack MVs -internally). - -We then scan all the blocks in the component, looking for blocks that have -predecessors with a different ending stack than that block's starting stack. -(The starting stack had better be a tail of the predecessor's ending stack.) -We insert a block intervening between all of these predecessors that sets SP to -the end of the values for the continuation that should be on stack top. Of -course, this pass needn't be done if there aren't any global unknown MVs. - -Also, if we find any block that wasn't reached during the walk, but that USEs -an outside unknown-values continuation, then we know that the DEST can't be -reached from this point, so the values are unused. We either insert code to -pop the values, or somehow mark the code to prevent the values from ever being -pushed. (We could cause the popping to be done by the normal pass if we -iterated over the pushes beforehand, assigning a correct END-STACK.) - -[\#\#\# But I think that we have to be a bit clever within blocks, given the -possibility of blocks being joined. We could collect some unknown MVs in a -block, then do a control transfer out of the receiver, and this control -transfer could be squeezed out by merging blocks. How about: - - (tagbody - (return - (multiple-value-prog1 (foo) - (when bar - (go UNWIND)))) - - UNWIND - (return - (multiple-value-prog1 (baz) - bletch))) - -But the problem doesn't happen here (can't happen in general?) since a node -buried within a block can't use a continuation outside of the block. In fact, -no block can have more then one PUSH continuation, and this must always be be -last continuation. So it is trivially (structurally) true that all pops come -before any push. - -[\#\#\# But not really: the DEST of an embedded continuation may be outside the -block. There can be multiple pushes, and we must find them by iterating over -the uses of MV receivers in LTN. But it would be hard to get the order right -this way. We could easily get the order right if we added the generators as we -saw the uses, except that we can't guarantee that the continuations will be -annotated at that point. (Actually, I think we only need the order for -consistency checks, but that is probably worthwhile). I guess the thing to do -is when we process the receiver, add the generator blocks to the -Values-Generators, then do a post-pass that re-scans the blocks adding the -pushes.] - -I believe that above concern with a dead use getting mashed inside a block -can't happen, since the use inside the block must be the only use, and if the -use isn't reachable from the push, then the use is totally unreachable, and -should have been deleted, which would prevent the prevent it from ever being -annotated. -] -] -|\# - -We find the partial ordering of the values globs for unknown values -continuations in each environment. We don't have to scan the code looking for -unknown values continuations since LTN annotates each block with the -continuations that were popped and not pushed or pushed and not popped. This -is all we need to do the inter-block analysis. - -After we have found out what stuff is on the stack at each block boundary, we -look for blocks with predecessors that have junk on the stack. For each such -block, we introduce a new block containing code to restore the stack pointer. -Since unknown-values continuations are represented as <start, count>, we can -easily pop a continuation using the Start TN. - -Note that there is only doubt about how much stuff is on the control stack, -since only it is used for unknown values. Any special stacks such as number -stacks will always have a fixed allocation. - - -\section{Non-local exit} - - -If the starting and ending continuations are not in the same environment, then -the control transfer is a non-local exit. In this case just call Unwind with -the appropriate stack pointer, and let the code at the re-entry point worry -about fixing things up. - -It seems like maybe a good way to organize VMR conversion of NLX would be to -have environment analysis insert funny functions in new interposed cleanup -blocks. The thing is that we need some way for VMR conversion to: - 1] Get its hands on the returned values. - 2] Do weird control shit. - 3] Deliver the values to the original continuation destination. -I.e. we need some way to interpose arbitrary code in the path of value -delivery. - -What we do is replace the NLX uses of the continuation with another -continuation that is received by a MV-Call to %NLX-VALUES in a cleanup block -that is interposed between the NLX uses and the old continuation's block. The -MV-Call uses the original continuation to deliver it's values to. - -[Actually, it's not really important that this be an MV-Call, since it has to -be special-cased by LTN anyway. Or maybe we would want it to be an MV call. -If did normal LTN analysis of an MV call, it would force the returned values -into the unknown values convention, which is probably pretty convenient for use -in NLX. - -Then the entry code would have to use some special VOPs to receive the unknown -values. But we probably need special VOPs for NLX entry anyway, and the code -can share with the call VOPs. Also we probably need the technology anyway, -since THROW will use truly unknown values.] - - -On entry to a dynamic extent that has non-local-exists into it (always at an -ENTRY node), we take a complete snapshot of the dynamic state: - the top pointers for all stacks - current Catch and Unwind-Protect - current special binding (binding stack pointer in shallow binding) - -We insert code at the re-entry point which restores the saved dynamic state. -All TNs live at a NLX EP are forced onto the stack, so we don't have to restore -them, and we don't have to worry about getting them saved. - diff --git a/docs/internals/object.tex b/docs/internals/object.tex deleted file mode 100644 index a043f3479bf36770c15ee4a473cfd27c73e43054..0000000000000000000000000000000000000000 --- a/docs/internals/object.tex +++ /dev/null @@ -1,713 +0,0 @@ -\chapter{Object Format} - - -\section{Tagging} - -The following is a key of the three bit low-tagging scheme: -\begin{description} - \item[000] even fixnum - \item[001] function pointer - \item[010] even other-immediate (header-words, characters, symbol-value trap value, etc.) - \item[011] list pointer - \item[100] odd fixnum - \item[101] structure pointer - \item[110] odd other immediate - \item[111] other-pointer to data-blocks (other than conses, structures, - and functions) -\end{description} - -This tagging scheme forces a dual-word alignment of data-blocks on the heap, -but this can be pretty negligible: -\begin{itemize} -\item RATIOS and COMPLEX must have a header-word anyway since they are not a - major type. This wastes one word for these infrequent data-blocks since - they require two words for the data. - -\item BIGNUMS must have a header-word and probably contain only one other word - anyway, so we probably don't waste any words here. Most bignums just - barely overflow fixnums, that is by a bit or two. - -\item Single and double FLOATS? - no waste, or - one word wasted - -\item SYMBOLS have a pad slot (current called the setf function, but unused.) -\end{itemize} -Everything else is vector-like including code, so these probably take up -so many words that one extra one doesn't matter. - - - -\section{GC Comments} - -Data-Blocks comprise only descriptors, or they contain immediate data and raw -bits interpreted by the system. GC must skip the latter when scanning the -heap, so it does not look at a word of raw bits and interpret it as a pointer -descriptor. These data-blocks require headers for GC as well as for operations -that need to know how to interpret the raw bits. When GC is scanning, and it -sees a header-word, then it can determine how to skip that data-block if -necessary. Header-Words are tagged as other-immediates. See the sections -"Other-Immediates" and "Data-Blocks and Header-Words" for comments on -distinguishing header-words from other-immediate data. This distinction is -necessary since we scan through data-blocks containing only descriptors just as -we scan through the heap looking for header-words introducing data-blocks. - -Data-Blocks containing only descriptors do not require header-words for GC -since the entire data-block can be scanned by GC a word at a time, taking -whatever action is necessary or appropriate for the data in that slot. For -example, a cons is referenced by a descriptor with a specific tag, and the -system always knows the size of this data-block. When GC encounters a pointer -to a cons, it can transport it into the new space, and when scanning, it can -simply scan the two words manifesting the cons interpreting each word as a -descriptor. Actually there is no cons tag, but a list tag, so we make sure the -cons is not nil when appropriate. A header may still be desired if the pointer -to the data-block does not contain enough information to adequately maintain -the data-block. An example of this is a simple-vector containing only -descriptor slots, and we attach a header-word because the descriptor pointing -to the vector lacks necessary information -- the type of the vector's elements, -its length, etc. - -There is no need for a major tag for GC forwarding pointers. Since the tag -bits are in the low end of the word, a range check on the start and end of old -space tells you if you need to move the thing. This is all GC overhead. - - - -\section{Structures} - -A structure descriptor has the structure lowtag type code, making -{\tt structurep} a fast operation. A structure -data-block has the following format: -\begin{verbatim} - ------------------------------------------------------- - | length (24 bits) | Structure header type (8 bits) | - ------------------------------------------------------- - | structure type name (a symbol) | - ------------------------------------------------------- - | structure slot 0 | - ------------------------------------------------------- - | ... structure slot length - 2 | - ------------------------------------------------------- -\end{verbatim} - -The header word contains the structure length, which is the number of words -(other than the header word.) The length is always at least one, since the -first word of the structure data is the structure type name. - - -\section{Fixnums} - -A fixnum has one of the following formats in 32 bits: -\begin{verbatim} - ------------------------------------------------------- - | 30 bit 2's complement even integer | 0 0 0 | - ------------------------------------------------------- -\end{verbatim} -or -\begin{verbatim} - ------------------------------------------------------- - | 30 bit 2's complement odd integer | 1 0 0 | - ------------------------------------------------------- -\end{verbatim} - -Effectively, there is one tag for immediate integers, two zeros. This buys one -more bit for fixnums, and now when these numbers index into simple-vectors or -offset into memory, they point to word boundaries on 32-bit, byte-addressable -machines. That is, no shifting need occur to use the number directly as an -offset. - -This format has another advantage on byte-addressable machines when fixnums are -offsets into vector-like data-blocks, including structures. Even though we -previously mentioned data-blocks are dual-word aligned, most indexing and slot -accessing is word aligned, and so are fixnums with effectively two tag bits. - -Two tags also allow better usage of special instructions on some machines that -can deal with two low-tag bits but not three. - -Since the two bits are zeros, we avoid having to mask them off before using the -words for arithmetic, but division and multiplication require special shifting. - - - -\section{Other-immediates} - -As for fixnums, there are two different three-bit lowtag codes for -other-immediate, allowing 64 other-immediate types: -\begin{verbatim} ----------------------------------------------------------------- -| Data (24 bits) | Type (8 bits with low-tag) | 1 0 | ----------------------------------------------------------------- -\end{verbatim} - -The type-code for an other-immediate type is considered to include the two -lowtag bits. This supports the concept of a single "type code" namespace for -all descriptors, since the normal lowtag codes are disjoint from the -other-immediate codes. - -For other-pointer objects, the full eight bits of the header type code are used -as the type code for that kind of object. This is why we use two lowtag codes -for other-immediate types: each other-pointer object needs a distinct -other-immediate type to mark its header. - -The system uses the other-immediate format for characters, -the {\tt symbol-value} unbound trap value, and header-words for data-blocks on -the heap. The type codes are laid out to facilitate range checks for common -subtypes; for example, all numbers will have contiguous type codes which are -distinct from the contiguous array type codes. See section -\ref{data-blocks-and-o-i} for details. - - -\section{Data-Blocks and Header-Word Format} - -Pointers to data-blocks have the following format: -\begin{verbatim} ----------------------------------------------------------------- -| Dual-word address of data-block (29 bits) | 1 1 1 | ----------------------------------------------------------------- -\end{verbatim} - -The word pointed to by the above descriptor is a header-word, and it has the -same format as an other-immediate: -\begin{verbatim} ----------------------------------------------------------------- -| Data (24 bits) | Type (8 bits with low-tag) | 0 1 0 | ----------------------------------------------------------------- -\end{verbatim} -This is convenient for scanning the heap when GC'ing, but it does mean that -whenever GC encounters an other-immediate word, it has to do a range check on -the low byte to see if it is a header-word or just a character (for example). -This is easily acceptable performance hit for scanning. - -The system interprets the data portion of the header-word for non-vector -data-blocks as the word length excluding the header-word. For example, the -data field of the header for ratio and complex numbers is two, one word each -for the numerator and denominator or for the real and imaginary parts. - -For vectors and data-blocks representing Lisp objects stored like vectors, the -system ignores the data portion of the header-word: -\begin{verbatim} ----------------------------------------------------------------- -| Unused Data (24 bits) | Type (8 bits with low-tag) | 0 1 0 | ----------------------------------------------------------------- -| Element Length of Vector (30 bits) | 0 0 | ----------------------------------------------------------------- -\end{verbatim} - -Using a separate word allows for much larger vectors, and it allows {\tt -length} to simply access a single word without masking or shifting. Similarly, -the header for complex arrays and vectors has a second word, following the -header-word, the system uses for the fill pointer, so computing the length of -any array is the same code sequence. - - - -\section{Data-Blocks and Other-immediates Typing} - -\label{data-blocks-and-o-i} -These are the other-immediate types. We specify them including all low eight -bits, including the other-immediate tag, so we can think of the type bits as -one type -- not an other-immediate major type and a subtype. Also, fetching a -byte and comparing it against a constant is more efficient than wasting even a -small amount of time shifting out the other-immediate tag to compare against a -five bit constant. -\begin{verbatim} -Number (< 30) - bignum 10 - ratio 14 - single-float 18 - double-float 22 - complex 26 - -Array (>= 30 code 86) - Simple-Array (>= 20 code 70) - simple-array 30 - Vector (>= 34 code 82) - simple-string 34 - simple-bit-vector 38 - simple-vector 42 - (simple-array (unsigned-byte 2) (*)) 46 - (simple-array (unsigned-byte 4) (*)) 50 - (simple-array (unsigned-byte 8) (*)) 54 - (simple-array (unsigned-byte 16) (*)) 58 - (simple-array (unsigned-byte 32) (*)) 62 - (simple-array single-float (*)) 66 - (simple-array double-float (*)) 70 - complex-string 74 - complex-bit-vector 78 - (array * (*)) -- general complex vector. 82 - complex-array 86 - -code-header-type 90 -function-header-type 94 -closure-header-type 98 -funcallable-instance-header-type 102 -unused-function-header-1-type 106 -unused-function-header-2-type 110 -unused-function-header-3-type 114 -closure-function-header-type 118 -return-pc-header-type (a.k.a LRA) 122 -value-cell-header-type 126 -symbol-header-type 130 -base-character-type 134 -system-area-pointer-type (header type) 138 -unbound-marker 142 -weak-pointer-type 146 -structure-header-type 150 -\end{verbatim} - -\section{Strings} - -All strings in the system are C-null terminated. This saves copying the bytes -when calling out to C. The only time this wastes memory is when the string -contains a multiple of eight characters, and then the system allocates two more -words (since Lisp objects are dual-word aligned) to hold the C-null byte. -Since the system will make heavy use of C routines for systems calls and -libraries that save reimplementation of higher level operating system -functionality (such as pathname resolution or current directory computation), -saving on copying strings for C should make C call out more efficient. - -The length word in a string header, see section "Data-Blocks and Header-Word -Format", counts only the characters truly in the Common Lisp string. -Allocation and GC will have to know to handle the extra C-null byte, and GC -already has to deal with rounding up various objects to dual-word alignment. - - - -\section{Symbols and NIL} - -Symbol data-block has the following format: -\begin{verbatim} -------------------------------------------------------- -| 7 (data-block words) | Symbol Type (8 bits) | -------------------------------------------------------- -| Value Descriptor | -------------------------------------------------------- -| Function Pointer | -------------------------------------------------------- -| Raw Function Address | -------------------------------------------------------- -| Setf Function | -------------------------------------------------------- -| Property List | -------------------------------------------------------- -| Print Name | -------------------------------------------------------- -| Package | -------------------------------------------------------- -\end{verbatim} - -Most of these slots are self-explanatory given what symbols must do in Common -Lisp, but a couple require comments. We added the Raw Function Address slot to -speed up named call which is the most common calling convention. This is a -non-descriptor slot, but since objects are dual word aligned, the value -inherently has fixnum low-tag bits. The GC method for symbols must know to -update this slot. The Setf Function slot is currently unused, but we had an -extra slot due to adding Raw Function Address since objects must be dual-word -aligned. - -The issues with nil are that we want it to act like a symbol, and we need list -operations such as CAR and CDR to be fast on it. CMU Common Lisp solves this -by putting nil as the first object in static space, where other global values -reside, so it has a known address in the system: -\begin{verbatim} -------------------------------------------------------- <-- space -| 0 | start -------------------------------------------------------- -| 7 (data-block words) | Symbol Type (8 bits) | -------------------------------------------------------- <-- nil -| Value/CAR | -------------------------------------------------------- -| Definition/CDR | -------------------------------------------------------- -| Raw Function Address | -------------------------------------------------------- -| Setf Function | -------------------------------------------------------- -| Property List | -------------------------------------------------------- -| Print Name | -------------------------------------------------------- -| Package | -------------------------------------------------------- -| ... | -------------------------------------------------------- -\end{verbatim} -In addition, we make the list typed pointer to nil actually point past the -header word of the nil symbol data-block. This has usefulness explained below. -The value and definition of nil are nil. Therefore, any reference to nil used -as a list has quick list type checking, and CAR and CDR can go right through -the first and second words as if nil were a cons object. - -When there is a reference to nil used as a symbol, the system adds offsets to -the address the same as it does for any symbol. This works due to a -combination of nil pointing past the symbol header-word and the chosen list and -other-pointer type tags. The list type tag is four less than the other-pointer -type tag, but nil points four additional bytes into its symbol data-block. - - - -;;;; Array Headers. - -The array-header data-block has the following format: -\begin{verbatim} ----------------------------------------------------------------- -| Header Len (24 bits) = Array Rank +5 | Array Type (8 bits) | ----------------------------------------------------------------- -| Fill Pointer (30 bits) | 0 0 | ----------------------------------------------------------------- -| Available Elements (30 bits) | 0 0 | ----------------------------------------------------------------- -| Data Vector (29 bits) | 1 1 1 | ----------------------------------------------------------------- -| Displacement (30 bits) | 0 0 | ----------------------------------------------------------------- -| Displacedp (29 bits) -- t or nil | 1 1 1 | ----------------------------------------------------------------- -| Range of First Index (30 bits) | 0 0 | ----------------------------------------------------------------- - . - . - . - -\end{verbatim} -The array type in the header-word is one of the eight-bit patterns from section -"Data-Blocks and Other-immediates Typing", indicating that this is a complex -string, complex vector, complex bit-vector, or a multi-dimensional array. The -data portion of the other-immediate word is the length of the array header -data-block. Due to its format, its length is always five greater than the -array's number of dimensions. The following words have the following -interpretations and types: -\begin{description} - \item[Fill Pointer:] - This is a fixnum indicating the number of elements in the data vector - actually in use. This is the logical length of the array, and it is - typically the same value as the next slot. This is the second word, so - LENGTH of any array, with or without an array header, is just four bytes - off the pointer to it. - \item[Available Elements:] - This is a fixnum indicating the number of elements for which there is - space in the data vector. This is greater than or equal to the logical - length of the array when it is a vector having a fill pointer. - \item[Data Vector:] - This is a pointer descriptor referencing the actual data of the array. - This a data-block whose first word is a header-word with an array type as - described in sections "Data-Blocks and Header-Word Format" and - "Data-Blocks and Other-immediates Typing" - \item[Displacement:] - This is a fixnum added to the computed row-major index for any array. - This is typically zero. - \item[Displacedp:] - This is either t or nil. This is separate from the displacement slot, so - most array accesses can simply add in the displacement slot. The rare - need to know if an array is displaced costs one extra word in array - headers which probably aren't very frequent anyway. - \item[Range of First Index:] - This is a fixnum indicating the number of elements in the first dimension - of the array. Legal index values are zero to one less than this number - inclusively. IF the array is zero-dimensional, this slot is - non-existent. - \item[... (remaining slots):] - There is an additional slot in the header for each dimension of the - array. These are the same as the Range of First Index slot. -\end{description} - - -\section{Bignums} - -Bignum data-blocks have the following format: -\begin{verbatim} -------------------------------------------------------- -| Length (24 bits) | Bignum Type (8 bits) | -------------------------------------------------------- -| least significant bits | -------------------------------------------------------- - . - . - . -\end{verbatim} -The elements contain the two's complement representation of the integer with -the least significant bits in the first element or closer to the header. The -sign information is in the high end of the last element. - - - - -\section{Code Data-Blocks} - -A code data-block is the run-time representation of a "component". A component -is a connected portion of a program's flow graph that is compiled as a single -unit, and it contains code for many functions. Some of these functions are -callable from outside of the component, and these are termed "entry points". - -Each entry point has an associated user-visible function data-block (of type -{\tt function}). The full call convention provides for calling an entry point -specified by a function object. - -Although all of the function data-blocks for a component's entry points appear -to the user as distinct objects, the system keeps all of the code in a single -code data-block. The user-visible function object is actually a pointer into -the middle of a code data-block. This allows any control transfer within a -component to be done using a relative branch. - -Besides a function object, there are other kinds of references into the middle -of a code data-block. Control transfer into a function also occurs at the -return-PC for a call. The system represents a return-PC somewhat similarly to -a function, so GC can also recognize a return-PC as a reference to a code -data-block. This representation is known as a Lisp Return Address (LRA). - -It is incorrect to think of a code data-block as a concatenation of "function -data-blocks". Code for a function is not emitted in any particular order with -respect to that function's function-header (if any). The code following a -function-header may only be a branch to some other location where the -function's "real" definition is. - - -The following are the three kinds of pointers to code data-blocks: -\begin{description} - \item[Code pointer (labeled A below):] - A code pointer is a descriptor, with other-pointer low-tag bits, pointing - to the beginning of the code data-block. The code pointer for the - currently running function is always kept in a register (CODE). In - addition to allowing loading of non-immediate constants, this also serves - to represent the currently running function to the debugger. - \item[LRA (labeled B below):] - The LRA is a descriptor, with other-pointer low-tag bits, pointing - to a location for a function call. Note that this location contains no - descriptors other than the one word of immediate data, so GC can treat - LRA locations the same as instructions. - \item[Function (labeled C below):] - A function is a descriptor, with function low-tag bits, that is user - callable. When a function header is referenced from a closure or from - the function header's self-pointer, the pointer has other-pointer low-tag - bits, instead of function low-tag bits. This ensures that the internal - function data-block associated with a closure appears to be uncallable - (although users should never see such an object anyway). - - Information about functions that is only useful for entry points is kept - in some descriptors following the function's self-pointer descriptor. - All of these together with the function's header-word are known as the - "function header". GC must be able to locate the function header. We - provide for this by chaining together the function headers in a NIL - terminated list kept in a known slot in the code data-block. -\end{description} - -A code data-block has the following format: -\begin{verbatim} -A --> -**************************************************************** -| Header-Word count (24 bits) | Code-Type (8 bits) | ----------------------------------------------------------------- -| Number of code words (fixnum tag) | ----------------------------------------------------------------- -| Pointer to first function header (other-pointer tag) | ----------------------------------------------------------------- -| Debug information (structure tag) | ----------------------------------------------------------------- -| First constant (a descriptor) | ----------------------------------------------------------------- -| ... | ----------------------------------------------------------------- -| Last constant (and last word of code header) | ----------------------------------------------------------------- -| Some instructions (non-descriptor) | ----------------------------------------------------------------- -| (pad to dual-word boundary if necessary) | - -B --> -**************************************************************** -| Word offset from code header (24) | Return-PC-Type (8) | ----------------------------------------------------------------- -| First instruction after return | ----------------------------------------------------------------- -| ... more code and LRA header-words | ----------------------------------------------------------------- -| (pad to dual-word boundary if necessary) | - -C --> -**************************************************************** -| Offset from code header (24) | Function-Header-Type (8) | ----------------------------------------------------------------- -| Self-pointer back to previous word (with other-pointer tag) | ----------------------------------------------------------------- -| Pointer to next function (other-pointer low-tag) or NIL | ----------------------------------------------------------------- -| Function name (a string or a symbol) | ----------------------------------------------------------------- -| Function debug arglist (a string) | ----------------------------------------------------------------- -| Function type (a list-style function type specifier) | ----------------------------------------------------------------- -| Start of instructions for function (non-descriptor) | ----------------------------------------------------------------- -| More function headers and instructions and return PCs, | -| until we reach the total size of header-words + code | -| words. | ----------------------------------------------------------------- -\end{verbatim} - -The following are detailed slot descriptions: -\begin{description} - \item[Code data-block header-word:] - The immediate data in the code data-block's header-word is the number of - leading descriptors in the code data-block, the fixed overhead words plus - the number of constants. The first non-descriptor word, some code, - appears at this word offset from the header. - \item[Number of code words:] - The total number of non-header-words in the code data-block. The total - word size of the code data-block is the sum of this slot and the - immediate header-word data of the previous slot. - header-word. - \item[Pointer to first function header:] - A NIL-terminated list of the function headers for all entry points to - this component. - \item[Debug information:] - The DEBUG-INFO structure describing this component. All information that - the debugger wants to get from a running function is kept in this - structure. Since there are many functions, the current PC is used to - locate the appropriate debug information. The system keeps the debug - information separate from the function data-block, since the currently - running function may not be an entry point. There is no way to recover - the function object for the currently running function, since this - data-block may not exist. - \item[First constant ... last constant:] - These are the constants referenced by the component, if there are any. -\vspace{1ex} - \item[LRA header word:] - The immediate header-word data is the word offset from the enclosing code - data-block's header-word to this word. This allows GC and the debugger - to easily recover the code data-block from a LRA. The code at the - return point restores the current code pointer using a subtract immediate - of the offset, which is known at compile time. -\vspace{1ex} - \item[Function entry point header-word:] - The immediate header-word data is the word offset from the enclosing code - data-block's header-word to this word. This is the same as for the - retrun-PC header-word. - \item[Self-pointer back to header-word:] - In a non-closure function, this self-pointer to the previous header-word - allows the call sequence to always indirect through the second word in a - user callable function. See section "Closure Format". With a closure, - indirecting through the second word gets you a function header-word. The - system ignores this slot in the function header for a closure, since it - has already indirected once, and this slot could be some random thing - that causes an error if you jump to it. This pointer has an - other-pointer tag instead of a function pointer tag, indicating it is not - a user callable Lisp object. - \item[Pointer to next function:] - This is the next link in the thread of entry point functions found in - this component. This value is NIL when the current header is the last - entry point in the component. - \item[Function name:] - This function's name (for printing). If the user defined this function - with DEFUN, then this is the defined symbol, otherwise it is a - descriptive string. - \item[Function debug arglist:] - A printed string representing the function's argument list, for human - readability. If it is a macroexpansion function, then this is the - original DEFMACRO arglist, not the actual expander function arglist. - \item[Function type:] - A list-style function type specifier representing the argument signature - and return types for this function. For example, - \begin{verbatim} -(function (fixnum fixnum fixnum) fixnum) - \end{verbatim} - or - \begin{verbatim} -(function (string &key (:start unsigned-byte)) string) - \end{verbatim} - This information is intended for machine readablilty, such as by the - compiler. -\end{description} - - -\section{Closure Format} - -A closure data-block has the following format: -\begin{verbatim} ----------------------------------------------------------------- -| Word size (24 bits) | Closure-Type (8 bits) | ----------------------------------------------------------------- -| Pointer to function header (other-pointer low-tag) | ----------------------------------------------------------------- -| . | -| Environment information | -| . | ----------------------------------------------------------------- -\end{verbatim} - -A closure descriptor has function low-tag bits. This means that a descriptor -with function low-tag bits may point to either a function header or to a -closure. The idea is that any callable Lisp object has function low-tag bits. -Insofar as call is concerned, we make the format of closures and non-closure -functions compatible. This is the reason for the self-pointer in a function -header. Whenever you have a callable object, you just jump through the second -word, offset some bytes, and go. - - - -\section{Function call} - -Due to alignment requirements and low-tag codes, it is not possible to use a -hardware call instruction to compute the LRA. Instead the LRA -for a call is computed by doing an add-immediate to the start of the code -data-block. - -An advantage of using a single data-block to represent both the descriptor and -non-descriptor parts of a function is that both can be represented by a -single pointer. This reduces the number of memory accesses that have to be -done in a full call. For example, since the constant pool is implicit in a -LRA, a call need only save the LRA, rather than saving both the -return PC and the constant pool. - - - -\section{Memory Layout} - -CMU Common Lisp has four spaces, read-only, static, dynamic-0, and dynamic-1. -Read-only contains objects that the system never modifies, moves, or reclaims. -Static space contains some global objects necessary for the system's runtime or -performance (since they are located at a known offset at a know address), and -the system never moves or reclaims these. However, GC does need to scan static -space for references to moved objects. Dynamic-0 and dynamic-1 are the two -heap areas for stop-and-copy GC algorithms. - -What global objects are at the head of static space??? -\begin{verbatim} - NIL - eval::*top-of-stack* - lisp::*current-catch-block* - lisp::*current-unwind-protect* - FLAGS (RT only) - BSP (RT only) - HEAP (RT only) -\end{verbatim} - -In addition to the above spaces, the system has a control stack, binding stack, -and a number stack. The binding stack contains pairs of descriptors, a symbol -and its previous value. The number stack is the same as the C stack, and the -system uses it for non-Lisp objects such as raw system pointers, saving -non-Lisp registers, parts of bignum computations, etc. - - - -\section{System Pointers} - -The system pointers reference raw allocated memory, data returned by foreign -function calls, etc. The system uses these when you need a pointer to a -non-Lisp block of memory, using an other-pointer. This provides the greatest -flexibility by relieving contraints placed by having more direct references -that require descriptor type tags. - -A system area pointer data-block has the following format: -\begin{verbatim} -------------------------------------------------------- -| 1 (data-block words) | SAP Type (8 bits) | -------------------------------------------------------- -| system area pointer | -------------------------------------------------------- -\end{verbatim} - -"SAP" means "system area pointer", and much of our code contains this naming -scheme. We don't currently restrict system pointers to one area of memory, but -if they do point onto the heap, it is up to the user to prevent being screwed -by GC or whatever. diff --git a/docs/internals/outline.txt b/docs/internals/outline.txt deleted file mode 100644 index 690781c9223d02b02bed9b4a96c5ba99da88d798..0000000000000000000000000000000000000000 --- a/docs/internals/outline.txt +++ /dev/null @@ -1,120 +0,0 @@ -Todo: -fasl.tex -In good shape. - -object.tex -Fairly good, but should probably be integrated with description of primitives -in vm.tex. - -front.tex -Needs updating cleanup scan. Not too bad. - -middle.tex -Need VMR overview. New names for GTN/LTN? Needs general cleanup, but not too -bad. NLX and stack are the worst. - -back.tex -Pack and assembler need more info. General cleanup. - - -compiler-overview.tex -Adapt introductory material from /../fred/usr/ram/comp.mss, pap:talk.mss -Division between ICR overview and ICR convert needs work. - -debugger.tex -Needs much work. Merge much info from debug-info and debug-int. Duplicating a -fair amount of stuff in the source may make sense where, since this is a part -of the system that is generally interesting. And also, a part that people -building on CMU CL might want to understand. - -glossary.tex -Finish, integrate w/ main text? - -interpreter.tex -Very sketchy and tentative. Needs to be fleshed out from the code. - -retargeting.tex -Very rough. Needs to be merged with parts of vm.tex (call vops). Needs some -additional text. Documentation of assembler, and all other exported -interfaces. (Generate defined VOP descriptions from the core, keyed to files?) - -vm.tex -This file should probably cease to exist, going into object, retargeting and -introductory material. [Also other scrap in stuff/] - - -[VMR and ICR overview also needed...] - -architecture.tex -Missing sections on startup code, compiling, building. - -environment.tex -Needs to be written: type system and info database interfaces. - -interface.tex -Needs to be written: source paths and error message utilities. - -lowlev.tex -Needs to be written. All manner of low-level stuff: memory layout and -management, core file format, C interface, low-level debugging (and ldb.) - - -Several different audiences: - -- Curious compiler implementors (not a big priority. Downplay academic - aspects, i.e. comparisons to other techniques, analysis of limitations, - future work...) Compiler part can be more academic, and include some - justifications of other design decisions. - -- System maintainers. - -- People retargeting the compiler. - -- People bringing up the system in a new environment. - -Sys arch part: - Package + file structure [system.txt] - system building [compiling.txt] - bootstrapping & cross compiling - -Compiler design: - Overview (mirror structure of rest of the part) - ICR data structure - Front end [front.tex] - Basic VMR data structures (no back-end stuff) - Middle end [middle.tex] - Back end + data structures [back.tex] - - Error system interface - Source tracking - -Compiler retargeting: - VM definition concepts [porting.txt, mail.txt, retargeting.tex] - SCs, SBs, primitive-types - Defining VOPS - time specification - defining - and using the assembler - Required VOPs [internal.txt, lowlev.txt, vm.mss] - Standard primitives [vm.mss] (broken down by type, parallels object format - section structure.) - Customizing VMR conversion - multiple hardware - constant operands - VM specific transforms - special-case IR2 convert methods - -Run-time system: - type system - info database - Data format [object.tex] - Debugger: - Info format [debug.txt] - Stack parsing [debug.txt] - Breakpoints - Internal errors - Signals - Memory management: [William] - heap Layout - stacks - GC - misc implementation stuff: foreign call, assembly routines [lowlev.txt] - LDB and low-level debugging - core file format [William] - fasl format [fasl.tex] diff --git a/docs/internals/retargeting.tex b/docs/internals/retargeting.tex deleted file mode 100644 index 82ab04391196232bbce654994e58b8e9ee7595de..0000000000000000000000000000000000000000 --- a/docs/internals/retargeting.tex +++ /dev/null @@ -1,1082 +0,0 @@ -\part{Compiler Retargeting} - -[\#\#\# - -In general, it is a danger sign if a generator references a TN that isn't an -operand or temporary, since lifetime analysis hasn't been done for that use. -We are doing weird stuff for the old-cont and return-pc passing locations, -hoping that the conflicts at the called function have the desired effect. -Other stuff? When a function returns unknown values, we don't reference the -values locations when a single-value return is done. But nothing is live at a -return point anyway. - - - -Have a way for template conversion to special-case constant arguments? -How about: - If an arg restriction is (:satisfies [<predicate function>]), and the - corresponding argument is constant, with the constant value satisfying the - predicate, then (if any other restrictions are satisfied), the template - will be emitted with the literal value passed as an info argument. If the - predicate is omitted, then any constant will do. - - We could sugar this up a bit by allowing (:member <object>*) for - (:satisfies (lambda (x) (member x '(<object>*)))) - -We could allow this to be translated into a Lisp type by adding a new Constant -type specifier. This could only appear as an argument to a function type. -To satisfy (Constant <type>), the argument must be a compile-time constant of -the specified type. Just Constant means any constant (i.e. (Constant *)). -This would be useful for the type constraints on ICR transforms. - - -Constant TNs: we count on being able to indirect to the leaf, and don't try to -wedge the information into the offset. We set the FSC to an appropriate -immediate SC. - - Allow "more operands" to VOPs in define-vop. You can't do much with the - more operands: define-vop just fills in the cost information according to - the loading costs for a SC you specify. You can't restrict more operands, - and you can't make local preferences. In the generator, the named variable - is bound to the TN-ref for the first extra operand. This should be good - enough to handle all the variable arg VOPs (primarily function call and - return). Usually more operands are used just to get TN lifetimes to work - out; the generator actually ignores them. - - Variable-arg VOPs can't be used with the VOP macro. You must use VOP*. - VOP* doesn't do anything with these extra operand except stick them on the - ends of the operand lists passed into the template. VOP* is often useful - within the convert functions for non-VOP templates, since it can emit a VOP - using an already prepared TN-Ref list. - - - It is pretty basic to the whole primitive-type idea that there is only one - primitive-type for a given lisp type. This is really the same as saying - primitive types are disjoint. A primitive type serves two somewhat - unrelated purposes: - -- It is an abstraction a Lisp type used to select type specific - operations. Originally kind of an efficiency hack, but it lets a - template's type signature be used both for selection and operand - representation determination. - -- It represents a set of possible representations for a value (SCs). The - primitive type is used to determine the legal SCs for a TN, and is also - used to determine which type-coercion/move VOP to use. - -] - -There are basically three levels of target dependence: - - -- Code in the "front end" (before VMR conversion) deals only with Lisp - semantics, and is totally target independent. - - -- Code after VMR conversion and before code generation depends on the VM, - but should work with little modification across a wide range of - "conventional" architectures. - - -- Code generation depends on the machine's instruction set and other - implementation details, so it will have to be redone for each - implementation. Most of the work here is in defining the translation into - assembly code of all the supported VOPs. - - - -\chapter{Storage bases and classes} -New interface: instead of CURRENT-FRAME-SIZE, have CURRENT-SB-SIZE <name> which -returns the current element size of the named SB. - -How can we have primitive types that overlap, i.e. (UNSIGNED-BYTE 32), -(SIGNED-BYTE 32), FIXNUM? -Primitive types are used for two things: - Representation selection: which SCs can be used to represent this value? - For this purpose, it isn't necessary that primitive types be disjoint, - since any primitive type can choose an arbitrary set of - representations. For moves between the overlapping representations, - the move/load operations can just be noops when the locations are the - same (vanilla MOVE), since any bad moves should be caught out by type - checking. - VOP selection: - Is this operand legal for this VOP? When ptypes overlap in interesting - ways, there is a problem with allowing just a simple ptype restriction, - since we might want to allow multiple ptypes. This could be handled - by allowing "union primitive types", or by allowing multiple primitive - types to be specified (only in the operand restriction.) The latter - would be long the lines of other more flexible VOP operand restriction - mechanisms, (constant, etc.) - - - -Ensure that load/save-operand never need to do representation conversion. - -The PRIMITIVE-TYPE more/coerce info would be moved into the SC. This could -perhaps go along with flushing the TN-COSTS. We would annotate the TN with -best SC, which implies the representation (boxed or unboxed). We would still -need represent the legal SCs for restricted TNs somehow, and also would have to -come up with some other way for pack to keep track of which SCs we have already -tried. - -A SC would have a list of "alternate" SCs and a boolean SAVE-P value that -indicates it needs to be saved across calls in some non-SAVE-P SC. A TN is -initially given its "best" SC. The SC is annotated with VOPs that are used for -moving between the SC and its alternate SCs (load/save operand, save/restore -register). It is also annotated with the "move" VOPs used for moving between -this SC and all other SCs it is possible to move between. We flush the idea -that there is only c-to-t and c-from-t. - -But how does this mesh with the idea of putting operand load/save back into the -generator? Maybe we should instead specify a load/save function? The -load/save functions would also differ from the move VOPs in that they would -only be called when the TN is in fact in that particular alternate SC, whereas -the move VOPs will be associated with the primary SC, and will be emitted -before it is known whether the TN will be packed in the primary SC or an -alternate. - -I guess a packed SC could also have immediate SCs as alternate SCs, and -constant loading functions could be associated with SCs using this mechanism. - -So given a TN packed in SC X and a SC restriction for Y and Z, how do we know -which load function to call? There would be ambiguity if X was an alternate -for both Y and Z and they specified different load functions. This seems -unlikely to arise in practice, though, so we could just detect the ambiguity -and give an error at define-vop time. If they are doing something totally -weird, they can always inhibit loading and roll their own. - -Note that loading costs can be specified at the same time (same syntax) as -association of loading functions with SCs. It seems that maybe we will be -rolling DEFINE-SAVE-SCS and DEFINE-MOVE-COSTS into DEFINE-STORAGE-CLASS. - -Fortunately, these changes will affect most VOP definitions very little. - - -A Storage Base represents a physical storage resource such as a register set or -stack frame. Storage bases for non-global resources such as the stack are -relativized by the environment that the TN is allocated in. Packing conflict -information is kept in the storage base, but non-packed storage resources such -as closure environments also have storage bases. -Some storage bases: - General purpose registers - Floating point registers - Boxed (control) stack environment - Unboxed (number) stack environment - Closure environment - -A storage class is a potentially arbitrary set of the elements in a storage -base. Although conceptually there may be a hierarchy of storage classes such -as "all registers", "boxed registers", "boxed scratch registers", this doesn't -exist at the implementation level. Such things can be done by specifying -storage classes whose locations overlap. A TN shouldn't have lots of -overlapping SC's as legal SC's, since time would be wasted repeatedly -attempting to pack in the same locations. - -There will be some SC's whose locations overlap a great deal, since we get Pack -to do our representation analysis by having lots of SC's. A SC is basically a -way of looking at a storage resource. Although we could keep a fixnum and an -unboxed representation of the same number in the same register, they correspond -to different SC's since they are different representation choices. - -TNs are annotated with the primitive type of the object that they hold: - T: random boxed object with only one representation. - Fixnum, Integer, XXX-Float: Object is always of the specified numeric type. - String-Char: Object is always a string-char. - -When a TN is packed, it is annotated with the SC it was packed into. The code -generator for a VOP must be able to uniquely determine the representation of -its operands from the SC. (debugger also...) - -Some SCs: - Reg: any register (immediate objects) - Save-Reg: a boxed register near r15 (registers easily saved in a call) - Boxed-Reg: any boxed register (any boxed object) - Unboxed-Reg: any unboxed register (any unboxed object) - Float-Reg, Double-Float-Reg: float in FP register. - Stack: boxed object on the stack (on cstack) - Word: any 32bit unboxed object on nstack. - Double: any 64bit unboxed object on nstack. - -We have a number of non-packed storage classes which serve to represent access -costs associated with values that are not allocated using conflicts -information. Non-packed TNs appear to already be packed in the appropriate -storage base so that Pack doesn't get confused. Costs for relevant non-packed -SC's appear in the TN-Ref cost information, but need not ever be summed into -the TN cost vectors, since TNs cannot be packed into them. - -There are SCs for non-immediate constants and for each significant kind of -immediate operand in the architecture. On the RT, 4, 8 and 20 bit integer SCs -are probably worth having. - -Non-packed SCs: - Constant - Immediate constant SCs: - Signed-Byte-<N>, Unsigned-Byte-<N>, for various architecture dependent - values of <N> - String-Char - XXX-Float - Magic values: T, NIL, 0. - - -\chapter{Type system parameterization} - -The main aspect of the VM that is likely to vary for good reason is the type -system: - - -- Different systems will have different ways of representing dynamic type - information. The primary effect this has on the compiler is causing VMR - conversion of type tests and checks to be implementation dependent. - Rewriting this code for each implementation shouldn't be a big problem, - since the portable semantics of types has already been dealt with. - - -- Different systems will have different specialized number and array types, - and different VOPs specialized for these types. It is easy add this kind - of knowledge without affecting the rest of the compiler. All you have to - do is define the VOPs and translations. - - -- Different systems will offer different specialized storage resources - such as floating-point registers, and will have additional kinds of - primitive-types. The storage class mechanism handles a large part of this, - but there may be some problem in getting VMR conversion to realize the - possibly large hidden costs in implicit moves to and from these specialized - storage resources. Probably the answer is to have some sort of general - mechanism for determining the primitive-type for a TN given the Lisp type, - and then to have some sort of mechanism for automatically using specialized - Move VOPs when the source or destination has some particular primitive-type. - -\#| -How to deal with list/null(symbol)/cons in primitive-type structure? Since -cons and symbol aren't used for type-specific template selection, it isn't -really all that critical. Probably Primitive-Type should return the List -primitive type for all of Cons, List and Null (indicating when it is exact). -This would allow type-dispatch for simple sequence functions (such as length) -to be done using the standard template-selection mechanism. [Not a wired -assumption] -|\# - - - -\chapter{VOP Definition} - -Before the operand TN-refs are passed to the emit function, the following -stuff is done: - -- The refs in the operand and result lists are linked together in order using - the Across slot. This list is properly NIL terminated. - -- The TN slot in each ref is set, and the ref is linked into that TN's refs - using the Next slot. - -- The Write-P slot is set depending on whether the ref is an argument or - result. - -- The other slots have the default values. - -The template emit function fills in the Vop, Costs, Cost-Function, -SC-Restriction and Preference slots, and links together the Next-Ref chain as -appropriate. - - -\section{Lifetime model} - -\#| -Note in doc that the same TN may not be used as both a more operand and as any -other operand to the same VOP, to simplify more operand LTN number coalescing. -|\# - -It seems we need a fairly elaborate model for intra-VOP conflicts in order to -allocate temporaries without introducing spurious conflicts. Consider the -important case of a VOP such as a miscop that must have operands in certain -registers. We allocate a wired temporary, create a local preference for the -corresponding operand, and move to (or from) the temporary. If all temporaries -conflict with all arguments, the result will be correct, but arguments could -never be packed in the actual passing register. If temporaries didn't conflict -with any arguments, then the temporary for an earlier argument might get packed -in the same location as the operand for a later argument; loading would then -destroy an argument before it was read. - -A temporary's intra-VOP lifetime is represented by the times at which its life -starts and ends. There are various instants during the evaluation that start -and end VOP lifetimes. Two TNs conflict if the live intervals overlap. -Lifetimes are open intervals: if one TN's lifetime begins at a point where -another's ends, then the TNs don't conflict. - -The times within a VOP are the following: - -:Load - This is the beginning of the argument's lives, as far as intra-vop - conflicts are concerned. If load-TNs are allocated, then this is the - beginning of their lives. - -(:Argument <n>) - The point at which the N'th argument is read for the last time (by this - VOP). If the argument is dead after this VOP, then the argument becomes - dead at this time, and may be reused as a temporary or result load-TN. - -(:Eval <n>) - The N'th evaluation step. There may be any number of evaluation steps, but - it is unlikely that more than two are needed. - -(:Result <n>) - The point at which the N'th result is first written into. This is the - point at which that result becomes live. - -:Save - Similar to :Load, but marks the end of time. This is point at which result - load-TNs are stored back to the actual location. - -In any of the list-style time specifications, the keyword by itself stands for -the first such time, i.e. - :argument <==> (:argument 0) - - -Note that argument/result read/write times don't actually have to be in the -order specified, but they must *appear* to happen in that order as far as -conflict analysis is concerned. For example, the arguments can be read in any -order as long no TN is written that has a life beginning at or after -(:Argument <n>), where N is the number of an argument whose reading was -postponed. - -[\#\#\# (???) - -We probably also want some syntactic sugar in Define-VOP for automatically -moving operands to/from explicitly allocated temporaries so that this kind of -thing is somewhat easy. There isn't really any reason to consider the -temporary to be a load-TN, but we want to compute costs as though it was and -want to use the same operand loading routines. - -We also might consider allowing the lifetime of an argument/result to be -extended forward/backward. This would in many cases eliminate the need for -temporaries when operands are read/written out of order. -] - - -\section{VOP Cost model} - -Note that in this model, if a operand has no restrictions, it has no cost. -This makes make sense, since the purpose of the cost is to indicate the -relative value of packing in different SCs. If the operand isn't required to -be in a good SC (i.e. a register), then we might as well leave it in memory. -The SC restriction mechanism can be used even when doing a move into the SC is -too complex to be generated automatically (perhaps requiring temporary -registers), since Define-VOP allows operand loading to be done explicitly. - - -\section{Efficiency notes} - - In addition to -being used to tell whether a particular unsafe template might get emitted, we -can also use it to give better efficiency notes: - -- We can say what is wrong with the call types, rather than just saying we - failed to open-code. - -- We can tell whether any of the "better" templates could possibly apply, - i.e. is the inapplicability of a template because of inadequate type - information or because the type is just plain wrong. We don't want to - flame people when a template that couldn't possibly match doesn't match, - e.g. complaining that we can't use fixnum+ when the arguments are known to - be floats. - - -This is how we give better efficiency notes: - -The Template-Note is a short noun-like string without capitalization or -punctuation that describes what the template "does", i.e. we say -"Unable to do ~A, doing ~A instead." - -The Cost is moved from the Vop-Info to the Template structure, and is used to -determine the "goodness" of possibly applicable templates. [Could flush -Template/Vop-Info distinction] The cost is used to choose the best applicable -template to emit, and also to determine what better templates we might have -been able to use. - -A template is possibly applicable if there is an intersection between all of -the arg/result types and the corresponding arg/result restrictions, i.e. the -template is not clearly impossible: more declarations might allow it to be -emitted. - - -\chapter{Assembler Retargeting} - - -\chapter{Writing Assembly Code} - -VOP writers expect: - MOVE - You write when you port the assembler.) - EMIT-LABEL - Assembler interface like INST. Takes a label you made and says "stick it - here." - GEN-LABEL - Returns a new label suitable for use with EMIT-LABEL exactly once and - for referencing as often as necessary. - INST - Recognizes and dispatches to instructions you defined for assembler. - ALIGN - This takes the number of zero bits you want in the low end of the address - of the next instruction. - ASSEMBLE - ASSEMBLE-ELSEWHERE - Get ready for assembling stuff. Takes a VOP and arbitrary PROGN-style - body. Wrap these around instruction emission code announcing the first - pass of our assembler. - CURRENT-NFP-TN - This returns a TN for the NFP if the caller uses the number stack, or - nil. - SB-ALLOCATED-SIZE - This returns the size of some storage based used by the currently - compiling component. - ... - -;;; -;;; VOP idioms -;;; - -STORE-STACK-TN -LOAD-STACK-TN - These move a value from a register to the control stack, or from the - control stack to a register. They take care of checking the TN types, - modifying offsets according to the address units per word, etc. - - -\chapter{Required VOPS} - - -Note: the move VOP cannot have any wired temps. (Move-Argument also?) This is -so we can move stuff into wired TNs without stepping on our toes. - - -We create set closure variables using the Value-Cell VOP, which takes a value -and returns a value cell containing the value. We can basically use this -instead of a Move VOP when initializing the variable. Value-Cell-Set and -Value-Cell-Ref are used to access the value cell. We can have a special effect -for value cells so that value cells references can be discovered to be common -subexpressions or loop invariants. - - - - -Represent unknown-values continuations as (start, count). Unknown values -continuations are always outside of the current frame (on stack top). Within a -function, we always set up and receive values in the standard passing -locations. If we receive stack values, then we must BLT them down to the start -of our frame, filling in any unsupplied values. If we generate unknown values -(i.e. PUSH-VALUES), then we set the values up in the standard locations, then -BLT them to stack top. When doing a tail-return of MVs, we just set them up in -the standard locations and decrement SP: no BLT is necessary. - -Unknown argument call (MV-CALL) takes its arguments on stack top (is given a -base pointer). If not a tail call, then we just set the arg pointer to the -base pointer and call. If a tail call, we must BLT the arguments down to the -beginning of the current frame. - - -Implement more args by BLT'ing the more args *on top* of the current frame. -This solves two problems: - -- Any register more arguments can be made uniformly accessibly by copying - them into memory. [We can't store the registers in place, since the - beginning of the frame gets double use for storing the old-cont, return-pc - and env.] - -- It solves the deallocation problem: the arguments will be deallocated when - the frame is returned from or a tail full call is done out of it. So - keyword args will be properly tail-recursive without any special mechanism - for squeezing out the more arg once the parsing is done. Note that a tail - local call won't blast the more arg, since in local call the callee just - takes the frame it is given (in this case containing the more arg). - -More args in local call??? Perhaps we should not attempt local call conversion -in this case. We already special-case keyword args in local call. It seems -that the main importance of more args is primarily related to full call: it is -used for defining various kinds of frobs that need to take arbitrary arguments: - -- Keyword arguments - -- Interpreter stubs - -- "Pass through" applications such as dispatch functions - -Given the marginal importance of more args in local call, it seems unworth -going to any implementation difficulty. In fact, it seems that it would cause -complications both at the VMR level and also in the VM definition. This being -the case, we should flush it. - - -\section{Function Call} - - - -\subsection{Registers and frame format} - -These registers are used in function call and return: - -A0..A{\it n} - In full call, the first three arguments. In unknown values return, the - first three return values. - -CFP - The current frame pointer. In full call, this initially points to a - partial frame large enough to hold the passed stack arguments (zero-length - if none). - -CSP - The current control stack top pointer. - -OCFP - In full call, the passing location for the frame to return to. - - In unknown-values return of other than one value, the pointer to returned - stack values. In such a return, OCFP is always initialized to point to - the frame returned from, even when no stack values are returned. This - allows OCFP to be used to restore CSP. - -LRA - In full call, the passing location for the return PC. - -NARGS - In full call, the number of arguments passed. In unknown-values return of - other than one value, the number of values returned. - - -\subsection{Full call} - -What is our usage of CFP, OCFP and CSP? - -It is an invariant that CSP always points after any useful information so that -at any time an interrupt can come and allocate stuff in the stack. - -TR call is also a constraint: we can't deallocate the caller's frame before the -call, since it holds the stack arguments for the call. - -What we do is have the caller set up CFP, and have the callee set CSP to CFP -plus the frame size. The caller leaves CSP alone: the callee is the one who -does any necessary stack deallocation. - -In a TR call, we don't do anything: CFP is left as CFP, and CSP points to the -end of the frame, keeping the stack arguments from being trashed. - -In a normal call, CFP is set to CSP, causing the callee's frame to be allocated -after the current frame. - - -\subsection{Unknown values return} - -The unknown values return convention is always used in full call, and is used -in local call when the compiler either can't prove that a fixed number of -values are returned, or decides not to use the fixed values convention to allow -tail-recursive XEP calls. - -The unknown-values return convention has variants: single value and variable -values. We make this distinction to optimize the important case of a returner -whose knows exactly one value is being returned. Note that it is possible to -return a single value using the variable-values convention, but it is less -efficient. - -We indicate single-value return by returning at the return-pc+4; variable value -return is indicated by returning at the return PC. - -Single-value return makes only the following guarantees: - A0 holds the value returned. - CSP has been reset: there is no garbage on the stack. - -In variable value return, more information is passed back: - A0..A2 hold the first three return values. If fewer than three values are - returned, then the unused registers are initialized to NIL. - - OCFP points to the frame returned from. Note that because of our - tail-recursive implementation of call, the frame receiving the values is - always immediately under the frame returning the values. This means that - we can use OCFP to index the values when we access them, and to restore - CSP when we want to discard them. - - NARGS holds the number of values returned. - - CSP is always (+ OCFP (* NARGS 4)), i.e. there is room on the stack - allocated for all returned values, even if they are all actually passed in - registers. - - -\subsection{External Entry Points} - -Things that need to be done on XEP entry: - 1] Allocate frame - 2] Move more arg above the frame, saving context - 3] Set up env, saving closure pointer if closure - 4] Move arguments from closure to local home - Move old-cont and return-pc to the save locations - 5] Argument count checking and dispatching - -XEP VOPs: - -Allocate-Frame -Copy-More-Arg <nargs-tn> 'fixed {in a3} => <context>, <count> -Setup-Environment -Setup-Closure-Environment => <closure> -Verify-Argument-Count <nargs-tn> 'count {for fixed-arg lambdas} -Argument-Count-Error <nargs-tn> {Drop-thru on hairy arg dispatching} -Use fast-if-=/fixnum and fast-if-</fixnum for dispatching. - -Closure vops: -make-closure <fun entry> <slot count> => <closure> -closure-init <closure> <values> 'slot - - -Things that need to be done on all function entry: - -- Move arguments to the variable home (consing value cells as necessary) - -- Move environment values to the local home - -- Move old-cont and return-pc to the save locations - - -\section{Calls} - -Calling VOP's are a cross product of the following sets (with some members -missing): - Return values - multiple (all values) - fixed (calling with unknown values conventions, wanting a certain - number.) - known (only in local call where caller/callee agree on number of - values.) - tail (doesn't return but does tail call) - What function - local - named (going through symbol, like full but stash fun name for error sys) - full (have a function) - Args - fixed (number of args are known at compile-time) - variable (MULTIPLE-VALUE-CALL and APPLY) - -Note on all jumps for calls and returns that we want to put some instruction -in the jump's delay slot(s). - -Register usage at the time of the call: - -LEXENV - This holds the lexical environment to use during the call if it's a closure, - and it is undefined otherwise. - -CNAME - This holds the symbol for a named call and garbage otherwise. - -OCFP - This holds the frame pointer, which the system restores upon return. The - callee saves this if necessary; this is passed as a pseudo-argument. - -A0 ... An - These holds the first n+1 arguments. - -NARGS - This holds the number of arguments, as a fixnum. - -LRA - This holds the lisp-return-address object which indicates where to return. - For a tail call, this retains its current value. The callee saves this - if necessary; this is passed as a pseudo-argument. - -CODE - This holds the function object being called. - -CSP - The caller ignores this. The callee sets it as necessary based on CFP. - -CFP - This holds the callee's frame pointer. Caller sets this to the new frame - pointer, which it remembered when it started computing arguments; this is - CSP if there were no stack arguments. For a tail call CFP retains its - current value. - -NSP - The system uses this within a single function. A function using NSP must - allocate and deallocate before returning or making a tail call. - -Register usage at the time of the return for single value return, which -goes with the unknown-values convention the caller used. - -A0 - The holds the value. - -CODE - This holds the lisp-return-address at which the system continues executing. - -CSP - This holds the CFP. That is, the stack is guaranteed to be clean, and there - is no code at the return site to adjust the CSP. - -CFP - This holds the OCFP. - -Additional register usage for multiple value return: - -NARGS - This holds the number of values returned. - -A0 ... An - These holds the first n+1 values, or NIL if there are less than n+1 values. - -CSP - Returner stores CSP to hold its CFP + NARGS * <address units per word> - -OCFP - Returner stores this as its CFP, so the returnee has a handle on either - the start of the returned values on the stack. - - -ALLOCATE FULL CALL FRAME. - -If the number of call arguments (passed to the VOP as an info argument) -indicates that there are stack arguments, then it makes some callee frame for -arguments: - VOP-result <- CSP - CSP <- CSP + value of VOP info arg times address units per word. - -In a call sequence, move some arguments to the right places. - -There's a variety of MOVE-ARGUMENT VOP's. - -FULL CALL VOP'S -(variations determined by whether it's named, it's a tail call, there -is a variable arg count, etc.) - - if variable number of arguments - NARGS <- (CSP - value of VOP argument) shift right by address units per word. - A0...An <- values off of VOP argument (just fill them all) - else - NARGS <- value of VOP info argument (always a constant) - - if tail call - OCFP <- value from VOP argument - LRA <- value from VOP argument - CFP stays the same since we reuse the frame - NSP <- NFP - else - OCFP <- CFP - LRA <- compute LRA by adding an assemble-time determined constant to - CODE. - CFP <- new frame pointer (remembered when starting to compute args) - This is CSP if no stack args. - when (current-nfp-tn VOP-self-pointer) - stack-temp <- NFP - - if named - CNAME <- function symbol name - the-fun <- function object out of symbol - - LEXENV <- the-fun (from previous line or VOP argument) - CODE <- function-entry (the first word after the-fun) - LIP <- calc first instruction addr (CODE + constant-offset) - jump and run off temp - - <emit Lisp return address data-block> - <default and move return values OR receive return values> - when (current-nfp-tn VOP-self-pointer) - NFP <- stack-temp - -Callee: - -XEP-ALLOCATE-FRAME - emit function header (maybe initializes offset back to component start, - but other pointers are set up at load-time. Pads - to dual-word boundary.) - CSP <- CFP + compile-time determined constant (frame size) - if the function uses the number stack - NFP <- NSP - NSP <- NSP + compile-time determined constant (number stack frame size) - -SETUP-ENVIRONMENT -(either use this or the next one) - -CODE <- CODE - assembler-time determined offset from function-entry back to - the code data-block address. - -SETUP-CLOSURE-ENVIRONMENT -(either use this or the previous one) -After this the CLOSURE-REF VOP can reference closure variables. - -VOP-result <- LEXENV -CODE <- CODE - assembler-time determined offset from function-entry back to - the code data-block address. - -Return VOP's -RETURN and RETURN-MULTIPLE are for the unknown-values return convention. -For some previous caller this is either it wants n values (and it doesn't -know how many are coming), or it wants all the values returned (and it -doesn't know how many are coming). - - -RETURN -(known fixed number of values, used with the unknown-values convention - in the caller.) -When compiler invokes VOP, all values are already where they should be; -just get back to caller. - -when (current-nfp-tn VOP-self-pointer) - ;; The number stack grows down in memory. - NSP <- NFP + number stack frame size for calls within the currently - compiling component - times address units per word -CODE <- value of VOP argument with LRA -if VOP info arg is 1 (number of values we know we're returning) - CSP <- CFP - LIP <- calc target addr - (CODE + skip over LRA header word + skip over address units per branch) - (The branch is in the caller to skip down to the MV code.) -else - NARGS <- value of VOP info arg - nil out unused arg regs - OCFP <- CFP (This indicates the start of return values on the stack, - but you leave space for those in registers for convenience.) - CSP <- CFP + NARGS * address-units-per-word - LIP <- calc target addr (CODE + skip over LRA header word) -CFP <- value of VOP argument with OCFP -jump and run off LIP - -RETURN-MULTIPLE -(unknown number of values, used with the unknown-values convention in - the caller.) -When compiler invokes VOP, it gets TN's representing a pointer to the -values on the stack and how many values were computed. - -when (current-nfp-tn VOP-self-pointer) - ;; The number stack grows down in memory. - NSP <- NFP + number stack frame size for calls within the currently - compiling component - times address units per word -NARGS <- value of VOP argument -copy the args to the beginning of the current (returner's) frame. - Actually some go into the argument registers. When putting the rest at - the beginning of the frame, leave room for those in the argument registers. -CSP <- CFP + NARGS * address-units-per-word -nil out unused arg regs -OCFP <- CFP (This indicates the start of return values on the stack, - but you leave space for those in registers for convenience.) -CFP <- value of VOP argument with OCFP -CODE <- value of VOP argument with LRA -LIP <- calc target addr (CODE + skip over LRA header word) -jump and run off LIP - - -Returnee -The call VOP's call DEFAULT-UNKNOWN-VALUES or RECEIVE-UNKNOWN-VALUES after -spitting out transfer control to get stuff from the returner. - -DEFAULT-UNKNOWN-VALUES -(We know what we want and we got something.) -If returnee wants one value, it never does anything to deal with a shortage -of return values. However, if start at PC, then it has to adjust the stack -pointer to dump extra values (move OCFP into CSP). If it starts at PC+N, -then it just goes along with the "want one value, got it" case. -If the returnee wants multiple values, and there's a shortage of return -values, there are two cases to handle. One, if the returnee wants fewer -values than there are return registers, and we start at PC+N, then it fills -in return registers A1..A<desired values necessary>; if we start at PC, -then the returnee is fine since the returning conventions have filled in -the unused return registers with nil, but the returnee must adjust the -stack pointer to dump possible stack return values (move OCFP to CSP). -Two, if the returnee wants more values than the number of return registers, -and it starts at PC+N (got one value), then it sets up returnee state as if -an unknown number of values came back: - A0 has the one value - A1..An get nil - NARGS gets 1 - OCFP gets CSP, so general code described below can move OCFP into CSP -If we start at PC, then branch down to the general "got k values, wanted n" -code which takes care of the following issues: - If k < n, fill in stack return values of nil for shortage of return - values and move OCFP into CSP - If k >= n, move OCFP into CSP -This also restores CODE from LRA by subtracting an assemble-time constant. - -RECEIVE-UKNOWN-VALUES -(I want whatever I get.) -We want these at the end of our frame. When the returnee starts starts at -PC, it moves the return value registers to OCFP..OCFP[An] ignoring where -the end of the stack is and whether all the return value registers had -values. The returner left room on the stack before the stack return values -for the register return values. When the returnee starts at PC+N, bump CSP -by 1 and copy A0 there. -This also restores CODE from LRA by subtracting an assemble-time constant. - - -Local call - -There are three flavors: - 1] KNOWN-CALL-LOCAL - Uses known call convention where caller and callee agree where all - the values are, and there's a fixed number of return values. - 2] CALL-LOCAL - Uses the unknown-values convention, but we expect a particular - number of values in return. - 3] MULTIPLE-CALL-LOCAL - Uses the unknown-values convention, but we want all values returned. - -ALLOCATE-FRAME - -If the number of call arguments (passed to the VOP as an info argument) -indicates that there are stack arguments, then it makes some callee frame for -arguments: - VOP-result1 <- CSP - CSP <- CSP + control stack frame size for calls within the currently - compiling component - times address units per word. - when (callee-nfp-tn <VOP info arg holding callee>) - ;; The number stack grows down. - ;; May have to round to dual-word boundary if machines C calling - ;; conventions demand this. - NSP <- NSP - number stack frame size for calls within the currently - compiling component - times address units per word - VOP-result2 <- NSP - -KNOWN-CALL-LOCAL, CALL-LOCAL, MULTIPLE-CALL-LOCAL -KNOWN-CALL-LOCAL has no need to affect CODE since CODE is the same for the -caller/returnee and the returner. This uses KNOWN-RETURN. -With CALL-LOCAL and MULTIPLE-CALL-LOCAL, the caller/returnee must fixup -CODE since the callee may do a tail full call. This happens in the code -emitted by DEFAULT-UNKNOWN-VALUES and RECEIVE-UNKNOWN-VALUES. We use these -return conventions since we don't know what kind of values the returner -will give us. This could happen due to a tail full call to an unknown -function, or because the callee had different return points that returned -various numbers of values. - -when (current-nfp-tn VOP-self-pointer) ;Get VOP self-pointer with - ;DEFINE-VOP switch :vop-var. - stack-temp <- NFP -CFP <- value of VOP arg -when (callee-nfp-tn <VOP info arg holding callee>) - <where-callee-wants-NFP-tn> <- value of VOP arg -<where-callee-wants-LRA-tn> <- compute LRA by adding an assemble-time - determined constant to CODE. -jump and run off VOP info arg holding start instruction for callee - -<emit Lisp return address data-block> -<case call convention - known: do nothing - call: default and move return values - multiple: receive return values -> -when (current-nfp-tn VOP-self-pointer) - NFP <- stack-temp - -KNOWN-RETURN - -CSP <- CFP -when (current-nfp-tn VOP-self-pointer) - ;; number stack grows down in memory. - NSP <- NFP + number stack frame size for calls within the currently - compiling component - times address units per word -LIP <- calc target addr (value of VOP arg + skip over LRA header word) -CFP <- value of VOP arg -jump and run off LIP - - - - -\chapter{Standard Primitives} - - -\chapter{Customizing VMR Conversion} - -Another way in which different implementations differ is in the relative cost -of operations. On machines without an integer multiply instruction, it may be -desirable to convert multiplication by a constant into shifts and adds, while -this is surely a bad idea on machines with hardware support for multiplication. -Part of the tuning process for an implementation will be adding implementation -dependent transforms and disabling undesirable standard transforms. - -When practical, ICR transforms should be used instead of VMR generators, since -transforms are more portable and less error-prone. Note that the Lisp code -need not be implementation independent: it may contain all sorts of -sub-primitives and similar stuff. Generally a function should be implemented -using a transform instead of an VMR translator unless it cannot be implemented -as a transform due to being totally evil or it is just as easy to implement as -a translator because it is so simple. - - -\section{Constant Operands} - -If the code emitted for a VOP when an argument is constant is very different -than the non-constant case, then it may be desirable to special-case the -operation in VMR conversion by emitting different VOPs. An example would be if -SVREF is only open-coded when the index is a constant, and turns into a miscop -call otherwise. We wouldn't want constant references to spuriously allocate -all the miscop linkage registers on the off chance that the offset might not be -constant. See the :constant feature of VOP primitive type restrictions. - - -\section{Supporting Multiple Hardware Configurations} - - -A winning way to change emitted code depending on the hardware configuration, -i.e. what FPA is present is to do this using primitive types. Note that the -Primitive-Type function is VM supplied, and can look at any appropriate -hardware configuration switches. Short-Float can become 6881-Short-Float, -AFPA-Short-Float, etc. There would be separate SBs and SCs for the registers -of each kind of FP hardware, with the each hardware-specific primitive type -using the appropriate float register SC. Then the hardware specific templates -would provide AFPA-Short-Float as the argument type restriction. - -Primitive type changes: - -The primitive-type structure is given a new %Type slot, which is the CType -structure that is equivalent to this type. There is also a Guard slot, with, -if true is a function that control whether this primitive type is allowed (due -to hardware configuration, etc.) - -We add new :Type and :Guard keywords to Def-Primitive-Type. Type is the type -specifier that is equivalent (default to the primitive-type name), and Guard is -an expression evaluated in the null environment that controls whether this type -applies (default to none, i.e. constant T). - -The Primitive-Type-Type function returns the Lisp CType corresponding to a -primitive type. This is the %Type unless there is a guard that returns false, -in which case it is the empty type (i.e. NIL). - -[But this doesn't do what we want it to do, since we will compute the -function type for a template at load-time, so they will correspond to whatever -configuration was in effect then. Maybe we don't want to dick with guards here -(if at all). I guess we can defer this issue until we actually support -different FP configurations. But it would seem pretty losing to separately -flame about all the different FP configurations that could be used to open-code -+ whenever we are forced to closed-code +. - -If we separately report each better possibly applicable template that we -couldn't use, then it would be reasonable to report any conditional template -allowed by the configuration. - -But it would probably also be good to give some sort of hint that perhaps it -would be a good time to make sure you understand how to tell the compiler to -compile for a particular configuration. Perhaps if there is a template that -applies *but for the guard*, then we could give a note. This way, if someone -thinks they are being efficient by throwing in lots of declarations, we can let -them know that they may have to do more. - -I guess the guard should be associated with the template rather than the -primitive type. This would allow LTN and friends to easily tell whether a -template applies in this configuration. It is also probably more natural for -some sorts of things: with some hardware variants, it may be that the SBs and -representations (SCs) are really the same, but there some different allowed -operations. In this case, we could easily conditionalize VOPs without the -increased complexity due to bogus SCs. If there are different storage -resources, then we would conditionalize Primitive-Type as well. - - - -\section{Special-case VMR convert methods} - - (defun continuation-tn (cont \&optional (check-p t)) - ...) -Return the TN which holds Continuation's first result value. In general -this may emit code to load the value into a TN. If Check-P is true, then -when policy indicates, code should be emitted to check that the value satisfies -the continuation asserted type. - - (defun result-tn (cont) - ...) -Return the TN that Continuation's first value is delivered in. In general, -may emit code to default any additional values to NIL. - - (defun result-tns (cont n) - ...) -Similar to Result-TN, except that it returns a list of N result TNs, one -for each of the first N values. - - -Nearly all open-coded functions should be handled using standard template -selection. Some (all?) exceptions: - -- List, List* and Vector take arbitrary numbers of arguments. Could - implement Vector as a source transform. Could even do List in a transform - if we explicitly represent the stack args using %More-Args or something. - -- %Typep varies a lot depending on the type specifier. We don't want to - transform it, since we want %Typep as a canonical form so that we can do - type optimizations. - -- Apply is weird. - -- Funny functions emitted by the compiler: %Listify-Rest-Args, Arg, - %More-Args, %Special-Bind, %Catch, %Unknown-Values (?), %Unwind-Protect, - %Unwind, %%Primitive. diff --git a/docs/internals/run-time.tex b/docs/internals/run-time.tex deleted file mode 100644 index eb21e1cf8b0b5ca4ebe33f13fa5196704385a862..0000000000000000000000000000000000000000 --- a/docs/internals/run-time.tex +++ /dev/null @@ -1,7 +0,0 @@ -\part{Run-Time system} -\include{environment} -\include{interpreter} -\include{debugger} -\include{object} -\include{lowlev} -\include{fasl} diff --git a/docs/internals/vm.tex b/docs/internals/vm.tex deleted file mode 100644 index b1e1c2fe8418f384a49871fbb5843ef8865068ac..0000000000000000000000000000000000000000 --- a/docs/internals/vm.tex +++ /dev/null @@ -1,1454 +0,0 @@ -\chapter{Introduction} % -*- Dictionary: design -*- - -(defun gvp (f) - (with-open-file (s f :direction :output :if-exists :supersede) - (maphash \#'(lambda (k v) - (declare (ignore v)) - (format s "~A~%" k)) - (c::backend-template-names c::*backend*)))) - - -\section{Scope and Purpose} - -This document describes the Virtual Machine that serves as the basis for the -portable implementation of \ccl. The Virtual Machine (hereafter referred to as -the VM) provides a layer of abstraction that hides low-level details of -hardware and implementation strategy, while still revealing enough of the -implementation so that most of the system can be written at the VM level or -above. - -\begin{comment} - -{\#\#\# Shouldn't specify VOPs. Instead, should specify which \clisp functions -are primitive and which subprimitives exist. Isn't really anyone's business -which VOPs actually exist. Each primitive function or subprimitive is -implemented either as a VOP or as expansion into Lisp code, at the particular -implementation's discretion. - -From this point of view, the document is expressing the contract that the Lisp -level code outside of the compiler must satisfy. All functions must ultimately -be defined in terms of primitive functions and sub-primitives. - -The responsibility of the compiler is to implement these primitive operations, -and also to implement special forms, variables and function calling. - -VOPs emitted by the hard-wired translators for non-function nodes are a -somewhat different story. Each implementation will presumably implement all -these VOPs in order to avoid having to rewrite IR2 translation. We also need -to spend quite a bit of time discussing the semantics of these operations, -since they don't just correspond to some \clisp function with type constraints. - -Hard-wired stuff: - -function call -variable access: - global - function - constant - closure - local -closure creation -non-local exit -special binding/unbinding -TN hacking: - move VOPs - TN address (???) -Conditionals: - Basic conditionals: EQ, ... - Interface to generation of other conditional VOPs. - -Some VOPs don't need to be implemented at all: - VOPs to delimit the lifetimes of big stack TNs such as catch blocks - Others? Move VOPs might be defined in terms of an implementation supplied - move routine, since we probably also need this info outside of VOP generators - so that implicit moves can be generated. - - -Type testing/checking (somehow) - -} - -What this document talks about: - -Interface between compiler front-end and back end. (VOPs) - Primitive \clisp operations directly supported by the VM. - Support for complex language features such as function call. - -Sub-primitives that allow system code to do things not possible in \clisp. - -Descriptions of how the current \ccl system uses VM facilities, especially -non-standard ones accessed through sub-primitives. - -Notes about known portability problems. - -Guidelines for writing portable \ccl system code. To some degree these -guidelines are implied by statements that certain things are true of \ccl -system code. - -Descriptions of data structures that are not directly used by the VM, such as -debug information and Core files. - -Descriptions of data structures that are directly used by the VM, such as -symbols and arrays. - - -Who should read it: - -People who want to port \ccl. -People who want to understand the compiler. -People who want to understand how \ccl works. -People who need to write portable \ccl system code. -People such as debugger writers who need to access \ccl\t()'s internal data -structures. - -What it won't do: - -Tell you things that are obviously implementation dependent, such as type -systems or memory management disciplines. See the the various implementation -VM documents. - -Tell you only what you need to know. Programmers shouldn't exploit properties -of the VM documented here unless there is no way to do the same thing in -portable \clisp. - -Tell you how the compiler works. In order to understand some of the subtleties -of VOP descriptions, you will have to understand the IR2 representation and how -it fits into the rest of the compiler. - -Tell you anything about \clisp semantics. When some part of the VM has a -direct relationship to \clisp semantics, the relationship will be directly -stated using \clisp terminology, since a restatement of the semantics is likely -to be inaccurate or misleading. Exceptions will be made only when some -implication of the \clisp semantics is non-obvious. - -Tell you everything about how \ccl works. This document only offers -information that is likely to be needed by programmers doing a port or writing -system code; portable, self-contained parts of the system are totally ignored. -This document deliberately avoids replicating information that is easily -available in the system sources, since such replicated information is always -incorrect somewhere. In some cases, a forwarding pointer to the appropriate -source will be given. - - -Things the VM won't do: - -The VM specification does not totally solve the problem of porting \ccl, since -it is inevitable that it will not map cleanly to all possible combinations of -hardware and operating systems. The VM should not be regarded as being cast in -concrete, since changes in many characteristics would only affect a tiny -fraction of the system sources. - -One current major problem with porting is that large pieces of functionality -are entirely within the VM, and would need to be reimplemented for each port. -A major goal for future work on the system is moving code out of the VM, both -by supporting a "fast-call" convention that allows reasonable use of Lisp in -the out of line implementation of VOPs, and by having a "bugout" mechanism that -allows the VM to call Lisp functions to implement the hard cases in some VOPs. - -The VM is designed to support conventional, untagged, general register -architectures. Suitably lobotomized, it could be mapped to less flexible -hardware such as "Lisp machines", but the compiler would have serious -difficulties supporting stack architectures. - -The VM does not support concurrent lightweight processes. Locking primitives -and deep-binding of specials would be needed. - -The VM does not deal with operating systems interface issues at all. A minimal -port would require implementing at least file and terminal I/O streams. \ccl -implements system interfaces using Aliens and other facilities built on top of -them. - -\end{comment} - - - -Major components: -\begin{itemize} -Specific virtual operations implemented by the VM (VOPs). VOPs are primarily -the concern of the compiler, since it translates Lisp code into VOPs and then -translates VOPs into the implementation. - -Sub-primitives that are used by Lisp code needing to perform operations -below the Lisp level. The compiler implements some sub-primitives directly -using VOPs, while others are translated into Lisp code. Sub-primitives provide -a layer of insulation between the Lisp system code and the VM, since the Lisp -code may assume the existence of operations that are not implemented directly -by the VM. Only sub-primitives with fairly portable semantics are documented -here. Others are in implementation-specific VM documentation. -\end{itemize} - -\comment<Not all sub-primitives are VOPs, and most VOPs are not sub-primitives.> - - - -\subsection{VOP base name rules} - -The names of VOPs that implement functions are based on the function name. -Other VOPs may use any base that doesn't conflict with a function name. There -are some rules used to obtain the base name for related operations. - -To get the name of a setting operation, replace the string "{\tt ref}" in the name -with "{\tt set}". If "{\tt ref}" doesn't appear in the name, add the prefix "{\tt set-}" to the -base name. For example, {\tt svref} becomes {\tt svset}, and {\tt symbol-value} -becomes {\tt set-symbol-value}. - -To get the name of a conditional VOP from the name of a predicate, add the -prefix "{\tt if-}" to the predicate name. For example, {\tt eq} becomes {\tt if-eq}. -{\tt eq} by itself would be a VOP that returned true or false value. - -Some operations check for some error condition, magically signalling the error -through an implicit control transfer. These operations are prefixed with -"{\tt check-}", as in {\tt check-fixnum} and {\tt check-bound}. - - - -\subsection{VOP name prefixes and suffixes} - -Prefixes and suffixes are added to the base to get the names of variant -versions of the VOP. The fully general VOP name looks like this: -\begin{format} - {"{\tt small-}" | "{\tt fast-}"} {\it name}{"{\tt -c}" {\it info}}{"{\tt /}" {\it type}{"{\tt =>}" {\it result-type}} -\end{format} -The "{\tt small-}" and "{\tt fast-}" prefixes indicates that the VOP does minimal -safety checking and is optimized for space or speed, respectively. The absence -of a prefix indicates the safest (or only) version. Usually if the "{\tt small-}" -VOP exists, it will be a synonym for either the fast version or the safe -version, depending on which is smaller. - -The "{\tt -c}" suffix indicates that the some info that is passed as a normal -argument to the base version of the VOP is passed as Codegen-Info in this -version. A typical use would be for VOPs where it is important to use a -different version when one of the arguments is a compile time constant. -{\it info} is some (possibly null) string that indicates which "{\tt -c}" variant -is involved. - -The "{\tt /}{\it type}" suffix asserts that all operands that could be of {\it type} are. -For example, {\tt +/fixnum} adds two fixnums returning a fixnum, while -{\tt length/simple-vector} finds the length of a simple vector, but the result isn't -a simple vector. - -The "{\tt =>}{\it result-type}" suffix supplies a result type assertion on the -operation. - -A not totally silly example of all these modifiers simultaneously is - {\tt fast-+-c/fixnum=>integer}. This operation would this operation adds two -fixnums, one of which is a constant passed as codegen info, resulting in an -integer. The implementation is optimized for speed at the expense of space and -safety. - - - -\chapter{Data Types and Storage Resources} - - -\section{Lisp Objects} -\index{Lisp objects} - -A Lisp object is fixed-size data structure that is organized in a way mandated -by the VM implementation. The fixed format allows the VM to determine the type -of the object. \comment<Virtual type? VM type? Implementation type? -...provides the VM enough information about the type of the object for the VM -to implement the VM-level semantics... ...supports the "dynamic types"...> - -Lisp objects are stored in locations known as cells. - - -Has major types: immediate and non-immediate. -Non-immediate objects may have a subtype. -Non-immediate types: - symbol (nil may be weird) - cons - ratio - complex - some float types - g-vector - i-vector - string - bit-vector - environment (always has subtype) - array header - bignum - structure - pc (code vector) - stack closure (control stack pointer) - -Non-immediate objects are allocated in "type spaces". The type space of an -object is characterized by a small integer known as the type code. Any two -objects of one of the above boxed types will always have the same type code. -{But not really... Some types might be allocated in different type spaces at -different times. (?)} - -The type code doesn't totally describe the object. In general, subtype -information may be involved. - - -Immediate types: - character - fixnum - unbound trap - short float - - - -\section{Type VOPs} - -We consider control transfer to be the fundamental result of comparison, rather -than anything such as a condition code. Although most compilers with whizzy -register allocation seem to explicitly allocate and manipulate the condition -codes, it seems that any benefit is small in our case. This is partly because -our VOPs are at a somewhat higher level, making it difficult to tell which VOPs -do and don't trash the the CC. Explicitly incorporating condition codes in our -VM also introduces another architecture dependency. - -At the IR2 level, we have a class of IF-XXX VOPs which transfer control to one -of two places on the basis of some test on the operands. When generating code -for a predicate, we peek at the destination IF node to find where to transfer -control to. - -The exact representation of type tests in IR2 will be fairly implementation -dependent, since it will depend on the specific type system for the given -implementation. For example, if an implementation can test some types with a -simple tag check, but other types require reading a field from the object in -addition, then the two different kinds of checks should be distinct at the VOP -level, since this will allow the VOP cost and storage information to be more -accurate. Generation of type tests should be factored out of code which would -otherwise be more portable. Probably the IR2 translator for TYPEP and the type -check generation code are the only places that should know about how type tests -are represented in IR2. - -if-type (object) -if-type-range - If-Type Tests whether Object has the type code that is passed in the - codegen info. If-Type-Range tests for a range of type codes. - -{small, fast} if-vector-type (object) - Test that Object is either of the specified type code, or is a 1d array - header with data having the specified type code. - -if-vector-subtype (object) - Test the subtype field of a vector-like object. It is assumed that the - object has already been determined to be vector-like. - -if-fixnump (object) -if-short-float-p -if-characterp - The rationale behind having these as separate VOPs is that they are likely - to be immediate types, and thus may have bizzare type schemes. - -if-consp (object) -if-listp - We have distinct operations for these predicates since one or the other - isn't a simple tag test, but we don't know which one. - -if-rationalp (object) -if-floatp -if-integerp -if-numberp -if-vectorp -if-functionp - The rationale behind having these operations is that they may take a lot of - code, so it is reasonable to put them out of line. - - - -\section{Type Sub-primitives} - -change-type (object) => result - Change the type of an object according to codegen info. The meaning of - this is highly type-system dependent, but it doesn't matter, since the - compiler will never emit this VOP directly. The only way that it can show - up is through %Primitive. -get-type - - -Storage resources: - -Boxed and unboxed locations: -Non-immediate objects may not be stored in unboxed locations. -Things not lisp objects may not be stored in boxed locations. - -Control stack is boxed. -Optional number stack is unboxed. -Heap environment is boxed. -Fixed number of registers, some boxed and some unboxed. - -PCs may be stored on the control stack or in boxed registers, subject to the -constraint that a corresponding environment is also stored. Locations -containing PCs don't need to be zeroed when they are no longer used; nothing -bad will happen if an old PC is unaccompanied by an environment. - - -\item[Trap]Illegal object trap. This value is used in symbols to signify an -undefined value or definition. - - -\chapter{Characters} - - -Character is an immediate type. Characters are manipulated primarily by -converting into an integer and accessing these fields: -\begin{description} -\item[{\tt %character-code-byte}]The character code. This is effectively required to -start at bit 0, since \cl equates {\tt char-int} to {\tt char-code} when there is -no bits or font. All current \ccl systems use ASCII for the character codes, -and define {\tt \#\newline} to be a linefeed, but system code should not count on -this. - -\item[{\tt %character-control-byte}]The character bits. Character bits are used by -Hemlock to describe modifiers in keyboard events, but there is no assumption of -any general portable significance of character bits. - -{\tt %character-font-byte}\\The character font. This is not used by \ccl, and is -not particularly useful. -\end{description} - -Characters should be converted to and from integers by using the \clisp -{\tt char-int} and {\tt int-char} functions, which the compiler translates into -these VOPs: -\begin{example} -char-int (char) => int -int-char (int) => char -\end{example} -In the common case where Char is known to be a {\tt string-char}, these -operations are equivalent to {\tt char-code} and {\tt code-char}. In addition to -providing a portable interface to character conversion, the VOP representation -of this type conversion allows the compiler to avoid unnecessary boxing and -unboxing of character objects. - -Existing code explicitly converts fixnums to characters by using the -Make-Immediate-Type sub-primitive with %Character-Type. Currently conversion -of characters to fixnums is rather confused. Originally, characters were a -subtype of the Misc type code, and the result of the Make-Fixnum sub-primitive -had to be masked with {\tt %character-int-mask}; some code still does this, while -other code may not. - -Character comparisons could be implemented by doing numeric comparisons on the -result of {\tt char-int}, or by using {\tt eq} in the case of {\tt char=}, but this -can result in unnecessary type conversions. Instead, the compiler uses these -conditional VOPs: -\begin{example} -if-char= (x y) -if-char< (x y) -if-char> (x y) -\end{example} - - -\chapter{Symbols} - - -Symbols are currently fairly boring in \ccl, containing only the obvious slots: -\begin{description} -{\tt %symbol-value-slot}\\The current dynamic value of this symbol. If the -symbol is currently unbound, then the value of this slot is the unbound marker. - -{\tt %symbol-function-slot}\\The global function function definition of this -symbol. If the symbol is not fbound, then this slot holds the unbound marker. - -\multiple{ -{\tt %symbol-plist-slot} \* -{\tt %symbol-name-slot} \* -{\tt %symbol-package-slot} -}\\The property list, print name and package for this symbol. -\end{description} - - - -\section{Sub-primitives} - -The {\tt alloc-symbol} sub-primitive allocates a new symbol object. {\it name} is -the simple-string that is to be the name of the symbol. -\begin{example} -alloc-symbol (name) => symbol -\end{example} - -The {\tt set-symbol-package} sub-primitive is used by system code that must set -the symbol package. -\begin{example} -set-symbol-package (symbol new-value) -\end{example} - - - -\section{Accessor VOPs} - -These VOPs read the global symbol value and definition cells. {\tt constant-ref} -may only be used on symbols that have been defined to be constants. Since a -constant cannot change in value and cannot be dynamically bound, the compiler -may be able to compile uses of {\tt constant-ref} more efficiently. Unsafe -versions of these VOPs may not check for the slot being unbound, which the -corresponding \clisp functions are required to do. -\begin{example} -{small, fast} symbol-value (symbol) => value -{small, fast} constant-ref (symbol) => value -{small, fast} symbol-function (symbol) => value -\end{example} - -These VOPs set the global symbol value and definition cells. {\tt makunbound} -and {\tt fmakunbound} are implemented by setting the value to the unbound marker. -\begin{example} -{small, fast} set-symbol-value (symbol new-value) -{small, fast} set-symbol-function (symbol new-value) -\end{example} - -The \clisp accessors for other symbol slots are translated into uses of the -{\tt slot-ref} and {\tt slot-set} VOPs. - - - -\section{Special Binding} - -These VOPs implement dynamic binding of special variables using shallow -binding. {\tt bind} binds {\it symbol} to the specified {\it value}, while -{\tt unbind} undoes the most recent {\it count} special bindings on the binding -stack. -\begin{example} -bind (symbol value) -unbind (count) -\end{example} - - -\section{Property Lists} - -The {\tt get} VOP implements the corresponding \clisp function, while {\tt put} -implements its setf-inverse. -\begin{example} -get (symbol indicator default) => value -put (symbol indicator value) -\end{example} - - -\chapter{Lists} - - -cons - -list<n> (elt0 ... elt<n-1>) => list -list (elt0 ... elt<n-1> more-elts) => list - For some small N, we have fixed-arg versions of List. For larger lists, we - pass in additional elements in a stack TN (possibly required to be on stack - top). List* is similar. - - -These VOPs implement the corresponding \clisp functions: -\begin{example} -{small, fast} car (list) => value -{small, fast} cdr (list) => value -\end{example} - -These VOPs set the car or cdr of a cons: -\begin{example} -{small, fast} set-car (cons new-value) -{small, fast} set-cdr (cons new-value) -\end{example} - -These VOPs implement the \clisp {\tt assoc} and {\tt member} functions with test -functions of {\tt eql} and {\tt eq}: -\begin{example} -assoc (item alist) => cons-or-nil -assq (item alist) => cons-or-nil -member (item list) => cons-or-nil -memq (item list) => cons-or-nil -\end{example} - - -{\tt getf} implements the corresponding \clisp function, while {\tt putf} is used -to implement its setf-inverse. {\tt putf} returns the new value for the list so -that it may stored back into the place. -\begin{example} -getf (list indicator default) => value -putf (list indicator new-value) => list -\end{example} - - -\chapter{Numbers} - -\index{Fixnum format} -Fixnum\\An N-bit two's complement integer. - -\index{Short float format} -Short-Float\\An immediate float format. - -\index{Bignum format} -\label{Bignums} -Bignum\\Bignums are infinite-precision integers, represented somehow. - -\index{Flonum format} -\index{Floating point formats} -Floats\\Floats are stored as consecutive words of bits. - -\index{Ratio format} -Ratio\\Ratios are stored as two consecutive words of Lisp objects, which should -both be integers. - -\index{Complex number format} -Complex\\Complex numbers are stored as two consecutive words of Lisp objects, -which should both be numbers. - - - -\section{Number VOPs} - -integer-length -{small, fast} integer-length/fixnum - -float=>xxx-float - -realpart -lmagpart -numerator -denominator -decode-float -{small, fast} decode-float/xxx-float -scale-float -{small, fast} scale-float/xxx-float - -if-= (x y) -{small, fast} if-=/fixnum -{small, fast} if-=/xxx-float - Do numeric comparison of X and Y. The codegen-info contains the - continuations to transfer to in the true and false cases. Same for <, >. - -+ (x y) => z -{small, fast} +/fixnum -{small, fast} +/fixnum=>integer -{small, fast} +/xxx-float - Same for -, *. Fixnum multiplication by a constant power of 2 (or near - power of 2) can be done by a transform. - -/ (x y) => z -{small, fast} //xxx-float - -negate -{small, fast} negate/fixnum -{small, fast} negate/fixnum=>integer -{small, fast} negate/xxx-float - Ditto for Abs. - -truncate (x y) => q r -{small, fast} truncate/fixnum - -logand (x y) => z -{small, fast} logand/fixnum - Ditto for logior, logxor. - -lognot (n) => z -{small, fast} lognot/fixnum - -ash (n x) => z -{small, fast} ash/fixnum -{small, fast} ash-c/fixnum - -ldb -dpb -mask-field -deposit-field - These will only be used as a last resort. There should be transforms that - turn fixnum operations with constant byte-specifiers into standard logical - operations. - - -\section{Number Sub-primitives} - - -alloc-bignum -make-complex -make-ratio -lsh -logldb -logdpb - - - -\chapter{Arrays} - -\cl arrays can be represented in a few different ways in \rtccl -- -different representations have different performance advantages. Simple -general vectors, simple vectors of integers, and simple strings are basic \rtccl - data types, and access to these structures is quicker than access to -non-simple (or ``complex'') arrays. However, all multi-dimensional arrays in -\rtccl are complex arrays, so references to these are always through a -header structure. - - -Once a vector has been allocated, it is possible to reduce its length by using -the Shrink-Vector sub-primitive, but never to increase its length, even back to -the original size, since the space freed by the reduction may have been -reclaimed. - - - -\subsection{Arrays} -\label{Arrays} -\index{Arrays} - -An array header is identical in form to a G-Vector. At present, the following -subtype codes are defined: -\begin{itemize, spread 0, spacing 1} -0 Normal. -1 Array is displaced to another array (which may be simple). -\end{itemize} -The entries in the header-vector are interpreted as follows: - -\index{Array header format} -\begin{description} -0 Data Vector \\This is a pointer to the I-Vector, G-Vector, or string that -contains the actual data of the array. In a multi-dimensional array, the -supplied indices are converted into a single 1-D index which is used to access -the data vector in the usual way. If the array is displaced, then this is -the array displaced to, which may be an array header. In general, array -access must loop until it finds an actual data vector. - -1 Number of Elements \\This is a fixnum indicating the number of elements for -which there is space in the data vector. - -2 Fill Pointer \\This is a fixnum indicating how many elements of the data -vector are actually considered to be in use. Normally this is initialized to -the same value as the Number of Elements field, but in some array applications -it will be given a smaller value. Any access beyond the fill pointer is -illegal. - -3 Displacement \\This fixnum value is added to the final code-vector index -after the index arithmetic is done but before the access occurs. Used for -mapping a portion of one array into another. For most arrays, this is 0. - -4 Range of First Index \\This is the number of index values along the first -dimension, or one greater than the largest legal value of this index (since the -arrays are always zero-based). A fixnum in the range 0 to 2\+{24}-1. If any -of the indices has a range of 0, the array is legal but will contain no data -and accesses to it will always be out of range. In a 0-dimension array, this -entry will not be present. - -5 - N Ranges of Subsequent Dimensions -\end{description} - -The number of dimensions of an array can be determined by looking at the length -of the array header. The rank will be this number minus 6. The maximum array -rank is 65535 - 6, or 65529. - -The ranges of all indices are checked on every access, during the conversion to -a single data-vector index. In this conversion, each index is added to the -accumulating total, then the total is multiplied by the range of the following -dimension, the next index is added in, and so on. In other words, if the data -vector is scanned linearly, the last array index is the one that varies most -rapidly, then the index before it, and so on. - - - -\section{Array VOPs} - -alloc-bit-vector -alloc-i-vector -alloc-string -alloc-g-vector - Initialized and uninitialized versions? - - -length (sequence) => size -{small, fast} length/vector -{small, fast} length/simple-vector -{small, fast} length/simple-string -{small, fast} length/simple-bit-vector - -aref1 (vector index) => value -{small, fast} aref1/simple-vector -{small, fast} aref1/simple-string -{small, fast} aref1/simple-bit-vector -{small, fast} aref1/simple-array-XXX-float - -aset1 (vector index new-value) -{small, fast} aset1/simple-vector -{small, fast} aset1/simple-string -{small, fast} aset1/simple-bit-vector -{small, fast} aset1/simple-array-XXX-float - -{small, fast} aref1/simple-array-unsigned-byte (vector index) => value -{small, fast} aset1/simple-array-unsigned-byte (vector index new-value) - Byte size is codegen info. - -aref<N> (array index0 ... index<n-1>) => value -aset<N> (array index0 ... index<n-1> new-value) - For some small value of N. Of course, higher dimensional arrays can also - be specialized in seven different ways.... Multi-dimensional simple array - reference with known dimensions can be open-coded using a transform (useful - for benchmarks.) - - - -\section{Array Sub-primitives} - -alloc-array -vector-subtype -set-vector-subtype -vector-access-code -set-vector-access-code -shrink-vector - -typed-vref -typed-vset - -header-length (header) => size -header-ref (header index) => value -header-set (header index new-value) - -bit-bash -byte-blt -{reverse-}find-character -{reverse-}find-character-with-attribute -{reverse-}string-compare -sxhash-simple-string -sxhash-simple-substring - - -\chapter{Structures} - -{small, fast} structure-ref (s) => value -{small, fast} structure-set (s new-value) - Read and write structure slots. Defstruct slot description is in codegen - info. - -alloc-structure - - -\chapter{Runtime Environment} -\index{Runtime Environment} -\label{Runtime} - - -\section{Register Allocation} -\index{Register allocation} - -The main idea is to globally allocate only those registers with global -significance. - -We permanently dedicate the CONT register to point to the current control stack -environment. This is the "frame pointer" in standard terminology. It isn't -possible to get pack to allocate this register on an as-needed basis due to the -classic phase-ordering problem. We need to know if TNs are allocated on the -stack before we can determine tell how badly we need a frame pointer register. -This is of little significance with the control stack environment, since we -almost always need one, and if there are any stack TNs, we must allocate the -frame pointer in a register, since there is nowhere else to put it. The -problem is more severe with a number stack environment pointer. We can't -dedicate a register to it, since we usually don't have any TNs on the number -stack. The only easy solution is to always allocate the number stack -environment pointer on the control stack. This really isn't too bad, when you -compare the cost of doing an extra memory reference to get at the number stack -to the cost of number-consing. - -We also dedicate the ENV register to the current constant pool. It would be -possible to explicitly allocate the constant pointer as needed if we explicitly -represented non-immediate constant access by a VOP, but this would be extra -work, and there are major advantages to representing all constants using TNs. -Another potential efficiency advantage is since the same constant pool is -shared by all the code in a component, we need only initialize ENV on entry to -the component. When we make local calls, we don't have to do anything to make -the constants available to the callee. - -Since the constant pool will also contain the code vector and the debug info, -having it in a known place may make life easier for GC and the debugger. We -may not be able to count on it too much, though, since ENV holds other things -will calls are in progress, and might be pretty random if we jumped into -hyperspace. - - -Runtime environment: - -CONT: the current control stack context. -PC is assumed to be accessible to the debugger when an error happens. -Current-Catch: pointer to the current catch frame. Format of frame is assumed. -Current-Unwind-Protect: current unwind protect frame. Similar to catch. - -If shallow-bind, binding stack and binding stack pointer. -If deep-bind, current special binding. Format of binding frame assumed. - -Everything depends on the current environment, which is CONT. - - -PC -OLD-CONT -ENV -A<n> -CONT -CS - - -\section{Other Dynamic State} - -There are some dynamic state variables that are stored in known memory -locations, rather than having a dedicated register: -\begin{description} -binding stack pointer\\The current pointer to the top of the binding stack. - -current catch\\The pointer to the current catch block. - -current unwind-protect\\The pointer to the current unwind-protect block. -\end{description} - - - - -\section{Control-Stack Format} -\label{Control-Stack-Format} -\index{Control-stack format} - - -The control stack contains only Lisp objects. Every object pointed to by an -entry on this stack is kept alive. - -The \rtccl control stack does not have a rigid frame structure. The compiler -is allowed a large amount of freedom in the use of the stack so that it choose -the best calling sequences. Mostly the compiler is the only system that cares -how the stack is laid out, so this isn't a big problem. See chapter -\ref{debug-info} for a description of the structures which allow the debugger -to parse the stack. - - - -\section{Values Passing Conventions} - - -The first {\it nregs} arguments are passed in registers, where nregs is an -implementation dependent constant. Any additional arguments are the block of -storage between CONT and CS on the control stack. The first nregs locations in -this block of storage are unused so that register more-args can be stored on -the stack without having to BLT the stack values up. - -Returning unknown values are passed in a similar way, but the stack values -block is between OLD-CONT and CS. There isn't any underneath the values: on -return OLD-CONT is always what CS was when the function was called. The -function returned to must copy the values into the desired location in its -frame and deallocate excess stuff on the top of the stack. - -More args are represented by a pointer to the block of values and a count. The -function that originally created the more arg must allocate and deallocate this -stuff somehow. In the case of a local call to a more arg entry, we can just -allocate it as a TN. The external entry point for a more arg entry is more -magical. - - - -The caller allocates the environment for the called function, stores the -arguments into it, and jumps to the function. The caller makes the called -environment current, passing in the return OLD-CONT and PC as explicit arguments. - -When returning values, the returner directly stores the return values into the -frame being returned to. This works even though the caller doesn't know what -function it is returning to, since the same return locations are allocated in -all frames. - -In a tail-recursive call, we can destructively modify the current frame and -jump right to the callee, rather than allocating a new frame. We can do this -because TNBind globally allocates frame locations; all frames are the same size -and have the same TNs in the same place. - - -\section{Binding-Stack Format} -\index{Binding stack format} -\comment<In a symbol chapter?> - - -The special binding stack is used to hold previous values of special variables -that have been bound. It grows and shrinks with the depth of the binding -environment, as reflected in the control stack. This stack contains -symbol-value pairs, with only boxed Lisp objects present. - -Each entry of the binding-stack consists of two boxed (32-bit) words. Pushed -first is a pointer to the symbol being bound. Pushed second is the symbol's -old value (any boxed item) that is to be restored when the binding stack is -popped. - - -\chapter{Functions} - -Function calling is a way of life. - -every function is a closure. pointer to current closure is passed in ENV -unless it isn't (in local call may be elsewhere). - -The description of the representation of functions and the function calling -conventions is a large part of the VM description, since: - Function calling is one of the most complicated facilities provided by the - VM. - - Everything that happens, happens in a function, so all parts of the system - tend to get dragged in. - - -Aspects of function call: - Control - Environment CONT, ENV - Argument/value passing - Argument/value count dispatching - - - - -\section{Function Object Format} -\label{Fn-Format} - -The old notion of a "function object" is now broken down into four different -parts: -\begin{description} -Function entry\\A function entry is a structure that holds the information -that we need to call a function. This is the user visible function object. - -Environment\\The environment is stuff that a function needs when it runs. -This includes constants computed at load time and variables closed over at run -time. Environment information may be allocated in the function entry structure -after the required linkage information. - -Entry information\\This is information about a specific function entry that is -occasionally referenced at run time, but need not be immediately accessible. -Entry information will be either allocated in the function entry -or in the environment that it points to. - -Debug information\\This is information about a function that isn't normally -needed at run time. Debug information can be found by poking around in -environment objects. -\end{description} -See chapter \ref{control-conventions} for a description of how function objects -are used. - - -\section{Environment Object Sub-primitives} - -alloc-code ? -alloc-closure? - - -\subsection{Debug Information Location} - -If present, debug information is stored immediately following any fixed -information in the environment object. It may be necessary to chain up -multiple levels of environments to find the debug information. The debug -information can be recognized because it is represented by a defstruct -structure. See chapter \ref{debug-info} for a description of the debug -information. - - -\section{Function Calls} -\index{function call} - -\ccl supports three major calling conventions. The convention used -depends on the amount of information available at compile time: -\begin{description} -Local\\Local call is used when the call and the called function are -compiled at the same time. Using the term "convention" to describe this -call mechanism is somewhat of a misnomer, since the compiler can do -whatever it wants. - -Named\\Named call is used when the call is to a global function whose name -is known at compile time. - -Anonymous\\Anonymous call is used when the function called is unknown until -run time. -\end{description} - -\#| -IR2 function call: - -Environment manipulation code is always emitted at the location of the Bind or -Return node for a Lambda. - -Implicit args to functions in IR2: - old-cont: cont to restore on return - return-pc: pc to return to - env: pointer to current closure (if heap) - closure<n>: closed values for current closure (if stack) - -Other info needed for IR2 conversion of functions: - base pointers for all heap closures consed by this function - also have passing locs for each explicit arg - return strategy (known or unknown) and return locs - -All arguments including implicit ones must have both a passing TN and a -permanent TN. Passing locs for let calls can be the actual TN that holds the -variable in the case of local variables. Set closure variables must still have -a separate passing TN. - -If we know the values counts for the argument continuations, then we compile -local mv-calls by moving the TNs for the values continuations into the argument -passing locations. Other mv-calls must be compiled using various hairy -stack-hacking VOPs and unknown argument count call VOPs. - -For now, we will create the callee's frame just before the call, instead of -creating it before the evaluation of the first argument. If we created the -environment early, then we would be able to move the argument values directly -into the frame, instead of having to store them somewhere else for a while. -The problem with early creation is that lifetime analysis gets confused because -there is more than one instance of the same TN present simultaneously in the -case where there are nested calls to the same function. - -It turns out that there isn't a problem with a simple self-call, because the TN -in the called frame is really the "same" TN as the one in the current frame, -due to the restricted way in which we use the passing TNs. - -We emit code for external entry points during IR2 conversion. The external -entry point is the place where we start running in a full call from a -function-entry. It does arg count checking and dispatching, moves the -arguments into the passing locations for the for the lambda being called, and -calls the lambda, moving the results into the standard locations if there -aren't there already. -|\# - - -In IR2, the environment manipulation semantics of function call are decoupled -from the control semantics. When allocating closure variables for a Let, it is -possible to do environment manipulation with only the normal sequential control -flow. In the case of a Let call with the same environment, we neither -manipulate the environment nor transfer control; we merely initialize the -variables with Move VOPs. - -If a local function returns a known number of values which is less than the -number expected by the caller, then additional code must be inserted at the -return site which sets the unused values to NIL. - -The full function call mechanism must effectively be a subset of the local call -mechanism, since the two mechanisms must mesh at entry points and full function -calls. A full call turns into some kind of full call VOP. There are different -VOPs for calling named functions and closures. We also have tail-recursive -full call VOPs. Arguments are set up using Move VOPs, just as for local call. -The only difference is that the passing locations and conventions are -restricted to the standard ones. - -The gory details of arg count checking and dispatching are buried in the -Function-Entry VOP, which takes a functional and a list of continuations, one -pointing to each external entry. - - -\subsection{Local Call} -\index{local call} - -Named and anonymous call are called full calls, to distinguish them from -local call. When making full calls, the compiler must make many worst-case -assumptions that aren't necessary in a local call. The advantage of local -call is that the compiler can choose to use only those parts of the full -call sequence that are actually necessary. - -In local call, we always know the function being called, so we never have -to do argument count checking, and can always use an immediate branch for -the control transfer. If the function doesn't return to more than one -place, then can just use a simple branch, or even drop through. - -The argument passing TNs may be allocated anywhere. The caller allocates the -stack frame for the called function, moving any non-register arguments into the -passing locations in the callee's frame. - -If we are calling a local function that doesn't always return the same -number of values, then we must use the same values returning mechanism that -is used in full call, but we don't have to use the standard registers. - -A tail-recursive local call doesn't require any call VOP. We just use Move -VOPs to put the arguments into the passing locations and then jump to the the -start of the code for the function. We don't have to do any stack hackery -since we use the same stack frame format for all the functions compiled at the -same time. In many cases tail-recursive local calls can be entirely optimized -away, since they involve only some moves and a branch. We preference the -argument values to the passing locations of the called function, making it -likely that no move will be necessary. Often the control transfer can be done -by simply dropping through. - -We have to do some funny stuff with local calls in order to get the lifetimes -for the passing locations right, since lifetime analysis skips directly from -the return point to the call point, ignoring the uses of the passing locations -in the called function. Similarly, we pretend that a block ending in a return -has no successors. - -call-local (arg*) "fun" => value -multiple-call-local (arg*) "fun" => start end val0 ... val<n> - Call-Local is used for calls to local functions that are forced to use the - unknown-values passing convention. Value is the first return value - register; we don't really do anything to it, but we specify it as a result - to represent the assignment done by the calling function. - - Multiple-Call-Local is similar, but specifies all the values used by the - unknown-values convention. Default-Values may be used to receive a - specific number of values. - -known-call-local (arg*) "fun" => value* - This VOP is used for local calls to functions where we can determine at - compile time that the number of values returned is always the same. In - this case, we don't need to indicate the number of values, and can pass - them in separate TNs. The Values are the actual return locations. We - don't really do anything to the return values; we just specify them as - results to represent the assignment done by the called function. - -known-return (return-pc value*) "fun" - This VOP is used for returning from local calls using the known return - values convention. The specified return Values are moved into the passing - locations in the caller's frame. - - -If we know that the function we are calling is non-recursive, then we can -compile it much like a tail-recursive call. We must have a call VOP to compute -the return PC, but we don't need to allocate a frame or save registers. We -just set up the arguments in the frame and do the call. - -We require simple functions to use the known-values convention. It would be -possible to support unknown values, but it would potentially require BLT'ing -return values out of the frame and on to the top of the stack. Supporting -unknown values would also require a bunch more VOPs, since we need different -call and return VOPs for simple call. - -Known values return causes no problems, since the callee knows how many values -are wanted. We store the values directly into the current frame, since it is -also the caller's frame. - -known-call-simple () "fun" => return-pc -known-return-simple (return-pc) "fun" - Similar to the non-simple VOPs, but don't allocate or deallocate frames, - and assume that argument and value passing is done with explicit Move VOPs. - - -\subsection{Full Call} -\index{full call} - -Both named and anonymous call are optimized for calls where the number of -arguments is known at compile time. Unknown argument calls are a -pathological case of anonymous call; this case will be ignored in the main -discussion. The difference between named and anonymous calls is in the -argument count dispatching mechanism. - -Named call allows an arbitrary number of entry points, with start PCs at -arbitrary locations in the code vector. The link-table mechanism described -below allows named calls to jump directly to the actual entry point without any -run-time argument count or type checking checking. - -Anonymous call has a fixed number of entry points, with start PCs at fixed -locations in the code vector. This allows calls to be made without knowing -what function is being called, but has more run-time overhead. The object -called must be checked to be a valid function-entry object. The entry PC must -be computed from the function entry, and argument count checking must be done -if there are more than three required or optional arguments. - -Argument passing in full call is conceptually similar to local call, but the -caller can't allocate the entire frame for the callee, since it doesn't know -how much stack is needed. Instead we allocate the frame in two parts. The -caller only allocates the beginning of the frame, which contains the stack -arguments in fixed locations. We leave the first <n> locations unused so that -the called function can move register more args onto the stack without having -to BLT down any stack arguments. - -The place in the code where a full call jumps in is called an external entry -point. The external entry point allocates the rest of the stack frame and then -does a local call to the actual entry-point function, fetching the arguments -from the standard passing locations. Usually we can do a tail-recursive local -call. - -There are two main cases where the call from the external entry point cannot be -tail-recursive: - -- It is desirable to use the known-values convention for calling the - entry-point function if the entry-point is used in other local calls - (perhaps because of recursion). In this case, the called function stores - the return values back into the frame allocated by the external entry point - and then returns back to it. The external entry point must then return - these values using the standard unknown-values convention. - -- In a more-arg entry point we don't know how many stack arguments there are - at the beginning of the frame, so we can't really use the frame allocated - by the external entry point at all. Instead we do a local call to the - more-arg entry point, passing in a pointer to the first extra value. When - the function returns, we deallocate the crap on the stack and then return - the values. It is still o.k. to use the known-values return convention - from the more-arg entry since the extra arg values are no longer needed by - the time the returning function stores the return values back into the - external entry point frame. - - -In full call we must always use the unknown-values convention for return. The -first <n> values are passed in the standard argument registers. The Old-Cont -register holds the Start of the values block and SP points to the End. - - -{small, fast} call (function arg0 ... arg<n>) "nargs" => value -{small, fast} call-named (arg0 ... arg<n>) "nargs" "name" => value - Call-Closure calls Function with the specified register arguments, - returning the first value as the result. "nargs" is the total number of - arguments passed. Only the register arguments actually passed should be - specified as operands. - - Call-Named is similar, but calls a global function specified at compile - time by "name". - -{small, fast} tail-call (function pc arg0 ... arg<n>) "nargs" -{small, fast} tail-call-named (pc arg0 ... arg<n>) "nargs" "name" - Similar to the standard call VOPs, but passes PC as the return PC, rather - than returning to the call site. These VOPs have no results since they - don't return. - -{small, fast} multiple-call (function arg0 ... arg<n>) "nargs" - => start end val0 ... val<n> -{small, fast} multiple-call-named (arg0 ... arg<n>) "nargs" "name" - => start end val0 ... val<n> - These VOPs are similar to the standard call VOPs, but allow any number of - values to be received by returning all the value passing registers as - results. A specific number of values may be received by using - Default-Values. - -call-unknown (function count arg0 ... arg<n>) => start end val0 ... val<n> -tail-call-unknown (function pc count arg0 ... arg<n>) - Call a function with an unknown number of arguments. Used for apply and - hairy multiple-value-call. - -Function-Entry () "function" => env return-pc old-cont arg* - This marks the place where we jump into a component for an external - entry point. It represents whatever magic is necessary to do argument - count checking and dispatching. The external entry points for each - argument count will be successors of the entry-vector block (might be in - the same block if only one?) - - Function-Entry also represents argument passing by specifying the actual - external passing locations as results, thus marking the beginning of their - lifetimes. All passing locations actually used by any entry point are - specified as Args, including stack arguments. - {\#\#\# Do we really need this? If we do, then we probably also need similar - entry markers for local functions. The lifetimes don't really need to be - explicitly bounded, since an entry point is effectively "the end of the - world."} - - -\section(Returning from a Function Call) -\label(Return) -\index(Return) - - -return (return-pc value) -multiple-return (return-pc start end val0 ... val<n>) - Return Value from the current function, jumping back to the location - specified by Return-PC. {Perhaps allow to return any fixed, known number - of values.} - - Multiple-Return is similar, but allows an arbitrary number of values to be - returned. End - Start is the total number of values returned. Start - points to the beginning of the block of return values, but the first <n> - values val0 ... val<n> are actually returned in registers. - -default-values (start end val0 ... val<n>) => val0 ... val<j> - This VOP is used when we want to receive exactly J values. If fewer than J - values were supplied, then missing values are defaulted to NIL. As a - side-effect, this VOP pops off any returned stack values. - - -\section{Saving and Restoring Registers} - -We use a caller-saves convention. The caller explicitly emits saving and -restoring code. Tail-recursive calls don't need -any register saving since we never come back. - - - -\chapter{Non-local exits} - - -\subsection{Unwind Blocks} -\index{Catch} -\index{Catch frames} - -There is one aspect of the control stack format that is fixed, and which -concerns us at this level. This is the format of the "frames" which mark the -destination of non-local exits, such as for BLOCK and CATCH. These frames are -collectively known as unwind blocks. The basic unwind block is used for -lexical exists such as BLOCK, and for UNWIND-PROTECT. Its format is the -following: -\begin{verbatim} -0 Pointer to current unwind-protect. -1 Control stack context to restore on entry. -2 PC to enter at. -\end{verbatim} - -The unwind block for CATCH is identical except for additional cells -containing the catch tag and previous catch. -\begin{verbatim} -0 Pointer to current unwind-protect. -1 Control stack context to restore on entry. -2 PC to enter at. -3 Catch tag. -4 Previous catch. -\end{verbatim} - -The conventions used to manipulate unwind blocks are described in chapter -\ref{Control-Conventions}. - - - -\section{Non-Local Exits} -\label{Catch} -\index{Catch} -\index{Throw} -\index{Unwinding} -\index{Unwind-Protect} -\index{Non-Local Exits} - -In the normal flow of control, each function that is called executes until it -reaches a return point; under these conditions no special effort is needed to -restore the environment as long as each function undoes any change that it -makes to the dynamic state before it returns. When we make a non-local -transfer, we skip a potentially arbitrary collection of these cleanup actions. -Since we cannot in general know what changes have been made to the dynamic -environment below us on the stack, we must restore a snapshot of the dynamic -environment at the re-entry point. - -We represent the closed continuation by the pointer to the unwind-block for the -reentry point. At the exit point, we just pass this stack pointer to the -Unwind VOP, which deals with processing any unwind-protects. When Unwind is -done, it grabs the re-entry PC out of the location at the stack pointer and -jumps in. - -Catch and Unwind-Protect work in pretty much the same way. We make a stack TN -to hold the catch frame or whatever, allocate TNs in them to represent the -slots, and then initialize them. The frame can be explicitly linked in by TN -manipulations, since the active catch and whatnot are represented by TNs. -Since allocation of the frame is decoupled from linking and unlinking, some of -this stuff could be moved out of loops. We will need a VOP for loading the PC -for an arbitrary continuation so that we can set up the reentry PC. This can -be done using the Call VOP. Using a call instruction is probably a good way to -get a PC on most architectures anyway. - -These TNs are allocated by Pack like any others; we use special alloc and -dealloc VOPs to delimit the aggregate lifetimes. - -In the non-local case, the the Block, Catch and Unwind-Protect special forms -are implemented using unwind blocks. The unwind blocks are built by move -operations emitted inline by the compiler. The compiler adds and removes -catches and unwind protects by explicit moves to the locations that hold the -current catch and unwind protect blocks. The entry PC is loaded using the Call -VOP. - -The Unwind miscop is the basis non-local exits. It takes the address of an -unwind block and processes unwind-protects until the current unwind-protect is -the one recorded in the unwind block, then jumps in at the entry in the unwind -block. The entry for the unwind block is responsible for restoring any state -other than the current unwind-protect. - -Unwind is used directly to implement non-local Return-From. The address of the -unwind block is stored in a closure variable. - -Catch just does a scan up the chain of Catch blocks, starting at the current -catch. When it finds the right one, it calls unwind on it. - -Unwind-protects are represented by unwind blocks linked into the current -unwind-protect chain. The cleanup code is entered just like any other any -other unwind entry. As before, the entry is responsible for establishing the -correct dynamic environment for the cleanup code. The target unwind block is -passed in some non-argument register. When the cleanup code is done, it -just calls Unwind with the block passed in. The cleanup code must be careful -not to trash the argument registers or CS, since there may be multiple values -lurking out there. - -With Catch/Throw, we always use the variable values return value passing convention, -since we don't know how many values the catch wants. With Block/Return-From, -we can do whatever we want, since the returner and receiver know each other. - -If a Block or Catch receives stack values, it must call a VOP that BLT's the -values down the stack, squeezing out any intermediate crud. - - -unwind (context) -throw (tag) - Unwind does a non-local exit, unwinding to the place indicated by Context. - Context is a pointer to a block of storage allocated on the control stack, - containing the entry PC, current environment and current unwind-protect. - We scan up the stack, processing unwind-protects until we reach the entry - point. The values being returned are passed in the standard locations. - Throw is similar, but does a dynamic lookup for the Tag to determine what - context to unwind to. - diff --git a/docs/rtguts.mss b/docs/rtguts.mss deleted file mode 100644 index 38f08e396776e027dbba559dcaa59d9555ff95ad..0000000000000000000000000000000000000000 --- a/docs/rtguts.mss +++ /dev/null @@ -1,4150 +0,0 @@ -@make [Manual] -@device [PostScript] -@use (database "/usr/lisp/scribe/database/") -@libraryfile [Mathematics10] -@libraryfile [ArpaCredit] -@libraryfile [table] -@libraryfile [spice] -@style(FontFamily=TimesRoman) -@style(Date="March 1952") - -@commandstring(pusharrow = "@jsym<L>") -@define(f, facecode f) - -@commandstring(InstrSection = "@tabclear@tabset[.5 in, 3.0 in]") -@form(Instr = "@*@\@Parm[name]@\") -@form(BInstr ="@*@\@Parm[name]@+[*]@\") -@string(DinkyMachine = "IBM RT PC") -@begin[TitlePage] -@begin[TitleBox] -@blankspace(0.25in) -@heading[Internal Design of CMU Common Lisp -on the IBM RT PC] -@begin[Center] -@b{David B. McDonald -Scott E. Fahlman -Skef Wholey - -@value[Date] - -CMU-CS-87-157 -} -@end[Center] -@end[TitleBox] -@center[@b<Abstract>] -@begin[Text] -CMU Common Lisp is an implementation of Common Lisp that currently runs on -the IBM RT PC under Mach, a Berkeley Unix 4.3 binary compatible operating -system. This document describes low level -details of the implementation. In particular, it describes the data -formats used for all Lisp objects, the assembler language routines -(miscops) used to support compiled code, the function call and return -mechanism, and other design information necessary to understand the -underlying structure of the CMU Common Lisp implementation on the IBM RT PC -under the Mach operating system. -@end[Text] - -@begin[ResearchCredit] -@ArpaCredit[Contract=Strategic87-90] -@end[ResearchCredit] -@end[TitlePage] - -@heading [Acknowledgments] - -This document is based heavily on the document @i[Revised Internal Design -of Spice Lisp] by Skef Wholey, Scott Fahlman, and Joseph Ginder. - -The FASL file format was designed by Guy L. Steele Jr. and Walter van -Roggen, and the appendix on this subject is their document with very few -modifications. - -@chapter [Introduction] - -@section [Scope and Purpose] - -This document describes a new implementation of CMU Common Lisp (nee Spice -Lisp) as it is implemented on the @value(DinkyMachine) running Mach, a -Berkeley Unix 4.3 binary compatible operating system. This design is -undergoing rapid change, and for the present is not guaranteed to -accurately describe any past, present, or future implementation of CMU -Common Lisp. All questions and comments on this material should be -directed to David B. McDonald (David.McDonald@@CS.CMU.EDU). - -This document specifies the hand-coded assembler routines (miscops) and -virtual memory architecture of the @value(DinkyMachine) CMU Common Lisp system. -This is a working document, and it will change frequently as the system is -developed and maintained. If some detail of the system does not agree with -what is specified here, it is to be considered a bug. - -@section [Notational Conventions] -@index [Bit numbering] -@index [Byte numbering] -CMU Common Lisp objects are 32 bits long. The high-order bit of each word is -numbered 0; the low-order bit is numbered 31. If a word is broken into smaller -units, these are packed into the word from left to right. For example, if we -break a word into bytes, byte 0 would occupy bits 0-7, byte 1 would occupy -8-15, byte 2 would occupy 16-23, and byte 3 would occupy 24-31. - -All CMU Common Lisp documentation uses decimal as the default radix; other -radices will be indicated by a subscript (as in 77@-[8]) or by a clear -statement of what radix is in use. - -@chapter [Data Types and Object Formats] - -@section [Lisp Objects] -@index [Lisp objects] - -Lisp objects are 32 bits long. They come in 32 basic types, divided into three -classes: immediate data types, pointer types, and forwarding pointer types. -The storage formats are as follows: - -@index [Immediate object format] -@index [Pointer object format] -@begin [verbatim, group] - -@b[Immediate Data Types:] - 0 4 5 31 ------------------------------------------------------------------------- -| Type Code (5) | Immediate Data (27) | ------------------------------------------------------------------------- - -@b[Pointer and Forwarding Types:] - 0 4 5 6 7 29 31 ------------------------------------------------------------------------- -| Type Code (5) | Space Code (2) | Pointer (23) | Unused (2) | ------------------------------------------------------------------------- -@end [verbatim] - -@section [Table of Type Codes] -@index [Type codes] - -@begin [verbatim, group] - -Code Type Class Explanation ----- ---- ----- ----------- -0 + Fixnum Immediate Positive fixnum, miscop code, etc. -1 GC-Forward Pointer GC forward pointer, used during GC. -4 Bignum Pointer Bignum. -5 Ratio Pointer Two words: numerator, denominator. -6 + Short Float Immediate Positive short flonum. -7 - Short Float Immediate Negative short flonum. -8 Single Float Pointer Single precision float. -9 Double Float Pointer Double precision float (?). -9 Long Float Pointer Long float. -10 Complex Pointer Two words: real, imaginary parts. -11 String Pointer Character string. -12 Bit-Vector Pointer Vector of bits -13 Integer-Vector Pointer Vector of integers -14 General-Vector Pointer Vector of Lisp objects. -15 Array Pointer Array header. -16 Function Pointer Compiled function header. -17 Symbol Pointer Symbol. -18 List Pointer Cons cell. -20 C. S. Pointer Pointer Pointer into control stack. -21 B. S. Pointer Pointer Pointer into binding stack. -26 Interruptible Immediate Marks a miscop as interruptible. -27 Character Immediate Character object. -28 Values-Marker Immediate Multiple values marker. -29 Catch-All Immediate Catch-All object. -30 Trap Immediate Illegal object trap. -31 - Fixnum Immediate Negative fixnum. -@end [verbatim] - -@section [Table of Space Codes] -@index [Space codes] - -@begin [verbatim, group] - -Code Space Explanation ----- ----- ----------- -0 Dynamic-0 Storage normally garbage collected, space 0. -1 Dynamic-1 Storage normally garbage collected, space 1. -2 Static Permanent objects, never moved or reclaimed. -3 Read-Only Objects never moved, reclaimed, or altered. -@end [verbatim] - -@section [Immediate Data Type Descriptions] - -@begin [description] - -@index [Fixnum format] -Fixnum@\A 28-bit two's complement integer. The sign bit is stored redundantly -in the top 5 bits of the word. - -@index [Short float format] -Short-Float@\The sign bit is stored as part of the type code, -allowing a 28 bit signed short float format. The format of short floating -point numbers is: -@begin [verbatim] - 0 3 4 5 12 13 31 ---------------------------------------------------------------- -| Type code (4) | Sign (1) | Exponent (8) | Mantissa (19) | ---------------------------------------------------------------- -@end [verbatim] -The floating point number is the same format as the @value(DinkyMachine) -supports for single precision numbers, except it has been shifted right -by four bits for the type code. The result of any operation is therefore -truncated. Long floating point numbers are also available if you need -more accuracy and better error propagation properties. - -@index [Character object] -Character@\A character object holding a character code, control bits, and font -in the following format: -@begin [verbatim, group] - 0 4 6 7 8 15 16 23 24 31 ---------------------------------------------------------------- -| Type code (5) | Unused (3) | Font (8) | Bits (8) | Code (8) | ---------------------------------------------------------------- -@end [verbatim] - -@index [Values-Marker] -Values-Marker@\Used to mark the presence of multiple values on the stack. The -low 16 bits indicate how many values are being returned. Note that only 65535 -values can be returned from a multiple-values producing form. These are pushed -onto the stack in order, and the Values-Marker is returned in register A0. - -@index [Catch-All object] -Catch-All@\Object used as the catch tag for unwind-protects. Special things -happen when a catch frame with this as its tag is encountered during a throw. -See section @ref[Catch] for details. - -@index[Trap] -@index[Illegal object trap] -Trap@\Illegal object trap. This value is used in symbols to signify an -undefined value or definition. - -@index[Interruptible Marker] -Interruptible-Marker@\Object used to mark a miscop as interruptible. This -object is put in one of the registers and signals to the interrupt handler -that the miscop can be interrupted safely. Only miscops that can take a long -time (e.g., length when passed a circular list, system call miscops that -may wait indefinitely) are marked this way. -@end [description] - -@section [Pointer-Type Objects and Spaces] -@index [Pointer object format] -@index [Virtual memory] - -Each of the pointer-type lisp objects points into a different space in virtual -memory. There are separate spaces for Bit-Vectors, Symbols, Lists, and so on. -The 5-bit type-code provides the high-order virtual address bits for the -object, followed by the 2-bit space code, followed by the 25-bit pointer -address. This gives a 30-bit virtual address to a 32-bit word; since the -@value(DinkyMachine) is a byte-addressed machine, the two low-order -bits are 0. In effect we have carved a 30-bit space into a fixed set -of 23-bit subspaces, not all of which are used. - -@index [Space codes] -The space code divides each of the type spaces into four sub-spaces, -as shown in the table above. At any given time, one of the dynamic -spaces is considered newspace, while the other is oldspace. -During a stop and copy garbage collection, a ``flip'' can be done, turning the -old newspace into the new oldspace. All type-spaces are flipped at once. -Allocation of new dynamic objects always occurs in newspace. - -@index [Static space] -@index [Read-only space] -Optionally, the user (or system functions) may allocate objects in -static or read-only space. Such objects are never reclaimed once they -are allocated -- they occupy the space in which they were initially -allocated for the lifetime of the Lisp process. The advantage of -static allocation is that the GC never has to move these objects, -thereby saving a significant amount of work, especially if the objects -are large. Objects in read-only space are static, in that they are -never moved or reclaimed; in addition, they cannot be altered once -they are set up. Pointers in read-only space may only point to -read-only or static space, never to dynamic space. This saves even -more work, since read-only space does not need to be scavenged, and -pages of read-only material do not need to be written back onto the -disk during paging. - -Objects in a particular type-space will contain either pointers to -garbage-collectible objects or words of raw non-garbage-collectible bits, but -not both. Similarly, a space will contain either fixed-length objects or -variable-length objects, but not both. A variable-length object always -contains a 24-bit length field right-justified in the first word, with -the positive fixnum type-code in the high-order five bits. The remaining three -bits can be used for sub-type information. The length field gives the -size of the object in 32-bit words, including the header word. The -garbage collector needs this information when the object is moved, and -it is also useful for bounds checking. - -The format of objects in each space are as follows: - -@begin [description] -@index [Symbol] -@index [Value cell] -@index [Definition cell] -@index [Property list cell] -@index [Plist cell] -@index [Print name cell] -@index [Pname cell] -@index [Package cell] -Symbol@\Each symbol is represented as a -fixed-length block of boxed Lisp cells. The number of cells -per symbol is 5, in the following order: -@begin [verbatim, group] -0 Value cell for shallow binding. -1 Definition cell: a function or list. -2 Property list: a list of attribute-value pairs. -3 Print name: a string. -4 Package: the obarray holding this symbol. -@end [verbatim] - -@index [List cell] -List@\A fixed-length block of two boxed Lisp cells, the CAR and the CDR. - -@index [General-Vector format] -@index [G-Vector format] -@index [Vector format] -General-Vector@\Vector of lisp objects, any length. The first word is a fixnum -giving the number of words allocated for the vector (up to 24 bits). The -highest legal index is this number minus 2. The second word is vector entry 0, -and additional entries are allocated contiguously in virtual memory. General -vectors are sometimes called G-Vectors. (See section @ref[Vectors] for further -details.) - -@index [Integer-Vector format] -@index [I-Vector format] -@index [Vector format] -Integer-Vector@\Vector of integers, any length. The 24 low bits of the first -word give the allocated length in 32-bit words. The low-order 28 bits of the -second word gives the length of the vector in entries, whatever the length of -the individual entries may be. The high-order 4 bits of the second word -contain access-type information that yields, among other things, the number of -bits per entry. Entry 0 is left-justified in the third word of the vector. -Bits per entry will normally be powers of 2, so they will fit neatly into -32-bit words, but if necessary some empty space may be left at the low-order -end of each word. Integer vectors are sometimes called I-Vectors. (See -section @ref[Vectors] for details.) - -@index [Bit-Vector format] -@index [Vector format] -Bit-Vector@\Vector of bits, any length. Bit-Vectors are represented in a form -identical to I-Vectors, but live in a different space for efficiency reasons. - -@index [Bignum format] -@label [Bignums] -Bignum@\Bignums are infinite-precision integers, represented in a format -identical to G-Vectors. Each bignum is stored as a series of 32-bit words, -with the low-order word stored first. The representation is two's complement, -but the sign of the number is redundantly encoded in the type field of the -fixnum in the header word. If this fixnum is non-negative, then so is the -bignum, if it is negative, so is the bignum. - -@index [Flonum format] -@index [Flonum formats] -@index [Floating point formats] -Floats@\Floats are stored as two or more consecutive words of bits, in the -following format: -@begin [verbatim, group] ---------------------------------------------------------------- -| Header word, used only for GC forward pointers. | ---------------------------------------------------------------- -| Appropriate number of 32-bit words in machine format | ---------------------------------------------------------------- -@end [verbatim] -The number of words used to represent a floating point number is one plus the -size of the floating point number being stored. The floating point numbers -will be represented in whatever format the @value(DinkyMachine) expects. The -extra header word is needed so that a valid floating point number is not -mistaken for a gc-forward pointer during a garbage collection. - -@index [Ratio format] -Ratio@\Ratios are stored as two consecutive words of Lisp objects, which should -both be integers. - -@index [Complex number format] -Complex@\Complex numbers are stored as two consecutive words of Lisp objects, -which should both be numbers. - -@index [Array format] -Array@\This is actually a header which holds the accessing and -other information about the array. The actual array contents are held in a -vector (either an I-Vector or G-Vector) pointed to by an entry in -the header. The header is identical in format to a G-Vector. For -details on what the array header contains, see section @ref[Arrays]. - -@index [String format] -String@\A vector of bytes. Identical in form to I-Vectors with the access type -always 8-Bit. However, instead of accepting and returning fixnums, string -accesses accept and return character objects. Only the 8-bit code field is -actually stored, and the returned character object always has bit and font -values of 0. - -@index [Function object format] -Function @\A compiled CMU Common Lisp function consists of both lisp -objects and raw bits for the code. The Lisp objects are stored in -the Function space in a format identical to that used for general -vectors, with a 24-bit length field in the first word. This object -contains assorted parameters needed by the calling machinery, a -pointer to an 8-bit I-Vector containing the compiled code, a number -of pointers to symbols used as special variables within the function, -and a number of lisp objects used as constants by the function. -@end [description] - -@section [Forwarding Pointers] -@index [Forwarding pointers] - -@begin [description] -@index [GC-Forward pointer] -GC-Forward@\When a data structure is transported into newspace, a GC-Forward -pointer is left behind in the first word of the oldspace object. This points -to the same type-space in which it is found. For example, a GC-Forward in -G-Vector space points to a structure in the G-Vector newspace. GC-Forward -pointers are only found in oldspace. -@end [description] - -@section [System and Stack Spaces] -@index [System table space] -@index [Stack spaces] -@index [Control stack space] -@index [Binding stack space] -@index [Special binding stack space] - -The virtual addresses below 08000000@-[16] are not occupied by Lisp objects, -since Lisp objects with type code 0 are positive fixnums. Some of this space -is used for other purposes by Lisp. A couple of pages (4096 byte pages) -at address 00100000@-[16] contain tables that Lisp needs to access -frequently. These include the allocation table, the active-catch-frame, -information to link to C routines, etc. Memory at location 00200000@-[16] -contains code for various miscops. Also, any C code loaded into a running -Lisp process is loaded after the miscops. The format of the allocation -table is described in chapter @ref[Alloc-Chapter]. - -The control stack grows upward (toward higher addresses) in memory, -and is a framed stack. It contains only general Lisp objects (with -some random things encoded as fixnums). Every object -pointed to by an entry on this stack is kept alive. The frame for a -function call contains an area for the function's arguments, an area -for local variables, a pointer to the caller's frame, and a pointer -into the binding stack. The frame for a Catch form contains similar -information. The precise stack format can be found in chapter -@ref[Runtime]. - -The special binding stack grows downward. This stack is used to hold -previous values of special variables that have been bound. It grows and -shrinks with the depth of the binding environment, as reflected in the -control stack. This stack contains symbol-value pairs, with only boxed -Lisp objects present. - -All Lisp objects are allocated on word boundaries, since the -@value(DinkyMachine) can only access words on word boundaries. - -@section [Vectors and Arrays] -@label [Vectors] -@index [Vectors] - -Common Lisp arrays can be represented in a few different ways in CMU Common -Lisp -- different representations have different performance advantages. -Simple general vectors, simple vectors of integers, and simple strings are -basic CMU Common Lisp data types, and access to these structures is quicker -than access to non-simple (or ``complex'') arrays. However, all -multi-dimensional arrays in CMU Common Lisp are complex arrays, so -references to these are always through a header structure. - -@subsection [General Vectors] -@index [General-Vector format] - -G-Vectors contain Lisp objects. The format is as follows: - -@begin [verbatim, group] ------------------------------------------------------------------- -| Fixnum code (5) | Subtype (3) | Allocated length (24) | ------------------------------------------------------------------- -| Vector entry 0 (Additional entries in subsequent words) | ------------------------------------------------------------------- -@end [verbatim] - -The first word of the vector is -a header indicating its length; the remaining words hold the boxed entries of -the vector, one entry per 32-bit word. The header word is of type fixnum. It -contains a 3-bit subtype field, which is used to indicate several special types -of general vectors. At present, the following subtype codes are defined: - -@index [DEFSTRUCT] -@index [Hash tables] -@begin [itemize, spread 0, spacing 1] -0 Normal. Used for assorted things. - -1 Named structure created by DEFSTRUCT, with type name in entry 0. - -2 EQ Hash Table, last rehashed in dynamic-0 space. - -3 EQ Hash Table, last rehashed in dynamic-1 space. - -4 EQ Hash Table, must be rehashed. -@end [itemize] - -Following the subtype is a 24-bit field indicating how many 32-bit words are -allocated for this vector, including the header word. Legal indices into the -vector range from zero to the number in the allocated length field minus 2, -inclusive. Normally, the index is checked on every access to the vector. -Entry 0 is stored in the second word of the vector, and subsequent entries -follow contiguously in virtual memory. - -Once a vector has been allocated, it is possible to reduce its length by using -the Shrink-Vector miscop, but never to increase its length, even back to -the original size, since the space freed by the reduction may have been -reclaimed. This reduction simply stores a new smaller value in the length -field of the header word. - -It is not an error to create a vector of length 0, though it will always be an -out-of-bounds error to access such an object. The maximum possible length for -a general vector is 2@+[24]-2 entries, and that can't fit in the available -space. The maximum length is 2@+[23]-2 entries, and that is only possible if -no other general vectors are present in the space. - -@index [Bignum Format] -Bignums are identical in format to G-Vectors although each entry is a 32-bit -integer, and thus only assembler routines should ever access an entry. - -@index [Function object format] -@index [Array format] -Objects of type Function and Array are identical in format to -general vectors, though they have their own spaces. - -@subsection [Integer Vectors] -@index [Integer-Vector format] - -I-Vectors contain unboxed items of data, and their format is more complex. The -data items come in a variety of lengths, but are of constant length within a -given vector. Data going to and from an I-Vector are passed as Fixnums, right -justified. Internally these integers are stored in packed form, filling 32-bit -words without any type-codes or other overhead. The format is as follows: - -@begin [verbatim, group] ----------------------------------------------------------------- -| Fixnum code (5) | Subtype (3) | Allocated length (24) | ----------------------------------------------------------------- -| Access type (4) | Number of entries (28) | ----------------------------------------------------------------- -| Entry 0 left justified | ----------------------------------------------------------------- -@end [verbatim] - -The first word of an I-Vector -contains the Fixnum type-code in the top 5 bits, a 3-bit subtype code in the -next three bits, and the total allocated length of the vector (in 32-bit words) -in the low-order 24 bits. At present, the following subtype codes are defined: -@begin [itemize, spread 0, spacing 1] -0 Normal. Used for assorted things. - -1 Code. This is the code-vector for a function object. -@end [itemize] - -The second word of the vector is the one that is looked at every -time the vector is accessed. The low-order 28 bits of this word -contain the number of valid entries in the vector, regardless of how -long each entry is. The lowest legal index into the vector is always -0; the highest legal index is one less than this number-of-entries -field from the second word. These bounds are checked on every access. -Once a vector is allocated, it can be reduced in size but not increased. -The Shrink-Vector miscop changes both the allocated length field -and the number-of-entries field of an integer vector. - -@index [Access-type codes] -The high-order 4 bits of the second word contain an access-type code -which indicates how many bits are occupied by each item (and therefore -how many items are packed into a 32-bit word). The encoding is as follows: -@begin [verbatim, group] -0 1-Bit 8 Unused -1 2-Bit 9 Unused -2 4-Bit 10 Unused -3 8-Bit 11 Unused -4 16-Bit 12 Unused -5 32-Bit 13 Unused -6 Unused 14 Unused -7 Unused 15 Unused -@end [verbatim] - -In I-Vectors, the data items are packed into the third and subsequent -words of the vector. Item 0 is left justified in the third word, -item 1 is to its right, and so on until the allocated number of items -has been accommodated. All of the currently-defined access types -happen to pack neatly into 32-bit words, but if this should not be -the case, some unused bits would remain at the right side of each -word. No attempt will be made to split items between words to use up -these odd bits. When allocated, an I-Vector is initialized to all -0's. - -As with G-Vectors, it is not an error to create an I-Vector of length -0, but it will always be an error to access such a vector. The -maximum possible length of an I-Vector is 2@+[28]-1 entries or -2@+[23]-3 words, whichever is smaller. - -@index [String format] -Objects of type String are identical in format to I-Vectors, though they have -their own space. Strings always have subtype 0 and access-type 3 (8-Bit). -Strings differ from normal I-Vectors in that the accessing miscops accept -and return objects of type Character rather than Fixnum. - -@subsection [Arrays] -@label [Arrays] -@index [Arrays] - -An array header is identical in form to a G-Vector. Like any G-Vector, its -first word contains a fixnum type-code, a 3-bit subtype code, and a 24-bit -total length field (this is the length of the array header, not of the vector -that holds the data). At present, the subtype code is always 0. The entries -in the header-vector are interpreted as follows: - -@index [Array header format] -@begin [description] -0 Data Vector @\This is a pointer to the I-Vector, G-Vector, or string that -contains the actual data of the array. In a multi-dimensional array, the -supplied indices are converted into a single 1-D index which is used to access -the data vector in the usual way. - -1 Number of Elements @\This is a fixnum indicating the number of elements for -which there is space in the data vector. - -2 Fill Pointer @\This is a fixnum indicating how many elements of the data -vector are actually considered to be in use. Normally this is initialized to -the same value as the Number of Elements field, but in some array applications -it will be given a smaller value. Any access beyond the fill pointer is -illegal. - -3 Displacement @\This fixnum value is added to the final code-vector index -after the index arithmetic is done but before the access occurs. Used for -mapping a portion of one array into another. For most arrays, this is 0. - -4 Range of First Index @\This is the number of index values along the first -dimension, or one greater than the largest legal value of this index (since the -arrays are always zero-based). A fixnum in the range 0 to 2@+[24]-1. If any -of the indices has a range of 0, the array is legal but will contain no data -and accesses to it will always be out of range. In a 0-dimension array, this -entry will not be present. - -5 - N Ranges of Subsequent Dimensions -@end [description] - -The number of dimensions of an array can be determined by looking at the length -of the array header. The rank will be this number minus 6. The maximum array -rank is 65535 - 6, or 65529. - -The ranges of all indices are checked on every access, during the conversion to -a single data-vector index. In this conversion, each index is added to the -accumulating total, then the total is multiplied by the range of the following -dimension, the next index is added in, and so on. In other words, if the data -vector is scanned linearly, the last array index is the one that varies most -rapidly, then the index before it, and so on. - -@section [Symbols Known to the Assembler Routines] -@label [Known-Objects] - -A large number of symbols will be pre-defined when a CMU Common Lisp system -is fired up. A few of these are so fundamental to the operation of the -system that their addresses have to be known to the assembler routines. -These symbols are listed here. All of these symbols are in static space, -so they will not move around. - -@begin [description] -@index [NIL] -NIL @\94000000@-[16] The value of NIL is always NIL; it is an error -to alter it. The plist of NIL is always NIL; it is an error to alter -it. NIL is unique among symbols in that it is stored in Cons cell -space and thus you can take its CAR and CDR, yielding NIL in either -case. NIL has been placed in Cons cell space so that the more common -operations on lists will yield the desired results. This slows down -some symbol operations but this should be insignificant compared to -the savings in list operations. A test for NIL for the -@value(DinkyMachine) is: -@begin(Example) - xiu R0,P,X'9400' - bz IsNIL or bnz IsNotNIL -@end(Example) - -@index [T] -T @\8C000000@-[16] The value of T is always T; it is an error -to alter it. A similar sequence of code as for NIL above can test for T, -if necessary. - -@index [%SP-Internal-Apply] -%SP-Internal-Apply @\8C000014@-[16] The function stored in the definition cell -of this symbol is called by an assembler routine whenever compiled code calls -an interpreted function. - -@index [%SP-Internal-Error] -%SP-Internal-Error @\8C000028@-[16] The function stored in the definition cell -of this symbol is called whenever an error is detected during the execution of -an assembler routine. See section @ref[Errors] for details. - -@index [%SP-Software-Interrupt-Handler] -%SP-Software-Interrupt-Handler @\8C00003C@-[16] The function stored in the -definition cell of this symbol is called whenever a software interrupt occurs. -See section @ref[Interrupts] for details. - -@index [%SP-Internal-Throw-Tag] -%SP-Internal-Throw-Tag @\8C000050@-[16] This symbol is bound to the tag being -thrown when a Catch-All frame is encountered on the stack. See section -@ref[Catch] for details. - -@index [%Initial-function] -%Initial-function@\8c000064@-[16] This symbol's function cell should contain -a function that is called when the initial core image is started. This -function should initialize all the data structures that Lisp needs to run. - -@index [%Link-table-header] -%Link-table-header@\8c000078@-[16] This symbol's value cell contains a pointer -to the link table information. - -@index [Current-allocation-space] -Current-allocation-space@\8c00008c@-[16] This symbol's value cell contains -an encoded form of the current space that new lisp objects are to be allocated -in. - -@index [%SP-bignum/fixnum] -%SP-bignum/fixnum@\8c0000a0@-[16] This function is invoked by the miscops -when a division of a bignum by a fixnum results in a ratio. - -@index [%SP-fixnum/bignum] -%SP-bignum/bignum@\8c0000b4@-[16] This -function is invoked by the miscops when a division of a fixnum by a -bignum results in a ratio. - -@index [%SP-bignum/bignum] -%SP-bignum/bignum@\8c0000c8@-[16] This function is invoked by the miscops -when a division of a bignum by a bignum results in a ratio. - -@index [%SP-abs-ratio] -%SP-abs-ratio@\8c0000dc@-[16] This function is invoked by the miscops -when the absolute value of a ratio is taken. - -@index [%SP-abs-complex] -%SP-abs-complex@\8c0000f0@-[16] This function is invoked by the miscops -when the absolute value of a complex is taken. - -@index [%SP-negate-ratio] -%SP-negate-ratio@\8c000104@-[16] This function is invoked by the miscops -when a ratio is to be negated. - -@index [%SP-negate-complex] -%SP-negate-ratio@\8c000118@-[16] This function is invoked by the miscops -when a complex is to be negated. - -@index[%SP-integer+ratio] -%SP-integer+ratio@\8c00012c@-[16] This function is invoked by the miscops -when a fixnum or bignum is added to a ratio. - -@index[%SP-ratio+ratio] -%SP-ratio+ratio@\8c000140@-[16] This function is invoked by the miscops -when a ratio is added to a ratio. - -@index[%SP-complex+number] -%SP-complex+number@\8c000154@-[16] This function is invoked by the miscops -when a complex is added to a number. - -@index[%SP-number+complex] -%SP-number+complex@\8c000168@-[16] This function is invoked by the miscops -when a number is added to a complex. - -@index[%SP-complex+complex] -%SP-complex+complex@\8c00017c@-[16] This function is invoked by the miscops -when a number is added to a complex. - -@index[%SP-1+ratio] -%SP-1+ratio@\8c000190@-[16] This function is invoked by the miscops when -1 is added to a ratio. - -@index[%SP-1+complex] -%SP-1+complex@\8c000190@-[16] This function is invoked by the miscops when -1 is added to a complex. - -@index[%SP-ratio-integer] -%SP-ratio-integer@\8c0001b8@-[16] This function is invoked by the miscops -when an integer is subtracted from a ratio. - -@index[%SP-ratio-ratio] -%SP-ratio-ratio@\8c0001cc@-[16] This function is invoked by the miscops -when an ratio is subtracted from a ratio. - -@index[%SP-complex-number] -%SP-complex-number@\8c0001e0@-[16] This function is invoked by the miscops -when a complex is subtracted from a number. - -@index[%SP-number-complex] -%SP-number-complex@\8c0001f4@-[16] This function is invoked by the miscops -when a number is subtracted from a complex. - -@index[%SP-complex-complex] -%SP-complex-complex@\8c000208@-[16] This function is invoked by the miscops -when a complex is subtracted from a complex. - -@index[%SP-1-complex] -%SP-1-complex@\8c000230@-[16] This function is invoked by the miscops when -1 is subtracted from a complex. - -@index[%SP-ratio*ratio] -%SP-ratio*ratio@\8c000244@-[16] This function is invoked by the miscops to -multiply two ratios. - -@index[%SP-number*complex] -%SP-number*complex@\8c000258@-[16] This function is invoked by the miscops to -multiply a number by a complex. - -@index[%SP-complex*number] -%SP-complex*number@\8c00026c@-[16] This function is invoked by the miscops to -multiply a complex by a number. - -@index[%SP-complex*complex] -%SP-complex*complex@\8c000280@-[16] This function is invoked by the miscops -to multiply a complex by a complex. - -@index[%SP-integer/ratio] -%SP-integer/ratio@\8c000294@-[16] This function is invoked by the miscops to -divide an integer by a ratio. - -@index[%SP-ratio/integer] -%SP-ratio/integer@\8c0002a8@-[16] This function is invoked by the miscops to -divide a ratio by an integer. - -@index[%SP-ratio/ratio] -%SP-ratio/ratio@\8c0002bc@-[16] This function is invoked by the miscops to -divide a ratio by a ratio. - -@index[%SP-number/complex] -%SP-number/complex@\8c0002d0@-[16] This function is invoked by the miscops to -divide a number by a complex. - -@index[%SP-complex/number] -%SP-complex/number@\8c0002e4@-[16] This function is invoked by the miscops to -divide a complex by a number. - -@index[%SP-complex/complex] -%SP-complex/complex@\8c0002f8@-[16] This function is invoked by the miscops -to divide a complex by a complex. - -@index[%SP-integer-truncate-ratio] -%SP-integer-truncate-ratio@\8c00030c@-[16] This function is invoked by the -miscops to truncate an integer by a ratio. - -@index[%SP-ratio-truncate-integer] -%SP-ratio-truncate-integer@\8c000320@-[16] This function is invoked by the -miscops to truncate a ratio by an integer. - -@index[%SP-ratio-truncate-ratio] -%SP-ratio-truncate-ratio@\8c000334@-[16] This function is invoked by the -miscops to truncate a ratio by a ratio. - -@index[%SP-number-truncate-complex] -%SP-number-truncate-complex@\8c000348@-[16] This function is invoked by the -miscops to truncate a number by a complex. - -@index[%SP-complex-truncate-number] -%SP-complex-truncate-number@\8c00035c@-[16] This function is invoked by the -miscops to truncate a complex by a number. - -@index[%SP-complex-truncate-complex] -%SP-complex-truncate-complex@\8c000370@-[16] This function is invoked by -the miscops to truncate a complex by a complex. - -@index[maybe-gc] -Maybe-GC@\8c000384@-[16] This function may be invoked by any miscop that -does allocation. This function determines whether it is time to garbage -collect or not. If it is it performs a garbage collection. Whether it -invokes a garbage collection or not, it returns the single argument passed -to it. - -@index[Lisp-environment-list] -Lisp-environment-list@\8c000398@-[16] The value of this symbol is -set to the a list of the Unix environment strings passed into the Lisp -process. This list by Lisp to obtain various environment information, such -as the user's home directory, etc. - -@index[Call-lisp-from-c] -Call-lisp-from-C@\8c0003ac@-[16] This function is called whenever a -C function called by Lisp tries to call a Lisp function. - -@index[Lisp-command-line-list] -Lisp-command-line-list@\8c0003c0@-[16] The value of this symbol is -set to the list of strings passed into the Lisp process as the command -line. - -@index[*Nameserverport*] -*Nameserverport*@\8c0003d4@-[16] The value of this symbol is set to -the C global variable name_server_port. This allows Lisp to access the -name server. - -@index[*Ignore-Floating-Point-Underflow*] -*Ignore-Floating-Point-Underflow*@\8c0003e8@-[16] If the the value of this -symbol is NIL then an error is signalled when floating point underflow -occurs, otherwise the operation quietly returns zero. -@End[description] - -@chapter [Runtime Environment] -@index [Runtime Environment] -@label [Runtime] - -@section [Register Allocation] -@index [Register allocation] -To describe the assembler support routines in chapter @ref[Instr-Chapter] and -the complicated -control conventions in chapter @ref[Control-Conventions] requires that we talk -about the allocation of the 16 32-bit general purpose registers provided -by the @value(DinkyMachine). -@begin [description] -@index [Program-Counter register] -Program-Counter (PC) [R15]@\This register contains an index into the current -code vector when a Lisp function is about to be called. When a miscop is -called, it contains the return address. It may be used as a super temporary -between miscop and function calls. - -@index [Active-Function-Pointer register] -Active-Function-Pointer (AF) [R14]@\This register contains a pointer to the -active function object. It is used to access the symbol and constant area for -the currently running function. - -@index [Active-Frame-Pointer register] -Active-Frame-Pointer (FP) [R13]@\This register contains a pointer to the -current active frame on the control stack. It is used to access the arguments -and local variables stored on the control stack. - -@index [Binding-Stack-Pointer register] -Binding-Stack-Pointer (BS) [R12]@\This register contains the current binding -stack pointer. The binding stack is a downward growing stack and follows -a decrement-write/increment-read discipline. - -@index [Local registers] -Local registers (L0-L4) [R7-R11]@\These registers contain locals and saved -arguments for the currently executing function. Functions may use these -registers, so that stack accesses can be reduced, since a stack access is -relatively expensive compared to a register access. - -@index [Argument registers] -Argument register (A0, A1, A2) [R1, R3, R5]@\These registers contain arguments -to a function or miscop that has just been called. On entry to a function -or miscop, they contain the first three arguments. The first thing a function -does is to move the contents of these registers into the local registers. - -@index [Miscop argument register] -Miscop argument register (A3) [R4]@\This register is used to pass a fourth -argument to miscops requiring four or more arguments. It is also used as a -super temporary by the compiler. - -@index [Control-Stack-Pointer register] -Control-Stack-Pointer (CS) [R6]@\The stack pointer for the control stack, an -object of type Control-Stack-Pointer. Points to the last used word in -Control-Stack space; this upward growing stack uses a -increment-write/read-decrement discipline. - -@index [Non-Lisp temporary registers] -Non-Lisp temporary registers (NL0, NL1) [R0, R2]@\These registers are used to -contain non-Lisp values. They will normally be used during miscop calls, but -may also be used in in-line code to contain temporary data. These are the only -two registers never examined by the garbage collector, so no pointers to Lisp -objects should be stored here (since they won't get updated during a garbage -collection). -@end [description] - -@section [Function Object Format] -@label [Fn-Format] - -Each compiled function is represented in the machine as a Function -Object. This is identical in form to a G-Vector of lisp objects, and -is treated as such by the garbage collector, but it exists in a -special function space. (There is no particular reason for this -distinction. We may decide later to store these things in G-Vector -space, if we become short on spaces or have some reason to believe -that this would improve paging behavior.) Usually, the function -objects and code vectors will be kept in read-only space, but nothing -should depend on this; some applications may create, compile, and -destroy functions often enough to make dynamic allocation of function -objects worthwhile. - -@index [Code vector] -@index [Constants in code] The function object contains a vector of -header information needed by the function-calling mechanism: a -pointer to the I-Vector that holds the actual code. Following this -is the so-called ``symbols and constants'' area. The first few -entries in this area are fixnums that give the offsets into the code -vector for various numbers of supplied arguments. Following this -begin the true symbols and constants used by the function. Any -symbol used by the code as a special variable. -Fixnum constants can be generated faster -with in-line code than they can be accessed from the function-object, -so they are not stored in the constants area. - -The subtype of the G-Vector header indicates the type of the function: -@begin(Itemize, spacing 1, spread 0) -0 - A normal function (expr). - -1 - A special form (fexpr). - -2 - A defmacro macroexpansion function. - -3 - An anonymous expr. The name is the name of the parent function. - -4 - A compiled top-level form. -@end(Itemize) -Only the fexpr information has any real meaning to the system. The rest -is there for the printer and anyone else who cares. - - -After the one-word G-Vector header, the entries of the function object -are as follows: - -@begin [verbatim, group] -0 Name of the innermost enclosing named function. -1 Pointer to the unboxed Code vector holding the instructions. -2 A fixnum with bit fields as follows: - 24 - 31: The minimum legal number of args (0 to 255). - 16 - 23: The maximum number of args, not counting &rest (0 to 255). - The fixnum has a negative type code, if the function accepts a &rest - arg and a positive one otherwise. -3 A string describing the source file from which the function was defined. - See below for a description of the format. -4 A string containing a printed representation of the argument list, for - documentation purposes. If the function is a defmacro macroexpansion - function, the argument list will be the one originally given to defmacro - rather than the actual arglist to the expansion function. -5 The symbols and constants area starts here. - This word is entry 0 of the symbol/constant area. - The first few entries in this area are fixnums representing the - code-vector entry points for various numbers of optional arguments. -@end [verbatim] - -@section [Defined-From String Format] -@label [Defined-From-String-Format] -@index [Defined-From String Format] - -The defined-from string may have any of three different formats, depending -on which of the three compiling functions compiled it: -@begin(Description) -compile-file "@i[filename user-time universal-time]"@\ The @i[filename] is -the namestring of the truename of the file the function was defined from. -The time is the file-write-date of the file. - -compile "Lisp on @i[user-time], machine @i[machine universal-time]"@\ -The time is the time that the function was compiled. @i[Machine] is the -machine-instance of the machine on which the compilation was done. - -compile-from-stream "@i[stream] on @i[user-time], machine @i[machine-instance -universal-time]"@\@i[Stream] is the printed representation of the stream -compiled from. The time is the time the compilation started. -@end(Description) - -An example of the format of @i[user-time] is 6-May-86 1:04:44. The -@i[universal-time] is the same time represented as a decimal integer. -It should be noted that in each case, the universal time is the last -thing in the string. - -@section [Control-Stack Format] -@label [Control-Stack-Format] -@index [Control-stack format] - -The CMU Common Lisp control stack is a framed stack. Call frames, which hold -information for function calls, are intermixed with catch frames, which hold -information used for non-local exits. In addition, the control stack is used -as a scratchpad for random computations. - -@subsection [Call Frames] -@index [Open frame] -@index [Active frame] - -At any given time, the machine contains pointers to the current top -of the control stack and the start of the current active frame (in -which the current function is executing). In addition, there is a -pointer to the current top of the special binding stack. CMU Common Lisp -on the Perq also has a pointer to an open frame. An open frame is -one which has been partially built, but which is still having -arguments for it computed. When all the arguments have been computed -and saved on the frame, the function is then started. This means -that the call frame is completed, becomes the current active frame, -and the function is executed. At this time, special variables may be -bound and the old values are saved on the binding stack. Upon -return, the active frame is popped away and the result is either sent -as an argument to some previously opened frame or goes to some other -destination. The binding stack is popped and old values are -restored. - -On the @value(DinkyMachine), open frames still exist, however, no register is -allocated to point at the most recent one. Instead, a count of the arguments -to the function is kept. In most cases, a known fixed number of arguments are -passed to a function, and this is all that is needed to calculate the correct -place to set the active frame pointer. -In some cases, it is not as simple, and runtime calculations are necessary to -set up the frame pointer. These calculations are simple except in some very -strange cases. - -The active frame contains pointers to the previously-active frame and -to the point to which the binding stack will be popped -on exit, among other things. Following this is a vector of storage locations -for the function's arguments and local variables. Space is allocated for the -maximum number of arguments that the function can take, regardless of how many -are actually supplied. - -In an open frame, stack space is allocated up to the point where the arguments -are stored. Nothing is stored in the frame -at this time. Thus, as arguments are computed, they can simply be pushed on -the stack. Since the first three arguments are passed in registers, it is -sometimes necessary to save these values when succeeding arguments are -complicated. When the function is finally started, the remainder of the frame -is built (including storing all the -registers that must be saved). A call frame looks like this: -@begin [verbatim, group] -0 Saved local 0 register. -1 Saved local 1 register. -2 Saved local 2 register. -3 Saved local 3 register. -4 Saved local 4 register. -5 Pointer to previous binding stack. -6 Pointer to previous active frame. -7 Pointer to previous active function. -8 Saved PC of caller. A fixnum. -9 Args-and-locals area starts here. This is entry 0. -@end [verbatim] -The first slot is pointed to by the Active-Frame register if this frame is -currently active. - -@subsection [Catch Frames] -@index [Catch] -@index [Catch frames] - -Catch frames contain much of the same information that call frames -do, and have a very similar format. A catch frame holds the function -object for the current function, a stack pointer to the current -active frame, a pointer to the current top of the binding stack, and -a pointer to the previous catch frame. When a Throw occurs, an -operation similar to returning from this catch frame (as if it -were a call frame) is performed, and the stacks are unwound to the -proper place for continued execution in the current function. A -catch frame looks like this: -@begin [verbatim, group] -0 Pointer to current binding stack. -1 Pointer to current active frame. -2 Pointer to current function object. -3 Destination PC for a Throw. -4 Tag caught by this catch frame. -5 Pointer to previous catch frame. -@end [verbatim] -The conventions used to manipulate call and catch frames are described in -chapter @ref[Control-Conventions]. - -@section [Binding-Stack Format] -@index [Binding stack format] - -Each entry of the binding-stack consists of two boxed (32-bit) words. Pushed -first is a pointer to the symbol being bound. Pushed second is the symbol's -old value (any boxed item) that is to be restored when the binding stack is -popped. - -@chapter [Storage Management] -@index [Storage management] -@index [Garbage Collection] -@label [Alloc-Chapter] - -@index [Free-Storage pointer] -@index [Clean-Space pointer] -New objects are allocated from the lowest unused addresses within the specified -space. Each allocation call specifies how many words are wanted, and a -Free-Storage pointer is incremented by that amount. There is one of these -Free-Storage pointers for each space, and it points to the lowest free address -in the space. There is also a Clean-Space pointer associated with each space -that is used during garbage collection. These pointers are stored in a table -which is indexed by the type and space code. The -address of the Free-Storage pointer for a given space is -@begin[verbatim] - (+ alloc-table-base (lsh type 5) (lsh space 3)). -@end[verbatim] -The address of the Clean-Space pointer is -@begin[verbatim] - (+ alloc-table-base (lsh type 5) (lsh space 3) 4). -@end[verbatim] - -Common Lisp on the @value(DinkyMachine) uses a stop-and-copy garbage collector -to reclaim storage. The Collect-Garbage miscop performs a full GC. The -algorithm used is a degenerate form of Baker's incremental garbage collection -scheme. When the Collect-Garbage miscop is executed, the following -happens: -@begin[enumerate] -The current newspace becomes oldspace, and the current oldspace becomes -newspace. - -The newspace Free-Storage and Clean-Space pointers are initialized to point to -the beginning of their spaces. - -The objects pointed at by contents of all the registers containing Lisp objects -are transported if necessary. - -The control stack and binding stack are scavenged. - -Each static pointer space is scavenged. - -Each new dynamic space is scavenged. The scavenging of the dynamic spaces -continues until an entire pass through all of them does not result in anything -being transported. At this point, every live object is in newspace. -@end[enumerate] -A Lisp-level GC function returns the oldspace pages to Mach. - -@index [Transporter] -@section [The Transporter] -The transporter moves objects from oldspace to newspace. It is given an -address @i[A], which contains the object to be transported, @i[B]. If @i[B] is -an immediate object, a pointer into static space, a pointer into read-only -space, or a pointer into newspace, the transporter does nothing. - -If @i[B] is a pointer into oldspace, the object it points to must be -moved. It may, however, already have been moved. Fetch the first -word of @i[B], and call it @i[C]. If @i[C] is a GC-forwarding -pointer, we form a new pointer with the type code of @i[B] and the -low 27 bits of @i[C]. Write this into @i[A]. - -If @i[C] is not a GC-forwarding pointer, we must copy the object that -@i[B] points to. Allocate a new object of the same size in newspace, -and copy the contents. Replace @i[C] with a GC-forwarding pointer to -the new structure, and write the address of the new structure back -into @i[A]. - -Hash tables maintained with an EQ relation need special treatment by the -transporter. Whenever a G-Vector with subtype 2 or 3 is transported to -newspace, its subtype code is changed to 4. The Lisp-level hash-table -functions will see that the subtype code has changed, and re-hash the entries -before any access is made. - -@index [Scavenger] -@section [The Scavenger] The scavenger looks through an area of -pointers for pointers into oldspace, transporting the objects they -point to into newspace. The stacks and static spaces need to be -scavenged once, but the new dynamic spaces need to be scavenged -repeatedly, since new objects will be allocated while garbage -collection is in progress. To keep track of how much a dynamic space -has been scavenged, a Clean-Space pointer is maintained. The -Clean-Space pointer points to the next word to be scavenged. Each -call to the scavenger scavenges the area between the Clean-Space -pointer and the Free-Storage pointer. The Clean-Space pointer is -then set to the Free-Storage pointer. When all Clean-Space pointers -are equal to their Free-Storage pointers, GC is complete. - -To maintain (and create) locality of list structures, list space is -treated specially. When a list cell is transported, if the cdr points -to oldspace, it is immediately transported to newspace. This continues until -the end of the list is encountered or a non-oldspace pointer occurs in the cdr -position. This linearizes lists in the cdr direction which should -improve paging performance. - -@section [Purification] -@index [Purification] -@label [PURIFY] - -Garbage is created when the files that make up a CMU Common Lisp system are -loaded. Many functions are needed only for initialization and -bootstrapping (e.g. the ``one-shot'' functions produced by the compiler for -random forms between function definitions), and these can be thrown away -once a full system is built. Most of the functions in the system, however, -will be used after initialization. Rather than bend over backwards to make -the compiler dump some functions in read-only space and others in dynamic -space (which involves dumping their constants in the proper spaces, also), -@i[everything] is dumped into dynamic space. A purify miscop is provided -that does a garbage collection and moves accessible information in dynamic -space into read-only or static space. - -@chapter [Assembler Support Routines] -@label [Instr-Chapter] -@index [Assembler Support Routines] - -To support compiled Common Lisp code many hand coded assembler -language routines (miscops) are required. These routines accept -arguments in the three argument registers, the special miscop -argument register, and in a very few cases on the stack. The current -register assignments are: -@begin(Itemize, spread 0, spacing 1) -A0 contains the first argument. - -A1 contains the second argument. - -A2 contains the third argument. - -A3 contains the fourth argument. -@end(itemize) -The rest of the arguments are passed on the stack with the last -argument at the end of the stack. All arguments on the stack must be -popped off the stack by the miscop. All miscops return their -values in register A0. A few miscops return two or three values, -these are all placed in the argument registers. The main return -value is stored in register A0, the others in A1 and A2. The -compiler must generate code to use the multiple values correctly, -i.e., place the return values on the stack and put a values marker in -register A0 if multiple-values are wanted. Otherwise the compiler -can use the value(s) it needs and ignore the rest. NB: Most of the -miscops follow this scheme, however, a few do not. Any -discrepancies are explained in the description of particular -miscops. - -Several of the instructions described in the Perq Internal Design Document do -not have associated miscops, rather they have been code directly in-line. -Examples of these instructions include push, pop, bind, bind-null, many of the -predicates, and a few other instructions. Most of these instructions can be -performed in 4 or fewer @value(DinkyMachine) instructions and the overhead of -calling a miscop seemed overly expensive. Some instructions are encoded -in-line or as a miscop call depending on settings of compiler optimization -switches. If space is more important than speed, then some Perq instructions -are compiled as calls to out of line miscops rather than generating in-line -code. - -@section [Miscop Descriptions] -@label[macro-codes] - -There are 10 classes of miscops: allocation, stack manipulation, -list manipulation, symbol manipulation, array manipulation, type predicate, -arithmetic and logical, function call and return, -miscellaneous, and system hacking. - -@subsection [Allocation] -@instrsection -All non-immediate objects are allocated in the ``current allocation space,'' -which is dynamic space, static space, or read-only space. The current -allocation space is initially dynamic space, but can be changed by using the -Set-Allocation-Space miscop below. The current allocation space can be -determined by using the Get-Allocation-Space miscop. One usually wants to -change the allocation space around some section of code; an unwind protect -should be used to insure that the allocation space is restored to some safe -value. - -@begin(Description) -@index [Get-Allocation-Space] -Get-Allocation-Space (@i[])@\returns 0, 2, or 3 if the current allocation -space is dynamic, static, or read-only, respectively. - -@index [Set-Allocation-Space] -Set-Allocation-Space (@i[X])@\sets the current allocation space to dynamic, -static, or read-only if @i[X] is 0, 2, or 3 respectively. Returns @i[X]. - -@index [Alloc-Bit-Vector] -Alloc-Bit-Vector (Length)@\returns a new bit-vector @i[Length] bits long, -which is allocated in the current allocation space. @i[Length] must be a -positive fixnum. - -@index [Alloc-I-Vector] -Alloc-I-Vector (@i[Length A])@\returns a new I-Vector @i[Length] -bytes long, with the access code specified by @i[A]. @i[Length] and -@i[A] must be positive fixnums. - -@index [Alloc-String] -Alloc-String (@i[Length])@\ returns a new string @i[Length] characters long. -@i[Length] must be a fixnum. - -@index [Alloc-Bignum] -Alloc-Bignum (@i[Length])@\returns a new bignum @i[Length] 32-bit words long. -@i[Length] must be a fixnum. - -@index [Make-Complex] -Make-Complex (@i[Realpart Imagpart])@\returns a new complex number with the -specified @i[Realpart] and @i[Imagpart]. @i[Realpart] and @i[Imagpart] should -be the same type of non-complex number. - -@index [Make-Ratio] -Make-Ratio (@i[Numerator Denominator])@\returns a new ratio with the -specified @i[Numerator] and @i[Denominator]. @i[Numerator] and -@i[Denominator] should be integers. - -@index [Alloc-G-Vector] -Alloc-G-Vector (@i[Length Initial-Element])@\returns a new G-Vector -with @i[Length] elements initialized to @i[Initial-Element]. -@i[Length] should be a fixnum. - -@index [Static-Alloc-G-Vector] -Static-G-Vector (@i[Length Initial-Element])@\returns a new G-Vector in -static allocation space with @i[Length] elements initialized to -@i[Initial-Element]. - -@index [Vector] -Vector (@i[Elt@-[0] Elt@-[1] ... Elt@-[Length - 1] Length])@\returns a new -G-Vector containing the specified @i[Length] elements. @i[Length] should be a -fixnum and is passed in register A0. The rest of the arguments are passed on -the stack. - -@index [Alloc-Function] -Alloc-Function (@i[Length])@\returns a new function with @i[Length] elements. -@i[Length] should be a fixnum. - -@index [Alloc-Array] -Alloc-Array (@i[Length])@\returns a new array with @i[Length] elements. -@i[Length] should be a fixnum. - -@index [Alloc-Symbol] -Alloc-Symbol (@i[Print-Name])@\returns a new symbol with the print-name as -@i[Print-Name]. The value is initially Trap, the definition is Trap, -the property list and the package are initially NIL. The symbol is -not interned by this operation -- that is done in Lisp code. -@i[Print-Name] should be a simple-string. - -@index [Cons] -Cons (@i[Car Cdr])@\returns a new cons with the specified @i[Car] and @i[Cdr]. - -@index [List] -List (@i[Elt@-[0] Elt@-[1] ... Elt@-[CE - 1] Length])@\returns a new list -containing the @i[Length] elements. @i[Length] should be fixnum and is -passed in register NL0. The first three arguments are passed in A0, A1, and -A2. The rest of the arguments are passed on the stack. - -@index [List*] -List* (@i[Elt@-[0] Elt@-[1] ... Elt@-[CE - 1] Length])@\returns a list* formed -by the @i[Length-1] elements. The last element is placed in the cdr of the -last element of the new list formed. @i[Length] should be a fixnum and is -passed in register NL0. The first three arguments are passed in A0, A1, and -A2. The rest of the arguments are passed on the stack. - -@index[mv-list] -MV-List (@i[Elt@-<0> Elt@-<1> ... Elt@-<CE - 1> Length])@\returns a list -formed from the elements, all of which are on the stack. @i[Length] is -passed in register A0. This miscop is invoked when multiple values from -a function call are formed into a list. -@end(Description) - -@subsection [Stack Manipulation] -@instrsection - -@begin(Description) -@index [Push] -Push (@i[E])@\pushes E on to the control stack. - -@index [Pop] -Pop (@i[E])@\pops the top item on the control stack into @i[E]. - -@index [NPop] -NPop (@i[N])@\If @i[N] is positive, @i[N] items are popped off of the stack. -If @i[N] is negative, NIL is pushed onto the stack -@i[N] times. @i[N] must be -a fixnum. - -@index [Bind-Null] -Bind-Null (@i[E])@\pushes @i[E] (which must be a symbol) and its current value -onto the binding stack, and sets the value of @i[E] to NIL. Returns NIL. - -@index [Bind] -Bind (Value Symbol)@\pushes @i[Symbol] (which must be a symbol) and its current -value onto the binding stack, and sets the value cell of @i[Symbol] to -@i[Value]. Returns @i[Symbol]. - -@index [Unbind] -Unbind (@i[N])@\undoes the top @i[N] bindings on the binding stack. -@end(Description) - -@subsection [List Manipulation] -@instrsection - -@begin(Description) -@index [Car] -@index [Cdr] -@index [Caar] -@index [Cadr] -@index [Cdar] -@index [Cddr] -Car, Cdr, Caar, Cadr, Cdar, Cddr (@i[E])@\returns the car, cdr, caar, cadr, -cdar, or cddr of @i[E] respectively. - -@index [Set-Cdr] -@index [Set-Cddr] -Set-Cdr, Set-Cddr (@i[E])@\The cdr or cddr of the contents of @i[E] is stored -in @i[E]. The contents of @i[E] should be either a list or NIL. - -@index [Set-Lpop] -Set-Lpop (@i[E])@\The car of the contents of @i[E] is returned; -the cdr of the contents of @i[E] is stored in @i[E]. The contents of @i[E] -should be a list or NIL. - -@index [Spread] -Spread (@i[E])@\pushes the elements of the list @i[E] onto the stack in -left-to-right order. - -@index [Replace-Car] -@index [Replace-Cdr] -Replace-Car, Replace-Cdr (@i[List Value])@\sets the car or cdr of the @i[List] -to @i[Value] and returns @i[Value]. - -@index [Endp] -Endp (X)@\sets the condition code eq bit to 1 if @i[X] is NIL, or 0 if @i[X] is -a cons cell. Otherwise an error is signalled. - -@index [Assoc] -@index [Assq] -Assoc, Assq (@i[List Item])@\returns the first cons in the association-list -@i[List] whose car is EQL to @i[Item]. If the = part of the EQL comparison -bugs out (and it can if the numbers are too complicated), a Lisp-level Assoc -function is called with the current cdr of the @i[List]. Assq returns the -first cons in the association-list @i[List] whose car is EQ to @i[Item]. - -@index [Member] -@index [Memq] Member, Memq (@i[List Item])@\returns the first cons in -the list @i[List] whose car is EQL to @i[Item]. If the = part of the -EQL comparison bugs out, a Lisp-level Member function is called with -the current cdr of the @i[List]. Memq returns the first cons in -@i[List] whose car is EQ to the @i[Item]. - -@index [GetF] - -GetF (@i[List Indicator Default])@\searches for the @i[Indicator] in -the list @i[List], cddring down as the Common Lisp form GetF would. -If @i[Indicator] is found, its associated value is returned, -otherwise @i[Default] is returned. -@end(Description) - -@subsection [Symbol Manipulation] -@instrsection - -Most of the symbol manipulation miscops are compiled in-line rather than -actual calls. - -@begin(Description) -@index [Get-Value] -Get-Value (@i[Symbol])@\returns the value of @i[Symbol] (which must be a -symbol). An error is signalled if @i[Symbol] is unbound. - -@index [Set-Value] -Set-Value (@i[Symbol Value])@\sets the value cell of the symbol @i[Symbol] to -@i[Value]. @i[Value] is returned. - -@index [Get-Definition] -Get-Definition (@i[Symbol])@\returns the definition of the symbol -@i[Symbol]. If @i[Symbol] is undefined, an error is signalled. - -@index [Set-Definition] -Set-Definition (@i[Symbol Definition])@\sets the definition of the symbol -@i[Symbol] to @i[Definition]. @i[Definition] is returned. - -@index [Get-Plist] -Get-Plist (@i[Symbol])@\returns the property list of the symbol @i[Symbol]. - -@index [Set-Plist] -Set-Plist (@i[Symbol Plist])@\sets the property -list of the symbol @i[Symbol] to -@i[Plist]. @i[Plist] is returned. - -@index [Get-Pname] -Get-Pname (@i[Symbol])@\returns the print name of the symbol @i[Symbol]. - -@index [Get-Package] -Get-Package (@i[Symbol])@\returns the package cell of the symbol @i[Symbol]. - -@index [Set-Package] -Set-Package (@i[Symbol Package])@\sets the package cell of the symbol -@i[Symbol] to @i[Package]. @i[Package] is returned. - -@index [Boundp] -Boundp (@i[Symbol])@\sets the eq condition code bit to 1 if the symbol -@i[Symbol] is bound; sets it to 0 otherwise. - -@index [FBoundp] -FBoundp (@i[Symbol])@\sets the eq condition code bit to 1 if the symbol -@i[Symbol] is defined; sets it to 0 otherwise. - -@index [Get] -Get (@i[Symbol] @i[Indicator] @i[Default])@\searches the property list of -@i[Symbol] for @i[Indicator] and returns the associated value. If -@i[Indicator] is not found, @i[Default] is returned. - -@index [Put] -Put (@i[Symbol] @i[Indicator] @i[Value])@\searches the property list of -@i[Symbol] for @i[Indicator] and replaces the associated value with @i[Value]. -If @i[Indicator] is not found, the @i[Indicator] @i[Value] pair are consed onto -the front of the property list. -@end(Description) - -@subsection [Array Manipulation] -@instrsection - -Common Lisp arrays have many manifestations in CMU Common Lisp. The CMU -Common Lisp data types Bit-Vector, Integer-Vector, String, General-Vector, -and Array are used to implement the collection of data types the Common -Lisp manual calls ``arrays.'' - -In the following miscop descriptions, ``simple-array'' means an array -implemented in CMU Common Lisp as a Bit-Vector, I-Vector, String, or -G-Vector. ``Complex-array'' means an array implemented as a CMU Common Lisp -Array object. ``Complex-bit-vector'' means a bit-vector implemented as a -CMU Common Lisp array; similar remarks apply for ``complex-string'' and so -forth. - -@begin(Description) -@index [Vector-Length] @index [G-Vector-Length] @index -[Simple-String-Length] @index [Simple-Bit-Vector-Length] Vector-Length -(@i[Vector])@\returns the length of the one-dimensional Common Lisp array -@i[Vector]. G-Vector-Length, Simple-String-Length, and -Simple-Bit-Vector-Length return the lengths of G-Vectors, CMU Common Lisp -strings, and CMU Common Lisp Bit-Vectors respectively. @i[Vector] should -be a vector of the appropriate type. - -@index [Get-Vector-Subtype] -Get-Vector-Subtype (@i[Vector])@\returns the subtype field of the vector -@i[Vector] as an integer. @i[Vector] should be a vector of some sort. - -@index [Set-Vector-Subtype] -Set-Vector-Subtype (@i[Vector A])@\sets the subtype field of the vector -@i[Vector] to @i[A], which must be a fixnum. - -@index [Get-Vector-Access-Code] -Get-Vector-Access-Code (@i[Vector])@\returns the access code of the I-Vector -(or Bit-Vector) @i[Vector] as a fixnum. - -@index [Shrink-Vector] -Shrink-Vector (@i[Vector Length])@\sets the length field and the -number-of-entries field of the vector @i[Vector] to @i[Length]. If the vector -contains Lisp objects, entries beyond the new end are set to Trap. -Returns the shortened vector. @i[Length] should be a fixnum. One cannot -shrink array headers or function headers. - -@index [Typed-Vref] -Typed-Vref (@i[A Vector I])@\returns the @i[I]'th element of the I-Vector -@i[Vector] by indexing into it as if its access-code were @i[A]. @i[A] and -@i[I] should be fixnums. - -@index [Typed-Vset] -Typed-Vset (@i[A Vector I Value])@\sets the @i[I]'th element of the I-Vector -@i[Vector] to @i[Value] indexing into @i[Vector] as if its access-code were -@i[A]. @i[A], @i[I], and @i[Value] should be fixnums. @i[Value] is returned. - -@index [Header-Length] -Header-Length (@i[Object])@\returns the number of Lisp objects in the header of -the function or array @i[Object]. This is used to find the number of -dimensions of an array or the number of constants in a function. - -@index [Header-Ref] -Header-Ref (@i[Object I])@\returns the @i[I]'th element of the function or -array header @i[Object]. @i[I] must be a fixnum. - -@index [Header-Set] -Header-Set (@i[Object I Value])@\sets the @i[I]'th element of the function of -array header @i[Object] to @i[Value], and pushes @i[Value]. @i[I] must be a -fixnum. -@end(Description) - -The names of the miscops used to reference and set elements of arrays are -based somewhat on the Common Lisp function names. The SVref, SBit, and SChar -miscops perform the same operation as their Common Lisp namesakes -- -referencing elements of simple-vectors, simple-bit-vectors, and simple-strings -respectively. Aref1 references any kind of one dimensional array. -The names of setting functions are derived by replacing ``ref'' with ``set'', -``char'' with ``charset'', and ``bit'' with ``bitset.'' - -@begin(Description) -@index [Aref1] -@index [SVref] -@index [SChar] -@index [SBit] -Aref1, SVref, SChar, SBit (@i[Array I])@\returns the @i[I]'th element of the -one-dimensional -array @i[Array]. SVref pushes an element of a G-Vector; SChar an element of a -string; Sbit an element of a Bit-Vector. @i[I] should be a fixnum. - -@index [Aset1] -@index [SVset] -@index [SCharset] -@index [SBitset] -Aset1, SVset, SCharset, SBitset (@i[Array I Value])@\sets the @i[I]'th element -of the one-dimensional -array @i[Array] to @i[Value]. SVset sets an element of a G-Vector; SCharset an -element of a string; SBitset an element of a Bit-Vector. @i[I] should be a -fixnum and @i[Value] is returned. - -@index [CAref2] -@index [CAref3] -CAref2, CAref3 (@i[Array I1 I2])@\returns the element (@i[I1], @i[I2]) of the -two-dimensional array @i[Array]. @i[I1] and @i[I2] should be -fixnums. CAref3 pushes the element (@i[I1], @i[I2], @i[I3]). - -@index [CAset2] -@index [CAset3] -CAset2, CAset3 (@i[Array I1 I2 Value]) @\sets the element (@i[I1], @i[I2]) of -the two-dimensional array @i[Array] to @i[Value] and returns @i[Value]. -@i[I1] and @i[I2] should be fixnums. CAset3 sets the element (@i[I1], @i[I2], -@i[I3]). - -@index [Bit-Bash] -Bit-Bash (@i[V1 V2 V3 Op])@\@i[V1], @i[V2], and @i[V3] should be bit-vectors -and @i[Op] should be a fixnum. The elements of the bit vector @i[V3] are -filled with the result of @i[Op]'ing the corresponding elements of @i[V1] and -@i[V2]. @i[Op] should be a Boole-style number (see the Boole miscop in -section @ref[Boole-Section]). -@end(Description) - -The rest of the miscops in this section implement special cases of sequence or -string operations. Where an operand is referred to as a string, it may -actually be an 8-bit I-Vector or system area pointer. - -@begin(Description) -@index [Byte-BLT] -Byte-BLT (@i[Src-String Src-Start Dst-String Dst-Start Dst-End])@\ -moves bytes from @i[Src-String] into @i[Dst-String] between @i[Dst-Start] -(inclusive) and @i[Dst-End] (exclusive). @i[Dst-Start] - @i[Dst-End] bytes are -moved. If the substrings specified overlap, ``the right thing happens,'' i.e. -all the characters are moved to the right place. This miscop corresponds -to the Common Lisp function REPLACE when the sequences are simple-strings. - -@index [Find-Character] -Find-Character (@i[String Start End Character])@\ -searches @i[String] for the @i[Character] from @i[Start] to @i[End]. If the -character is found, the corresponding index into @i[String] is returned, -otherwise NIL is returned. This miscop corresponds to the Common Lisp -function FIND when the sequence is a simple-string. - -@index [Find-Character-With-Attribute] -Find-Character-With-Attribute (@i[String Start End Table Mask])@\ -The codes of the characters of @i[String] from @i[Start] to @i[End] are used as -indices into the @i[Table], which is an I-Vector of 8-bit bytes. When the -number picked up from the table bitwise ANDed with @i[Mask] is non-zero, the -current index into the @i[String] is returned. - -@index [SXHash-Simple-String] -SXHash-Simple-String (@i[String Length])@\Computes the hash code of the first -@i[Length] characters of @i[String] and pushes it on the stack. This -corresponds to the Common Lisp function SXHASH when the object is a -simple-string. The @i[Length] operand can be Nil, in which case the length of -the string is calculated in assembler. -@end(Description) - -@subsection [Type Predicates] -@instrsection - -Many of the miscops described in this sub-section can be coded in-line rather -than as miscops. In particular, all the predicates on basic types are coded -in-line with default optimization settings in the compiler. Currently, all of -these predicates set the eq condition code bit to return an indication of -whether the predicate is true or false. This is so that the -@value(DinkyMachine) branch instructions can be used directly without having to -test for NIL. However, this only works if the value of the predicate is needed -for a branching decision. In the cases where the value is actually needed, T -or NIL is generated in-line according to whether the predicate is true or -false. At some point it might be worthwhile having two versions of these -predicates, one which sets the eq condition code bit, and one which returns T -or NIL. This is especially true if space becomes an issue. - -@begin(Description) -@index [Bit-Vector-P] -Bit-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is -a Common Lisp bit-vector or 0 if it is not. - -@index [Simple-Bit-Vector-P] -Simple-Bit-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if -@i[Object] is a CMU Common Lisp bit-vector or 0 if it is not. - -@index [Simple-Integer-Vector-P] -Simple-Integer-Vector-P (@i[Object])@\sets the eq condition code bit to 1 -if @i[Object] is a CMU Common Lisp I-Vector or 0 if it is not. - -@index [StringP] -StringP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -Common Lisp string or 0 if it is not. - -@index [Simple-String-P] -Simple-String-P (@i[Object])@\sets the eq condition code bit to 1 if -@i[Object] is a CMU Common Lisp string or 0 if it is not. - -@index [BignumP] -BignumP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -bignum or 0 if it is not. - -@index [Long-Float-P] -Long-Float-P (@i[Object])@\sets the eq condition code bit to 1 if -@i[Object] is a long-float or 0 if it is not. - -@index [ComplexP] -ComplexP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -complex number or 0 if it is not. - -@index [RatioP] -RatioP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -ratio or 0 if it is not. - -@index [IntegerP] -IntegerP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -fixnum or bignum or 0 if it is not. - -@index [RationalP] -RationalP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -fixnum, bignum, or ratio or 0 if it is not. - -@index [FloatP] -FloatP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -short-float or long-float or 0 if it is not. - -@index [NumberP] -NumberP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -number or 0 if it is not. - -@index [General-Vector-P] -General-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if -@i[Object] is a Common Lisp general vector or 0 if it is not. - -@index [Simple-Vector-P] -Simple-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] -is a CMU Common Lisp G-Vector or 0 if it is not. - -@index [Compiled-Function-P] -Compiled-Function-P (@i[Object])@\sets the eq condition code bit to 1 if -@i[Object] is a compiled function or 0 if it is not. - -@index [ArrayP] -ArrayP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -Common Lisp array or 0 if it is not. - -@index [VectorP] -VectorP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -Common Lisp vector of 0 if it is not. - -@index [Complex-Array-P] -Complex-Array-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] -is a CMU Common Lisp array or 0 if it is not. - -@index [SymbolP] -SymbolP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -symbol or 0 if it is not. - -@index [ListP] -ListP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a cons -or NIL or 0 if it is not. - -@index [ConsP] -ConsP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a cons -or 0 if it is not. - -@index [FixnumP] -FixnumP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a -fixnum or 0 if it is not. - -@index [Single-Float-P] -Single-Float-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] -is a single-float or 0 if it is not. - -@index [CharacterP] -CharacterP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is -a character or 0 if it is not. -@end(Description) - -@subsection [Arithmetic] -@instrsection - -@begin(Description) -@index [Integer-Length] -Integer-Length (@i[Object])@\returns the integer-length (as defined in the -Common Lisp manual) of the integer @i[Object]. - -@index [Logcount] -Logcount (@i[Object])@\returns the number of 1's if @i[object] is a -positive integer, the number of 0's if @i[object] is a negative integer, -and signals an error otherwise. - -@index [Float-Short] -Float-Short (@i[Object])@\returns a short-float corresponding to the number -@i[Object]. - -@index [Float-Long] -Float-Long (@i[Number])@\returns a long float formed by coercing @i[Number] to -a long float. This corresponds to the Common Lisp function Float when given a -long float as its second argument. - -@index [Realpart] -Realpart (@i[Number])@\returns the realpart of the @i[Number]. - -@index [Imagpart] -Imagpart (@i[Number])@\returns the imagpart of the @i[Number]. - -@index [Numerator] -Numerator (@i[Number])@\returns the numerator of the rational @i[Number]. - -@index [Denominator] -Denominator (@i[Number])@\returns the denominator of the rational @i[Number]. - -@index [Decode-Float] -Decode-Float (@i[Number])@\performs the Common Lisp Decode-Float function, -returning 3 values. - -@index [Scale-Float] -Scale-Float (@i[Number X])@\performs the Common Lisp Scale-Float function, -returning the result. - -@index[=] -= (@i[X Y])@\sets the condition codes according to whether @i[X] is equal -to @i[Y]. Both @i[X] and @i[Y] must be numbers, otherwise an error is -signalled. If a rational is compared with a flonum, the rational is -converted to a flonum of the same type first. If a short flonum is compared -with a long flonum, the short flonum is converted to a long flonum. -Flonums must be exactly equal (after conversion) for the condition codes to -be set to equality. This miscop also deals with complex numbers. - -@index [Compare] -Compare (@i[X Y])@\sets the condition codes according to -whether @i[X] is less than, equal to, or greater than @i[Y]. @i[X] -and @i[Y] must be numbers. Conversions as described in = above are done -as necessary. This miscop replaces the < and > instructions on the Perq, -so that the branch on condition instructions can be used more -effectively. The value of < and > as defined for the Perq are -only generated if necessary, i.e., the result is saved. If @i[X] or @i[Y] -is a complex number, an error is signalled. - -@index [Truncate] -Truncate (@i[N X])@\performs the Common Lisp TRUNCATE operation. There are 3 -cases depending on @i[X]: -@Begin[Itemize] -If @i[X] is fixnum 1, return two items: a fixnum or bignum -representing the integer part of @i[N] (rounded toward 0), then either 0 if -@i[N] was already an integer or the fractional part of @i[N] represented as a -flonum or ratio with the same type as @i[N]. - -If @i[X] and @i[N] are both fixnums or bignums and @i[X] is not 1, divide -@i[N] by @i[X]. Return two items: the integer quotient (a fixnum or -bignum) and the integer remainder. - -If either @i[X] or @i[N] is a flonum or ratio, return a fixnum or bignum -quotient (the true quotient rounded toward 0), then a flonum or ratio -remainder. The type of the remainder is determined by the same type-coercion -rules as for +. The value of the remainder is equal to @i[N] - @i[X] * -@i[Quotient]. -@End[Itemize] -On the @value(DinkyMachine), the integer part is returned in register A0, and -the remainder in A1. - -@index [+] -@index [-] -@index [*] -@index [/] -+, -, *, / (@i[N X])@\returns @i[N] + @i[X]. -, *, and / are similar. - -@index [Fixnum*Fixnum] -@index [Fixnum/Fixnum] -Fixnum*Fixnum, Fixnum/Fixnum (@i[N X])@\returns @i[N] * @i[X], where -both @i[N] and @i[X] are fixnums. Fixnum/ is similar. - -@index [1+] -1+ (@i[E])@\returns @i[E] + 1. - -@index [1-] -1- (@i[E])@\returns @i[E] - 1. - -@index [Negate] -Negate (@i[N])@\returns -@i[N]. - -@index [Abs] -Abs (@i[N])@\returns |@i[N]|. - -@index [GCD] -GCD (@i[N X])@\returns the greatest common divisor of the integers @i[N] and @i[X]. - -@index [Logand] -@index [Logior] -@index [Logxor] -Logand (@i[N X])@\returns the bitwise and of the integers @i[N] and @i[X]. -Logior and Logxor are analogous. - -@index [Lognot] -Lognot (@i[N])@\returns the bitwise complement of @i[N]. - -@index [Boole] -@label [Boole-Section] -Boole (@i[Op X Y])@\performs the Common Lisp Boole operation @i[Op] on @i[X], -and @i[Y]. The Boole constants for CMU Common Lisp are these: -@begin [verbatim, group] - boole-clr 0 - boole-set 1 - boole-1 2 - boole-2 3 - boole-c1 4 - boole-c2 5 - boole-and 6 - boole-ior 7 - boole-xor 8 - boole-eqv 9 - boole-nand 10 - boole-nor 11 - boole-andc1 12 - boole-andc2 13 - boole-orc1 14 - boole-orc2 15 -@end [verbatim] - -@index [Ash] -Ash (@i[N X])@\performs the Common Lisp ASH operation on @i[N] and @i[X]. - -@index [Ldb] -Ldb (@i[S P N])@\All args are integers; @i[S] and @i[P] are non-negative. -Performs the Common Lisp LDB operation with @i[S] and @i[P] being the size and -position of the byte specifier. - -@index [Mask-Field] -Mask-Field (@i[S P N])@\performs the Common Lisp Mask-Field operation with -@i[S] and @i[P] being the size and position of the byte specifier. - -@index [Dpb] -Dpb (@i[V S P N])@\performs the Common Lisp DPB operation with @i[S] and @i[P] -being the size and position of the byte specifier. - -@index [Deposit-Field] -Deposit-Field (@i[V S P N])@\performs the Common Lisp Deposit-Field operation -with @i[S] and @i[P] as the size and position of the byte specifier. - -@index [Lsh] -Lsh (@i[N X])@\returns a fixnum that is @i[N] shifted left by @i[X] bits, with -0's shifted in on the right. If @i[X] is negative, @i[N] is shifted to the -right with 0's coming in on the left. Both @i[N] and @i[X] should be fixnums. - -@index [Logldb] -Logldb (@i[S P N])@\All args are fixnums. @i[S] and @i[P] specify a ``byte'' -or bit-field of any length within @i[N]. This is extracted and is returned -right-justified as a fixnum. @i[S] is the length of the field in bits; @i[P] -is the number of bits from the right of @i[N] to the beginning of the -specified field. @i[P] = 0 means that the field starts at bit 0 of @i[N], and -so on. It is an error if the specified field is not entirely within the 26 -bits of @i[N] - -@index [Logdpb] -Logdpb (@i[V S P N])@\All args are fixnums. Returns a number equal to @i[N], -but with the field specified by @i[P] and @i[S] replaced by the @i[S] low-order -bits of @i[V]. It is an error if the field does not fit into the 26 bits of -@i[N]. - -@index[Sin]@index[Cos]@index[Tan]@index[Atan] -Sin(@i[X]), Cos(@i[X]), Tan(@i[X]), and Atan(@i[X])@\accept a single number -@i[X] as argument and return the sine, cosine, tangent, and arctangent of -the number respectively. These miscops take advantage of the hardware -support provided on the IBM RT PC if it is available, otherwise they escape -to Lisp code to calculate the appropriate result. - -@index[Log] -Log(@i[X])@\returns the natural log of the number @i[X]. This miscop uses -the hardware operation if it is available, otherwise it escapes to Lisp -code to calculate the result. - -@index[Exp] -Exp(@i[X])@\returns e raised to the power @i[X]. This miscop uses the -hardware operation if it is available, otherwise it escapes to Lisp code to -calculate the result. - -@index[Sqrt] -Sqrt(@i[X])@\returns the square root of @i[X]. This miscop uses the -hardware operation if it is available, otherwise it escapes to Lisp code to -calculate the result. -@end(Description) - -@subsection [Branching] -All branching is done with @value(DinkyMachine) branch instructions. -Instructions are generated to set the condition code bits appropriately, and -a branch which tests the appropriate condition code bit is generated. - -@subsection [Function Call and Return] -@instrsection - -@begin(Description) -@index [Call] -Call()@\A call frame for a function is opened. This is explained in -more detail in the next chapter. - -@index [Call-0] -Call-0 (@i[F])@\@i[F] must be an executable function, but is a -function of 0 arguments. Thus, there is no need to collect arguments. The -call frame is opened and activated in a single miscop. - -@index [Call-Multiple] -Call-Multiple ()@\Just like a Call miscop, but it marks the frame -to indicate that multiple values will be accepted. See -section @ref[Multi]. - -@index[Set-Up-Apply-Args] -Set-Up-Apply-Args ()@\is called to handle the last argument of a -function called by apply. All the other arguments will have been -properly set up by this time. Set-up-apply-args places the values of -the list passed as the last argument to apply in their proper -locations, whether they belong in argument registers or on the stack. -It updates the NArgs register with the actual count of the arguments -being passed to the function. When Set-up-apply-args returns, all the -arguments to the function being applied are in their correct -locations, and the function can be invoked normally. - -@index[Start-Call-Interpreter] -Start-Call-Interpreter (@i[NArgs])@\is called from the interpreter to -start a function call. It accepts the number of arguments that are -pushed on the stack in register A0. Just below the arguments is the -function to call; just below the function is the area to store the -preserved registers. This miscop sets up the argument registers -correctly, moves any other arguments down on the stack to their -proper place, and invokes the function. - -@index[Invoke1] -Invoke1 (@i[Function] @i[Argument])@\is similar to Start-Call-Interpreter, -but is simpler, since the @i[Function] is being called with only a -single @i[Argument]. - -@index[Invoke1*] -Invoke1* (@i[Function] @i[Argument])@\is similar to Invoke1, but the -@i[Function] being called is called for one value, rather than multiple ones. - -@index [Start-call-mc] -Start-call-mc ()@\is called when the compiler generates code for the -form multiple-value-call. Register A0 contains the function to be -called, A1 contains a 0 if the call if for a single value, and 1 -otherwise, NArgs contains the number of arguments that are stored on -the stack. The argument registers are set up correctly, and the -excess values moved down on the stack if necessary. Finally, the -function is actually invoked. - -@index [Push-Last] -Push-Last ()@\closes the currently open call frame, and initiates a function -call. - -@index [Return] -Return (@i[X])@\Return from the current function call. After the current -frame is popped off the stack, @i[X] is returned in register A0 as the result -Being returned. See section @ref[Return] for more details. - -@index [Return-From] -Return-From (@i[X] @i[F])@\is similar to Return, except it accepts the frame -to return from as an additional argument. - -@index [Return-1-Value-Any-Bind] -Return-1-Value-Any-Bind (@i[X])@\is similar to return, except only -one value is returned. Any number of bindings are undone during the -return operation. - -@index [Return-Mult-Value-0-Bind] -Return-Mult-Value-0-Bind (@i[X])@\is similar to return, except multiple values -may be returned, but the binding stack does not have to be popped. - -@index [Link-Address-Fixup] -Link-Address-Fixup (@i[Symbol NArgs Code-Vector Offset])@\finds the -correct link table entry for @i[Symbol] with @i[NArgs] (@i[NArgs] -specifies the fixed number of arguments and a flag if more may be -passed). It smashes the @i[Code-Vector] at @i[Offset] to generate -code to point at the absolute address of the link table entry. - -@index [Miscop-Fixup] -Miscop-Fixup (@i[Code-Vector Offset Index])@\smashes @i[Code-Vector] at -@i[Offset] with the correct value for the miscop specified by @i[Index] in a -transfer vector of all the miscops. - -@index [Make-Compiled-Closure] -Make-Compiled-Closure (@i[env fcn offset])@\returns a new function object -that is a copy of the function object @i[fcn] which has the @i[env] -information stored at @i[offset]. Compiled lexical closures are now -represented as real function objects rather than as lists. This miscop is -necessary to support this change. - -@index [Reset-link-table] -Reset-link-table (@i[function])@\resets all the link table entries for -@i[function] to the default action. This is necessary because Portable -Commonloops updates generic function objects by copying new information -into the function object. The link table must be updated to reflect this -or the wrong function will be called. - -@index[Interrupt-Handler] -@begin[Multiple] -Interrupt-Handler (@i[Signal Code Signal-Context])@\gets the first -indication that a Unix signal has occurred. This miscop does not follow -the normal Lisp calling conventions at all. Instead it follows the -standard IBM RT PC calling conventions for C or other algorithmic -languages. On entry the registers are as follows: -@begin(Description) -R0@\Pointer to C data area for Interrupt-Handler. Currently this data area -only holds a pointer to the entry point for Interrupt-Handler and nothing -else. - -R1@\Pointer to a C stack that contains information about the signal. - -R2@\Contains the @i[Signal] number that caused the interrupt to happen. - -R3@\Contains the @i[Code] that further specifies what caused the interrupt -(if necessary). - -R4@\Contains a pointer to the @i[signal-context] which contains -information about where the interrupt occurred, the saved registers, etc. - -R5-R14@\Contain unknown values. - -R15@\is the return PC which will return from the interrupt handler and -restart the computation. -@end(Description) -Interrupt-Handler determines whether it is safe to take the interrupt now, -i.e., it is executing in Lisp code, C code, or an interruptible miscop. An -interruptible miscop is one that has been specially written to make sure -that it is safe to interrupt it at any point and is possible that it will -never return of its own accord (e.g., length which could be passed a -circular list, some of the system call miscops, etc.). If it is safe to -take the interrupt, the signal-context is modified so that control will -transfer to the miscop interrupt-routine when the interrupt-handler returns -normally (i.e., after the kernel has done the necessary bookkeeping). If -it is unsafe to take the interrupt (i.e., it is executing in an -non-interruptible miscop), then the return PC of the miscop is modified to -be interrupt-routine and interrupt-handler returns to the kernel. In -either case interrupts are disabled and information is stored in a global -Lisp data area, so that the interrupt-routine miscop can retrieve the -important information about the interrupt. -@end[Multiple] - -Interrupt-Routine ()@\gets control when it is safe to take an interrupt. -It saves the current state of the computation on the appropriate stack (on -the C stack if it was executing in C or on the Lisp stack if in Lisp) -including all the registers, some control information specifying whether -the computation was in C code, Lisp code, whether it should form a PC in -register R15. When a PC has to be formed in R15, R14 will contain a pointer -to the active function and R15 will contain an index into the code vector -associated with the active function. Reforming the PC is necessary so -it is possible to restart a computation even after a garbage collection -may have moved the function. Once this information is stored, -interrupt-routine invokes the Lisp function %sp-software-interrupt-routine -which moves the processing of the interrupt to Lisp code. - -@index [Break-Return] -Break-Return (@i[])@\returns from a function called by the -interrupt-routine miscop. The only function that should ever do this is -%sp-software-interrupt-routine. This miscop expects the stack to be in a -format that is generated during an interrupt and should not be used for -anything else. - -@index [Catch] -Catch (@i[Tag PC])@\builds a catch frame. @i[Tag] is the tag caught by this -catch frame, @i[PC] is a saved-format PC (i.e., an index into the current code -vector). See section @ref[Catch] for details. - -@index [Catch-Multiple] -Catch-Multiple (@i[Tag PC])@\builds a multiple-value catch frame. @i[Tag] is -the tag caught by this catch frame, and @i[PC] is a saved-format PC. See -section @ref[Catch] for details. - -@index [Catch-All] -Catch-All (@i[PC])@\builds a catch frame whose tag is the special Catch-All -object. @i[PC] is the saved-format PC, which is the address to branch to if -this frame is thrown through. See section @ref[Catch] for details. - -@index [Throw] -Throw (@i[X Tag])@\@i[Tag] is the throw-tag, normally a symbol. @i[X] is the -value to be returned. See section @ref[Catch] for a description of how this -miscop works. - -@index[Rest-Entry-0]@index[Rest-Entry-1]@index[Rest-Entry-2]@index[Rest-Entry] -Rest-Entry-0, Rest-Entry-1, Rest-Entry-2, Rest-Entry@\are miscops -that do the processing for a function at its &rest entry point. -Rest-Entry-@i[i] are miscops that are invoked by functions that have -0, 1, or 2 arguments before the &rest argument. Rest-entry is -invoked for all other cases, and is passed an additional argument in -A3 which is the number of non-&rest arguments. These miscops form -the &rest arg list and set up all the registers to have the -appropriate values. In particular, the non-&rest arguments are copied -into preserved registers, and the &rest arg list is built and stored -in the appropriate preserved register or on the stack as appropriate. - -@index[Call-Foreign] -Call-Foreign (@i[C-Function Arguments NArgs])@\establishes the C -environment so that C code can be called correctly. @i[C-Function] is a -pointer to the data area for a C function, the first word of which is a -pointer to the entry point of the C function. @i[Arguments] is a block of -storage that contains the @i[NArgs] arguments to be passed to the C -function. The first four of these arguments are passed in registers R2 -through R5 respectively, the rest are moved onto the C stack in the proper -location. When the C function returns, Call-Foreign restores the Lisp -environment and returns as its value the integer in R2. - -@index[Call-Lisp] -Call-Lisp (@i[Arg@-<1> ... Arg@-<2>])@\is a Lisp miscop that gets control -when a C function needs to call a Lisp function. Lisp provides a mechanism -for setting up an object that looks like a C procedure pointer. The code -pointer in this object always points at Call-Lisp. Additional data in this -procedure pointer is the Lisp function to call and the number of arguments -that it should be called with. Call-Lisp restores the Lisp environment, -saves the state of the C computation, moves the C arguments into the -correct places for a call to a Lisp function and then invokes the special -Lisp function call-lisp-from-c. This Lisp function actually invokes the -correct Lisp function. Call-Lisp never regains control. - -@index[Return-To-C] -Return-To-C (@i[C-Stack-Pointer Value])@\is used in the -function call-lisp-from-c to return control to C from a Lisp function -called by C. @i[C-Stack-Pointer] is the C stack pointer when the call-lisp -miscop got control. The C stack pointer argument is used to restore the C -environment to what it was at the time the call to Lisp was made. -@i[Value] is the value returned from Lisp and is passed back to C in -register R2. Currently, it is not possible to return other than a single -32 bit quantity. - -@index[Reset-C-Stack] -Reset-C-Stack ()@\is invoked when a Lisp function called by C throws out -past where it should return to C. Reset-C-Stack restores the C stack to -what it was before the original call to C happened. This is so that in the -future, the C stack will not contain any garbage that should not be there. - -@index[Set-C-Procedure-Pointer] -Set-C-Procedure-Pointer (@i[Sap] @i[I] @I[Proc])@\sets the @i[I/2]'th -element of @i[sap] to be the data part of the statically allocated g-vector -@i[Proc]. This is used to set up a C procedure argument in the argument -block that is passed to call-foreign. - -@end(Description) - -@subsection [Miscellaneous] -@instrsection - -@begin(Description) -@index [Eq] -Eq (@i[X Y])@\sets the eq condition code bit to 1 if @i[X] and @i[Y] are the -same object, 0 otherwise. - -@index [Eql] -Eql (@i[X Y])@\sets the eq condition code bit to 1 if @i[X] and @i[Y] are the -same object or if -@i[X] and @i[Y] are numbers of the same type with the same value, 0 otherwise. - -@index [Make-Predicate] -Make-Predicate (@i[X])@\returns NIL if @i[X] is NIL or T if it is not. - -@index [Not-Predicate] -Not-Predicate (@i[X])@\returns T if @i[X] is NIL or NIL if it is not. - -@index [Values-To-N] -Values-To-N (@i[V])@\@i[V] must be a Values-Marker. Returns the number -of values indicated in the low 24 bits of @i[V] as a fixnum. - -@index [N-To-Values] -N-To-Values (@i[N])@\@i[N] is a fixnum. Returns a Values-Marker with the -same low-order 24 bits as @i[N]. - -@index [Force-Values] -Force-Values (@i[VM])@\If the @i[VM] is a Values-Marker, do -nothing; if not, push @i[VM] and return a Values-Marker 1. - -@index [Flush-Values] -Flush-Values (@i[])@\is a no-op for the @value(DinkyMachine), since the only -time that a Flush-Values miscop is generated is in some well-defined cases -where all the values are wanted on the stack. -@end(Description) - -@subsection [System Hacking] -@label [System-Hacking-Instructions] -@instrsection - -@begin(Description) -@index [Get-Type] -Get-Type (@i[Object])@\returns the five type bits of the @i[Object] as a -fixnum. - -@index [Get-Space] -Get-Space (@i[Object])@\returns the two space bits of @i[Object] as a -fixnum. - -@index [Make-Immediate-Type] -Make-Immediate-Type (@i[X A])@\returns an object whose type bits are the -integer @i[A] and whose other bits come from the immediate object or pointer -@i[X]. @i[A] should be an immediate type code. - -@index [8bit-System-Ref] -8bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer, returns -the @i[I]'th byte of @i[X], indexing into @i[X] directly. @i[I] -must be a fixnum. - -@index [8bit-System-Set] -8bit-System-Set (@i[X I V])@\@i[X] must be a system area pointer, sets the -@i[I]'th element of @i[X] to @i[V], indexing into @i[X] directly. - -@index [16bit-System-Ref] -16bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer, returns the -@i[I]'th 16-bit word of @i[X], indexing into @i[X] directly. - -@index [Signed-16bit-System-Ref] -Signed-16bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer, -returns the @i[I]'th 16-bit word of @i[X] extending the high order bit as -the sign bit. - -@Index [16bit-System-Set] -16bit-System-Set (@i[X I V])@\@i[X] must be a system area pointer, sets the -@i[I]'th element of @i[X] to @i[V], indexing into @i[X] directly. - -@Index [Signed-32bit-System-Ref] -Signed-32bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer and -@i[I] an even fixnum, returns the @i[I]/2'th 32 bit word as a signed -quantity. - -@Index [Unsigned-32bit-System-Ref] -Unsigned-32bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer and -@i[I] an even fixnum, returns the @i[I]/2'th 32 bit word as an unsigned -quantity. - -@Index [Signed-32bit-System-Set] -Signed-32bit-System-Set (@i[X I V])@\@i[X] must be a system area pointer, -@i[I] an even fixnum, and @i[V] an integer, sets the @i[I]/2'th element of -@i[X] to @i[V]. - -@index[Sap-System-Ref] -Sap-System-Ref (@i[X I])@\@i[X] must be a system area pointer and @i[I] and -even fixnum, returns the @i[I]/2'th element of @i[X] as a system area -pointer. - -@index[Sap-System-Set] -Sap-System-Set (@i[X I V])@\@i[X] and @i[V] must be a system area pointers -and @i[I] an even fixnum, sets the @i[I]/2'th element of @i[X] to @i[V]. - -@index[Pointer-System-Set] -Pointer-System-Set (@i[X I])@\@i[X] must be a system area pointer, @i[I] an -even fixnum, and @i[V] a pointer (either system area pointer or Lisp -pointer), sets the @i[I]/2'th element of @i[X] to the pointer @i[V]. If -the pointer is a Lisp pointer, the pointer stored is to the first word of -data (i.e., the header word(s) are bypassed). - -@index[Sap-Int] -Sap-Int (@i[X])@\@i[X] should be a system area pointer, returns a Lisp -integer containing the system area pointer. This miscop is useful when it -is necessary to do arithmetic on system area pointers. - -@index[Int-Sap] -Int-Sap (@i[X])@\@i[X] should be an integer (fixnum or bignum), returns a -system area pointer. This miscop performs the inverse operation of sap-int. - -@index[Check-<=] -Check-<= (@i[X] @i[Y])@\checks to make sure that @i[X] is less than or -equal to @i[Y]. If not, then check-<= signals an error, otherwise it just -returns. - -@index [Collect-Garbage] -Collect-Garbage (@i[])@\causes a stop-and-copy GC to be performed. - -@index [Purify] -Purify (@i[])@\is similar to collect-garbage, except it copies Lisp objects -into static or read-only space. This miscop needs Lisp level code to get -the process started by putting some root structures into the correct space. - -@index [Newspace-Bit] -Newspace-Bit (@i[])@\returns 0 if newspace is currently space 0 or 1 if it is -1. - -@index [Save] -Save (@i[*current-alien-free-pointer*] @i[Checksum] @I[memory])@\Save takes -a snap short of the current state of the Lisp computation. The value of -the symbol *Current-alien-free-pointer* must be passed to save, so that it -can save the static alien data structures. The parameter @i[checksum] -specifies whether a checksum should be generated for the saved image. -Currently, this parameter is ignored and no checksum is generated. The -parameter @i[memory] should be be a pointer to a block of memory where the -saved core image will be stored. Save returns the size of the core image -generated. - -@index [Syscall0] -@index [Syscall1] -@index [Syscall2] -@index [Syscall3] -@index [Syscall4] -@index [Syscall] -Syscall0 Syscall1 Syscall2 Syscall3 Syscall4 Syscall (@i[number] -@i[arg@-<1> ... arg@-<n>])@\is for making syscalls to the Mach kernel. The -argument @i[number] should be the number of the syscall. Syscall0 accepts -no arguments to the syscall; syscall1 accepts one argument to the syscall, -etc. Syscall accepts five or more arguments to the syscall. - -@index[Unix-write] -Unix-Write (@i[fd buffer offset length])@\performs a Unix write syscall to -the file descriptor @i[fd]. @i[Buffer] should contain the data to be -written; @i[Offset] should be an offset into buffer from which to start -writing; and @i[length] is the number of bytes of data to write. - -@index[Unix-fork] -Unix-Fork ()@\performs a Unix fork operation returning one or two values. -If an error occurred, the value -1 and the error code is returned. If no -error occurred, 0 is returned in the new process and the process id of the -child process is returned in the parent process. - -@index [Arg-In-Frame] Arg-In-Frame (@i[N F])@\@i[N] is a fixnum, @i[F] is a -control stack pointer as returned by the Active-Call-Frame miscop. It -returns the item in slot @i[N] of the args-and-locals area of call frame -@i[F]. - -@index [Active-Call-Frame] -Active-Call-Frame (@i[])@\returns a control-stack pointer to the start of the -currently active call frame. This will be of type Control-Stack-Pointer. - -@index [Active-Catch-Frame] -Active-Catch-Frame (@i[])@\returns the control-stack pointer to the start of -the currently active catch frame. This is Nil if there is no active catch. - -@index [Set-Call-Frame] -Set-Call-Frame (@i[P])@\@i[P] must be a control stack pointer. This becomes -the current active call frame pointer. - -@index [Current-Stack-Pointer] -Current-Stack-Pointer (@i[])@\returns the Control-Stack-Pointer that points -to the current top of the stack (before the result of this operation is -pushed). Note: by definition, this points to the -to the last thing pushed. - -@index [Current-Binding-Pointer] -Current-Binding-Pointer (@i[])@\returns a Binding-Stack-Pointer that points -to the first word above the current top of the binding stack. - -@index [Read-Control-Stack] -Read-Control-Stack (@i[F])@\@i[F] must be a control stack pointer. Returns -the Lisp object that resides at this location. If the addressed object is -totally outside the current stack, this is an error. - -@index [Write-Control-Stack] -Write-Control-Stack (@i[F V])@\@i[F] is a stack pointer, @i[V] is any Lisp -object. Writes @i[V] into the location addressed. If the addressed cell is -totally outside the current stack, this is an error. Obviously, this should -only be used by carefully written and debugged system code, since you can -destroy the world by using this miscop. - -@index [Read-Binding-Stack] -Read-Binding-Stack (@i[B])@\@i[B] must be a binding stack pointer. Reads and -returns the Lisp object at this location. An error if the location specified -is outside the current binding stack. - -@index [Write-Binding-Stack] -Write-Binding-Stack (@i[B V])@\@i[B] must be a binding stack pointer. Writes -@i[V] into the specified location. An error if the location specified is -outside the current binding stack. -@end(Description) - -@chapter [Control Conventions] -@label [Control-Conventions] -@index [Hairy stuff] - -@section [Function Calls] -@index [Call] -@index [Call-0] -@index [Call-Multiple] - -On the Perq function calling is done by micro-coded instructions. The -instructions perform a large number of operations, including determining -whether the function being called is compiled or interpreted, determining that -a legal number of arguments are passed, and branching to the correct entry -point in the function. To do all this on the @value(DinkyMachine) would -involve a large amount of computation. In the general case, it is necessary to -do all this, but in some common cases, it is possible to short circuit most of -this work. - -To perform a function call in the general case, the following steps occur: -@begin(Enumerate) - -Allocate space on the control stack for the fix-sized part of a call -frame. This space will be used to store all the registers that must -be preserved across a function call. - -Arguments to the function are now evaluated. The first three -arguments are stored in the argument registers A0, A1, and A2. The -rest of the arguments are stored on the stack as they are evaluated. -Note that during the evaluation of arguments, the argument registers -may be used and may have to be stored in local variables and restored -just before the called function is invoked. - -Load R0 with the argument count. - -Load the PC register with the offset into the current code vector of -the place to return to when the function call is complete. - -If this call is for multiple values, mark the frame as accepting -multiple values, by making the fixnum offset above negative by oring -in the negative fixnum type code. - -Store all the registers that must be preserved over the function call in the -current frame. -@end(Enumerate) - -At this point, all the arguments are set up and all the registers have been -saved. All the code to this point is done inline. If the object being called -as a function is a symbol, we get the definition from the definition cell of -the symbol. If this definition is the trap object, an undefined symbol error -is generated. The function calling mechanism diverges at this point depending -on the type of function being called, i.e., whether it is a compiled function -object or a list. - -If we have a compiled function object, the following steps are performed (this -code is out of line): -@begin(Enumerate) -Load the active function register with a pointer to the compiled function -object. - -The active frame register is set to the start of the current frame. - -Note the number of arguments evaluated. Let this be K. The correct -entry point in the called function's code vector must be computed as -a function of K and the number of arguments the called function -wants: -@begin(Enumerate, spread 0, spacing 1) -If K < minimum number of arguments, signal an error. - -If K > maximum number of arguments and there is no &rest argument, -signal an error. - -If K > maximum number of arguments and there is a &rest argument, -start at offset 0 in the code vector. This entry point must collect -the excess arguments into a list and leave the &rest argument in the -appropriate argument register or on the stack as appropriate. - -If K is between the minimum and maximum arguments (inclusive), get -the starting offset from the appropriate slot of the called -function's function object. This is stored as a fixnum in slot K - -MIN + 6 of the function object. -@end(Enumerate) - -Load one of the Non-Lisp temporary registers with the address of the -code vector and add in the offset calculated above. Then do a branch -register instruction with this register as the operand. The called -function is now executing at the appropriate place. -@end(enumerate) - -If the function being called is a list, %SP-Internal-Apply must be called to -interpret the function with the given arguments. Proceed as follows: -@begin(Enumerate) -Note the number of arguments evaluated for the current open frame (call this N) -and the frame pointer for the frame (call it F). Also remember the lambda -expression in this frame (call it L). - -Load the active function register with the list L. - -Load the PC register with 0. - -Allocate a frame on the control stack for the call to %SP-Internal-Apply. - -Move the contents of the argument registers into the local registers L0, L1, -and L2 respectively. - -Store all the preserved registers in the frame. - -Place N, F, and L into argument registers A0, A1, and A2 respectively. - -Do the equivalent of a start call on %SP-Internal-Apply. -@end(Enumerate) %SP-Internal-Apply, a function of three arguments, -now evaluates the call to the lambda-expression or interpreted -lexical closure L, obtaining the arguments from the frame pointed to -by F. The first three arguments must be obtained from the frame that -%SP-Internal-Apply runs in, since they are stored in its stack frame -and not on the stack as the rest of the arguments are. Prior to -returning %SP-Internal-Apply sets the Active-Frame register to F, so -that it returns from frame F. - -The above is the default calling mechanism. However, much of the -overhead can be reduced. Most of the overhead is incurred by having -to check the legality of the function call everytime the function is -called. In many situations where the function being called is a -symbol, this checking can be done only once per call site by -introducing a data structure called a link table. The one exception -to this rule is when the function apply is used with a symbol. In -this situation, the argument count checks are still necessary, but -checking for whether the function is a list or compiled function -object can be bypassed. - -The link table is a hash table whose key is based on the name of the -function, the number of arguments supplied to the call and a flag -specifying whether the call is done through apply or not. Each entry -of the link table consists of two words: -@begin(Enumerate) -The address of the function object associated with the symbol being -called. This is here, so that double indirection is not needed to -access the function object which must be loaded into the active -function register. Initially, the symbol is stored in this slot. - -The address of the instruction in the function being called to start -executing when this table entry is used. Initially, this points to -an out of line routine that checks the legality of the call and -calculates the correct place to jump to in the called function. This -out of line routine replaces the contents of this word with the -correct address it calculated. In the case when the call is caused -by apply, this will often be an out of line routine that checks the -argument count and calculates where to jump. In the case where the -called function accepts &rest arguments and the minimum number of -arguments passed is guaranteed to be greater than the maximum number -of arguments, then a direct branch to the &rest arg entry point is -made. -@end(Enumerate) - -When a compiled file is loaded into the lisp environment, all the -entries for the newly loaded functions will be set to an out of line -routine mentioned above. Also, during a garbage collection the -entries in this table must be updated when a function object for a -symbol is moved. - -The @value(DinkyMachine) code to perform a function call using the link table -becomes: -@begin(Example) - cal CS,CS,%Frame-Size ; Alloc. space on control st. - - <Code to evaluate arguments to the function> - - cau NL1,0,high-half-word(lte(function nargs flag)) - oil NL1,0,low-half-word(lte(function nargs flag)) - cal PC,0,return-tag ; Offset into code vector. - <oiu PC,PC,#xF800 ; Mark if call-multiple frame> - stm L0,CS,-(%Frame-Size-4) ; Save preserved regs. - lm AF,NL1,0 ; Link table entry contents. - bnbrx pz,R15 ; Branch to called routine. - cal FP,CS,-(%Frame-Size-4) ; Get pointer to frame. -return-tag: -@end(Example) -The first two instructions after the arguments are evaled get the -address of the link table entry into a register. The two 16-bit half -word entries are filled in at load time. The rest of the -instructions should be fairly straight forward. - -@section(Returning from a Function Call) -@label(Return) -@index(Return) - -Returning from a function call on the Perq is done by a micro-coded -instruction. On the @value(DinkyMachine), return has to do the following: -@begin(enumerate) -Pop the binding stack back to the binding stack pointer stored in the frame -we're returning from. For each symbol/value pair popped of the binding stack, -restore that value for the symbol. - -Save the current value of the frame pointer in a temporary registers. This -will be used to restore the control stack pointer at the end. - -Restore all the registers that are preserved across a function call. - -Get a pointer to the code vector for the function we're returning to. This is -retrieved from the code slot of what is now the active function. - -Make sure the relative PC (which is now in a register) is positive and add it -to the code vector pointer above, giving the address of the instruction to -return to. - -If the function is returning multiple values do a block transfer of all the -return values down over the stack frame just released, i.e., the first return -value should be stored where the temporarily saved frame pointer points to. -In effect the return values can be pushed onto the stack using the saved frame -pointer above as a stack pointer that is incremented everytime a value is -pushed. Register A0 can be examined to determine the number of values that -must be transferred. - -Set the control stack register to the saved frame pointer above. NB: it may -have been updated if multiple values are being returned. - -Resume execution of the calling function. -@end(enumerate) - -Again, it is not always necessary to use the general return code. At compile -time it is often possible to determine that no special symbols have to be -unbound and/or only one value is being returned. For example the code to -perform a return when only one value is returned and it is unnecessary to -unbind any special symbols is: -@begin(Example) - cas NL1,FP,0 ; Save frame register. - lm L0,FP,0 ; Restore all preserved regs. - ls A3,AF,%function-code ; Get pointer to code vector. - niuo PC,PC,#x07FF ; Make relative PC positive. - cas PC,A3,PC ; Get addr. of instruction - bnbrx pz,PC ; to return to and do so while - cas CS,NL1,0 ; updating control stack reg. -@end(Example) - - -@subsection [Returning Multiple-Values] -@label [Multi] -@index [Multiple values] - -If the current frame can accept multiple values and a values marker is in -register A0 indicating N values on top of the stack, it is necessary to copy -the N return values down to the top of the control stack after the current -frame is popped off. Thus returning multiple values is similar to the -above, but a block transfer is necessary to move the returned values down to -the correct location on the control stack. - -In tail recursive situations, such as in the last form of a PROGN, one -function, FOO, may want to call another function, BAR, and return ``whatever -BAR returns.'' Call-Multiple is used in this case. If BAR returns multiple -values, they will all be passed to FOO. If FOO's caller wants multiple values, -the values will be returned. If not, FOO's Return instruction will see that -there are multiple values on the stack, but that multiple values will not be -accepted by FOO's caller. So Return will return only the first value. - -@section [Non-Local Exits] -@label [Catch] -@index [Catch] -@index [Throw] -@index [Catch-All object] -@index [Unwind-Protect] -@index [Non-Local Exits] - -The Catch and Unwind-Protect special forms are implemented using -catch frames. Unwind-Protect builds a catch frame whose tag is the -Catch-All object. The Catch miscop creates a catch frame for a -given tag and PC to branch to in the current instruction. The Throw -miscop looks up the stack by following the chain of catch frames -until it finds a frame with a matching tag or a frame with the -Catch-All object as its tag. If it finds a frame with a matching -tag, that frame is ``returned from,'' and that function is resumed. -If it finds a frame with the Catch-All object as its tag, that frame -is ``returned from,'' and in addition, %SP-Internal-Throw-Tag is set -to the tag being searched for. So that interrupted cleanup forms -behave correctly, %SP-Internal-Throw-Tag should be bound to the -Catch-All object before the Catch-All frame is built. The protected -forms are then executed, and if %SP-Internal-Throw-Tag is not the -Catch-All object, its value is thrown to. Exactly what we do is -this: -@begin [enumerate] -Put the contents of the Active-Catch register into a register, A. -Put NIL into another register, B. - -If A is NIL, the tag we seek isn't on the stack. Signal an -Unseen-Throw-Tag error. - -Look at the tag for the catch frame in register A. If it's the tag -we're looking for, go to step 4. If it's the Catch-All object and B -is NIL, copy A to B. Set A to the previous catch frame and go back -to step 2. - -If B is non-NIL, we need to execute some cleanup forms. Return into -B's frame and bind %SP-Internal-Throw-Tag to the tag we're searching -for. When the cleanup forms are finished executing, they'll throw to -this tag again. - -If B is NIL, return into this frame, pushing the return value (or -BLTing the multiple values if this frame accepts multiple values and -there are multiple values). -@end [enumerate] - -If no form inside of a Catch results in a Throw, the catch frame -needs to be removed from the stack before execution of the function -containing the throw is resumed. For now, the value produced by the -forms inside the Catch form are thrown to the tag. Some sort of -specialized miscop could be used for this, but right now we'll -just go with the throw. The branch PC specified by a Catch -miscop is part of the constants area of the function object, -much like the function's entry points. - -@section [Escaping to Lisp code] -@label [Escape] -@index [Escape to Lisp code convention] - -Escaping to Lisp code is fairly straight forward. If a miscop discovers that -it needs to call a Lisp function, it creates a call frame on the control -stack and sets it up so that the called function returns to the function that -called the miscop. This means it is impossible to return control to a miscop -from a Lisp function. - -@section [Errors] -@label [Errors] -@index [Errors] - -When an error occurs during the execution of a miscop, a call -to %SP-Internal-Error is performed. This call is a break-type call, -so if the error is proceeded (with a Break-Return instruction), no -value will be returned. - - -%SP-Internal-Error is passed a fixnum error code as its first -argument. The second argument is a fixnum offset into the current -code vector that points to the location immediately following the -instruction that encountered the trouble. From this offset, the -Lisp-level error handler can reconstruct the PC of the losing -instruction, which is not readily available in the micro-machine. -Following the offset, there may be 0 - 2 additional arguments that -provide information of possible use to the error handler. For -example, an unbound-symbol error will pass the symbol in question as -the third arg. - -The following error codes are currently defined. Unless otherwise -specified, only the error code and the code-vector offset are passed -as arguments. - -@begin -[description] -1 Object Not List@\The object is passed as the third argument. - -2 Object Not Symbol@\The object is passed as the third argument. - -3 Object Not Number@\The object is passed as the third argument. - -4 Object Not Integer@\The object is passed as the third argument. - -5 Object Not Ratio@\The object is passed as the third argument. - -6 Object Not Complex@\The object is passed as the third argument. - -7 Object Not Vector@\The object is passed as the third argument. - -8 Object Not Simple Vector@\The object is passed as the third argument. - -9 Illegal Function Object@\The object is passed as the third argument. - -10 Object Not Header@\The object (which is not an array or function header) -is passed as the third argument. - -11 Object Not I-Vector@\The object is passed as the third argument. - -12 Object Not Simple Bit Vector@\The object is passed as the third argument. - -13 Object Not Simple String@\The object is passed as the third argument. - -14 Object Not Character@\The object is passed as the third argument. - -15 Object Not Control Stack Pointer@\The object is passed as the third -argument. - -16 Object Not Binding Stack Pointer@\The object is passed as the third -argument. - -17 Object Not Array@\The object is passed as the third argument. - -18 Object Not Non-negative Fixnum@\The object is passed as the third -argument. - -19 Object Not System Area Pointer@\The object is passed as the third -argument. - -20 Object Not System Pointer@\The object is passed as the third argument. - -21 Object Not Float@\The object is passed as the third argument. - -22 Object Not Rational@\The object is passed as the third argument. - -23 Object Not Non-Complex Number@\A complex number has been passed to -the comparison routine for < or >. The complex number is passed as the -third argument. - -25 Unbound Symbol @\Attempted access to the special value of an unbound -symbol. Passes the symbol as the third argument to %Sp-Internal-Error. - -26 Undefined Symbol @\Attempted access to the definition cell of an undefined -symbol. Passes the symbol as the third argument to %Sp-Internal-Error. - -27 Altering NIL @\Attempt to bind or setq the special value of NIL. - -28 Altering T @\Attempt to bind or setq the special value of T. - -30 Illegal Vector Access Type @\The specified access type is returned as the -third argument. - -31 Illegal Vector Size @\Attempt to allocate a vector with negative size or -size too large for vectors of this type. Passes the requested size as the -third argument. - -32 Vector Index Out of Range @\The specified index is out of bounds for -this vector. The bad index is passed as the third argument. - -33 Illegal Vector Index@\The specified index is not a positive fixnum. The -bad index is passed as the third argument. - -34 Illegal Shrink Vector Value@\The specified value to shrink a vector to is -not a positive fixnum. The bad value is passed as the third argument. - -35 Not A Shrink@\The specified value is greater than the current size of the -vector being shrunk. The bad value is passed as the third argument. - -36 Illegal Data Vector@\The data vector of an array is illegal. The bad -vector is passed as the third value. - -37 Array has Too Few Indices@\An attempt has been made to access -an array as a two or three dimensional array when it has fewer than two -or three dimensions, respectively. - -38 Array has Too Many Indices@\An attempt has been made to access an array -as a two or three dimensional array when it has more than two or three -dimensions, respectively. - -40 Illegal Byte Specifier@\A bad byte specifier has been passed to one -of the byte manipulation miscops. The offending byte specifier is passed -as the third argument. - -41 Illegal Position in Byte Specifier@\A bad position has been given in a -byte specifier that has been passed to one of the byte manipulation -miscops. The offending byte specifier is passed as the third -argument. - -42 Illegal Size in Byte Specifier@\A bad size has been given in a -byte specifier that has been passed to one of the byte manipulation -miscops. The offending byte specifier is passed as the third -argument. - -43 Illegal Shift Count@\A shift miscop has encountered non fixnum shift -count. The offending shift count is passed as the third argument. - -44 Illegal Boole Operation@\The operation code passed to the boole miscop -is either not a fixnum or is out of range. The operation code is passed as -the third argument. - -50 Too Few Arguments@\Too few arguments have been passed to a function. The -number of arguments actually passed is passed as the third argument, and the -function is passed as the fourth. - -51 Too Many Arguments@\Too many arguments have been passed to a function. -The number of arguments actually passed is passed as the third argument, and -the function is passed as the fourth. - -52 Last Apply Arg Not a List@\The last argument to a function being -invoked by apply is not a list. The last argument is passed as the third -argument. - -53 Deleted Link Table Entry@\An attempt has been made to call a function -through a link table entry which no longer exists. This is a serious -internal error and should never happen. - -55 Error Not <=@\The check-<= miscop will invoke this error if the condition -is false. The two arguments are passed as the third and fourth arguments -to %SP-internal-error. - -60 Divide by 0@\An division operation has done a division by zero. The -two operands are passed as the third and fourth arguments. - -61 Unseen Throw Tag@\An attempt has been made to throw to a tag that is -not in the current catch hierarchy. The offending tag is passed as the -third argument. - -62 Short Float Underflow@\A short float operation has resulted in -underflow. The two arguments to the operation are passed as the third -and fourth arguments. - -63 Short Float Overflow@\A short float operation has resulted in -overflow. The two arguments to the operation are passed as the third -and fourth arguments. - -64 Single Float Underflow@\A single float operation has resulted in -underflow. The two arguments to the operation are passed as the third -and fourth arguments. - -65 Single Float Overflow@\A single float operation has resulted in -overflow. The two arguments to the operation are passed as the third -and fourth arguments. - -66 Long Float Underflow@\A long float operation has resulted in -underflow. The two arguments to the operation are passed as the third -and fourth arguments. - -67 Long Float Overflow@\A long float operation has resulted in -overflow. The two arguments to the operation are passed as the third -and fourth arguments. - -68 Monadic Short Float Underflow@\A short float operation has resulted in -underflow. The argument to the operation is passed as the third argument. - -69 Monadic Short Float Overflow@\A short float operation has resulted in -overflow. The argument to the operation is passed as the third argument. - -70 Monadic Long Float Underflow@\A long float operation has resulted in -underflow. The argument to the operation is passed as the third argument. - -71 Monadic Long Float Overflow@\A long float operation has resulted in -overflow. The argument to the operation is passed as the third argument. -@end [description] - -@section [Trapping to the Mach Kernel] -@label [Trap] -@index [Trapping to the kernel] -@index [Kernel traps] - -Trapping to the Mach kernel is done through one of the syscall0, syscall1, -syscall2, syscall3, syscall4, or syscall miscops. The first argument to -these miscops is the number of the Unix syscall that is to be invoked. Any -other arguments the syscall requires are passed in order after the first -one. Syscall0 accepts only the syscall number and no other arguments; -syscall1 accepts the syscall number and a single argument to the syscall; -etc. Syscall accepts the syscall number and five or more arguments to the -Unix syscall. These syscalls generally return two values: the result twice -if the syscall succeeded and a -1 and the Unix error code if the syscall -failed. - -@section [Interrupts] -@label [Interrupts] -@index [Interrupts] - -An interface has been built to the general signal mechanism defined by the -Unix operating system. As mentioned in the section on function call and -return miscops, several miscops are defined that support the lowest level -interface to the Unix signal mechanism. The manual @I[CMU Common Lisp -User's Manual, Mach/IBM RT PC Edition] contains descriptions of functions -that allow a user to set up interrupt handlers for any of the Unix signals -from within Lisp. - -@appendix [Fasload File Format] -@section [General] - -The purpose of Fasload files is to allow concise storage and rapid -loading of Lisp data, particularly function definitions. The intent -is that loading a Fasload file has the same effect as loading the -ASCII file from which the Fasload file was compiled, but accomplishes -the tasks more efficiently. One noticeable difference, of course, is -that function definitions may be in compiled form rather than -S-expression form. Another is that Fasload files may specify in what -parts of memory the Lisp data should be allocated. For example, -constant lists used by compiled code may be regarded as read-only. - -In some Lisp implementations, Fasload file formats are designed to -allow sharing of code parts of the file, possibly by direct mapping -of pages of the file into the address space of a process. This -technique produces great performance improvements in a paged -time-sharing system. Since the Mach project is to produce a -distributed personal-computer network system rather than a -time-sharing system, efficiencies of this type are explicitly @i[not] -a goal for the CMU Common Lisp Fasload file format. - -On the other hand, CMU Common Lisp is intended to be portable, as it will -eventually run on a variety of machines. Therefore an explicit goal -is that Fasload files shall be transportable among various -implementations, to permit efficient distribution of programs in -compiled form. The representations of data objects in Fasload files -shall be relatively independent of such considerations as word -length, number of type bits, and so on. If two implementations -interpret the same macrocode (compiled code format), then Fasload -files should be completely compatible. If they do not, then files -not containing compiled code (so-called "Fasdump" data files) should -still be compatible. While this may lead to a format which is not -maximally efficient for a particular implementation, the sacrifice of -a small amount of performance is deemed a worthwhile price to pay to -achieve portability. - -The primary assumption about data format compatibility is that all -implementations can support I/O on finite streams of eight-bit bytes. -By "finite" we mean that a definite end-of-file point can be detected -irrespective of the content of the data stream. A Fasload file will -be regarded as such a byte stream. - -@section [Strategy] - -A Fasload file may be regarded as a human-readable prefix followed by -code in a funny little language. When interpreted, this code will -cause the construction of the encoded data structures. The virtual -machine which interprets this code has a @i[stack] and a @i[table], -both initially empty. The table may be thought of as an expandable -register file; it is used to remember quantities which are needed -more than once. The elements of both the stack and the table are -Lisp data objects. Operators of the funny language may take as -operands following bytes of the data stream, or items popped from the -stack. Results may be pushed back onto the stack or pushed onto the -table. The table is an indexable stack that is never popped; it is -indexed relative to the base, not the top, so that an item once -pushed always has the same index. - -More precisely, a Fasload file has the following macroscopic -organization. It is a sequence of zero or more groups concatenated -together. End-of-file must occur at the end of the last group. Each -group begins with a series of seven-bit ASCII characters terminated -by one or more bytes of all ones (FF@-(16)); this is called the -@i[header]. Following the bytes which terminate the header is the -@i[body], a stream of bytes in the funny binary language. The body -of necessity begins with a byte other than FF@-(16). The body is -terminated by the operation @f[FOP-END-GROUP]. - -The first nine characters of the header must be "@f[FASL FILE]" in -upper-case letters. The rest may be any ASCII text, but by -convention it is formatted in a certain way. The header is divided -into lines, which are grouped into paragraphs. A paragraph begins -with a line which does @i[not] begin with a space or tab character, -and contains all lines up to, but not including, the next such line. -The first word of a paragraph, defined to be all characters up to but -not including the first space, tab, or end-of-line character, is the -@i[name] of the paragraph. A Fasload file header might look something like -this: -@begin(verbatim) -FASL FILE >SteelesPerq>User>Guy>IoHacks>Pretty-Print.Slisp -Package Pretty-Print -Compiled 31-Mar-1988 09:01:32 by some random luser -Compiler Version 1.6, Lisp Version 3.0. -Functions: INITIALIZE DRIVER HACK HACK1 MUNGE MUNGE1 GAZORCH - MINGLE MUDDLE PERTURB OVERDRIVE GOBBLE-KEYBOARD - FRY-USER DROP-DEAD HELP CLEAR-MICROCODE - %AOS-TRIANGLE %HARASS-READTABLE-MAYBE -Macros: PUSH POP FROB TWIDDLE -@r[<one or more bytes of FF@-(16)>] -@end(verbatim) -The particular paragraph names and contents shown here are only intended as -suggestions. - -@section [Fasload Language] - -Each operation in the binary Fasload language is an eight-bit -(one-byte) opcode. Each has a name beginning with "@f[FOP-]". In -the following descriptions, the name is followed by operand -descriptors. Each descriptor denotes operands that follow the opcode -in the input stream. A quantity in parentheses indicates the number -of bytes of data from the stream making up the operand. Operands -which implicitly come from the stack are noted in the text. The -notation "@PushArrow stack" means that the result is pushed onto the -stack; "@PushArrow table" similarly means that the result is added to the -table. A construction like "@i[n](1) @i[value](@i[n])" means that -first a single byte @i[n] is read from the input stream, and this -byte specifies how many bytes to read as the operand named @i[value]. -All numeric values are unsigned binary integers unless otherwise -specified. Values described as "signed" are in two's-complement form -unless otherwise specified. When an integer read from the stream -occupies more than one byte, the first byte read is the least -significant byte, and the last byte read is the most significant (and -contains the sign bit as its high-order bit if the entire integer is -signed). - -Some of the operations are not necessary, but are rather special -cases of or combinations of others. These are included to reduce the -size of the file or to speed up important cases. As an example, -nearly all strings are less than 256 bytes long, and so a special -form of string operation might take a one-byte length rather than a -four-byte length. As another example, some implementations may -choose to store bits in an array in a left-to-right format within -each word, rather than right-to-left. The Fasload file format may -support both formats, with one being significantly more efficient -than the other for a given implementation. The compiler for any -implementation may generate the more efficient form for that -implementation, and yet compatibility can be maintained by requiring -all implementations to support both formats in Fasload files. - -Measurements are to be made to determine which operation codes are -worthwhile; little-used operations may be discarded and new ones -added. After a point the definition will be "frozen", meaning that -existing operations may not be deleted (though new ones may be added; -some operations codes will be reserved for that purpose). - -@begin(description) -0 @f[ ] @f[FOP-NOP] @\ -No operation. (This is included because it is recognized -that some implementations may benefit from alignment of operands to some -operations, for example to 32-bit boundaries. This operation can be used -to pad the instruction stream to a desired boundary.) - -1 @f[ ] @f[FOP-POP] @f[ ] @PushArrow @f[ ] table @\ -One item is popped from the stack and added to the table. - -2 @f[ ] @f[FOP-PUSH] @f[ ] @i[index](4) @f[ ] @PushArrow @f[ ] stack @\ -Item number @i[index] of the table is pushed onto the stack. -The first element of the table is item number zero. - -3 @f[ ] @f[FOP-BYTE-PUSH] @f[ ] @i[index](1) @f[ ] @PushArrow @f[ ] stack @\ -Item number @i[index] of the table is pushed onto the stack. -The first element of the table is item number zero. - -4 @f[ ] @f[FOP-EMPTY-LIST] @f[ ] @PushArrow @f[ ] stack @\ -The empty list (@f[()]) is pushed onto the stack. - -5 @f[ ] @f[FOP-TRUTH] @f[ ] @PushArrow @f[ ] stack @\ -The standard truth value (@f[T]) is pushed onto the stack. - -6 @f[ ] @f[FOP-SYMBOL-SAVE] @f[ ] @i[n](4) @f[ ] @i[name](@i[n]) -@f[ ] @PushArrow @f[ ] stack & table@\ -The four-byte operand @i[n] specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the default package, -and the resulting symbol is both pushed onto the stack and added to the table. - -7 @f[ ] @f[FOP-SMALL-SYMBOL-SAVE] @f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ] @PushArrow @f[ ] stack & table@\ -The one-byte operand @i[n] specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the default package, -and the resulting symbol is both pushed onto the stack and added to the table. - -8 @f[ ] @f[FOP-SYMBOL-IN-PACKAGE-SAVE] @f[ ] @i[index](4) -@f[ ] @i[n](4) @f[ ] @i[name](@i[n]) -@f[ ] @PushArrow @f[ ] stack & table@\ -The four-byte @i[index] specifies a package stored in the table. -The four-byte operand @i[n] specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the specified package, -and the resulting symbol is both pushed onto the stack and added to the table. - -9 @f[ ] @f[FOP-SMALL-SYMBOL-IN-PACKAGE-SAVE] @f[ ] @i[index](4) -@f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ] -@PushArrow @f[ ] stack & table@\ -The four-byte @i[index] specifies a package stored in the table. -The one-byte operand @i[n] specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the specified package, -and the resulting symbol is both pushed onto the stack and added to the table. - -10 @f[ ] @f[FOP-SYMBOL-IN-BYTE-PACKAGE-SAVE] @f[ ] @i[index](1) -@f[ ] @i[n](4) @f[ ] @i[name](@i[n]) -@f[ ] @PushArrow @f[ ] stack & table@\ -The one-byte @i[index] specifies a package stored in the table. -The four-byte operand @i[n] specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the specified package, -and the resulting symbol is both pushed onto the stack and added to the table. - -11@f[ ] @f[FOP-SMALL-SYMBOL-IN-BYTE-PACKAGE-SAVE] @f[ ] @i[index](1) -@f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ] -@PushArrow @f[ ] stack & table@\ -The one-byte @i[index] specifies a package stored in the table. -The one-byte operand @i[n] specifies the length of the print name -of a symbol. The name follows, one character per byte, -with the first byte of the print name being the first read. -The name is interned in the specified package, -and the resulting symbol is both pushed onto the stack and added to the table. - -12 Unused. - -13 @f[ ] @f[FOP-DEFAULT-PACKAGE] @f[ ] @i[index](4) @\ -A package stored in the table entry specified by @i[index] is made -the default package for future @f[FOP-SYMBOL] and @f[FOP-SMALL-SYMBOL] -interning operations. (These package FOPs may change or disappear -as the package system is determined.) - -14 @f[ ] @f[FOP-PACKAGE] @f[ ] @PushArrow @f[ ] table @\ -An item is popped from the stack; it must be a symbol. The package of -that name is located and pushed onto the table. - -15 @f[ ] @f[FOP-LIST] @f[ ] @i[length](1) @f[ ] @PushArrow @f[ ] stack @\ -The unsigned operand @i[length] specifies a number of -operands to be popped from the stack. These are made into a list -of that length, and the list is pushed onto the stack. -The first item popped from the stack becomes the last element of -the list, and so on. Hence an iterative loop can start with -the empty list and perform "pop an item and cons it onto the list" -@i[length] times. -(Lists of length greater than 255 can be made by using @f[FOP-LIST*] -repeatedly.) - -16 @f[ ] @f[FOP-LIST*] @f[ ] @i[length](1) @f[ ] @PushArrow @f[ ] stack @\ -This is like @f[FOP-LIST] except that the constructed list is terminated -not by @f[()] (the empty list), but by an item popped from the stack -before any others are. Therefore @i[length]+1 items are popped in all. -Hence an iterative loop can start with -a popped item and perform "pop an item and cons it onto the list" -@i[length]+1 times. - -17-24 @f[ ] @f[FOP-LIST-1], @f[FOP-LIST-2], ..., @f[FOP-LIST-8] @\ -@f[FOP-LIST-@i{k}] is like @f[FOP-LIST] with a byte containing @i[k] -following it. These exist purely to reduce the size of Fasload files. -Measurements need to be made to determine the useful values of @i[k]. - -25-32 @f[ ] @f[FOP-LIST*-1], @f[FOP-LIST*-2], ..., @f[FOP-LIST*-8] @\ -@f[FOP-LIST*-@i{k}] is like @f[FOP-LIST*] with a byte containing @i[k] -following it. These exist purely to reduce the size of Fasload files. -Measurements need to be made to determine the useful values of @i[k]. - -33 @f[ ] @f[FOP-INTEGER] @f[ ] @i[n](4) @f[ ] @i[value](@i[n]) @f[ ] -@PushArrow @f[ ] stack @\ -A four-byte unsigned operand specifies the number of following -bytes. These bytes define the value of a signed integer in two's-complement -form. The first byte of the value is the least significant byte. - -34 @f[ ] @f[FOP-SMALL-INTEGER] @f[ ] @i[n](1) @f[ ] @i[value](@i[n]) -@f[ ] @PushArrow @f[ ] stack @\ -A one-byte unsigned operand specifies the number of following -bytes. These bytes define the value of a signed integer in two's-complement -form. The first byte of the value is the least significant byte. - -35 @f[ ] @f[FOP-WORD-INTEGER] @f[ ] @i[value](4) @f[ ] @PushArrow @f[ ] stack @\ -A four-byte signed integer (in the range -2@+[31] to 2@+[31]-1) follows the -operation code. A LISP integer (fixnum or bignum) with that value -is constructed and pushed onto the stack. - -36 @f[ ] @f[FOP-BYTE-INTEGER] @f[ ] @i[value](1) @f[ ] @PushArrow @f[ ] stack @\ -A one-byte signed integer (in the range -128 to 127) follows the -operation code. A LISP integer (fixnum or bignum) with that value -is constructed and pushed onto the stack. - -37 @f[ ] @f[FOP-STRING] @f[ ] @i[n](4) @f[ ] @i[name](@i[n]) -@f[ ] @PushArrow @f[ ] stack @\ -The four-byte operand @i[n] specifies the length of a string to -construct. The characters of the string follow, one per byte. -The constructed string is pushed onto the stack. - -38 @f[ ] @f[FOP-SMALL-STRING] @f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ] @PushArrow @f[ ] stack @\ -The one-byte operand @i[n] specifies the length of a string to -construct. The characters of the string follow, one per byte. -The constructed string is pushed onto the stack. - -39 @f[ ] @f[FOP-VECTOR] @f[ ] @i[n](4) @f[ ] @PushArrow @f[ ] stack @\ -The four-byte operand @i[n] specifies the length of a vector of LISP objects -to construct. The elements of the vector are popped off the stack; -the first one popped becomes the last element of the vector. -The constructed vector is pushed onto the stack. - -40 @f[ ] @f[FOP-SMALL-VECTOR] @f[ ] @i[n](1) @f[ ] @PushArrow @f[ ] stack @\ -The one-byte operand @i[n] specifies the length of a vector of LISP objects -to construct. The elements of the vector are popped off the stack; -the first one popped becomes the last element of the vector. -The constructed vector is pushed onto the stack. - -41 @f[ ] @f[FOP-UNIFORM-VECTOR] @f[ ] @i[n](4) @f[ ] @PushArrow @f[ ] stack @\ -The four-byte operand @i[n] specifies the length of a vector of LISP objects -to construct. A single item is popped from the stack and used to initialize -all elements of the vector. The constructed vector is pushed onto the stack. - -42 @f[ ] @f[FOP-SMALL-UNIFORM-VECTOR] @f[ ] @i[n](1) @f[ ] @PushArrow @f[ ] stack @\ -The one-byte operand @i[n] specifies the length of a vector of LISP objects -to construct. A single item is popped from the stack and used to initialize -all elements of the vector. The constructed vector is pushed onto the stack. - -43 @f[ ] @f[FOP-INT-VECTOR] @f[ ] @i[n](4) @f[ ] @i[size](1) @f[ ] @i[count](1) @f[ ] -@i[data](@ceiling<@i[n]/@i[count]>@ceiling<@i[size]*@i[count]/8>) @f[ ] -@PushArrow @f[ ] stack @\ -The four-byte operand @i[n] specifies the length of a vector of -unsigned integers to be constructed. Each integer is @i[size] -bits big, and are packed in the data stream in sections of -@i[count] apiece. Each section occupies an integral number of bytes. -If the bytes of a section are lined up in a row, with the first -byte read at the right, and successive bytes placed to the left, -with the bits within a byte being arranged so that the low-order bit -is to the right, then the integers of the section are successive -groups of @i[size] bits, starting from the right and running across -byte boundaries. (In other words, this is a consistent -right-to-left convention.) Any bits wasted at the left end of -a section are ignored, and any wasted groups in the last section -are ignored. -It is permitted for the loading implementation to use a vector -format providing more precision than is required by @i[size]. -For example, if @i[size] were 3, it would be permitted to use a vector -of 4-bit integers, or even vector of general LISP objects filled -with integer LISP objects. However, an implementation is expected -to use the most restrictive format that will suffice, and is expected -to reconstruct objects identical to those output if the Fasload file -was produced by the same implementation. -(For the PERQ U-vector formats, one would have -@i[size] an element of {1, 2, 4, 8, 16}, and @i[count]=32/@i[size]; -words could be read directly into the U-vector. -This operation provides a very general format whereby almost -any conceivable implementation can output in its preferred packed format, -and another can read it meaningfully; by checking at the beginning -for good cases, loading can still proceed quickly.) -The constructed vector is pushed onto the stack. - -44 @f[ ] @f[FOP-UNIFORM-INT-VECTOR] @f[ ] @i[n](4) @f[ ] @i[size](1) @f[ ] -@i[value](@ceiling<@i[size]/8>) @f[ ] @PushArrow @f[ ] stack @\ -The four-byte operand @i[n] specifies the length of a vector of unsigned -integers to construct. -Each integer is @i[size] bits big, and is initialized to the value -of the operand @i[value]. -The constructed vector is pushed onto the stack. - -45 @f[ ] @f[FOP-FLOAT] @f[ ] @i[n](1) @f[ ] @i[exponent](@ceiling<@i[n]/8>) @f[ ] -@i[m](1) @f[ ] @i[mantissa](@ceiling<@i[m]/8>) @f[ ] @PushArrow @f[ ] stack @\ -The first operand @i[n] is one unsigned byte, and describes the number of -@i[bits] in the second operand @i[exponent], which is a signed -integer in two's-complement format. The high-order bits of -the last (most significant) byte of @i[exponent] shall equal the sign bit. -Similar remarks apply to @i[m] and @i[mantissa]. The value denoted by these -four operands is @i[mantissa]@f[x]2@+{@i[exponent]-length(@i[mantissa])}. -A floating-point number shall be constructed which has this value, -and then pushed onto the stack. That floating-point format should be used -which is the smallest (most compact) provided by the implementation which -nevertheless provides enough accuracy to represent both the exponent -and the mantissa correctly. - -46-51 Unused - -52 @f[ ] @f[FOP-ALTER] @f[ ] @i[index](1) @\ -Two items are popped from the stack; call the first @i[newval] and -the second @i[object]. The component of @i[object] specified by -@i[index] is altered to contain @i[newval]. The precise operation -depends on the type of @i[object]: -@begin(description) -List @\ A zero @i[index] means alter the car (perform @f[RPLACA]), -and @i[index]=1 means alter the cdr (@f[RPLACD]). - -Symbol @\ By definition these indices have the following meaning, -and have nothing to do with the actual representation of symbols -in a given implementation: -@begin(description) -0 @\ Alter value cell. - -1 @\ Alter function cell. - -2 @\ Alter property list (!). -@end(description) - -Vector (of any kind) @\ Alter component number @i[index] of the vector. - -String @\ Alter character number @i[index] of the string. -@end(description) - -53 @f[ ] @f[FOP-EVAL] @f[ ] @PushArrow @f[ ] stack @\ -Pop an item from the stack and evaluate it (give it to @f[EVAL]). -Push the result back onto the stack. - -54 @f[ ] @f[FOP-EVAL-FOR-EFFECT] @\ -Pop an item from the stack and evaluate it (give it to @f[EVAL]). -The result is ignored. - -55 @f[ ] @f[FOP-FUNCALL] @f[ ] @i[nargs](1) @f[ ] @PushArrow @f[ ] stack @\ -Pop @i[nargs]+1 items from the stack and apply the last one popped -as a function to -all the rest as arguments (the first one popped being the last argument). -Push the result back onto the stack. - -56 @f[ ] @f[FOP-FUNCALL-FOR-EFFECT] @f[ ] @i[nargs](1) @\ -Pop @i[nargs]+1 items from the stack and apply the last one popped -as a function to -all the rest as arguments (the first one popped being the last argument). -The result is ignored. - -57 @f[ ] @f[FOP-CODE-FORMAT] @f[ ] @i[id](1) @\ -The operand @i[id] is a unique identifier specifying the format -for following code objects. The operations @f[FOP-CODE] -and its relatives may not -occur in a group until after @f[FOP-CODE-FORMAT] has appeared; -there is no default format. This is provided so that several -compiled code formats may co-exist in a file, and so that a loader -can determine whether or not code was compiled by the correct -compiler for the implementation being loaded into. -So far the following code format identifiers are defined: -@begin(description) -0 @\ PERQ - -1 @\ VAX - -3 @\ @value(DinkyMachine) -@end(description) - -58 @f[ ] @f[FOP-CODE] @f[ ] @i[nitems](4) @f[ ] @i[size](4) @f[ ] -@i[code](@i[size]) @f[ ] @PushArrow @f[ ] stack @\ -A compiled function is constructed and pushed onto the stack. -This object is in the format specified by the most recent -occurrence of @f[FOP-CODE-FORMAT]. -The operand @i[nitems] specifies a number of items to pop off -the stack to use in the "boxed storage" section. The operand @i[code] -is a string of bytes constituting the compiled executable code. - -59 @f[ ] @f[FOP-SMALL-CODE] @f[ ] @i[nitems](1) @f[ ] @i[size](2) @f[ ] -@i[code](@i[size]) @f[ ] @PushArrow @f[ ] stack @\ -A compiled function is constructed and pushed onto the stack. -This object is in the format specified by the most recent -occurrence of @f[FOP-CODE-FORMAT]. -The operand @i[nitems] specifies a number of items to pop off -the stack to use in the "boxed storage" section. The operand @i[code] -is a string of bytes constituting the compiled executable code. - -60 @f[ ] @f[FOP-STATIC-HEAP] @\ -Until further notice operations which allocate data structures -may allocate them in the static area rather than the dynamic area. -(The default area for allocation is the dynamic area; this -default is reset whenever a new group is begun. -This command is of an advisory nature; implementations with no -static heap can ignore it.) - -61 @f[ ] @f[FOP-DYNAMIC-HEAP] @\ -Following storage allocation should be in the dynamic area. - -62 @f[ ] @f[FOP-VERIFY-TABLE-SIZE] @f[ ] @i[size](4) @\ -If the current size of the table is not equal to @i[size], -then an inconsistency has been detected. This operation -is inserted into a Fasload file purely for error-checking purposes. -It is good practice for a compiler to output this at least at the -end of every group, if not more often. - -63 @f[ ] @f[FOP-VERIFY-EMPTY-STACK] @\ -If the stack is not currently empty, -then an inconsistency has been detected. This operation -is inserted into a Fasload file purely for error-checking purposes. -It is good practice for a compiler to output this at least at the -end of every group, if not more often. - -64 @f[ ] @f[FOP-END-GROUP] @\ -This is the last operation of a group. If this is not the -last byte of the file, then a new group follows; the next -nine bytes must be "@f[FASL FILE]". - -65 @f[ ] @f[FOP-POP-FOR-EFFECT] @f[ ] stack @f[ ] @PushArrow @f[ ] @\ -One item is popped from the stack. - -66 @f[ ] @f[FOP-MISC-TRAP] @f[ ] @PushArrow @f[ ] stack @\ -A trap object is pushed onto the stack. - -67 @f[ ] @f[FOP-READ-ONLY-HEAP] @\ -Following storage allocation may be in a read-only heap. -(For symbols, the symbol itself may not be in a read-only area, -but its print name (a string) may be. -This command is of an advisory nature; implementations with no -read-only heap can ignore it, or use a static heap.) - -68 @f[ ] @f[FOP-CHARACTER] @f[ ] @i[character](3) @f[ ] @PushArrow @f[ ] stack @\ -The three bytes specify the 24 bits of a CMU Common Lisp character object. -The bytes, lowest first, represent the code, control, and font bits. -A character is constructed and pushed onto the stack. - -69 @f[ ] @f[FOP-SHORT-CHARACTER] @f[ ] @i[character](1) @f[ ] -@PushArrow @f[ ] stack @\ -The one byte specifies the lower eight bits of a CMU Common Lisp character -object (the code). A character is constructed with zero control -and zero font attributes and pushed onto the stack. - -70 @f[ ] @f[FOP-RATIO] @f[ ] @PushArrow @f[ ] stack @\ -Creates a ratio from two integers popped from the stack. -The denominator is popped first, the numerator second. - -71 @f[ ] @f[FOP-COMPLEX] @f[ ] @PushArrow @f[ ] stack @\ -Creates a complex number from two numbers popped from the stack. -The imaginary part is popped first, the real part second. - -72 @f[ ] @f[FOP-LINK-ADDRESS-FIXUP] @f[ ] @i[nargs](1) @f[ ] @i[restp](1) -@f[ ] @i[offset](4) @f[ ] @PushArrow @f[ ] stack @\ -Valid only for when FOP-CODE-FORMAT corresponds to the Vax or the -@value(DinkyMachine). -This operation pops a symbol and a code object from the stack and pushes -a modified code object back onto the stack according to the needs of the -runtime code linker on the Vax or @value(DinkyMachine). - -73 @f[ ] @f[FOP-LINK-FUNCTION-FIXUP] @f[ ] @i[offset](4) @f[ ] -@PushArrow @f[ ] stack @\ -Valid only for when FOP-CODE-FORMAT corresponds to the Vax or the -@value(DinkyMachine). -This operation pops a symbol and a code object from the stack and pushes -a modified code object back onto the stack according to the needs of the -runtime code linker on the Vax or the @value(DinkyMachine). - -74 @f[ ] @f[FOP-FSET] @f[ ] @\ -Pops the top two things off of the stack and uses them as arguments to FSET -(i.e. SETF of SYMBOL-FUNCTION). - -128 @f[ ] @f[FOP-LINK-ADDRESS-FIXUP] @f[ ] @i[nargs] @f[ ] @i[flag] @f[ ] -@i[offset] @f[ ]@\Valid only when FOP-CODE-FORMAT corresponds to the -@value(DinkyMachine). This operation pops a symbol and a function object -off the stack. The code vector in the function object is modified -according to the needs of the runtime code linker of the @value(DinkyMachine) -and pushed back on the stack. This FOP links in calls to other functions. - -129 @f[ ] @f[FOP-MISCOP-FIXUP] @f[ ] @i[index](2) @f[ ] @i[offset](4) @f[ ]@\ -Valid only when FOP-CODE-FORMAT corresponds to the @value(DinkyMachine). -This operation pops a code object from the stack and pushes a -modified code object back onto the stack according to the needs of -the runtime code linker on the @value(DinkyMachine). This FOP links in -calls to the assembler language support routines. - -130 @f[ ] @f[FOP-ASSEMBLER-ROUTINE] @f[ ] @i[code-length] @f[ ] @\ -Valid only when FOP-CODE-FORMAT corresponds to the @value(DinkyMachine). -This operation loads assembler code into the assembler code space of the -currently running Lisp. - -131 @f[ ] @f[FOP-FIXUP-MISCOP-ROUTINE] @f[ ]@\Valid only when FOP-CODE-FORMAT -corresponds to the @value(DinkyMachine). This operation pops a list of -external references, a list of external labels defined, the name, and the -code address off the stack. This information is saved, so that after -everything is loaded, all the external references can be resolved. - -132 @f[ ] @f[FOP-FIXUP-ASSEMBLER-ROUTINE] @f[ ]@\is similar to -FOP-FIXUP-MISCOP-ROUTINE, except it is for internal assembler routines -rather than ones visible to Lisp. - -133 @f[ ] @f[FOP-FIXUP-USER-MISCOP-ROUTINE] @f[ ]@\is similar to -FOP-FIXUP-MISCOP-ROUTINE, except it is for routines written by users who -have an extremely good understanding of the system internals. - -134 @f[ ] @f[FOP-USER-MISCOP-FIXUP] @f[ ] @i[offset](4) @f[ ]@\is similar -to FOP-MISCOP-FIXUP, but is used to link in user defined miscops. - -255 @f[ ] @f[FOP-END-HEADER] @\ Indicates the end of a group header, as described above. -@end(description) - -@Appendix[Building CMU Common Lisp] - -@section(Introduction) -This document explains how to build a working Common Lisp from source code on -the IBM RT PC under the Mach operating system. You should already have a -working Common Lisp running on an IBM RT PC before trying to build a new Common -Lisp. - -Throughout this document the following terms are used: -@begin(Description) -Core file@\A core file is a file containing an image of a Lisp system. The -core file contains header information describing where the data in the rest of -the file should be placed in memory. There is a simple C program which reads a -core file into memory at the correct locations and then jumps to a location -determined by the contents of the core file. The C code includes the X -window system version 10 release 4 which may be called from Lisp. - - -Cold core file @\A cold core file contains enough of the Lisp system to make it -possible to load in the rest of the code necessary to generate a full Common -Lisp. A cold core file is generated by the program Genesis. - -Miscops@\Miscops are assembler language routines that are used to support -compiled Lisp code. A Lisp macro assembler provides a -convenient mechanism for writing these assembler language routines. - -Matchmaker@\Matchmaker is a program developed to automatically generate -remote procedure call interfaces between programs. Matchmaker accepts -a description of a remote procedure call interface and generates code -that implements it. -@end(Description) - -There are many steps required to go from sources to a working Common Lisp -system. Each step will be explained in detail in the following sections. -It is possible to perform more than one step with one invocation of Lisp. -However, I recommend that each step be started with a fresh Lisp. There -is some small chance that something done in one step will adversely affect -a following step if the same Lisp is used. The scripts for each -step assume that you are in the user package which is the default when -Lisp first starts up. If you change to some other package, some of these -steps may not work correctly. - -In many of the following steps, there are lines setting up search lists so that -command files know where to find the sources. What I have done is create a -init.lisp file that sets up these search lists for me. This file is -automatically loaded from the user's home directory (as determined by the -@b[HOME] environment variable) when you start up Lisp. Note that my init.lisp -file is included with the sources. You may have to modify it, if you change -where the lisp sources are. - -@section(Installing Source Code) -With this document, you should also have received a tape cartridge in tar -format containing the complete Common Lisp source code. You should create -some directory where you want to put the source code. For the following -discussion, I will assume that the source code lives in the directory -/usr/lisp. To install the source code on your machine, issue the following -commands: -@begin(Example) -cd /usr/lisp -tar xvf <tape device> -@end(Example) -The first command puts you into the directory where you want the source code, -and the second extracts all the files and sub-directories from the tape into -the current directory. <Tape device> should be the name of the tape device on -your machine, usually /dev/st0. - -The following sub-directories will be created by tar: -@begin(Description) -bin@\contains a single executable file, lisp, which is a C program -used to start up Common Lisp. - -clc@\contains the Lisp source code for the Common Lisp compiler and assembler. - -code@\contains the Lisp source code that corresponds to all the functions, -variables, macros, and special forms described in @i[Common Lisp: The Language] -by Guy L. Steele Jr., as well as some Mach specific files. - -hemlock@\contains the Lisp source code for Hemlock, an emacs-like editor -written completely in Common Lisp. - -icode@\contains Matchmaker generated code for interfaces to Inter Process -Communication (IPC) routines. This code is used to communicate with other -processes using a remote procedure call mechanism. Under Mach, all the -facilities provided by Mach beyond the normal Berkeley Unix 4.3 system -calls are accessed from Lisp using this IPC mechanism. Currently, the -code for the Mach, name server, Lisp typescript, and Lisp eval server -interfaces reside in this directory. - -idefs@\contains the Matchmaker definition files used to generate the Lisp -code in the icode directory. - -lib@\contains files needed to run Lisp. The file lisp.core is known as a -Lisp core file and is loaded into memory by the lisp program mentioned -above in the entry for the bin directory. This file has a format which -allows it to be mapped into memory at the correct locations. The files -spell-dictionary.text and spell-dictionary.bin are the text and binary -form of a dictionary, respectively, used by Hemlock's spelling checker and -corrector. The two files hemlock.cursor and hemlock.mask are used by -Hemlock when running under the X window system. - -miscops@\contains the Lisp assembler source code for all the miscops -that support low level Lisp functions, such as storage allocation, -complex operations that can not performed in-line, garbage collection, and -other operations. These routines are written in assembler, so that they -are as efficient as possible. These routines use a very short calling -sequence, so calling them is very cheap compared to a normal Lisp -function call. - -mm@\contains the Lisp source code for the Matchmaker program. This program -is used to generate the Lisp source code files in icode from the corresponding -matchmaker definitions in idefs. - -pcl@\contains the Lisp source code for a version of the Common Lisp Object -System (originally Portable Common Loops), -an object oriented programming language built on top of Common Lisp. - -X@\contains the C object files for X version 10 release 4 C library -routines. These are linked with the lisp startup code, so that X is -available from Lisp. - -scribe@\contains Scribe source and postscript output for the manuals -describing various aspects of the CMU Common Lisp implementation. - -demos@\contains the Lisp source code for various demonstration programs. -This directory contains the Gabriel benchmark set (bmarks.lisp) and -a sub-directory containing the Soar program which is also used for -benchmarking purposes. There may be other programs and/or sub-directories -here that you may look at. -@end(Description) -These directories contain source files as well as Lisp object files. -This means it is not necessary to go through all the steps to -build a new a Common Lisp, only those steps that are affected by -a modification to the sources. For example, modifying the compiler -will require recompiling everything. Modifying a miscop file should -require only reassembling that particular file and rebuilding the -cold core file and full core file. - -As well as the directories mentioned above, there are also several files -contained in the top-level directory. These are: -@begin(Description) -init.lisp@\is a Lisp init file I use. This sets up some standard search -lists, as well as defines a Hemlock mode for editing miscop -source files. - -lisp.c@\contains the C code used to start up the lisp core image under Mach. - -lispstart.s@\contains some assembler language code that is invoked by lisp.c -to finish the process of starting up the lisp process. - -makefile@\contains make definitions for compiling lisp.c and lispstart.s -into the lisp program. - -rg@\contains some adb commands that can be read into adb while debugging a lisp -process. It prints out all the registers, the name of the currently -executing Lisp function, and sets an adb variable to the current stack frame -which is used by the following file. - -st@\contains some adb commands that can be read into adb while debugging -a lisp process. It prints out a Lisp stack frame and the name of the -function associated with the stack frame. It also updates the adb variable -mentioned above to point to the next stack frame. Repeatedly reading this -file into adb will produce a backtrace of all the active call frames -on the Lisp stack. - -ac@\contains some adb commands that print out the current values of the -active catch pointer. This points to the head of a list of catch frames -that exist on the control stack. - -cs@\contains some adb commands that print out the contents of a catch -frame. Reading cs into adb several times in a row (after reading ac once) -will print out the catch frames in order. -@end(Description) - -@section(Compiling the Lisp Startup Program) -To compile the lisp start up program, you should be in the top level directory -of the sources (/usr/lisp) and type: -@begin(Example) -make lisp -@end(Example) -This will compile the file lisp.c, assemble the file lispstart.s and produce -an executable file lisp. Currently the default location for the lisp core -file is /usr/misc/.lisp/lib/lisp.core. If you want to change this default -location, edit the file lisp.c and change the line -@begin(Example) -#define COREFILE "/usr/misc/.lisp/lib/lisp.core" -@end(Example) -to refer to the file where you intend to put the core file. - -This step takes a few seconds. - -@section(Assembling Assembler routines) -The standard core image includes a Lisp macro assembler. To assemble all -the miscops, the following steps should be performed: -@begin(Example) -(compile-file "/usr/lisp/clc/miscasm.lisp") -(load "/usr/lisp/clc/miscasm.fasl") -(setf (search-list "msc:") '("/usr/lisp/miscops/")) -(clc::asm-files) -@end(Example) -The first line compiles a file that contains a couple of functions used to -assemble miscop source files. The second line loads the resulting compiled -file into the currently executing core image. The third line defines the -msc search list which is used by the function clc::asm-files to locate -the miscop sources. The terminal will display information as each file -is assembled. For each file a .fasl, a .list, and an .err file will be -generated in /usr/lisp/miscops. - -This step takes about half an hour. - -@section(Compiling the Compiler) - -To compile the compiler is simple: -@begin(Example) -(setf (search-list "clc:") '("/usr/lisp/clc/")) -(load "clc:compclc.lisp") -@end(Example) -The first line just sets up a search list variable clc, so that the file -compclc.lisp can find the compiler sources. The terminal will display -information as each file is assembled. For each file a .fasl and an .err file -will be generated. A log of the compiler output is also displayed on the -terminal. - -This step takes about forty-five minutes. - -@section(Compiling the Lisp Sources) - -Compiling the Lisp source code is also easy: -@begin(Example) -(setf (search-list "code:") '("/usr/lisp/code/")) -(load "code:worldcom.lisp") -@end(Example) -Again, the first line defines a search list variable, so that the file -worldcom.lisp can find the Lisp sources. As each file is compiled, the -name of the file is printed on the terminal. For each file a .fasl will be -generated. Also, a single error log will be generated in the file -code:compile-lisp.log. - -This step takes about an hour and a half. - -@section(Compiling Hemlock) - -Compiling the Hemlock source code is done as follows: -@begin(Example) -(setf (search-list "hem:") '("/usr/lisp/hemlock/")) -(load "hem:ctw.lisp") -@end(Example) -Again, the first line defines a search list variable, so that ctw.lisp can -find the Hemlock sources. As each file is compiled, the name of the file is -printed on the terminal. For each file a .fasl will be generated. Also, a -single error log will be generated in the file hem:lossage.log. - -This step takes about forty-five minutes. - -@section(Compiling Matchmaker) -Compiling the matchmaker sources is done as follows: -@begin(Example) -(setf (search-list "mm:") '("/usr/lisp/mm")) -(compile-file "mm:mm.lisp") -(load "mm:mm.fasl") -(compile-mm) -@end(Example) -The first line sets up a search list, so that the matchmaker sources can be -found. The second line compiles the file containing a function for compiling -the matchmaker sources. The third line loads the file just -compiled, and the final line invokes the function compile-mm which compiles the -matchmaker sources. For each file, a .fasl and .err file is generated. Also, -a log of the compiler output is printed to the terminal. - -This step takes about 15 minutes - -@section(Generating Lisp Source Files from Matchmaker Definition Files) -The following sequence of commands is necessary to generate the Lisp -files for the Mach interface: -@begin(Example) -(setf (search-list "mm:") '("/usr/lisp/mm/")) -(setf (search-list "idefs:") '("/usr/lisp/idefs/")) -(setf (search-list "icode:") '("/usr/lisp/icode/")) -(setf (search-list "code:") '("/usr/lisp/code/")) -(setf (default-directory) "/usr/lisp/icode/") -(load "code:mm-interfaces.lisp") -@end(Example) -The first four lines set up search lists for mm (matchmaker sources), idefs -(matchmaker interface definition files), icode (Lisp matchmaker interface -sources), and code (Lisp code sources). The fifth line changes the current -working directory to be /usr/lisp/icode. This is where the output from -matchmaker will be placed. And finally, the last line invokes matchmaker on -the matchmaker definition files for all the interfaces. - -Matchmaker generates three files for each interface XXX: -@begin(Description) -XXXdefs.lisp@\contains constants and record definitions for the interface. - -XXXmsgdefs.lisp@\contains definitions of offsets to important fields in the -messages that are sent to and received from the interface. - -XXXuser.lisp@\contains code for each remote procedure, that sends a message -to the server and receives the reply from the server (if appropriate). -Each of these functions returns one or more values. The first value -returned is a general return which specifies whether the remote procedure -call succeeded or gives an indication of why it failed. Other values may -be returned depending on the particular remote procedure. These values are -returned using the multiple value mechanism of Common Lisp. -@end(Description) - -This step takes about five minutes. - -@section(Compiling Matchmaker Generated Lisp Files) -To compile the matchmaker generated Lisp files the following steps should -be performed: -@begin(Example) -(setf (search-list "code:") '("/usr/lisp/code/")) -(setf (search-list "icode:") '("/usr/lisp/icode/")) -(load "code:comutil.lisp") -@end(Example) -The first two lines set up search lists for the code and icode directory. -The final line loads a command file that compiles the Mach interface -definition in the correct order. Note that once the files are compiled, -the XXXmsgdefs files are no longer needed. The file -/usr/lisp/icode/lossage.log contains a listing of all the error messages -generated by the compiler. - -This step takes about fifteen minutes. - -@section(Compiling the Common Lisp Object System) - -To compile the Common Lisp Object System (CLOS) do the following: -@begin(Example) -(setf (search-list "pcl:") '("/usr/lisp/pcl/")) -(rename-package (find-package "CLOS") "OLD-CLOS") -(compile-file "pcl:defsys.lisp") -(load "pcl:defsys.fasl") -(clos::compile-pcl) -@end(Example) -The first line sets up a search list as usual. The second line renames the -CLOS package to be the OLD-CLOS package. This is so that the current version -of CLOS doesn't interfere with the compilation process. The third line -compiles a file containing some functions for building CLOS. The fourth -line loads in the result of the previous compilation. The final line -compiles all the CLOS files necessary for a working CLOS system. - -The file /usr/lisp/pcl/test.lisp is a file that contains some test functions. -To run it through CLOS build a new Lisp and start up a fresh Lisp -resulting from the build and do the following: -@begin(Example) -(in-package 'clos) -(compile-file "/usr/lisp/pcl/test.lisp") -(load "/usr/lisp/pcl/test.fasl") -@end(Example) -This sequence of function calls puts you in the CLOS package, compiles the -test file and then loads it. As the test file is loaded, it executes several -tests. It will print out a message specifying whether each test passed or -failed. - -Currently, CLOS is built into the standard core. - -This step takes about 30 minutes. - -@section(Compiling Genesis) -To compile genesis do the following: -@begin(Example) -(compile-file "/usr/lisp/clc/genesis.lisp") -@end(Example) -Genesis is used to build a cold core file. Compiling Genesis takes about five -minutes. - -@section(Building a Cold Core File) -Once all the files have been assembled or compiled as described above, it is -necessary to build a cold core file as follows: -@begin(Example) -(setf (search-list "code:") '("/usr/lisp/code/")) -(setf (search-list "icode:") '("/usr/lisp/icode/")) -(setf (search-list "msc:") '("/usr/lisp/miscops/")) -(load "/usr/lisp/clc/genesis.fasl") -(load "code:worldbuild.lisp") -@end(Example) -The first three lines set up search lists for the code, icode, and miscops -subdirectories. The fourth line loads in the program Genesis which builds -the cold core file. The last line calls Genesis on a list of the files that -are necessary to build the cold core file. As each file is being processed, -its name is printed to the terminal. Genesis generates two files: -/usr/lisp/ilisp.core and /usr/lisp/lisp.map. Ilisp.core is the cold core -file and lisp.map is a file containing the location of all the functions -and miscops in the cold core file. Lisp.map is useful for debugging the -cold core file. - -This step takes from about fifteen minutes. - -@section(Building a Full Common Lisp) -The cold core file built above does not contain some of the more useful -programs such as the compiler and hemlock. To build these into a core, it is -necessary to do the following: -@begin(Example) -lisp -c /usr/lisp/ilisp.core -(in-package "USER") -(load (open "/usr/lisp/code/worldload.lisp")) -@end(Example) -The first line invokes the lisp startup program specifying the cold core -file just built as the core file to load. This cold core file is set up -to do a significant amount of initialization and it is quite possible that -some bug will occur during this initialization process. After about a -minute, you should get a prompt of the form: -@begin(Example) -CMU Common Lisp kernel core image 2.7(?). -[You are in the Lisp Package.] -* -@end(Example) -The following two lines should then be entered. The first of these puts -you into the User package which is the package you should be in when the -full core is first started up. It is necessary to add this line, because -the current package is rebound while a file is loaded. The last line loads -in a file that loads in the compiler, hemlock, and some other files not yet -loaded. The open call is @b[essential] otherwise when the full core is -started up, load will try to close the file and probably invalidate memory -that is needed. When load is passed a stream, it does not automatically -close the stream. With a file name it now does after a recent bug fix. -This file prompts for the versions of the Lisp system, the compiler, and -hemlock. You should enter versions that make sense for your installation. -It then purifies the core image. Up to this point most of the Lisp system -has been loaded into dynamic space. Only a few symbols and some other data -structures are in static space. The process of purification moves Lisp -objects into static and read-only space, leaving very little in dynamic -space. Having the Lisp system in static and read-only space reduces the -amount of work the garbage collector has to do. Only those objects needed -in the final core file are retained. Finally, a new core file is generated -and is written to the file /usr/lisp/nlisp.core. Also, the currently -running Lisp should go through the default initialization process, finally -prompting for input with an asterisk. At this point you have successfully -built a new core file containing a complete Common Lisp implementation. - -This step takes about thirty minutes. - -@section(Debugging) -Debugging Lisp code is much easier with a fully functional Lisp. However, it -is quite possible that a change made in the system can cause a bug to happen -while running the cold core file. If this happens, it is best to use adb to -track down the problem. Unfortunately, the core file (i.e., the -remains of a process normally created by Unix when a process dies) generated by -such a bug will be of no use. To get some useful information, follow these -steps: -@begin(Enumerate) -Look at the file /usr/lisp/lisp.map and find the entry points for the -miscop routines error0, error1, and error2. These entry points are -used to invoke the Lisp error system from the miscops. Write down -the numbers beside these names. They are the addresses (in hex) of where -the miscops are located when the cold core file is loaded into memory. - -Run adb on the lisp file, i.e.: -@begin(example) -adb lisp -@end(Example) - -Set a breakpoint at the lispstart entry point: -@begin(Example) -lispstart:b -@end(Example) - -Start the lisp program running, telling it to use ilisp.core (I'm -assuming you're in /usr/lisp): -@begin(Example) -:r -c ilisp.core -@end(Example) - -After a while, you will hit the lispstart breakpoint. The core file has been -mapped into memory, but control is still in the C startup code. At this point, -you should enter breakpoints for all the error entry points described above. - -Continue running the program by typing :c. Shortly after this, the C lisp -program will give up control to Lisp proper. Lisp will start doing its -initialization and will probably hit one of the error break points. -At that point you can look around at the state and try and discover -what has gone wrong. Note that the two files rg and st are useful at this -point. Also, you should look at the document @i[Internal Design of Common -Lisp on the IBM RT PC] by David B. McDonald, Scott E. Fahlman, and Skef -Wholey so that you know the internal data structures. -@end(Enumerate) - -@section(Running the Soar Benchmark) -To compile the soar benchmark, you should do the following: -@begin(Example) -(compile-file "/usr/lisp/demos/soar/soar.lisp") -@end(Example) - -To run the benchmark, you should start up a fresh Lisp and do the following: -@begin(Example) -(load "/usr/lisp/demos/soar/soar.fasl") -(load "/usr/lisp/demos/soar/default.soar") -(load "/usr/lisp/demos/soar/eight.soar") -(user-select 'first) -(init-soar) -(time (run)) -@end(Example) -The first two lines load in the standard Soar system. The third line loads in -information about the eight puzzle which is a standard Soar puzzle that has -been run on several different machines. The fourth line sets up the puzzle -conditions so that it will select a goal to work on automatically. The fifth -line initializes Soar's working memory, etc. The final line is the one that -actually runs the benchmark. Soar prints out a fair amount of information as -it solves the puzzle. The final state should be numbered 143 when it finishes. -The time macro prints out information about information various resources after -the eight puzzle has run. - -@section(Summary) -I have tried to present sufficient information here to allow anyone to be -able to build a Common Lisp system under Mach from the sources. I am sure -there are many tricks that I have learned to use to reduce the amount of grief -necessary to build a system. My best recommendation is to go slowly. Start -by building a system from the sources provided on the tape. Make sure you -are comfortable doing that before you try modifying anything. - -Some hints on building the system which you may find useful: -@begin(Itemize) -If you change the compiler, you will have to recompile all the sources before -the change is reflected in a system. Changing the compiler is probably the -most dangerous change you can make, since an error here means that -nothing will work. In particular, this is the time you are going to need -to get familiar with adb and the internal structure of the Lisp, since a -serious error in the compiler will show up during the initialization of the -cold core file. - -Changing the miscops should be done with care. They follow a fairly rigid -convention and you should understand all the information provided in -@i[Internal Design of Common Lisp on the IBM RT PC] before making any changes -to miscops. You will probably need to get familiar with adb to debug some of -the changes. Note that this requires building a new cold core file and a final -core file before the change is reflected in the system. - -Changing sources in the code directory should be fairly straight forward. The -only time this will cause trouble is if you change something that a lot of -files depend on in which case you will have to recompile everything and build -a new cold core file and a core file. - -Changing hemlock should have no adverse effect on system integrity. - -If you make a fairly major change, it is a good idea to go through the complete -process of building a core file at least two or three times. If things are -still working at the end of this, your change is probably correct and shouldn't -cause any serious trouble. - -Finally, always keep at least one backup copy of a good core image around. -If you build a bad core file over an existing one and can't back up, it is -possible that you may not be able to recover from a serious error. -@end(Itemize) diff --git a/general-info/alpha-notes-thru-92.txt b/general-info/alpha-notes-thru-92.txt deleted file mode 100644 index 2ac0f4ae524b3a40940cde9c07a26aed01ccf98b..0000000000000000000000000000000000000000 --- a/general-info/alpha-notes-thru-92.txt +++ /dev/null @@ -1,3056 +0,0 @@ -11/23/92 to 12/5/92: - -Code: - -Minor fixes to LOOP and DELETE-PACKAGE. - -Low level support for various subtypes of function for use with Dylan. - - - -10/21/92 to 11/23/92: - -Code: - -Fixed ``enum'' alien types to always use up 32 bits to be compatable with -the various C compilers on the machines we are using. - -Fixed a bug in the ~<...~:> FORMAT directive where ~^ would blow out of -whatever the ~<...~:> was inside instead of just the ~<...~:>. - -Extended hash tables to allow user defined :tests. There is now a function -DEFINE-HASH-TABLE-TEST that takes three arguments: the symbol name of the -hash table test, the test function, and the hash function. It registers -the name, test function, and hash function so that MAKE-HASH-TABLE can be -called with either the name or the test function for the :test argument. -The hash function should take one argument (the object) and return a -positive fixnum hash value. - -Delete-package function added according to X3J13/92 specification. - -Fixed pprint-lambda-list to print a space before the dot when the tail of -the lambda list is shared. In other words, print (foo . #1=(bar baz)) -instead of (foo. #1=(bar baz)). - -The newest implementation of LOOP employs a recursive descent parser with -an intermediate representation in terms of variable, clause and loop -structures. After the entire expression is parsed the loop template is -filled according to a set of rules determined by the clause operator. Parts -of this system are based on code in Peter Norvig's book Paradigm's of -Artificial Intelligence Programming: Case Studies in Common Lisp (Ch 24.5). -The complete implementation satisfies all the test cases in the MIT test -suite and in the less complete ANSI Loop specification. - - -Compiler: - -Fixed FIND-RESULT-TYPE to correctly handle assignment conversion. - -Only try to generate a disassembly when making a trace file if the -disassembler has been set up for the backend we are using. - -Added a ``variable-lenght'' instruction attribute that indicates that the -instruction can be a variable length, and hence cannot be used in a branch -delay slot. - - -C Support Code: - -[SPARC only] Fixed a bug were it would sometimes not save the floating -point state on a signal. This was causing all sorts of lossage. - - -Tools: - -Added clmcom.lisp, as script to compile the clm stuff. And added stuff to -compile-all to invoke it. - - - -10/9/92 to 10/21/92: - -Compiler: - -Changed %MORE-ARG-CONTEXT to be a :translate instead of a def-source- -transform to get rid of one more use of %primitive. - -Changed MOVE-FROM-mumble-FLOAT to do the st[d]f after the pseudo-atomic so -that if we take a trap, we won't try to handle it while pseudo-atomic is -active. [Sparc only] - -Removed definitions for primitive types random and interior because they -arn't needed anymore. - -Couple patches from Miles to make the disassembler work better when -disassembling into a trace file during a compile-file. - - -C Runtime Support: - -When we get a trap_PendingInterrupt, skip over the breakpoint instruction. -Otherwise, we will try to handle the signal again and again. - -When done fixing up after a pseudo-atomic-interrupted, skip past the -tagged-add instruction. Otherwise, we turn pseudo-atomic off twice, which -results in it being left on, which confuses the garbage collector. [Sparc -only.] - - -9/29/92 to 10/9/92 - -Added arch specific routine SANCTIFY-FOR-EXECUTION that is suppowed to do -whatever cache magic is necessary to make it so we can execute newly -created code objects, and changed load and in-core compile to call it. -[This is needed for the HP port.] - - -9/25/92 to 9/29/92 - -Compiler fix to inline expansion of functions in non-null environments. -Recompiled CLX with this fix so that it works again. -Fix to the MAKE-LOAD-FORM for hash-tables to actually work. - - -9/7/92 to 9/25/92 - -Code changes: - -- Various C code changes. - -- Changed PROFILE argument count determination to parse the function type and - look at it, instead of trying to fake it. Among other things, this allows - efficient profiling of functions with FTYPE declarations even when - compilation policy has caused the function-object's type to be dropped. - -- In SERVE-EVENT, fixed WAIT-UNTIL-FD-USABLE to correctly borrow from the - timeout seconds when computing the new value for the timeout microseconds - and it is negative. - -- Added interpreter stub for VALUE-CELL-REF (for interpreted - LOAD-TIME-VALUE). - -- Fixed MAKE-INTERPRETED-FUNCTION to pass the arglist in so that it is - available to DESCRIBE. - -Compiler: - -It is now possible to inline expand global functions which are defined in a a -not-completely-empty environment information (containing local macros, etc.) -Inline expansion now works for local and block-compiled functions. Now -local-call conversion is responsible for copying lambdas for copy-per-call -inlining. - -DEFUN handling has been totally rewritten. Semi-inline expansion now has -exactly the same semantics as introducing a non-entry-point copy of the -function into the current compilation block. A new DEFINED-FUNCTION leaf is -entered in *FREE-FUNCTIONS* to represent functions which either have inline -expansions or are defined in the current compilation block. This allowed the -implementation of block compilation and inline expansion to be cleaned up. - -The new variable EXT:*INLINE-EXPANSION-LIMIT* controls the maximum number of -inline expansions done in a given function (or block compilation.) This serves -to keep inline expansions of recursive functions from crashing the compiler. - -Added block compilation declarations to ir1 conversion and optimization. Moved -some stuff around to get better locality. Substantially revamped known call -reoptimization so that more code is sharable with ir1-conversion. Formerly -some stuff (like inline expansion) only happend at ir1-conversion time. -Some other minor compile speed tweaks such as declaring some simple utilities -inline. - -Compiler bug fixes: - -- Added a hack to IF-IF optimization to prevent some spurious unreachable - code notes. - -- Fixed the code which converts "assignment" lets to ordinary lets to - actually work. - -- Merged William's change to load-time-value to not include make-value-cell - in the name. - -- Don't compile load-time-value lambdas if they've already been compiled - because they ended up in a non-top-level component. - -- Don't run the back-end(s) on components with no code. - -- Fixed START-BLOCK, END-BLOCK and recognized declarations to be ignored in - %PROCLAIM (they only make it that far when called by the interpreter. - Changed the unrecognized proclamation error to be a warning. - -- instruction scheduler fixes. - - -8/17/92 to 9/7/92 [PMAX only] - -Code: - -Changed the way continuing from breakpoints is implemented. It should work -in more cases, and be easier to port to other machines now. - -When printing the initial frame in the debugger, ignore errors that occur -while looking for the source. - -Changed DOLIST not to introduce the spurious let around the result form when -there is no result form. Also, just read the var in the spurious let, instead -of using IGNORABLE, since the var might be special. - - -Compiler: - -Re-worked some aspects of how the various compiler backends are defined in -order to make the compiler more compact. - -Fixed several bugs left over from the pmax ``improvements.'' - -Picked up several disassembler fixes from Miles. - - - -8/4/92 to 8/17/92 - -Many low level interal improvements for the pmax. None of this is user -visable, except that allocation should be faster. *** Note: these internal -changes require all files to be recompiled. If you try to load an old fasl -file, you will get an error message to this effect. - - -Code: - -Changed backq-list, etc., from being inline functions to compiler-macros, since -although the optimizer does eventually get the right code, it has to work awful -hard. - -When groveling a defmacro lambda list, check to see if some part is a LIST -before checking to see if it is a SYMBOL, because we want NIL to act like -the empty list, and not an attempt to bind NIL. - -Fixed quote-string to stop at the fill pointer for strings with fill -pointers. - -In %defsetf, don't bother creating temp vars for constants. This is -necessary so that keywords stay keywords, and are not changed to gensyms. - -Set *ENVIRONMENT-LIST* to NIL before we start to push things on it in -ENVIRONMENT-INIT so that we don't keep around the old values. - -Changed GET-INTERNAL-RUN-TIME to use UNIX-FAST-GETRUSAGE to avoid -number-consing and generic arithmetic. Also, rearranged the computation so -that the time is correctly computed for up to 457 days, instead of only 71 -minutes. - -Added UNIX-FAST-GETRUSAGE which is inline, only returns the system and user -time, and returns them as seconds and microseconds. - - -Compiler: - -Fixed a problem with conflict analysis of :more TNs (which are created -when a single vop has ~>= 50 operands.) - - -PCL: - -Don't clobber DEFINE-COMPILER-MACRO, because we have it now. - - - -7/31/92 to 8/4/92 - -[SPARC only] - -Fixes to bit-bash and compiler to get bit-bash to stop consing. - -July 92 beta PCL. Mostly MOP and ANSI enhancements, and some tweaks to -structure-class support. - -Fixed debugger VPRINT command to actually be verbose again. - -Flushed old-assembler stuff, and import new-assem stuff directly into the C -package. Various tweaks for the byte compiler and instruction scheduler. - -If we discover a FUNCALL to an inline function, convert it (unless it is a SETF -function.) - -Gag bound-but-not-referenced warnings when brevity = 3. - - -7/24/92 to 7/31/92 - -[SunOS SPARC only] - -Code: - -Fixed OUTPUT-SYMBOL to no longer call CHECK-FOR-CIRCULARITY now that -OUTPUT-OBJECT does it for us. This was causing gensyms to print as #1=#1# -when *PRINT-CIRCLE* was T. - -In FORCE-PRETTY-OUTPUT, EXPAND-TABS before outputing the output buffer. - -Fixed RUN-PROGRAM to know that UNIX-FORK returns NIL, not -1, when it -fails. - -Hacked over unix-select to actually work with nfds>32 and to be more -effecient in that case. - -Fixed UNIX-FORK to actually return the error code when it fails. - - -Compiler: - -Flushed old assembler. - -Changed NATIVE-COMPILE-COMPONENT to output the disassembly to the trace -file, and added DISASSEM:DISASSEMBLE-BLOCKS, which actually does it. - -Moved the (compiler-mumble "~&") from native-compile-component to compile- -component, so it happens when byte compiling also. - -Added stream argument to two write-char's in DISASSEM's -PRINT-CURRENT-ADDRESS where it was left out. - -Several changes to the new assembler in preperation to running the -instruction scheduler and supporting the disassembler. - - - -7/7/92 to 7/24/92 - -[SunOS SPARC only.] - -Code: - -Many improvements to the debugger: -- Exported variables *use-block-starts-only* and *print-code-location-kind* -which control the verbosity of LIST-LOCATIONS. -- Imroved source file organization. -- Changed PRINT-FRAME-CALL to print the source if verbosity >= 2 and the -source is available. -- Removed mentions of *current-code-location*, which was only set, never read. -- Changed source location printing to cache information so that it is much -faster when many locations in the same function are printed. -- The source file is now only printed when the file changes from one -printing to the next. -- The format of LIST-LOCATIONS is now more readable. The number: comes -before the form, and consecutive locations with the same souce print as -ranges, not as multiple lines. - -Changed BREAK to accept a condition as well as a format string. - -Changed default base file name for LOAD-FOREIGN to be the name used to run -lisp, and not "lisp". - -Changed INSPECT::PLAN-DISPLAY-OBJECT to use WITH-SLOTS instead of -accessors, since those accessors don't seem to exist anymore. - -Added code to support CONNECT-TO-UNIX-SOCKET so that Unix domain sockets -are available for connecting to other processes. - -Changed timeout handling in SERVE-EVENT to work for non-integer timeouts. -Moved WAIT-UNTIL-FD-USABLE into the SERVE-EVENT block so that it could -share timeout hackery. Compiled with efficiency notes & tweaked -declarations. Broke SERVE-EVENT into a couple of functions for -readability. - -Changed #a reader to allow arbitrary sequences instead of just lists. - -Merged Olssons fix to WITH-ENABLED-INTERRUPTS now that it doesn't change -interrupt characters anymore. - -Changed NTRACE to use PRINT-FRAME-CALL instead of the internal -PRINT-CALL-FRAME-1. - -Added new SYSCALL* macro which signals an error instead of returing errno. -Changed gettimeofday and rusage to use this version. Changed timeval slots to -be long, not unsigned-long, since they really are, and this simplifies -representation problems. - -Fixed unix-select to shift the masks by -32 instead of shifting -32 by the -masks. - - -Compiler: - -Code generation changed to use the new assembler. - -Don't call CONTINUATION-CHECK-TYPES if PROBABLE-TYPE-CHECK-P returns NIL. -This lets type checking assume that the continuation does have a DEST, -and also avoids some unnecessary work. - -Fixed dump-1-location to also take integer positions directly, instead of -always requiring labels. - -Added checking for potentially TR local calls with different tail sets. Added -BARF restart which allows conditional ignoring of particular error messages. - -Fixed IR2-CONVERT-ENTRY to correctly handle tagbodies with more than one tag -that is non-locally exited to. - -MERGE-TAIL-SETS before potential let-conversion so that we will -correctly recognize all tail calls. Make the analogous change to -CONVERT-MV-CALL. - -Fixed DUMP-DATA-MAYBE-BYTE-SWAPPING to work. [Needed for cross compiling.] - -In the new assembler, fixed FORGET-OUTPUT-BLOCKS to also reset -*ALL-OUTPUT-BLOCKS*. When using ADJUST-ARRAY to extent the vector of -OUTPUT-BLOCKS, spec the initial-element as nil so it doesn't just leave the -0's behind. - - -Tools: - -Change $* to $@ in sample-wrapper. - -When compiling the compiler, keep a bit more safety and debug-info when -#-small. - - -CLX: - -Fixed fast pixarray functions to return T when they do something. - -Fixed copy-bit-rect to correctly compute indices for bit-bash-copy -so that it will actually work. - -Fixed ANGLEP to test for being a real before it assumes it is. - -Fixed several places where values that could really be negative were -declared to be array-indices. - - -Documentation, etc. - -Clarified that CMUCL_EMPTYFILE must be a file in sunos-README. - -Update for new TR number, use cmu-titlepage style. - -Added new debugger breakpoint commands and new trace documentation. - -Ran spell checker. - -Fixed various minor formatting problems, especially w.r.t description -environments. - -Updated debugger documentation to describe the prefix-completing command -parser (which has been in for quite a while.) - -Incorporated Paul's suggested improvements in the debugger and aliens -chapters. - -Updated indexing to make much greater use of subindexing. - - - -6/22/92 to 7/7/92 - -Code: - -Added debugger commands to manipulate breakpoints. See the debugger help -string for details. - -Changed the type of *TOTAL-BYTES-CONSED* from fixnum to integer because it -is very easy to cons more than most-positive-fixnum bytes. It just takes a -while. - -Added some type declarations so that a call to make-array in -make-hash-table gets open coded. - -Removed *task-data* and *task-notify* because they aren't used, and I have -no idea what they should be changed to under mach 3.0. - - -Compiler: - -Fixed MAKE-LOAD-TIME-CONSTANT-TN to quit looking once it found an matching -constant, so that it actually uses the same constant slot for the same -value. - - - -6/15/92 to 6/22/92 - -Code: - -Fixed PACKAGE-ERROR to have a PACKAGE slot instead of a PATHNAME slot. - -Two changes to DEBUG-INTERNALS to support breakpoint debugger commands: -- Added CODE-LOCATION-KIND. -- Changed HANDLE-BREAKPOINT-AUX to correctly handle the case in which all -breakpoints at a location are deactivated and then at least one is -activated within the hook functions. - - -Compiler: - -Changed the defknown for PACKAGE-NAME to include NIL as a possible result, -because that is what it is supposed to return after the package is fed -to DELETE-PACKAGE. - -More internal changes to for the HP PA-RISC 1.1 port. - - - -6/12/92 to 6/15/92 - -Code: - -Reworked the internals of circularity detection and depth abbreviation. -Structure print-functions that use PPRINT-LOGICAL-BLOCK will no longer be -counted as as two levels against *PRINT-LEVEL*, and will no longer be -printed as #1=#1# when *PRINT-CIRCLE* is set. Also, printing various -condition structures (for example, TYPE-ERROR) will no longer flame out -when *PRINT-CIRCLE* is set. - -Note: any uses of PPRINT-LOGICAL-BLOCK will have to be recompiled. - - - -6/3/92 to 6/12/92 - -Code: - -Don't destructively modify the breakpoint list in SUB-ACTIVATE-BREAKPOINT so -that any breakpoints activated while we are already at this location will not -be processed this time around. - -Fixed dispatch macro characters to be case-insensitive, and to disallow digits -as sub-characters. - - -Compiler: - -Moved the page size into the backend structure. - -Changed not to barf if a block has no predecessors. This really shouldn't -happen, since we do DFO before constraint if it is needed, and that should -flush any blocks with no predecessors (or that are otherwise unreachable), but -it is happening... - -Moved tail-set merging out of IR1-OPTIMIZE-RETURN into LTN. Changed -MAYBE-DELETE-EXIT to call MERGE-TAIL-SETS. - -Set COMPONENT-REANALYZE in MAYBE-TERMINATE-BLOCK if we do terminate. - -Added setting of COMPONENT-REANALYZE all places where we do UNLINK-BLOCKS and -might create dead code. - -Changed CONVERT-CALL-IF-POSSIBLE to not attempt to convert when the call is in -a deleted function or a delete-p block. - -Moved tail-set merging here from IR1-OPTIMIZE-RETURN, since it wasn't being -triggered reliably (and required IR1 optimization to run to completion for -correctness.) Now we merge tail sets whenever we convert a local call that -delivers its value to a return (regardless of whether it is truly TR.) This -liberalization actually improves type inference: previously non-TR calls would -mess up type inference. - -Now MERGE-TAIL-SETS must be called whenever IR1 is modified so that a local -call is changed to be potentially tail recursive (i.e. deliver its value to a -return.) It seems that the only such place is in MAYBE-DELETE-EXIT in ir1opt. - -Changed to bind *features* to (backend-features *target-backend*) just -before doing the read instead of binding *features* to (backend-features -*backend*) for the duration of the compile. This way, the compiler can use -(backend-featurep :foo) to tell how to compile, and cross compilers can be -compiled correctly with respect to #+foo. - -Fixed RANDOM derive-type method when the class is NIL, or is FLOAT and FORMAT -is specified (need to get the right type of zero.) - - -Hemlock: - -Couple fixes to dired: -- Updated function merge-dirs to reflect updated pathname-directory returns a -list rather than a simple vector and amended its use of make-pathname to -set :device argument to :unspecific rather than :absolute. -- In set-write-date spliced in the *utimes-buffer* list into the -unix:unix-utimes function call. - - -CLX: - -Fixed ANGLE to handle ratios. In now discards all unnecessary precision -when doing the bounds check. - - -PCL: - -Fixed function environment hackery to work even when *LEXICAL-ENVIRONMENT* is -NIL (i.e. we aren't in the compiler.) - - - -5/25/92 to 6/3/92 - -New PCL, version March 92 2a. Supposed to have many bug fixes and some -performance enhancements. - -Code: - -Merged Mile's fix to MAKE-PATHNAME so that it knows the difference between -an arg being NIL and being unsupplied. - -Fixed ACTIVATE-BREAKPOINT to build the breakpoints list in forward order to -preserve the desired hook invocation order. - -Made function-end breakpoints for known-return functions signal an error, since -they aren't implemented. - -Defined new parameterized PRINT-HERALD, exported *HERALD-ITEMS*. Doc for -*herald-items*: - Determines what PRINT-HERALD prints (the system startup banner.) This is a - database which can be augmented by each loaded system. The format is a - property list which maps from subsystem names to the banner information for - that system. This list can be manipulated with GETF -- entries are printed - in, reverse order, so the newest entry is printed last. Usually the system - feature keyword is used as the system name. A given banner is a list of - strings and functions (or function names). Strings are printed, and - functions are called with an output stream argument. - -Trace has been substantially rewritten, and has a new syntax as well as new -functionality. It now subsumes the old encapsulation-based trace via the -:ENCAPSULATE option. Interpreted functions and generic functions are traced -via encapsulation by default, which works. Conditional stuff works much -better. *debug-print-level* is used instead of a separate -*trace-print-level*. Here is the new doc string: - TRACE {Option Global-Value}* {Name {Option Value}*}* - TRACE is a debugging tool that prints information when specified functions - are called. In its simplest form: - (trace Name-1 Name-2 ...) - - TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named - functions is entered or returns (the Names are not evaluated.) The output - is indented according to the number of pending traced calls, and this trace - depth is printed at the beginning of each line of output. - - Options allow modification of the default behavior. Each option is a pair - of an option keyword and a value form. Options may be interspersed with - function names. Options only affect tracing of the function whose name they - appear immediately after. Global options are specified before the first - name, and affect all functions traced by a given use of TRACE. - - The following options are defined: - - :CONDITION Form - :CONDITION-AFTER Form - :CONDITION-ALL Form - If :CONDITION is specified, then TRACE does nothing unless Form - evaluates to true at the time of the call. :CONDITION-AFTER is - similar, but suppresses the initial printout, and is tested when the - function returns. :CONDITION-ALL tries both before and after. - - :WHEREIN Names - If specified, Names is a function name or list of names. TRACE does - nothing unless a call to one of those functions encloses the call to - this function (i.e. it would appear in a backtrace.) Anonymous - functions have string names like "DEFUN FOO". - - :BREAK Form - :BREAK-AFTER Form - :BREAK-ALL Form - If specified, and Form evaluates to true, then the debugger is invoked - at the start of the function, at the end of the function, or both, - according to the respective option. - - :PRINT Form - :PRINT-AFTER Form - :PRINT-ALL Form - In addition to the usual prinout, he result of evaluating Form is - printed at the start of the function, at the end of the function, or - both, according to the respective option. Multiple print options cause - multiple values to be printed. - - :FUNCTION Function-Form - This is a not really an option, but rather another way of specifying - what function to trace. The Function-Form is evaluated immediately, - and the resulting function is traced. - - :ENCAPSULATE {:DEFAULT | T | NIL} - If T, the tracing is done via encapsulation (redefining the function - name) rather than by modifying the function. :DEFAULT is the default, - and means to use encapsulation for interpreted functions and funcallable - instances, breakpoints otherwise. When encapsulation is used, forms are - *not* evaluated in the function's lexical environment, but DEBUG:ARG can - still be used. - - :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment - of the called function; DEBUG:VAR and DEBUG:ARG can be used. The -AFTER and - -ALL forms are evaluated in the null environment. - - -Compiler: - -Fixed several uses of FIND to use EQUAL instead of EQL to compare function -names, because (SETF mumble) is now a valid function name, and isn't -necessarily EQL. - -More stuff in preperation for more ports and the byte-compiler. - -Changed NEW-BACKEND to call DEFINE-STANDARD-TYPE-PREDICATES to fill in -the BACKEND-TYPE-PREDICATES and BACKEND-PREDICATE-TYPES slots. - -Fixed some bugs revealed by the new PCL and William's hackery. Support for -"assignments" (local functions used for iteration) was rather proken, and still -has at least one problem. - - -5/17/92 to 5/25/92 - -Code: - -Lots of internal fixes to how breakpoints are handled. There currently is -nothing that uses this stuff, but it works better now. - -Fixed DEFPACKAGE not to loose when the :use option is specified. - - -Compiler: - -More internal changes to help facilitate future ports. - -Internal changes to support the above mentioned breakpoint improvements. - - -PCL - -Fixed a bug in WALK-ARGLIST where it would ignore the rest of the current -arglist if the current arg destructured. This was causing it to compile -forms like: - (macrolet ((foo ((a b) c) ...)) ...) -as: - (macrolet ((foo ((a b)) ...)) ...) -note the loss of the arg c. - - -Other: - -The loading of CLX and Hemlock has been changed to more easily allow -loading them into cores originally built without them. - - - -4/30/92 to 5/17/92 - -Code: - -Inline expand %MAKE-ALIEN and FREE-ALIEN to avoid spurious Alien-value consing. - -Changed DESCRIBE to allow T or NIL as the stream argument. - -Rewrote most of the hash table support: -- MAKE-HASH-TABLE now conforms to the ANSI spec. -- EQL hash tables now work with complex numbers, and better in general. -- HASH-TABLE-mumble accessors now exist. - -Changed several uses of DEFINE-CONDITION to use the new syntax. - -Removed several extra )'s - -Changed several setfs of arguments that were inhibiting the compiler from -using all the argument type information available for list and sequence -functions. - -Changed IN-PACKAGE to conform to the new definition. But if you use an -old-style IN-PACKAGE, it will use the old behavior. - -Rewrote DEFPACKAGE to tell you about inconsistencies between the package -and the DEFPACKAGE form. - -Rewrote the DO-mumble-SYMBOLS iterators in order to stamp out more uses of -prog. They now wrap the user body in an flet and then just use regular -looping constructs to grovel through the packages. - -Several fixes to the new TRACE: -- Fixed to actually allow tracing anonymous function objects. -- Changed to allow tracing of macros. -- When tracing an already traced function, untrace and retrace it, instead -of ignoring the second request. -- Moved the undefined error for UNTRACE to the UNTRACE-1 subfunction, -instead of signalling it at macroexpand time. -- In TRACE-1, added an assertion that there isn't already an entry in the -trace breakpoint table, since sometimes we seem to be forgetting about -breakpoints. - - -Compiler: - -Several internal changes in preperation for supporting future ports. - - -CLX: - -READ-BITMAP-FILE modified to decrement the indexed property :x-hot only if -non-nil and positive. If already negative, it is left unchanged to indicate -that the bitmap has no hotspot. - - - - -4/7/92 to 4/30/92 - -**** FASL files have been incompatibly changed in this release. You must -recompile all your fasl files. - - -Big Change: - -Function call is now different. Specifically, named-call has been changed -so that it can be used for both regular functions and setf functions. -Named calls to setf functions are now just as efficient as named calls to -regular functions. - - - -Code: - -Changed the handler-bind in debug-loop to not invoke the debugger directly. -Otherwise, debug:*stack-top-hint* never gets set for errors received while -debugging. - -Fixed MACROEXPAND-1 to pass the environment into MACRO-FUNCTION when -checking to see if the form has a macro defintion. Otherwise, -macroexpanding macrolets doesn't work. - -Fixed doc string for maphash to indicate that it returns NIL instead of T. - -Changed the undefined-symbol-error handler to use fdefn-name to extract out -the name from the fdefn object when its really a fdefn object that was -undefined instead of a symbol. - -Added function-subtype and (setf function-subtype). These functions can be -used to retrieve and set the header type for functions and closures. - -Moved lots of exports from lispinit.lisp into the files that contain the -thing being exported. Moved the object-set stuff into serve-event.lisp. - -Added a call to GC-INIT to REINIT to facilitate making sure set-auto-gc- -trigger gets called. - -Added the start of stuff necessary to support byte compiled functions. - -Export REALP from LISP now that it's a real function. Minor tweek to -bounds testing in %%typep of complex numbers. - -Chagned the unmatched close parenthesis warning to include the file -position so that it is easier to track them down. - - -Compiler: - -Lots of changes to support the new function call, and to fix bugs exposed -by these changes. - -On the SPARC, fixed sap+ not to flame out when the second argument is an -immediate that doesn't fit in a signed-byte 13 offset. - -Don't substitute out LET variables when the initial value is a reference to a -:NOTINLINE functional. The inlinep information must be retained, since we -count on :NOTLININE calls never being local call converted. - -Removed some debugger code that accedently got left behind. - -Fixed SOURCE-TRANSFORM-STRUCTURE-TYPEP to return T-or-NIL in the frozen -included case, and not some random non-null lists. - - - -3/29/92 to 4/7/92 - -Code: - -Changed the default structure printer to print slot names as keywords -instead of unqualified symbols as per X3J13 cleanup STRUCTURE-READ-PRINT- -SYNTAX:KEYWORDS. - -Added COMPILER-MACRO-FUNCTION, COMPILER-MACROEXPAND, COMPILER- -MACROEXPAND-1, and DEFINE-COMPILER-MACRO. - -Fixed things that invoke *MACROEXPAND-HOOK* to coerce it to a function -before calling it as per X3J13 cleanup FUNCTION-TYPE:X3J13- MARCH-88 by -introducing KERNEL:INVOKE-MACROEXPAND-HOOK, which does that and then -funcalls it. - -Fixed MACRO-FUNCTION to take an environment argument as per X3J13 cleanup -MACRO-FUNCTION-ENVIRONMENT:YES. - -Added BYTES-CONSED-BETWEEN-GCS, a function that returns (and sets when -used with setf) *BYTES-CONSED-BETWEEN-GCS*. Additionally, it changes -*GC-TRIGGER* immediately to reflect the new values of *bytes-consed...*. - -Changed GET-SETF-METHOD-MULTIPLE-VALUE to try to macroexpand-1 the form -when it's an atom in case it's a symbol-macro as per the X3J13 cleanup -SYMBOL-MACROLET-SEMANTICS:SPECIAL-FORM. Now you can safely INCF, etc. -symbol macros where the macroexpansion has side effects. - -Fixed SETF of GETF to evaluate the various parts in the correct order as -per X3J13 cleanup SETF-SUB-METHODS:DELAYED-ACCESS-STORES. - -Fixed bug in NTH-VALUE where it expanded into bogus code unless ``n'' was a -constant integer. - -X3J13 cleanup SETF-MULTIPLE-STORE-VARIABLES: - - Extend the semantics of the macros SETF, PSETF, SHIFTF, ROTATEF, and - ASSERT to allow "places" whose SETF methods have more than one "store - variable". In such cases, the macros accept as many values from the - newvalue form as there are store variables. As usual, extra values - are ignored and missing values default to NIL. - - Extend the long form of DEFSETF to allow the specification of more - than one "store variable", with the obvious semantics. - - Clarify that GET-SETF-METHOD signals an error if there would be more - than one store-variable. - -Added real support for the REAL type. - -Export REALP from LISP now that it's a real function. Minor tweek to -bounds testing in %%typep of complex numbers. - -Changed the return value of SET-SYNTAX-FROM-CHAR from NIL to T as per X3J13 -cleanup RETURN-VALUES-UNSPECIFIED:SPECIFY. [Hard to believe nobody has -complained about not conforming to this one.] - -Removed the :enable-gc from save-lisp option, as it's no longer needed. - -Allow SHADOW to take strings in addition to symbols as per X3J13 cleanup -SHADOW-ALREADY-PRESENT:WORKS. - - -Compiler: - -Fixed a bug in DEFAULT-UNKNOWN-VALUES where it wasn't resetting the stack -if between 2 and 6 (inclusive) values were expected. Also, spiffed up the -case where > 6 values were expected. [On the RT, change 6 to 3] - -Fixed NUMERIC-CONTAGION with respect to (COMPLEX RATIONAL). - -Fixed the ``fold identity operation'' for *, /, and EXPT to no longer -consider #C(0 1) identity. - -BARF is not return type NIL, since it calls CERROR. -Fixed function consistency checking to work better on deleted functions. -Added a condition handler in PRINT-ALL-BLOCKS. - -Fixed RETURN-VALUE-EFFICENCY-NOTE not to flame out when some functions in the -tail set have no RETURN. - -Changed SUBSTITUTE-SINGLE-USE-CONTINUATION to not substitute if the -continuation type assertions conflict. - -Added optimization which deletes MV-BINDS when all variables have been deleted. - -Minor tweeks to conform to X3J13 cleanup MACRO-DECLARATIONS:MAKE-EXPLICIT. - -Added noise to support compiler-macros. Removed #+/- new-compiler -conditialization. - -Fixed SYMBOL-MACROLET to allow declarations as per X3J13 cleanup SYMBOL- -MACROLET-DECLARE:ALLOW. When declaring things about symbol macros, type -declarations just wrap (the type ...) around the expansion, special -declarations signal an error, and ignore/ignorable declarations are -ignored. - -Apply global function type declarations to calls and definitions of global -inline functions. - -Changed CONVERT-AND-MAYBE-COMPILE to temporarily increate *bytes-consed- -between-gcs* by a factor of 4 instead of turning off all garbage -collection. - - -Construction Tools: - -Changed the way the garbage collector gets turned on. - - - - -3/23/92 to 3/29/92 - -Code: - -Adjust-array has been updated to be ANSI compliant by allowing arrays which -were not created with :adjustable non-nil to be adjusted to new dimensions. - -Adjustable-array-p has been updated to ANSI standards. It returns T if adjust -ADJUST-ARRAY would return an EQ array. - -Fixed DESCRIBE of alien variables. - -Fixed EVAL of alien variables. We just hand it off to the real -interpreter. - -Fixed DEFINE-CONDITION to clean up the slot description before handing it -to defstruct now that defstruct is less forgiving. - -Added EXT:BYTES-CONSED-BETWEEN-GCS, a function that returns (and sets when -used with setf) *BYTES-CONSED-BETWEEN-GCS*. Additionally, it changes -*GC-TRIGGER* immediately to reflect the new values of *bytes-consed...*. - -Added GC-INIT to facilitate making sure set-auto-gc-trigger. - -Changed ROOM-MINIMAL-INFO to print everything that doesn't use -map-allocated-objects and also to indicate whether or not the garbage -collector is currenty on or off. - -Fixed FIND-INTERRUPTED-FRAME to FLUSH-FRAMES-ABOVE before returning the -frame. - -Changed PURIFY to bind *INTERNAL-GC* and then invoke the garbage collector -so all the auxiliary stuff (hooks, etc.) gets handled correctly. - -Removed the :ENABLE-GC option from SAVE-LISP, as it's no longer needed. - - -Compiler: - -Rewrote the way pseudo-atomic works for the SPARCs. Hence, all sparc fasl -files will have to be recompiled. An error will be signaled if you try to -load an old fasl file. [SPARC only] - -Fixed {alloc,dealloc}-number-stack-space to work with large amounts. - -Changed CONVERT-AND-MAYBE-COMPILE to temporarily increate *bytes-consed- -between-gcs* by a factor of 4 instead of turning off all garbage -collection. - -Rewrote the ub-32 logcount vop. The new version uses an O(log2 32) algo. -resulting in 30 cycles (no branches). The old version used an O(n) algo. -where n was the integer-length of the argument, resulting in somewhere -between 4 and 130 cycles. [MIPS only] - - - -3/7/92 to 3/23/92 - -Code: - -Several debugger improvements: -- The debugger now checks a new special DEBUG:*STACK-TOP-HINT* for a hint -as to what it should use for the top of the stack. INTERNAL-ERROR, ERROR, -BREAK, etc. all bind this before calling INVOKE-DEBUGGER so that there are -not zillions of irrelevent stack frames at the top of the stack. -- Fixed def-debugger-command to remove the old definition when a command -is redefined. -- Merged Miles' changes that allow the use of restart names as debugger -commands. -- Added ``DESCRIBE'' debugger command, which calls DESCRIBE on the function -in the current frame. - -Two fixes/changes to the new breakpoint based trace facility: -- Protected function-end-cookie-valid-p against running across interpreted -frames. This was causing it to flame out. -- Don't bother warning about dynamic flow of control, because it is obvious -from the call depth numbers and the warning can happen at real confusing -times. - -More DEFSTRUCT changes: -- Make stuff work when conc-names make a subtype slot accessor have the -same name as the supertype accessor. -- Fixed PARSE-1-DSD to correctly recognize conc-name accessor duplication -when there is multi-level inheritance. Now we look at the ACCESSOR-FOR -info and see if it is an accessor for the same slot. -- In PARSE-1-DSD, don't blow away the accessor when we are just redefining -the same structure. For shadowing to be a problem, the accessor must be of -a supertype. -- In DSD-NAME, intern the symbol in *PACKAGE* if the accessor is NIL. -- In DEFAULT-STRUCTURE-PRINT, directly use DSD-%NAME, rather than messing -around creating a symbol. - -A few more improvements to the new aliens stuff. - -Declare the BACKQ-mumble's INLINE to avoid gratuitous pessimization. - -Fixed define-condition to clean up the slot description before handing it -to defstruct now that defstruct is less forgiving. - -Added partial support for FDEFN objects. - -Export FEATUREP from EXT. - -Changed WITH-SYMBOL package hashtable lookup to not repeated call REM when -going down a collision chain. - -In TIME, fixed display of consing and page faults in the case where no GC time -is displayed. - -Added SEARCH-LIST-DEFINED-P, a predicate that tells if the search list is -currently defined. - - -Compiler: - -Redid the way compiler backend specific data structures are accessed to -simplify changing the set of backend specific data structures. - - -Hemlock: - -Fixed GET-EDITOR-TTY-INPUT to read the data into an c-call:unsigned-char -buffer instead of a c-call:char so that when we access the elements from -it, we don't get negative numbers, which make code-char unhappy. - - -C runtime support code: - -Fixed a bug in os_allocate_at that was causing load-foreign to lose. - - -Construction scripts: - -Changed ``mk-lisp'' to pause for 5 minutes before actually building the -core to allow people to clear out. This can be overridden by supplying -``-now'' as the first argument. - - - - -3/4/92 to 3/7/92 - -Code: - -Several new-aliens changes: -- Export SYSTEM-AREA-POINTER from ALIEN for consistency. -- Export MAKE-ALIEN and FREE-ALIEN from ALIEN. -- Export ALIEN-VALUE-TYPE from ALIEN-INTERNALS so that TYPE-OF can use it. -- Changed ALIEN-VALUE printer to be less verbose. -- Implemented %MAKE-ALIEN and FREE-ALIEN using malloc/free. Changed MAKE-ALIEN -to accept an alien-type object as well as an Alien type descriptor. -- Now that we've implemented FREE-ALIEN, finalize the Aliens created by -interpreted WITH-ALIEN. -- Added an (OPTIMIZE-INTERFACE (SAFETY 2)) declaration on %CAST so that we get -a better type error message. -- Added NULL-ALIEN and many doc-strings. -- Allow (* char) in the c-string lisp-rep as well. -- Allow storing of (* char) in c-strings so that we can initialize c-string -variables and slots. -- Added support in TYPE-OF for alien-value structures. - -Added compiled-debug-function branch to DI:DEBUG-FUNCTION-FUNCTION. - -Changed a few places where ESCAPE-REGISTER was left over to -VM:SIGCONTEXT-REGISTER. This was causing function-end breakpoints -to die. - -Added Miles' changes to keep errors and warnings on one line if they fit. - -Added Miles' stuff to use the same stream for input and output if they are -the same file descriptor. This makes CHAR-POS work after input. - -Changed LOAD-FOREIGN to be exported from ALIEN. Changed it have keyword args -instead of optionals. Deleted obsolete linker argument. - -Added Miles' stuff to diddle the child's pgrp for better signal handling in -EXT:RUN-PROGRAM. - -Fixed UNIX-IOCTL to not flame out of the cmd is a ub-32 instead of a sb-32. - -Added Miles' UNIX:TCSETPGRP, UNIX:TCGETPGRP, and UNIX:TTY-PROCESS-GROUP. - - -Compiler: - -Picked up a SPARC specific assembly routine call improvement from Miles. - -Miles' fixes to make disassembling [mc][tf]c1 work on the PMAX. - - -Hemlock: - -Fixed GET-EDITOR-TTY-INPUT to read the data into an c-call:unsigned-char -buffer instead of a c-call:char so that when we access the elements from -it, we don't get negative numbers, which make code-char unhappy. - - -C Runtime Support: - -Fixed function-end breakpoints for the sparc. - - - -3/2/92 to 3/4/92 [16a] - -Code: - -Fixed a major bug in def-alien-type where the macroexpansion wouldn't -include the code to define the type if the type was defined at compile -time. - -Allow LISP:AND, LISP:OR, and LISP:NOT in features lists in addition to -:AND, :OR, and :NOT. This makes FEATUREP useful outside of #+ and #-. - -Added ``:verbose nil'' to the load of site-init.lisp. - - -C Runtime support: - -Whenever we allocate a chunk of memory, set the protections to include -VM_PROT_EXECUTE so that we can execute code on it. - - - -2/24/92 to 3/2/92 - -Code: - -Added some dimension type checking to parsing of alien array types. - -Fixed a bug where the size of single-floats and double-floats wasn't know -by the new aliens stuff. - -Really make sure compute-time-overhead-ax has function type info in -profile. - -Reworked the SETQ branch of EVAL to pass more cases (like setting alien -vars or constants) off to the real interpreter. - -Fixed FMAKUNBOUND to return the symbol instead of T. - -Moved OS-INIT into mumble-os.lisp, so that different OSes can do different -things for initialization. - -SET now protects against setting T, NIL, and keywords. (SETF -SYMBOL-FUNCTION) now expands into FSET, which protects against defining -NIL. %SET-SYMBOL-PACKAGE is a new function that sets the symbol package. -%SP-SET-PLIST has been renamed %SET-SYMBOL-PLIST. - -Fixed the ``mumble doesn't start with a search-list'' error message. - -Fixed the MIPS disassembler OR control to look at the RT field instead of -the RD field. - - -Compiler: - -Weakened component kind type assertion in JOIN-COMPONENTS. - -Changed the %DEFCONSTANT transform to protect against trying to change T, -NIL, or keywords. - -Changed LET* and &AUX to allow duplicate variable names. - -Re-wrote the SAP-REF-mumble VOPs for better immediate support. - - -CLX: - -Don't try to set char-bits for CMU, because we don't have any. - - -C runtime support: - -Instead of using os_zero to zero the control stack after a GC, fill it with -zeros ourselves. - -Whenever we allocate a chunk of memory, set the protections to include -VM_PROT_EXECUTE so that we can execute code on it. This is so we can run -under MACH 3.0. - - - -2/18/92 to 2/23/92 - -Code: - -Several bug fixes to the new alien stuff. - -All SAP-REF-mumble functions now uniformly take the offset argument in -bytes. - -Changed *LOAD-VERBOSE* initial value to T. - -Added *GC-RUN-TIME* accounting. Added some declarations, primarily for the -benefit of GET-BYTES-CONSED. - -Changed TIME to use *GC-RUN-TIME* to print the amount of time spent in GC. - -Allow search-lists to expand into relative pathnames by quietly merging -them with ``default:''. - - -Compiler: - -Added a new DEFTRANSFORM keyword, :IMPORTANT, which means an failed -transform efficiency note should be generated when brevity<=speed, not just -brevity<speed. - -Added an assertion that we don't join components with random kinds. - -Bind *PRINT-LINES* around compiler error output to *ERROR-PRINT-LINES*. - -Make DELETE-COMPONENT set COMPONENT-KIND to :DELETED so that we can detect -inconsistencies more easily. - -When checking if the call we are about to convert is going to be deleted, look -at the block holding the combination, not the ref, since the combination may be -deleted when the ref isn't. - - - - -2/12/92 to 2/18/92 - -Aliens and the foreign function call interface have been totally -re-designed and re-written. Therefore, anything using aliens will have to -be re-written. Complete docs are forthcomming. - -Additional changes are as follows: - -Code: - -The USER package has been renamed COMMON-LISP-USER (with USER as a -nickname) to go along with the LISP->COMMON-LISP rename. - -Unix system calls are no longer in the MACH package, but in a new package -named UNIX. - -UNIX-DUP now returns the new FD as the first return value instead of the -second to be more consistent with the other system calls. - -You can no longer pass UNIX-READ a string (or any other vector). If you -really want to do this, do something like: - (system:without-gcing - (unix:unix-read fd (system:vector-sap string) ...)) -Before, if someone interrupted the read, GCed, and then restarted the read, -it would have read into the wrong place. - -Fixed FORMAT to print the floating point exponent in decimal irrespective -of *PRINT-BASE*. - -The initial value of *LOAD-VERBOSE* is now T. Additional, LOAD no longer -always binds *LOAD-VERBOSE* and *LOAD-PRINT-STUFF*. Now it only binds them -when :verbose or :print are explicity supplied. Therefore, you can set -either of these in your init file and it will take effect. - -LOAD is less verbose when *LOAD-VERBOSE* is T. Specifically, it just -prints the filename that was loaded (if it can be figured out). - -Added ANSI features *LOAD-TRUENAME*, *LOAD-PATHNAME* and *LOAD-PRINT*. - -As per ANSI, bind *READTABLE* to itself to make assignments file-local. - -Added new variables EXT:*SOURCE-FILE-TYPES* and EXT:*OBJECT-FILE-TYPES*. When -no file type is specified, LOAD tries the types in these lists to locate the -source and object files. LOAD now recognizes source types "l", "cl" and "lsp" -in addition to "lisp". - -The compiler OPTIMIZE policy is now bound during load, so proclamations in a -file don't leave the global policy clobbered when the load is finished. - -Changed the :IF-SOURCE-NEWER option to signal an error and use restarts, rather -than PROMPT-FOR-Y-OR-N. Fixed the load source case to actually load the -source, rather than loading the object as a source file... - -Changed load to deal with source files having NIL type more reasonably. - -Added support for wild pathnames in load. - -Improved handling of nonexistent files, in particular, don't always assume -that missing files are source files. Added condition restarts for missing -files. - -Improved formatting of error and warning messages. - -PRINT-UNREADABLE-OBJECT returns NIL, not #\> - -Changed FLONUM-TO-STRING to consider widths < 1 to be 1 to prevent infinite -looping in those cases. - -Print the package name instead of NIL when we can't find a package in symbol -reading. Also, read |LISP|::cons as CONS, not |cons|. - -Replaces {alloc,realloc,dealloc}ate-system-memory with versions that use -the routines exported by os.c instead of MACH specific vm_allocate. - -Changed pointer< and pointer> to sap< and sap>. - - -Compiler: - -Fixed a bug that caused an internal error when a never-referenced function -(e.g. from FLET) had non-local exit code in it. - -Fixed spelling of "efficency" in several function names. - -Print a error summary even when *compile-verbose* is false. (This is only -printed when there are errors, so this doesn't seem a violation of the spirit -of the spec.) - - -Hemlock: - -Removed all RFS authentication stuff from the MH interface, because -kerberose handles it for us now. - - - -2/3/92 to 2/12/92 - -Code: - -Several changes to the reader. Specifically: -- READTABLE-CASE is now supported. -- Several bugs with respect to #+, #-, #n=, and #n# have been fixed. -- The reader now signals the correct type of error when things go wrong -instead of always signaling a simple-error. -- Export new variable *ignore-extra-close-parentheses* if true (the -default), extra close parens are only a warning, not an error. They used -to be quietly ignored. -- # is now a non-terminating macro character, so foo#bar is read as a -symbol. -- Added Ted's changes to make INTERNAL-READ-EXTENDED-TOKEN work when there -are `|' escapes. The main significance of this is that #+nil '|foo;bar| -and #:|foobar| now work properly. Also change this function to recognize -unquoted colons so that #:foo:bar will error, but not #:foo\:bar. - -Print unbound-markers to the correct stream instead of always printing them -to *standard-output*. - -Added UPGRADED-COMPLEX-PART-TYPE and UPGRADED-ARRAY-ELEMENT-TYPE. - -Fixed (typep x '(and ...)) to not always return NIL. - -When restarting a core, process the command line before printing the herald -so that we can eval some form and quit without printing anything. - -Added exports for LEAST-NEGATIVE-NORMALIZED-mumble-FLOAT. - -The ``LISP'' package has been renamed ``COMMON-LISP'' with the nicknames -``LISP'' and ``CL.'' - - -Compiler: - -Don't look at the LAMBDA-TAIL-SET of deleted functions to find out the result -type, because there isn't any. - -Changed LET* and &AUX to allow duplicate variable names. - -Properly qualify kernel::*values-specifier-type-cache-vector* in BOUNDP check -in %NOTE-TYPE-DEFINED. We were never clearing the cache. - -More tweaking of arithmetic identities. (* x 0) transform is also -rational-specific. Include CONSTANT-ARGUMENT in various arg type restrictions -so that we don't get silly efficiency notes. - -Changed multiplier recoding to left-associate the sum so that we are less -likely to run out of non-descriptor registers. - - - -1/26/92 to 2/3/92 - -Fixed filename parsing to correctly handle "/foo". - -Changed NCONC to signal an error if a non-null ATOM appears other than as the -last argument. - -Fixed PPRINT to call OUT-SYNONYM-OF on it's stream argument so that it will -actually work for the ``streams'' T and NIL. - -Fixed profile to work again now that argument information may be omitted (due -to low debug info.) First of all, don't seg-fault on functions w/o arg info; -print a warning instead, and assume arbitrary args. Also, determine the -precise arg counts for closures and funcallable instances (generic functions.) - -Fixed some DIRED bugs resulting from the new pathname changes. - -Compiler: - -[Sparc:] Fixed integer comparison VOPs to be appropriately prioritized by cost. - -In %DEFTRANSFORM, when determining wither to replace a transform or add a new -one, check that it has the same note as well as the same type. This provides a -way to have more than one transform with the same type signature. - -Fixed (- x) to expand directly to (%negate x), rather than going by the -intermediate of (- 0 x), since this is not a correct transformation. (- 0 0.0) -is 0.0, not -0.0. Fixed the (- 0 x) transform to be restricted to rational -args. - -Changed COMMUTATIVE-ARG-SWAP to actually splice in the constant arg, so that -variable substitution can't swap it back again. - -Fixed multiply recoding to include many TRULY-THE's in the expansion so that -the resulting shift-and-add code would actually open coded. - -Added comprehensive handling of arithmetic and logical identities when an arg -is -1, 0 or +1. - - -1/17/92 to 1/26/92 - -Fixed the multi-dim array printer to use aref on the data vector instead -of svref, because despite being simple and being a vector, it's not a -simple-vector. - -Fixed compiler error context stuff to know that the source-info-name for a file -is now the namestring and not the pathname. This allows filenames to be -printed in error context once again. - -Fixed a bug in Purify that was manifesting on the RT. - - -12/22/91 to 1/17/92 - - Mostly minor bug fixes and cosmetic improvements. - -Code: - -The MIPS disassembler now supports all the bells and whistles of the SPARC -version. [Courtesy of Miles] - -The pretty printer now ``unparses'' the results of backquote expressions -and rebuilds the original backquote-comma expression. This makes reading -macro definitions, etc. much easier. [Also courtesy of Miles] - -Fixed a few minor bugs in debug-int.lisp: -- When computing interpreted debug blocks, ignore successors to the component -tail or other functions. -- Compute the correct result for DEBUG-FUNCTION-START-LOCATION with -interpreted debug functions. -- In parse-debug-blocks, fix typecase to look for I-D-FUNCTION, not BLOCK. - -Fixed FORMAT-JUSTIFICATION to assume the charpos is 0 if we can't tell from -the stream. This was causing (FORMAT (MAKE-BROADCAST-STREAM) ...) to fail. -The compiler sometimes binds *ERROR-OUTPUT* to (MAKE-BROADCAST-STREAM) when -it wants to suppress error output. - -Fixed OUTPUT-VECTOR to not consider *PRINT-ARRAY* in string printing. - -Changed FEATUREP to barf if it is passed a list form with a strange CAR. - -Changed the default list pretty-printer to only print lists that start with -symbols as function calls if the symbol is fboundp. - -Fixed MERGE-DIRECTORIES to correctly handle the case when the second -directory spec is NIL. In this case it should just use the first directory -verbatim. This fixes (MERGE-PATHNAMES "foo/bar" ""). - -Changed WITH-PATHNAME to call PARSE-NAMESTRING on the result of FILE-NAME. - - -Compiler: - -When we have a :SAFE VOP, flush result type checks when the result has only a -single use. - -In COMPILE-FILE use PATHNAME of the output stream rather than TRUENAME of the -output-file. It seems that sometimes the file doesn't appear in the file -system until some time after we close the file. - -When computing costs for references by MOVE VOPs, don't signal an error if a -cost is missing. - -Several minor fixes to the SPARC code generators: -- Fixed result type assertion on the :SAFE (tagged add) VOPs. The result type -must be FIXNUM (when with :SAFE VOPs need not be proven type, only asserted.) -- Added GENERIC-EQL/FIXNUM VOPs (with higher costs) to prevent spurious -representation number-consing when a fixnum and a word-integer are compared -(e.g. in ZEROP.) -- Added notes for character move/coerce VOPs. -- Added notes for float move/coerce VOPs. -- Updated the integer move/coerce VOPs to correspond to the MIPS version. -The fixnum cases are split off so that we have a better idea of the cost (for -efficiency notes.) Added notes to these VOPs. -- Added notes for SAP coercion VOPs. Fixed cost for MOVE-FROM-SAP. - - -Hemlock: - -Fixed REVERT-PATHNAME not to call FILE-WRITE-DATE on NIL if there it no -checkpoint file. - -Don't call NAMESTRING on NIL in REGION-COMPILE. - -Deleted EVAL-WHEN (COMPILE) around DEFINE-SEARCH-KIND and -SEARCH-ONCE-{FORWARD,BACKWARD}-MACRO so that we don't have to compile this file -to compile search2. - - -CLX: - -Fixed DEFTYPE for CHAR-INFO-VEC. It is not in fact always length six (in -fact, I believe it never will be.) - -Fixed ordering of some forms that got trashed in the last merge. - - - -12/19/91 to 12/22/91 - -Various fixes in the new pathname code. Following is some clarification of the -nature of the new pathname support. - -Programs that actually conform to the CLtL1 pathname spec will have very few -problems. However, the CLtL1 spec was extremely vague, and CMU CL did not make -use of much of the allowed flexibility, so many technically non-portable -programs previously worked under CMU CL. - -The main incompatible changes from CLtL1 to CLtL2: - -- Symbols are no longer acceptable filenames. - -- PATHNAME-HOST may be any object. - -- :UNSPECIFIC is now a legal pathname component. - -- MERGE-PATHNAMES now recognizes relative pathnames and treats them - specially. - -The format of directories is now specified (to be a list in a certain format.) -This required an incompatible change from the previous practice of using a -vector PATHNAME-DIRECTORY and using "DEFAULT" or :ABSOLUTE in the -PATHNAME-DEVICE to indicate relative and absolute pathnames. - -In a related change, the CMU SEARCH-LIST extension was changed so that the -search-list now appears in the PATHNAME-DIRECTORY as - (:ABSOLUTE #<Search-list "name"> ...) - -A consequence of this change is that search-list definitions can now only -contain directories (and other search lists); the component pathnames cannot -have name or type specified. Other changes to search-lists: - -- (SETF SEARCH-LIST) now accepts a string or pathname, and converts it into - a one-element list. - -- Search-list elements are now canonicalized to pathnames rather than to - strings. - -New features which are now supported: - -- Wildcard pathnames are now fully supported. In addition to allowing :WILD - in any pathname component, "extended wildcards" such as "foo*.*" are also - supported. A consequence of this is that PATTERN objects may appear in - wildcard pathname components instead of strings. See PATHNAME-MATCH-P and - TRANSLATE-PATHNAME. - -- As a CMU CL extension, a wildcard pathname may be used as the argument to - any filesystem interface (like OPEN) as long as it matches only one file. - -- The pathname :COMMON case mechanism provides a way around the problems of - portably specifying string pathname components in the presence of operating - systems with differing preferred case in their filesystem. An uppercase - string "LISP" is mapped to the "customary case" (lowercase on unix.) - Lowercase is also inverted: "readme" becomes "README". Mixed case is left - alone. Note that this mechanism is explicitly enabled by supplying :CASE - :COMMON to functions such as MAKE-PATHNAME. The default is the old - behavior (:CASE :LOCAL). - -Also, DIRECTORY now actually returns the TRUENAME of each file (as it was -always supposed to do.) If a matched file is a symbolic link, the truename may -be a file in some other directory that doesn't even match the pattern. The old -behavior can be obtained by specifying :FOLLOW-LINKS NIL. - -The new wildcard pathname mechanism has not yet been used to replace the old -single-wildcard matching in Hemlock DIRED, etc. - -Other bug-fixes: - -- PURIFY now places indirect value cells and funcallable instances in static - space. Purified code that contained closures or generic functions as - function constants could have experienced bad pointer problems. - -- The compiler now correctly compiles dynamic scope binding forms such as - CATCH and special binding even when there is no code the scope. - -- Fixed a bug in the FASL dumper's byte-swapping. This affects only - implementors who do cross-compilation. - -Also, a new heap-groveling tools was used to locate a major reason for the -spurious retention of deleted Hemlock buffers. This has now been fixed. Stay -tuned for more memory leaks. - - -12/13/91 to 12/19/91 - -Code: - -All pathname support has been rewritten to conform to X3J13. (Except logical -pathnames haven't been written yet). Any code that makes assumptions about -the format for pathnames (e.g. pathname-device being the search-list, or -pathname-directory being a simple-vector) will have to be rewritten. - -Changed SHOW-RESTARTS to also display the restart name (but only if it's -not shadowed by a higher priority restart). Changed the restart command to -look for restarts by name if a symbol is typed. - -Substantially rearranged function describing to make it more consistent, and -added support for describing interpreted functions. - -Changed the FORMATTER stuff to use positional args where possible instead -of always extracting elements from the rest arg. - -The control stack is now zeroed between top level forms to reduce the -number of dangling pointers. - -Fixed pprint-logical-block :suffixes and *print-line* abbreviations to work -together. - - -Compiler: - -Dumping of constant structures has been fixed to conform to X3J13, except -that the generic function MAKE-LOAD-FORM isn't really used. Instead, a new -defstruct option, :make-load-form-fun, has been added that can be used to -specify a function that acts like a MAKE-LOAD-FORM method. When we have a -CLOS that supports STRUCTURE-CLASS, the default method for MAKE-LOAD-FORM -will use this information instead of having the compiler use it directly. - -When the INHIBIT-WARNINGS optimize policy is 3, suppress warnings about -undefined functions and variables. - - -PCL: - -Fixed SET-FUNCTION-NAME to correctly set interpreted function names. - - - -12/12/91 to 12/13/91 - -Code: - -The printer now goes to extra care to make sure structures only count as -one level against *print-level* and are handled correctly with respect to -*print-circle*. - -Several fixes to the pretty printer: - -- Actually store the change in the suffix length in the pretty-stream -structure (was causing suffixes to be ignored with line abbrevs). - -- Fixed an off-by-one error in desciding when to use line abbrevs. - -- Fixed output-line to make sure the buffer is large enough to fit -the prefix before we copy it in. - -- Added several new keywords to pprint-logical-block to allow better -support for pretty printing non-list objects. - -- Changed pprint-function-call to put a fill-style newline between the -the function and the first arg instead of a miser style newline. - -- Printing lists when *print-circle* and *print-pretty* are both T now -works. - - - -12/5/91 to 12/12/91 - -Code: - -Added automatic closing of opened FD-streams when they become garbage. - -Fixed the interpretive indexing conditional (~[...~]) to take into account -the list of sections is reversed. Also, check to see if zero is less than -or equal the index, not the index less than or equal zero. - -Added doc strings for pretty-printer defvars. Added a descend-into for -print-vector. Added an export for *print-pprint-dispatch*. - -Changed the dispatch for cons to pprint-fill and added a dispatch for -(cons symbol) to pprint-function-call. This way the results of -(list-all-packages) won't show up as a function call. - -Bind *current-level* to 0, *print-readably* to nil, and *read-eval* to T -when entering the debugger to make sure things print as expected. - -Picked up Miles' latest disassembler changes (source printing.) - -Changed reader to ignore undefined macro characters when *read-suppress* is T -(i.e. in #+/- conditionals.) - - -Compiler: - -Fixed various places where the result type of a node was spuriously being -inferred to be NIL, causing spurious code deletion. - -Give a warning in DERIVE-NODE-TYPE when we prove inconsistent types. This -is probably always a bug, but I don't want to use ASSERT until all -the problems are fixed. - -The compiler now recognizes a new class of local functions and compiles them -more efficiently. Basically, in many cases local functions with more than one -call can share the same stack frame with the caller as long as there is only -one place that the function ever returns to (all other calls must be -tail-recursive.) This compiles recursion-loops much more like setq/go loops. - -Fixed various bugs related to dead code deletion which were revealed by the new -optimizations. - -Fixed a bug in the implementation of tail-recursive calls which could cause -functions to use the number stack without a frame having been allocated. One -effect of this bug was that a segment violation would always kill lisp. - -If we undefine a structure type because of incompatible redefinition, then -unfreeze it also. - -Really fixed named constant referencing to preserve EQL-ness. - - -Startup code: - -Fixed to install the correct instruction on non-mips machines instead of -always installing a mips break instruction. - - -Hemlock: - -Fixed indentation for FLET&c to check that we are actually in the first arg -form before doing funny indentation. - -Set the typescript stream character position to zero whenever the user presses -enter. - - -11/27/91 to 12/5/91 - -Code: - -Almost all of the printing code has been rewritten/restructured to support -all of the printing features added to the language. Some highlights: - - *PRINT-READABLY* is now supported. - - *PRINT-CIRCLE* works irrespective of *PRINT-PRETTY*. - - *PRINT-LEVEL* abbreviation now works automatically inside structure - printers. - - XP has been replaced with a native pretty printer that is fully - integrated with the rest of the system. - - The macros WITH-STANDARD-IO-SYNTAX and PRINT-UNREADABLE-OBJECT have - been added. - - The FORMATTER macro has been written, and FORMAT extended to accept - a function instead of a control string. - -DATA-VECTOR-SET, the internal function responsible for doing the work of -(SETF (AREF ...) ...), has been fixed to type-check the value. - -The FASL loader has been changed so that you can concatenate fasl files -together and load the result. - -Added *READ-EVAL*, which when set to NIL causes #. to signal an error -instead of evaluating the next form. - - -Compiler: - -You can now (DECLARE (IGNORE #'FUN)) as per an ANSI cleanup. - -IGNORABLE, as in (DECLARE (IGNORABLE ...)) is now exported from the LISP -package as ANSI adopted it. - -Fixed TYPES-INTERSECT to consider any supertype of T to definitely intersect -with anything. - - - -11/25/19 to 11/27/91 - -Code: - -Made TRACE and UNTRACE handle function objects as well as function names. - -Made calling UNTRACE while with a BREAK from TRACE'ing work fine. No output -occurs at the end of the call even though there was TRACE output at the -beginning of the call before going into the BREAK loop. - -Modified HANDLE-BREAKPOINT-AUX to test whether any user hook deactivated any -breakpoints at the current code location. When there are no longer any -breakpoints at this location, it foregoes setting an after breakpoint to -re-establish the break instruction at this code location. There is no reason -to plan to re-establish the break instruction since there are no longer any -active breakpoints at the location. - -Modified SUB-DEACTIVATE-BREAKPOINT to only remove the break instruction from -the code when there are no longer any active breakpoints at the code location. - - -Compiler: - -Picked up a large number of changes for Miles' disassembler. - -Miles' disassembler is now used on the PMAX in addition to the SPARC. - -Fixed named constant dumping to allow direct references to interned symbols. - - - -11/19/91 to 11/25/91 - -Compiler: - -The new special form LOAD-TIME-VALUE now exists. See CLtL2 for information -on how to use it. - -Handling of constants has been cleaned up. When using COMPILE and -COMPILE-FROM-STREAM, anything is allowed as a constant. When using -COMPILE-FILE, dumping of arrays has been brought up to spec with respect to -X3J13. Specifically: - - displaced or adjustable arrays and vectors with fill pointers are -converted to a simple-array duplicate during the dump. - - arrays of floats are left as arrays of floats instead of being converted -into arrays of element-type T that just so happen to hold a bunch of -floats. - -The type declarations for DOCUMENTATION and (SETF DOCUMENTATION) have been -fixed to allow any symbol for the document kind. - -If we see a reference to a named constant that isn't a number or charcter, -then convert it as SYMBOL-VALUE. This is so that DEFCONSTANT'ed values -remain EQL. - - -Hemlock: - -Added wm-hints for pop-up display windows. This will be necessary to receive -input in OpenLook windowing systems, but we also thought this might be be MWM -bug that prevents pop-up windows from receiving input. It was unlikely this -was the problem since other Hemlock windows could receive input without the new -wm-hint we set to get input in OpenLook windowing systems. - -Delete SET-WINDOW-ROOT-Y since it is no longer used since we installed window -groups. - - - -10/14/91 to 11/19/91 - -CLX: updated to CLX R5. Please report any new X lossage. X applications -should probably be recompiled. - -PCL: merged with the lastest PCL version. PCL/CLOS applications must be -recompiled. - -Note: although some problems with the existing Alien code have been fixed, -many problems remain. In particular, interpreted Alien code doesn't work. -We are currently implementing a new Alien interface with much greater -functionality (as well as fewer bugs.) - -Cleanups: - -- The types BASE-CHARACTER and EXTENDED-CHARACTER have been renamed to - BASE-CHAR and EXTENDED-CHAR as per the CHARACTER-VS-CHAR cleanup. - -- Added syntax checking on the DEFSTRUCT :CONC-NAME option, and also, allow - it to be a string as well as a symbol. - -Enhancements: - -- Modified DESCRIBE-FUNCTION-COMPILED to better output function documentation - relative to displaying arguments. The format now is as follows: - - Function: - <printed representation of function object> - Function Arguments: - <printed representation of function object> - Function Documentation: - ... - -- Added EXT:*TOP-LEVEL-AUTO-DECLARE*. This variable allows control over how - the interpreter treats SETQ's of undeclared variables. - -- Modified EXT:COMPLETE-FILE to correctly complete files relative to the - defaults. This fixes a long standing Hemlock problem: you could find files - relative to the defaults with subdirectory specs, but you could not - complete them. - -- Added definition of SYSTEM:FOREIGN-SYMBOL-ADDRESS, which returns the SAP - corresponding to a loaded foreign symbol. - -- NTH-VALUE now no longer cones for it now doesn't cons for non-constant N - less than 3. - -- Added :UNIX to the features list. - -Bug fixes: - -- Changed inspector font specs to use point size instead of pixel size so - that they will work on 100dpi devices. - -- FDEFINITION should now signal undefined function errors when appropriate, - instead of returning a trap object. - -- EXPT now handles the SINGLE-FLOAT x SINGLE-FLOAT arg type combination. - -- TRUNCATE now handles the single-float/double-float case. - -- Bignum printing now works with base 36. - -- Fixed DIRECTORY to no longer signal errors. It's job is to return a list - of files matching its argument, and it should return nil when the spec is - inaccurate. - -Debug Internals interface: - Changed name of DI:DO-BLOCKS to DI:DO-DEBUG-FUNCTION-BLOCKS. - - Wrote DI:FUNCTION-END-COOKIE-VALID-P which takes a frame and a - function-end-cookie. It returns whether the cookie is still valid. This - provides a way for function-end breakpoint users to detect that the - function end breakpoint was never run due to a THROW (or other non-local - exit.) - - Wrote DEBUG-FUNCTION-START-LOCATION which takes a debug-function; it - returns a code-location before the body of a function and after all the - arguments are in place. If this cannot determine that location due to a - lack of debug information, it returns nil. - -Fdefinition.lisp is all new, and it contains the following interface routines: - EXT:ENCAPSULATED-DEFINITION - Returns whatever definition is stored for name, regardless of whether it - is encapsulated. This is SETF'able. - EXT:ENCAPSULATE - Replaces the definition of name with a function that binds name's - arguments a variable named argument-list, binds name's definition to a - variable named basic-definition, and EVAL's body in that context. Type - is whatever you would like to associate with this encapsulation for - identification in case you need multiple encapsuations of the same name. - EXT:UNENCAPSULATE - Removes name's most recent encapsulation of the specified type. - EXT:ENCAPSULATED-P - Returns t if name has an encapsulation of the given type, otherwise nil. - -The old encapsulation-based tracer has been replaced with a new one based on -breakpoints. The new traced is exported from DEBUG, using the same name and -interface as the old one. The old tracer is still exported from EXTENSIONS as: - ext:*old-trace-print-level* - ext:*old-trace-print-length* - ext:*old-traced-function-list* - ext:*max-old-trace-indentation* - EXT:OLD-TRACE - EXT:OLD-UNTRACE - -Miles's retargetable disassebler should now be available on the SPARC. - - -Compiler: - -The compiler now recognizes function calls that never return, and takes this -into consideration when determining the possible control flows. A function can -be declared not to return by declaring its result type to be NIL (not to be -confused with NULL). If a function declared NIL does return, and error will be -signalled. - -Optimizations: - -- Fixed some problems where the compiler would unnecessarily number-cons - because it wasn't taking into consideration the advantages of keeping a - descriptor representation. - -- The CLOS FUNCALLABLE-INSTANCE-P is now a primitive predicate. - -- Loop rotation is now done, eliminating the unconditional branch at the - bottom of while loops. - -- Control flow determination now recognizes code that doesn't return (error - traps, throws, etc.) so as to minimize unconditional branches in code - containing error checks. - -- Added derive-type methods for ASIN, ACOS, ACOSH, ATANH and SQRT which figure - out whether the result type is real on the basis of the argument range. - Added inference methods on irrational functions whose result is real - when the args are. - -- Many previously defined optimizations are now being triggered more - consistently when they are applicable. - -- Improved inline expansion of the set functions by causing implicit MEMBER - calls to be inlined as well. - -Enhancements/big fixes: - -- Suppress argument assignment warning if the function type doesn't give us - any new information. - -- The compiler now recognizes that the second value of INTERN can be NIL. - -- Lambdas with &key but no specified keywords are now correctly parsed. - -- Fixed a block compilation / FTYPE declaration interaction. - -- Fixed TAGBODY not to consider NIL to be a tag. - -- PCL defmethods now have qualifiers and specializers in their names. - -- Fixed a number of problems with dead code deletion, now that more dead code - is being detected. - -- FTYPE proclamations on structure accessors are now quietly ignored, instead - of causing the structure to be undefined. - -- Added a RANDOM derive-type method. - -- Added multiplier recoding for ub-32 * ub-32 => ub-32. - -SPARC: - -- Fixed decode-float for long-floats (fixing long float printing, etc.) - -- CHECK-STRUCTURE now uses a conditional trap, reducing code size. - - -Hemlock: - -Modified CREATE-WINDOW-WITH-PROPERTIES to supply :input :on to allow silly -OpenLook pseudo-X11 Sun servers to do the right thing. - -Added termcap parsing for things like begin/end bold, underline, etc. - -Fixed a redisplay problem that often caused subprocess output to not be -displayed until some input event came along. - -There's a new "Buffer Modified Hook" function that raises the "Echo Area" -window when it becomes modified. You can control this with the Hemlock -variable: "Raise Echo Area When Modified". It isn't good enough to set "Set -Window Autoraise" to :echo-only because output appears in the echo area at -times when the echo area is not set as the current window. The only -malfunction of setting this new variable is sometimes Hemlock clears the echo -area, which modifies it, and then does not output any text; in this situation, -Hemlock would raise the echo area, but it doesn't need to do so. This cannot -be eliminated due to the nature of the "Buffer Modified Hook". - -Fixed the :file branch of "Help on Parse" to trim leading directory -components off the pathname if it wouldn't otherwise fit on the screen. - -Before doing directory translations, try a probe-file of the source file -first. This way, you don't have to have 400 different translations -for ever conceivable source path. - -Fixed "Load File" to correspond with the manual by making it regard "Remote -Compile File". It was always going through RFS when it should do so -conditionally. - -Generalized FLET-style indentation to reference the variable -"Lisp Indentation Local Definers", and also to recognize LABELS (as well as -MACROLET and FLET.) - -Added DEFINDENT's for the "WIRE" package. - -Fixed name of mail drop MH profile component from mail-drop to MailDrop - -"Insert Message Buffers" now handles multiple windows appropriately when -inserting text into a Netnews Post buffer. - -Changed Hemlock window flashing to be less spastic in the presence of net delays. - -Netnews: - -The binding #k"r" has changed to "Netnews Reply to Sender in Other Window" in -"News-Headers" and "News-Message modes. - -The binding #k"R" has changed to "Netnews Reply to Group in Other Window" in -"News-Headers" and "News-Message" modes. - -Changed NN-REPLY-CLEANUP-SPLIT-WINDOWS to delete the message-window instead of -the reply-window. - -Split CONNECT-TO-NNTP into two: RAW-CONNECT-TO-NNTP and CONNECT-TO-NNTP. The -first is the same as the original with the addition of specifying a timeout -value to MAKE-FD-STREAM. The second binds a handler for the IO-TIMEOUT -condition and gives the user an error message. - -Added Hemlock variable "Netnews NNTP Timeout Period" to control how long -Netnews will wait (while connecting to NNTP) before timing out. - -Changed *nntp-server* into Hemlock variable "Netnews NNTP Server". - -Added command "Netnews Reply to Sender in Other Window". - -Added functions NN-SETUP-FOR-REPLY-BY-MAIL and NN-REPLY-TO-SENDER to hold -common code for "Netnews Forward Message", "Netnews Reply to Sender", and -"Netnews Reply to Sender in Other Window". - -Changed default bindings to use "Netnews Reply to Group in Other Window" and -"Netnews Reply to Sender in Other Window" - - -10/8/91 to 10/14/91 - -This is version 15b (destined for beta release.) - -Debugger: - Fixed to use SYMBOL-MACROLET instead of "SYMBOL-MACRO-LET." - Updated documentation on MAKE-BREAKPOINT and ACTIVATE-BREAKPOINT. - - The latest alpha test breakpoint interface is available as described in the - Debugging Tools Programmer's Interface. Also, support for setting - breakpoints from the editor has been changed to use the "WIRE" package - directly. There is a new interface for deleting breakpoints set by the - editor. This is all alpha test code. - - Added an optional argument to PRINT-FRAME-CALL-1, an internal function, to - control whether it precedes its output with a newline. - -Hemlock: - Added a form to SERVER-DIED to clean up breakpoint-infos for that server. - Added a missing ~ in slave compilation the echo area message. Oops... - - Changed hemlock init file loading to accept .hemlock-init as well as - hemlock-init. Fixed ED doc string. - - Modified TTY-DELETE-WINDOW to be consistent with TTY-MAKE-WINDOW's creation - policy; that is, if the latter makes window by putting the new one after - some hunk it shrunk to make room, then the former should prefer to grow the - previous hunk, not the next. This was the intended behavior. - - The "Debug Breakpoint" and "Debug Delete Breakpoints" commands are ready - for alpha testing, which they need a lot. Some other bugs have been fixed - too, but those were long enough ago, I don't remember them. - - -9/18/91 to 10/8/91 - -Code: - -Changed ordering of CHAR-NAME-ALIST to prefer NEWLINE, ESCAPE and DELETE to -LINEFEED, ALTMODE and RUBOUT (when printing.) - -Changed the internal directory support functions to use the C routines -opendir, readdir, and closedir, so that directory works under sunos. - -In RUN-PROGRAM, don't set XTABS on the pty so that tabs will be passed -through to as is. This allows better tab support in Hemlock shell buffers. - -Added :KEY argument to REDUCE. - -Fixed SUBSTITUTE & friends to pass arguments to the TEST in the right order. - -Fixed SUBSTITUTE not to randomly apply the KEY to the OLD value. - -Changed LIST NSUBSTITUTE & friends to work in the :FROM-END case. - -Added export of remote-object, the name of a type, from the "WIRE" package. - -Added WIRE-{OUTPUT,GET}-BIGNUM and extended WIRE-{OUTPUT,GET}-OBJECT to use -them. - - -Compiler: - -Fixed bug in FIND-REFERENCE-FUNCTIONS introduced by the last change. Ignoring -of top-level references was effectively disabled, causing top-level code to -normally be incorporated in real function components. - -Fix to make unreferenced arguments in local call work. We were correctly -only popping (into the INTERNAL-APPLY arglist) the number of referenced -args, but INTERNAL-APPLY was assuming that all arguments were present -in the list. Added a flag to INTERNAL-APPLY to control this behavior. -This was breaking full call to interpreted functions as well, since the -XEP did a local call to the main entry. - -Changed NOTE-FAILED-OPTIMIZATION to print the transform note explaining what -the transform was trying to do. - -Fixed lossage concerning the following compiler output: - Definition has N args, but the previous definition had M. -This used to be a note, but it should be a warning. - -If it is a warning that users change the definitions of structures, then it -should be a warning when users change the definitions of functions. In both -cases, code might be lying around assuming an incorrect interface. I think -this is equally dangerous. Also, changing the redefinition of arg counts to a -warning makes it more compatible with the warning that someone supposedly -called a routine with the wrong number of args. - -Changed SYMBOL-MACRO-LET to SYMBOL-MACROLET. - - -Hemlock: - -Added "Typescript Slave Status", with binding H-s. - -Added font support for the TTY. Allow active region highlighting and open -paren highlighting when on the TTY, as they now work. - -Changed the compile-in-slave utilities to count notes and display in -completion message. Also fixed not to print echo area messages "Error in -NIL ..." - -Fixed "Move Over )" to use a permanent mark instead of a temporary mark -because it deletes text. - -Adjusted length of the :hemlock-banner modeline-field to prevent the -*truncated-field-character* from appearing after the date. - -Fixed sentence-offset-forward to work at the end of the buffer. - -Added noise to skip over comments in /etc/termcap, which start with a # and -end on the end of the line. This was necessary in order to bring Hemlock -up under SunOS, because the SunOS /etc/termcap file has comments in it. - -Deleted unused function TTY-FIND-BIGGEST-HUNK. - -Modified TTY-DELETE-WINDOW to be consistent with TTY-MAKE-WINDOW's creation -policy; that is, if the latter makes window by putting the new one after some -hunk it shrunk to make room, then the former should prefer to grow the previous -hunk, not the next. This was the intended behavior. - -Modified %SET-MODELINE-FIELD-FUNCTION to allow its function argument to be a -symbol or function since the purpose is to FUNCALL the thing. Since the new -system is up to spec on the disjointedness of functions, this needed to be -fixed for usefulness. - - -C Support: - -Moved the heap around to free up 0x0f000000...0x0fffffff, cause Mach 3.0 -wants to use that range. - - - -9/13/91 to 9/18/91 - -Hemlock: - -Removed some old bindings for some netnews commands that no longer exist. - -The Netnews post delivery code no longer adds a DATE field to the message. The -lower level transport mechanism does this. - -Modified MH-PROFILE-PATHNAME and MH-DIRECTORY-PATHNAME to use TRUENAME on the -result of USER-HOMEDIR-PATHNAME now that it returns a logical name instead of -an absolute pathname. - - - -8/29/91 to 9/13/91 - -Code: - -Changed all places absolute pathnames were used to indirect search-lists, -mostly library:. The library: search-list is built from the CMUCLLIB -environemnt variable if it exists, and defaults to /usr/misc/.cmucl/lib/ if -not. - -Moved OS specific functions into the new files mach-os.lisp and -sunos-os.lisp. Also, added some routines to abstract some OS operations, -like get-page-size. - -Optimized the TIME macro to keep the consing overhead of using it zero. - - -Compiler: - -Fixed a bug where the compiler would flame out when it came across an -NLX-INFO structure when it was expecting a LEAF. - -Fixed VALUES declaration to work correctly when zero values are specified. - -Fixed FORMAT transform to warn if there are to many or too few args. - - -Hemlock: - -Changed the default value of "Slave Utility" to just "lisp" which hopefully -will be found on path:. If you don't have lisp on your path, you need to -set "Slave Utility" to the full pathname of lisp, /usr/misc/.cmucl/bin/lisp -on MACH machines. - -"Netnews Show Whole Header" is bound to #k"w" in "News-Headers" and -"News-Message" modes. - -"Netnews Show All Headers" is bound to #k"h" in "News-Headers" and -"News-Messages" modes. - -"Netnews Show Whole Header" replaces the command, in name only, "Netnews Show -All Headers". - -The Netnews interface is more polished and consistent in naming. We fixed one -or two small bugs. - - -C startup code: - -Search the CMUCLLIB search path for the core file instead of always -assuming that /usr/misc/.cmucl/lib is going to hold it. - - - - -8/9/91 to 8/29/91 - -Changed EVAL to use the recorded CONSTANT-VALUE when evaluating constants so -that interpreting references to constants in the compiler environment works -better. Now (defconstant a 3) (defconstant b (+ a 4)) works again. -Make all non-symbol atoms self-evaluate (an X3J13 cleanup.) - -Fixed one-off error in list remove-duplicates :from-end. - -Added #P pathname read syntax, and changed the pathname printer to use it. -Fixed all recursive READ calls in sharp-macros to specify eof-error-p T, so -that EOF errors are signalled when appropriate. - -Added code to compile the argument to TIME when possible, and print a warning -when it isn't. - -Fixed compiler problems with maybe-inline functions and defmethods that use -&allow-other-keys. Also fixed some problems with block compilation and unused -function deletion. - -Fixed a problem with Netnews's startup header window proportions. - -Added new command, "Netnews Show All Headers". - - -7/16/91 to 8/9/91 - -Code: - -Merged Simon Leinen's fix to OUTPUT-SYMBOL. This amounted to deleting an -incorrect and questionably optimal optimization of printing package qualifiers. - -Lots of changes to the time parsing and printing extensions including bug -fixes. - -Modified DESCRIBE-FUNCTION-COMPILED and DESCRIBE-SYMBOL to print function and -macro doc strings before arg and result info. - - -Hemlock: - -Modified "Fill Lisp Comment Paragraph" to fill strings with the appropriate -indentation as a fill prefix. When invoked outside a comment or string, this -fills contiguous lines with the same, non-empty intial whitespace. Before -executing this last case, the command prompts for confirmation, but you can -inhibit this prompting by setting "Fill Lisp Comment Paragraph Confirm" to nil. -This last case is useful for filling long EXPORT lists or other length listings -of symbols or indented text. - -Added some prototype netnews support. Details to be anounced later. - -Modified "Delete Draft and Buffer" and DELIVER-DRAFT-BUFFER-MESSAGE to work -with Netnews drafts. - -Modified "Insert Message Region" and "Insert Message Buffer" to work with -Netnews message and post buffers. - -Added a "Manual Page" command, which runs man(1) in a shell buffer. - - -Hemlock-internals: - -CREATE-WINDOW-FROM-CURRENT now creates a window according to its new proportion -argument instead of simply splitting the current window in two. It returns nil -without doing anything if either window is too small. - -WINDOW-GROUP-CHANGED no longer unifies the sizes of window when the user -resizes a group. It now tries to distribute the new size of the group -according to the proportions of the old size consumed by the windows. - -Changed ARRAY-ELEMENT-FROM-MARK to use AREF for the Netnews stuff. I -documented this to be an internal interface since a few other modes use it. - -WRITE-FILE now takes an :append argument. - - - - -6/4/91 to 7/16/91 - -Code: - -Fixed make-array to allow :initial-contents to be built out of any kind -of sequence, not just lists. - -Fixed vector-push and vector-push-extend to return the original fill -pointer, not the new fill pointer. - -Fixed vector-pop to return the value indexed by the new fill pointer, not -the original fill pointer. - -Fixed two bugs in the truncation code. - -When using the form offset to find the source form, bind *read-suppress* to -T to keep the reader from barfing on stuff that will no longer read (e.g. -#.foo in the wrong package, etc.). - -Fixed a typo in an error message in defstruct. - -Fixed FORMAT-PRINT-NUMBER to correctly insert commas for negative numbers -(don't print -,123). - -Fixed get-setf-method to only inhibit for local functions, not local macros -too. - -Fixed COPY-DESCRIPTOR-TO-STREAM to set a flag when it closes the descriptor -and to check this flag before it selects. This way, if we recursively -enter the handler (due to write-string calling something that calls -serve-event), then we won't blow out when we unwind. - -Merged old system changes. Added noise to SETUP-CHILD to try execing -/bin/sh if the original exec didn't work because of a bad magic number. - -Tweaked PRINT-HERALD to print the backend version, and to say to send mail to -cmucl-bugs. - - -Compiler: - -Fixed the compiler function database to list that the MAKE-ARRAY -:INITIAL-CONTENTS argument can be anything, because if the array has zero -dimensions, then the :initial-contents keyword is used as is. - -Made the default for COMPILE-FILE's :error-file argument be nil. It is a dated -notion and never desired to expect compilation to defaultly produce an error -output file. You always compile in the editor catching the output or in a -system building utility that saves all the compiler's output. - -Fixed a problem in EMIT-ARG-MOVES. If we do a coercion + move-arg, then the -coercion would be inserted after the ALLOCATE-FRAME VOP, which caused register -save computation to get confused. - -Fixed the make-array derive type optimizer to only spec the dimensions -if the created array is known to be simple. Otherwise, someone might -adjust it, which would cause the type to be wrong. - - -Hemlock: - -Raised the *hemlock-version* to 3.5 (.1 greater than the last old RT core.) - -"Shell Complete Filename" is a new command that attempts to complete the -filename immediately before point. The commands that start "Process" buffers -with shells establish a stream with the shell that tries to track the current -working directory of the shell. It uses the variable "Current Working -Directory" to do this. For it to work, you should add the following to your -.cshrc file: - if ($term == emacs) then - alias cd 'cd \!* ; echo ""`pwd`"/"' - alias popd 'popd \!* ; echo ""`pwd`"/"' - alias pushd 'pushd \!* ; echo ""`pwd`"/"' - endif - -Added binding, M-escape, for "Shell Complete Filename" in "Process" mode. - -Removed the definitions of command-char-bits-limit, command-char-code-limit, -KEY-CHAR-BITS, and KEY-CHAR-CODE. These are no longer used anywhere in the -system. - -Fixed some syntax constants to make 8-bit chars work. - -Modified "Visit File" to issue a loud message whenever another buffer already -contains the file visited. The quiet message often went unnoticed defeating -its purpose. - -Fixed a bug in "Center Line" which caused an internal error when invoked on the -last line of the buffer with the buffer end at the end of the line. - -Commented LISP-INDENTATION to explain what it is looking for when it determines -how to indent. Added LISP-INDENTATION-CHECK-FOR-LOCAL-DEF and used it in -LISP-INDENTATION to check for FLET or MACROLET syntax, so we could correctly -indent local definitions. They used to appear as normal forms in function call -syntax, but now they indent as definitions. - -Added DEFINDENT's for the "DEBUG-INTERNALS" interface. - -Modified LISP-GENERIC-INDENTATION to check if the mark in was in a string -context. If it is, then we return the column one greater than the opening -double quote. Otherwise, we use the first preceding non-blank line's -indentation. This fixes the problem with doc strings and ERROR strings which -got indented respectively at the beginning of the line and under the paren for -the ERROR call. - -Added "Fill Lisp Comment Paragraph" to core. This also works for strings, -except for the first line of the string. - -Added binding for "Fill Lisp Comment Paragraph" to M-q in "Lisp" mode. - -Added a doc string to EXT:SAVE-ALL-BUFFERS. - -Added a doc string to HI:DIRECTORYP. - - -Release 14c to beta.... - - -5/24/91 to 6/4/91 - -Further space reductions from compiler policy tweaks. This core is 19.1 meg. - -Tuned bignum code and added declarations and to reduce number consing. - -Added :TIMEOUT argument to MAKE-FD-STREAM. The SYSTEM:IO-TIMEOUT condition is -signalled if a timeout is specified and exceeded. - -Added :PACKAGE context declaration. - -Changed a null test in LOOP into an endp test. - -If we enter trace recursively (due to the printer calling the traced function), -then just quietly call the function, instead of signalling an annoying "unable -to trace" error. - - -5/16/91 to 5/24/91 - - -CLX: - -Fixed the CLX X interface to be much more efficient, as well as fixing some -bugs. The low-level I/O to the server is now faster and conses much less. -Enabled "fast" pixarray read/write for CMU. Code that uses X must be -recompiled. The X inspector now works reliably with both the PMAX and RT X -servers. - - -Code: - -Made SYSTEM:BITS, BYTES, etc., be defined in the null environment so that they -can be inline expanded. This was causing spurious consing in various system -code. - -Some tuning and bug fixes to FD-STREAMS (file descriptor streams) which are -used for file I/O (and now for communication with the X server.) Also, now in -OPEN complains if you try to open a non-writable file for output with :RENAME -or :RENAME-AND-DELETE. Previously this would succeed as long as the directory -was writable. SYSTEM:READ-N-BYTES on FD streams is now more efficient, but -does *not* wait using SERVE-EVENT; it blocks instead. Fixed a problem with -LISTEN at EOF on FD-STREAMS. Made *standard-output* a two-way stream so that -reading *standard-input* will force output on standard output. - -Fixed CONNECT-TO-INET-SOCKET to check that we successfully looked up the name -so that we don't get segment violations on unknown hosts. - -Fixed sequence functions that have output type specifiers to correctly handle -DEFTYPE types and other complex type specifiers. - -Some tuning in SERVE-EVENT which reduces consing and speeds up Hemlock and -terminal I/O. - - -Compiler: - -Representation conversion of a SAP (system area pointer) to a pointer -representation now results in an efficiency note. - -[PMAX] Fixed TRUNCATE on floats to truncate instead of rounding. - -If debug-info is < 1, then don't dump debug-args or function type. - -Fixed a problem that could cause type checks to be spuriously deleted in some -contexts where there is a local change in the SAFETY optimization policy. - -When doing inline expansion of recursive functions, respect NOTINLINE -declarations. - -Changed declaration processing to treat a FUNCTION declaration as an ordinary -variably type declaration (as proposed by X3J13). The old semantics is still -obtained when the second arg to the declaration is a list (as it always would -be in the old usage.) - -Added support for the EXT:CONSTANT-FUNCTION declaration (already in the -documentation.) - -When a DEFUN is compiled and the name has a FTYPE declaration, then a note is -printed if any arguments to the function are assigned to (i.e. SETQ) in the -body, as this inhibits application of the FTYPE declaration to the argument -variables. - -&AUX bindings are now compiled with the EXT:OPTIMIZE-INTERFACE policy, mainly -so that proper type checking is done for hairy keyword args. - -(<mumble>-P x) structure predicates are now just as efficient as -(TYPEP x '<mumble>). - - -4/28/91 to 5/16/91 - -New packages: - -Changed the windowing inspector to use standard fonts (courier) and to -generally work under the new-compiler system. Also, made the help window -bigger. - -An improved version of the profile package (previously in the library) is now -in the core. It now compensates for recursive calls or nested calls, and -interacts better with trace and function redefinition. - -Code: - -Now almost all Common Lisp functions which are SETFable have a (SETF name) -function. The exceptions are functions where it makes no sense (LDB, GETF), -and a few other functions (GET, GETHASH.) Now SETF of APPLY works for any -function which has a setf function. - -Changed GET-SETF-METHOD to ignore setf macros (always global) when there is a -local macro or function of the place function. [An x3j13 cleanup] - -Some fixes to DI: condition report methods, and a preliminary version of -breakpoints. - -MACROEXPAND now expands symbol macros. - -Fixed the new (sequential) ONCE-ONLY to deal properly with things like -(once-only ((a (somefun a))) ...). - -ROOM is now much more verbose, displaying a breakdown of memory usage by object -type. - -In the Unix interface, extended the length of pathnames from 64 to 1024. - -Fixed sequence functions with output type specifiers to handle DEFTYPE'ed types -and other complex types correctly. COERCE is still broken. - -Compiler: - -The compiler will now print a note whenever there is a FTYPE declaration for a -function, and an argument is assigned to. - -If debug-info is < 1, then don't dump debug-args or function type. - -&aux bindings are now compiled with the interface policy. Fixed a few places -where complex keyword arguments were not being correctly checked according to -the interface policy. - -Fixed block compilation stuff to ignore START-BLOCK declarations if -:BLOCK-COMPILE is NIL. - -The compiler now ignores assignments to special variables when determining -which representation to use for a variable. Also, we don't print -representation selection efficiency notes about coercion that are due to -error checking code. - -Changed the type system to consider #(:foo :bar) to be a subtype of -(vector keyword). In other words, array subtype relations are determined -according to the specialized element types actually present in this -implementation, rather than assuming that all element types can be -discriminated. - -Hemlock: - -Fixed a bug in completion mode (didn't previously work in the new-compiler -system.) - -Made the slave switch demon set debug:*help-line-scroll-count* to -most-positive-fixnum, since the editor can do the scrolling for us. - -CLX: - -Merged in a bug-fix to EVENT-LISTEN to make it return the right number of -events when called when there is a current event (i.e. in an EVENT-CASE.) - -4/25/91 to 4/28/91 - -Release mainly to fix a problem with in-core compilation introduced in the 3/27 -release (the usual symptom was flaming out during the compilation with a type -error about an illegal object.) - -Also, Hemlock has a new command "Set Buffer Writable", and the obsolete command -"Connect to Registered Eval Server" has been removed. - - -4/21/91 to 4/25/91 - -Some minor space reductions from leaving out compiler databases that users -don't need, and from reducing the initial allocation size of Hemlock string -tables. Some major space reductions from compiling with debug-info 1, and -reduced safety. The core is currently 18.8 meg, which is 2.5 meg smaller than -the last alpha release and 7.3 meg smaller than the current beta release. - -Major parts of the system are now compiled with no error checking. Users -should not notice any reduction in safety, since user visible interfaces are -supposed to be fully checked. Standard functions that users can cause to get -unbound symbol or array index errors needed to be changed to either do explicit -error checks or locally use a safe policy. Some of these cases may have been -missed. Let us know if you get any less-than-informative error messages -(segmentation violation) inside standard functions. - -Code: - -Argument type checking for Common Lisp functions is now driven by the -compiler's function type database. This means that some type errors might be -detected that were previously unnoticed. - -Added a CONTINUE restart in LOAD that returns NIL. Fixed up the code that was -trying to prevent you from loading zero-length fasl files (from AFS lossage). -Now if you try to load a file with a fasl file type, but that doesn't have a -valid fasl header, then you will get an error (proceeding loads as a source -file.) - -The non-destructive string functions now accept characters as well as strings -and symbols. This is an x3j13 change. - -Changed the internal WITH-ARRAY-DATA macro to do bounds checking. This causes -various string functions to give better error messages when an :END arg is out -of bounds or :START is greater than :END. - -Added type inference methods for sequence functions, and various functions that -return an argument as their result value. - -Hemlock: - -Added "Slave GC Alarm" variable (default :MESSAGE) which controls how obnoxious -the slave GC notification is. Other values are like for "Input Wait Alarm", -:LOUD-MESSAGE and NIL. - -Extensions: - -ONCE-ONLY now does sequential variable binding. This can't cause any problems, -since all names are gensyms, and is often useful. - -4/10/91 to 4/21/91 - -Code: - -Fixed some bugs in control of garbage collection that should solve some -problems with GC failing to be triggered automatically. Also, GC no longer -implicitly reenables automatic GC if it has been disabled with GC-OFF. - -Changed the default GC notify function to not beep. The old behavior can still -be obtained by setting *GC-VERBOSE* to :BEEP. Note that this only affects use -on TTYs, since slave GC notification works differently. - -Changed the printer to print the name of code objects and the value of value -cells. - -Compiler: - -Added the OPTIMIZE-INTERFACE declaration, which is just like OPTIMIZE, but -specifies the policy for parsing the arguments to defined functions and -checking of any declared argument types, allowing it to be distinct from the -general compilation policy. This allows debugged code to be compiled with -lowered safety in its "guts", while still doing checking on the arguments that -users may supply (incorrectly.) Any quality not separately specified defaults -to the normal OPTIMIZE quality. - -Fixed WITH-COMPILATION-UNIT keyword to be :OVERRIDE instead of :FORCE. -Also, added :OPTIMIZE and :OPTIMIZE-INTERFACE for changing the "global" -compilation policy within the dynamic extent. - -Added :CONTEXT-DECLARATIONS, which provides a way to insert declarations -conditional on pattern matching of the context in which the definition -appears. So you can compile all external functions safe, or whatever. -See the doc string for WITH-COMPILATION-UNIT. - -Fixed a bug in accessors for 1,2, and 4 bit arrays that was causing #* to -generate incorrect bit vectors. - - -4/8/91 to 4/10/91 - -In addition to William's fix to LOAD :IF-DOES-NOT-EXIST NIL, and a few fixes in -compiler internal error messages, this core is also 1.6 meg smaller than the -last core, which makes it 2.8 meg smaller than the current beta. (A mere 23.4 -meg) - -This space reduction came from compiling the compiler VM definition with -debug-info 1 and safety 0. - - -3/27/91 to 4/8/91 - -Code: - -Changed load to look at the file contents for the "FASL FILE" header to -determine whether to fasload or slow load, instead of forcing use of a single -fasl file type. Also, when the given filename doesn't exist and doesn't have a -type, try ``fasl'' in addition to the machine specific fasl file type. - -When the loader prints comments about loading progress, the number of leading -semicolons is now the depth of recursive loading. - -Compiler: - -Reduced the size of debug information for OPTIMIZE DEBUG-INFO less than 1. - -Compiled Hemlock with minimal debug debug, reducing the core size 1 meg. - -Added new START-BLOCK and END-BLOCK declarations to allow portions of a file to -be block compiled (instead of only entire files.) This mechanism also allows -the entry points to a block to be specified, allowing improved compilation of -non-entry-point functions. Fixed many bugs that appeared once block -compilation was actually used. - -COMPILE-FILE now has :ENTRY-POINTS and :BLOCK-COMPILE keywords. :BLOCK-COMPILE -NIL will totally inhibit compile-time resolution of function names (including -self-calls.) The default (:SPECIFIED) allows compile time resolution, but -still one top-level form at a time, preventing local calls between top-level -forms. In this mode, a (BLOCK-START Entry-Point*) declaration will start block -compilation. Block compilation is terminated by BLOCK-END, or the BLOCK-START -of the next block. - -See also the COMPILE-FILE doc string. - -Also, the ANSI :VERBOSE and :PRINT keyword arguments are now supported. The -:PROGRESS keyword is a CMU extensions that provides an even higher level of -verbosity. The *COMPILE-VERBOSE*, etc., variables are also now supported. - -Made forms within a LOCALLY be recognized as "top-level" so that subforms can -be compiled separately. - - -3/14/91 to 3/27/91 - -Highlights: - -** The FASL file format has changed, so all files must be recompiled. ** - - -Code: - -Modified EXT:OPEN-CLX-DISPLAY to set XLIB:DISPLAY-DEFAULT-SCREEN to the -screen specified by the user before returning the display. - -Fixed DOCUMENTATION to retun only one value. - -Fixed typep of (satisfies (lambda (obj) ...)) to coerce the form into a -function instead of just assuming that it could be funcalled. - -Wrapped a without-interrupts around the guts of maybe-gc so that the -notify messages and state updates don't get seperated from the actual -gc. - -Removed the icache flushing stuff from GC, because it was unneeded (and -sometimes printed annoying messages that it didn't work). - - -Compiler: - -Fixed CHECK-KEYWORDS not to print "zeroth". - -Fixed a bug introduced in the previous core in which special bindings would -not be undone if the function doing the binding tail-called some other -function. - -An additional slot has been added to the header of code objects. This slot -holds the offset of an optional ``trace-table'' that contains information -about where function prologues and epilogues, call sites, and other random -things occure. This will allow more reliable backtracing from interrupts. - - -Hemlock: - -Added *in-redisplay* flag which inhibits recursive invocations of redisplay -from doing anything. Recursive invocations can happen in TTY redisplay, since -LISTEN serves events. Also, made REDISPLAY-WINDOW-FROM-MARK check that we are -in the editor before doing anything. - -Modified MAKE-BUFFERS-FOR-TYPESCRIPT to make sure the user supplied slave-name -is free for use, so we don't clobber currently existing slaves. - - - -3/11/91 to 3/14/91 - -Code: - -Fixed FUNCTION-DEBUG-FUNCTION (though it still returns the XEP.) - -Fixed a bug in RENAME-PACKAGE that happened when the new name was one of the -old nicknames. - -Added support for the TIOCGWINSZ and TIOCSWINSZ ioctls. - -Compiler: - -Some compiler debug fixes that will hopefully eliminate spurious -undefined-function warnings. In particular, definitions of functions in -non-null lexical environments will be noticed. - -Also, now if a function is defined incompatibly with previous calls, the -warning will have proper source context. - -The compiler note count is no longer incremented when notes are suppressed by -INHIBIT-WARNINGS 3. - -Hemlock: - -Several changes to allow redisplay to be delayed until process output (i.e. in -a shell buffer) is complete. This allows the editor to catch up with output by -only displaying the final state of the shell buffer, instead of forcing every -line of output to be displayed. This is very nice with slow terminals or large -outputs. - -Changed TTY redisplay to get the terminal size and speed from Unix using the -appropriate "ioctl" calls. The speed of a PTY (and hence any telnet or MCN -connection) is infinite by default. For best results with TTY redisplay, it is -crucial to set the terminal speed with the Unix "stty" command: - stty 2400 - stty 9600 -etc. - -Setting the speed allows the editor to keep in synch with the terminal so that -typing a command can abort redisplay until the screen stabilizes. -This way, if you type C-v C-v in succession, output of the first screen will -stop when you type the second C-v. - -Fixed several bugs in TTY redisplay. "Unexpected zero transition delta" is -gone. Also, fixed some problems with the screen not being updated properly -after redisplay has been aborted. (When you type several commands in quick -succession.) - -REDISPLAY now returns T, NIL or :EDITOR-INPUT. T is returned when redisplay -changed the screen. NIL is returned when there was no change. :EDITOR-INPUT -is returned when redisplay tried to update the screen, but was aborted due to -pending editor input. - -Changed the editor input loop calling redisplay until it indicates no change. -This insures that any text modifications happening concurrently with redisplay -(such as process output) will be noticed before we go into a read wait. - - -3/4/91 through 3/11/91 - -Only Compiler fixes: - -Fixed a number of bugs in the handling of closures over top-level variables. - -Fixed a problem with semi-inline functions. - -Fixed a problem with local call conversion of functions with both optionals and -more args. - -Disabled the compiler's internal consistency checking by default. These phases -are only useful for locating compiler bugs. - - -2/3/91 through 3/4/91 - -General system code: - -Merged fix to DEFSTRUCT constructor parsing that allows multiple default -constructors, or none at all. You will need to recompile uses of DEFSTRUCT for -the #S reader to work correctly. - -Fixed bit-copy assembly routine to correctly handle overlapping source and -destination. - -standard-char-p no longer returns T for #\return - -Fixed default-structure-print to work when *print-circle* is T. - -Fixed a bug in format regarding ~@*. - -Fixed the read-eval-print loop to frob +, ++, +++ correctly. - -Changed fasl loader to eliminate the "feature" whereby zero-length fasl files -were considered to be valid (doing nothing). - -Changed DEFPACKAGE to expand into stuff that will have the package effect at -compile time as well as at load time. - -Fixed DEFPACKAGE to deal more correctly with finding symbols that must exist. - -Fixed package system code to not destructively modify the USE, USED-BY and -SHADOWING-SYMBOLS lists so that they don't get retroactively modified when -we hand them off to the user. - -Also, in SHADOW, when symbols is NIL, shadow no symbols, not NIL. - -Fixed a bug in Y-OR-N-P. It was calling WHITESPACEP on a symbol. - -Fixed READ-QUOTE to call READ with t for eof-errorp which it previously failed -to do. fixed READ-PRESERVING-WHITESPACE to no longer screw with eof-errorp -based on recursivep - -Fixed the LOOP THEREIS keyword. - -Tweaked handling of LISTEN a bit to allow READ-CHAR-NO-HANG to work correctly. -Fixed the listen method for concatenated streams. It failed to step to the -next stream when the current one hit eof. - -Make two-way streams force-output on the output side before passing any -input requests on to the input side. This eliminates the need for explicit -calls for FORCE-OUTPUT when prompting. - -Changed GET-INTERNAL-REAL-TIME to subtract out the time of the first -call to minimize the probability of bignum results. Also some other tuning -that reduced the consing of this function to 0. - -Changed TRACE to use FORCE-OUTPUT instead of FINISH-OUTPUT to prevent -gratuitous slowdowns when running in a slave. - -Compiler: - -Fixed EQL (and =) on integers to not unnecessarily cons a word-integer argument -just because one argument is known to be a fixnum. - -A number of improvements to register allocation. - -New version of the assembly with instruction scheduling (no-op deletion) -support. This reduced the size of the core by 1.3 meg, and makes everything -run faster too. - -Fixed incorrect argument type information for some standard Common Lisp -functions. - -Added a new optimization of MULTIPLE-VALUE-CALL which converts MV calls having -a known number of arguments into MULTIPLE-VALUE-BIND/FUNCALL. Combined with -some other existing optimizations, this allows functions like: - (defun foo (&rest x) - (apply #'glorp x)) - -to be efficiently inline expanded (i.e. the APPLY turns to a FUNCALL.) - -Fixed PROCLAIM to work correctly when the argument isn't a constant. - -Eliminated some problems that could cause spurious undefined function -warnings. - -Fixed the compiler to not flame out if it sees a SATISFIES type specifier where -the predicate function is undefined, and generally to deal better with testing -whether a compile-time constant is of some type that may not be properly -defined yet. - -Fixes to copy propagation and register allocated to reduce spurious moves. - -Hemlock: - -Changed typescript streams to cache the line length. This greatly speeds up -slave output. - -CLX: - -Eliminated redundant type checking. -Fixed some broken declarations. diff --git a/general-info/beta-release-notes.txt b/general-info/beta-release-notes.txt deleted file mode 100644 index 2b177e4282578b62273a7e58fd8164e3ea880835..0000000000000000000000000000000000000000 --- a/general-info/beta-release-notes.txt +++ /dev/null @@ -1,766 +0,0 @@ - Release notes for CMU Common Lisp 16f, 11 December 92 - -The changes between 16e and 16f are almost exclusively bug-fixes. When we -announce a version 17 beta, 16f will probably become the default release -(replacing 15e). The PCL has been upgraded from "March 92 (2a)" to -"March 92 (2c)", which provides some bug-fixes; also, all of the patches in -the March-92-PCL-bugs file have been applied. - -Enhancements: - -- PROVIDE & REQUIRE are now back in the system, since proposed ANSI CL has - reinstated them as deprecated features. See the doc strings for these - functions and EXT:DEFMODULE. - -- The SPARC dynamic heap size limit has been doubled from 64meg to 128meg. - -Pretty printer: - -- Fixed a bug in pprint-let that caused to to barf on (let (nil) ...). - -- Fixed pprint-lambda-list to print a space before the dot when the tail of - the lambda list is shared. In other words, print (foo . #1=(bar baz)) - instead of (foo. #1=(bar baz)). - -- Added an additional use of ~^ in pprint-flet so that (flet (nil) ...) - doesn't flame out. - -- Make pretty printer properly process pprint tabs when output is forced. - -- In format pprint logical blocks, fixed ~^ to act like - PPRINT-EXIT-IF-LIST-EXHAUSTED instead of blowing out to some containing - directive. - -Compiler: - -- Fixed compiler internal error with dead-code deletion of top-level code. - -- Bind *gensym-counter* instead of setting it so that compiling doesn't - globally reset the gensym counter. - -- Fixed problem with interpreted LOAD-TIME-VALUE causing undefined function - VALUE-CELL-REF errors. - -- Preserve the arglist in interpreted functions for DESCRIBE, etc. - -- Gag bound-but-not-referenced warnings when the EXT:INHIBIT-WARNINGS - optimize quality is 3. - -- Fixed a problem with register allocation conflict analysis which appeared - when a function was called with ~>= 50 arguments. - -- Fixed bug with optimization of tail local calls. - -- Fixed interpreted PROCLAIM/DECLAIM to ignore - START-BLOCK, END-BLOCK and declared DECLARATION declarations. - Changed the unrecognized proclamation error to be a warning. - -- Fixed float heap allocation to not wedge when the store causes a trap - (SPARC only.) - -Trace: - -- Added pretty-printer directives so that arg lists and results print better. - -- Fixed UNTRACE not to flame out when untracing untraced functions. - -- Fixed bug with redefining function traced with encapsulation (e.g. - interpreted functions. - -Misc bug fixes: - -- Fixed I/O timeout handling (e.g. for CLX) to correctly borrow from the - timeout seconds when computing the new value for the timeout microseconds. - -- Restored proper (prompt) handling of queued CLX events in SERVE-EVENT - -- Alien enums always take up an int to be compatable with C. Also, - sort the from-alist so that enum aliens are unparsed in a canonical - format. - -- When doing macro destructuring, check to see if some part of a lambda-list - is a LIST before checking to see if it is a SYMBOL, because we want NIL to - act like the empty list, and not an attempt to bind NIL. - -- Fixed PACKAGE-ERROR to have a PACKAGE slot instead of a PATHNAME slot. - -- Changed DOLIST not to introduce the spurious let around the result form - when there is no result form. Also, just read the var in the spurious - let, instead of using IGNORABLE, since the var might be special. - -- In complex DEFSETF, don't bother creating temp vars for constants. This - is necessary so that keywords stay keywords, and are not changed to - gensyms. - -Enhancements: - -- Changed the backquote expanded functions (backq-list, ...) from being - inline functions to compiler-macros, since although the optimizer does - eventually get the right code, it has to work awful hard. Changed BREAK - to accept a condition as well as a format string. - -- Exported EXT:CONNECT-TO-UNIX-SOCKET and EXT:CREATE-UNIX-SOCKET, which had - been forgotten before. Added code to CONNECT-TO-UNIX-SOCKET so that Unix - domain sockets are available for connecting to other processes. - -- Removed sys:*task-data* and sys:*task-notify* because they aren't used - even under Mach. - - - - Release notes for CMU Common Lisp 16e, 5 August 92 - -16e is primarily a bug-fix release. The main changes from 16d are: - -- CLOS support is from March 92 PCL (2a). This is a new version of PCL - developed by Richard Harris which incorporates many bug-fixes and ANSI - compliance cleanups. He has also back-merged the CMU changes into his - sources so that we can release future PCLs without time-consuming merging. - On the downside, there are a couple of new bugs (discrimination on - pcl::structure-object doesn't always work; generic functions which contain - methods which discriminate on both null and list sometimes do not work). - Patches for these bugs are available in March-92-PCL-bugs in the CMU CL - release area and by anonymous ftp from host parcftp.xerox.com - (13.1.64.94), in the directory pub/pcl/. - -- TRACE has been reimplemented, has a new syntax and new features. - -- The hardcopy and info documentation has been updated. Note that it - describes some debugger capabilities (breakpoints) which won't appear - until version 17. - -The fasl file format is the same as for 16d, but some code may need to be -recompiled. In particular, the expansion of PPRINT-LOGICAL-BLOCK has changed. - - -March 92 PCL highlights: (see notes.text in the sources for details) - -- This version of PCL is much closer than previous versions of PCL to the - metaobject protocol specified in "The Art of the Metaobject Protocol", - chapters 5 and 6, by Gregor Kiczales, Jim des Riveres, and Daniel G. - Bobrow. - -- You can use structure-class as a metaclass to create new classes. - Classes created this way create and evaluate defstruct forms which - have generated symbols for the structure accessors and constructor. - -- Various optimization of instance variable access, both inside and outside - of methods. - -- More work (lookups and precompilation) is done at compile and load time, - rather than run-time. - - -New TRACE: - -Trace has been substantially rewritten, and has a new syntax as well as new -functionality: - -- Tracing of compiled functions is now implemented using breakpoints. - Breakpoints destructively modify the code object, causing all calls to the - function to be trapped, instead of only those calls that indirect through - the symbol. This makes TRACE more useful for debugging programs that use - data structures containing function values, since you can now trace - anonymous functions and macros. Also, the breakpoint stops the function - after the arguments have been parsed, so arguments can accessed by name in - the debugger or in TRACE options. - -- Depending on the ENCAPSULATE option and DEBUG:*TRACE-ENCAPSULATE-DEFAULT*, - encapsulation may be used instead. This is the default for closures, - generic functions and interpreted functions. - -- TRACE options are no longer set off by extra parens, and you can specify - global trace options which affect all functions traced by a particular - call to TRACE. - -- Conditional breakpoints now work much better than before. - -- *DEBUG-PRINT-LEVEL*, -LENGTH* are used instead of a separate - *TRACE-PRINT-LEVEL*, etc. - -Here is the documentation string (see also the hardcopy/info documentation): - TRACE {Option Global-Value}* {Name {Option Value}*}* - TRACE is a debugging tool that prints information when specified functions - are called. In its simplest form: - (trace Name-1 Name-2 ...) - - TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named - functions is entered or returns (the Names are not evaluated.) The output - is indented according to the number of pending traced calls, and this trace - depth is printed at the beginning of each line of output. - - Options allow modification of the default behavior. Each option is a pair - of an option keyword and a value form. Options may be interspersed with - function names. Options only affect tracing of the function whose name they - appear immediately after. Global options are specified before the first - name, and affect all functions traced by a given use of TRACE. - - The following options are defined: - - :CONDITION Form - :CONDITION-AFTER Form - :CONDITION-ALL Form - If :CONDITION is specified, then TRACE does nothing unless Form - evaluates to true at the time of the call. :CONDITION-AFTER is - similar, but suppresses the initial printout, and is tested when the - function returns. :CONDITION-ALL tries both before and after. - - :WHEREIN Names - If specified, Names is a function name or list of names. TRACE does - nothing unless a call to one of those functions encloses the call to - this function (i.e. it would appear in a backtrace.) Anonymous - functions have string names like "DEFUN FOO". - - :BREAK Form - :BREAK-AFTER Form - :BREAK-ALL Form - If specified, and Form evaluates to true, then the debugger is invoked - at the start of the function, at the end of the function, or both, - according to the respective option. - - :PRINT Form - :PRINT-AFTER Form - :PRINT-ALL Form - In addition to the usual prinout, he result of evaluating Form is - printed at the start of the function, at the end of the function, or - both, according to the respective option. Multiple print options cause - multiple values to be printed. - - :FUNCTION Function-Form - This is a not really an option, but rather another way of specifying - what function to trace. The Function-Form is evaluated immediately, - and the resulting function is traced. - - :ENCAPSULATE {:DEFAULT | T | NIL} - If T, the tracing is done via encapsulation (redefining the function - name) rather than by modifying the function. :DEFAULT is the default, - and means to use encapsulation for interpreted functions and funcallable - instances, breakpoints otherwise. When encapsulation is used, forms are - *not* evaluated in the function's lexical environment, but DEBUG:ARG can - still be used. - - :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment - of the called function; DEBUG:VAR and DEBUG:ARG can be used. The -AFTER and - -ALL forms are evaluated in the null environment. - - -Assorted bug fixes and enhancements: - -System code: - -- Changed default base file name for LOAD-FOREIGN to be argv[0] rather than - being hard-wired to "lisp". - -- Fixed a bad declaration which caused garbage collection to fail if more - than MOST-POSITIVE-FIXNUM bytes had been consed since process creation. - -- Changed GET-INTERNAL-RUN-TIME to use UNIX-FAST-GETRUSAGE to avoid - number-consing and generic arithmetic. Also, rearranged the computation - so that the time is correctly computed for up to 457 days, instead of only - 71 minutes. - -- Merged Miles' fix to MAKE-PATHNAME so that it knows the difference between - an arg being NIL and being unsupplied. - -- Some partial fixes to circular printing (the #1=#1# bug). - PPRINT-LOGICAL-BLOCK no longer checks the list argument for CAR - circularity, now that OUTPUT-OBJECT does it for us. - -- Fixed reader dispatch macro characters to be case-insensitive, and to - disallow digits as sub-characters. - -- Changed #A reader to allow arbitrary sequences instead of just lists. - -- RUN-PROGRAM now gives a proper error message when "fork" fails (i.e. too - many processes.) - -- Fixed a bug in initialization of saved cores which caused the old - environment to be left on the end of EXT:*ENVIRONMENT-LIST*. One symptom - was that RUN-PROGRAM would run programs with strange environment values - based on those in effect at the time the core was saved. In particular, - Lisp subprocesses (i.e. Hemlock slaves) might get the wrong value of - CMUCLLIB, which caused the slave to die before connecting. - -- SYSTEM:SERVE-EVENT (and XLIB:EVENT-CASE, etc.) now correctly handle - non-integer timeouts. Added declarations to improve the efficiency of - event handling. - -- Fixed some bugs in UNIX-SELECT which could cause Lisp to hang when more - than 32 files were open. Also, improved efficiency in this case. - -- Merged Olssons fix to WITH-ENABLED-INTERRUPTS to not try to change - interrupt characters anymore. - -- A number of bug-fixes for breakpoint support in compiled code (but there - are still problems with arbitrary breakpoints.) - -- Fixed DI:FRAME-CATCHES - -CLX: - -- Fixed the implementation-dependent pixarray copying routines (for - GET-IMAGE, etc.) so that they don't occasionally trash memory, and are - actually faster. - -- Fixed the definition of the ANGLE type (used by DRAW-ARC, etc.) to work - regardless of the kind of real number (single or double float, rational, - etc.) - -- Fixed several places in image operations where values that could really - be negative were declared to be non-negative. - -Compiler: - -- Fixed a bug which caused an internal error whenever a call to random - was compiled and the argument type wasn't known to be either a float or - an integer. - -- Fixed a bug which caused an internal compiler error when a value that - wasn't used had an unproven type assertion. - -- Fixed some more dead-code deletion bugs. - -- Fixed a problem with the new "assignment" optimization of local function - call where the compiler could get assertion failures such as tail-sets not - being equal. - -- Fixed a few places where reoptimization wasn't being triggered when it - should have been. - -- You can now have a TAGBODY with more than one tag that is non-locally - exited to. Evidently this never worked... - -- Some changes in debug-info format related to breakpoint support. - -Misc: - -- Fixed some Hemlock Dired commands to know that PATHNAME-DIRECTORY is - now a list, not a vector. - -- Fixed the bin/sample-wrapper script to use "$@" instead of $* so that - arguments are properly passed through. - - - Release notes for CMU Common Lisp 16d, 30 May 92 - -16d is our first version 16 general release, and incorporates many changes not -present in the 15 series. It is currently fairly close to our current -internal development (alpha) systems, and is thus less stable. The major -changes are: - New Aliens - New pathnames - New pretty printer - New format - R5.0 CLX. - 5/1/90 May Day PCL (REV 4b) - Revised manual - -The fasl file format is nominally compatible with version 15, but the pathname -change affects any pathname constants in fasl files, which includes the -defined-from information present in every fasl file. It is probably a good -idea to recompile everything. - -CLX and Hemlock are now optional. When CMU CL is installed, the maintainer can -elect not to load CLX and Hemlock -- this saves 7 megabytes of disk and -improves memory usage somewhat. See the installation section of the README -file for details. - -The ``CMU Common Lisp User's Manual'' has been updated to be more helpful for -non-CMU users. The new manual also documents the new Alien facility for -foreign function calls and data structure access. The manual is now formatted -with Mike Clarkson's LaTeXinfo package, so a consistent version of the -documentation is available online in Gnu info format. See `doc/cmu-user.ps' -and `doc/cmu-user.info'. - - -General system code: - -ANSI cleanups: - -- ANSI Compiler macros are now implemented: see COMPILER-MACRO-FUNCTION, - COMPILER-MACROEXPAND, COMPILER-MACROEXPAND-1 and DEFINE-COMPILER-MACRO. - -- Fixed things that invoke *MACROEXPAND-HOOK* to coerce it to a function - before calling it. - -- Fixed MACRO-FUNCTION to take an environment argument. - -- SYMBOL-MACROLET now accepts declarations. - -- SHADOW now accepts strings in addition to symbols. - -- Added UPGRADED-ARRAY-ELEMENT-TYPE and UPGRADED-COMPLEX-PART-TYPE. - -- IGNORABLE is now in the LISP package instead of the EXT package. - -- ADJUST-ARRAY has been updated to allow adjusting of arrays which were - not created with :adjustable non-nil to be adjusted to new dimensions. - -- ADJUSTABLE-ARRAY-P has been updated correspondingly. It returns T if - adjust ADJUST-ARRAY would return an EQ array. - -- The BASE-CHARACTER type has been renamed to BASE-CHAR. - -- The REAL type and REALP function are now implemented. - -- Changed the default structure printer to print slot names as keywords - instead of unqualified symbols. - -Enhancements: - -- Added MAYBE-INLINE declaration for GET, PUT, etc., so that these - functions can be inline expanded according to the compilation policy. - -- Added some type declarations so that GET-INTERNAL-REAL-TIME doesn't cons. - -- Process the command line before printing the herald so that we can eval - some form and quit without printing anything. - -- SET now protects against setting T, NIL, and keywords. (SETF - SYMBOL-FUNCTION) now expands into FSET, which protects against defining - NIL. - -- Substantially rearranged function describing to make it more consistent, - and added support for describing interpreted functions. - -- PURIFY is now called multiple times during system building to improve - locality. - -- (EVAL-WHEN (EVAL) ...) is now actually eval'ed. - -Bug fixes: - -- Fixed bug in NTH-VALUE where it expanded into bogus code unless ``n'' was - a constant integer. - -- Fixed FMAKUNBOUND to return the symbol instead of T. - -- Allocate memory as executable so that the OS knows to maintain cache - consistency. - -- Changed DESCRIBE to allow T or NIL as the stream argument. - -Load enhancements and cleanups: - -- The initial value of *LOAD-VERBOSE* is now T. Additionally, LOAD no - longer always binds *LOAD-VERBOSE* and *LOAD-PRINT*. Now it only - binds them when :VERBOSE or :PRINT are explicity supplied. Therefore, you - can set either of these in your init file and it will take effect. - -- Normally when *LOAD-VERBOSE* is T, only the file name is printed. - Formerly, the loaded stream was always printed, whereas now a stream is - printed only when the stream is not a file stream. - -- Added ANSI features *LOAD-TRUENAME*, *LOAD-PATHNAME* and *LOAD-PRINT*. - -- As per ANSI, bind *READTABLE* to itself to make assignments file-local. - -- Added new variables EXT:*SOURCE-FILE-TYPES* and EXT:*OBJECT-FILE-TYPES*. - When no file type is specified, LOAD tries the types in these lists to - locate the source and object files. LOAD now recognizes source types "l", - "cl" and "lsp" in addition to "lisp". - -- The compiler OPTIMIZE policy is now bound during load, so proclamations in - a file don't leave the global policy clobbered when the load is finished. - -- Changed the :IF-SOURCE-NEWER option to signal an error and use restarts, - rather than PROMPT-FOR-Y-OR-N. Fixed the load source case to actually - load the source, rather than loading the object as a source file... - -- Changed load to deal with source files having NIL type more reasonably. - -- If a wild pathname is given to LOAD, all files matched will be loaded. - -- Proceeding from nonexistent file errors has been improved. It is no longer - assumed that missing files are always source files. Added condition - restarts for missing files. - -- Improved formatting of error and warning messages. - - -Garbage collection: - -- Changed the minimal ROOM output to include all easily computed information - including whether GC is disabled. The verbose ROOM now conses less. - -- Removed the :ENABLE-GC SAVE-LISP option, as it's no longer needed. - Garbage collection is now correctly enabled in cores which have been saved - and then restarted. - -- Added EXT:BYTES-CONSED-BETWEEN-GCS, a function that returns (and sets when - used with setf) *BYTES-CONSED-BETWEEN-GCS*. Additionally, it changes - *GC-TRIGGER* immediately to reflect the new values of *bytes-consed...*. - -- TIME now displays the GC run-time. - -- Added EXT:*GC-RUN-TIME* with accumulates the INTERNAL-RUN-TIME spent doing - garbage collection. Added declarations to make EXT:GET-BYTES-CONSED more - efficient. - -- The top-level REP loop now zeros the unused non-zero portion of the - control stack to discourage spurious garbage retention. - -- The garbage collector now closes open file streams when it reclaims them. - - -Packages: - -- The LISP and USER packages have been renamed to COMMON-LISP and - COMMON-LISP-USER. LISP and USER are nicknames, so they can still be used. - -- The LISP package namespace has been cleaned up somewhat. For example, - *DESCRIBE-PRINT-LEVEL* is no longer exported from LISP. - -- The Mach/Unix division in the package system has been clarified a great - deal. Unix specific features have been moved from the MACH package to the - UNIX package. Mach specific features have been left in (or moved to) the - MACH package. For example, all standard Unix syscalls are related - definitions are un UNIX, whereas vm_statistics remains in MACH and GR-CALL - has been moved to MACH. - -SETF cleanups: - -- Changed GET-SETF-METHOD-MULTIPLE-VALUE to try to macroexpand-1 the form - when it's an atom in case it's a symbol-macro as per the X3J13 cleanup - SYMBOL-MACROLET-SEMANTICS:SPECIAL-FORM. Now you can safely INCF, etc. - symbol macros where the macroexpansion has side effects. - -- Fixed SETF of GETF to evaluate the various parts in the correct order as - per X3J13 cleanup SETF-SUB-METHODS:DELAYED-ACCESS-STORES. - -- X3J13 cleanup SETF-MULTIPLE-STORE-VARIABLES: - Extend the semantics of the macros SETF, PSETF, SHIFTF, ROTATEF, and - ASSERT to allow "places" whose SETF methods have more than one "store - variable". In such cases, the macros accept as many values from the - newvalue form as there are store variables. As usual, extra values - are ignored and missing values default to NIL. - -- Extended the long form of DEFSETF to allow the specification of more - than one "store variable", with the obvious semantics. - -- GET-SETF-METHOD signals an error if there would be more than one - store-variable. - - -Printer: - -Almost all of the printing code has been rewritten/restructured to support -all of the printing features added to the language. Some highlights: - -- *PRINT-READABLY* is now supported. - -- *PRINT-CIRCLE* works irrespective of *PRINT-PRETTY*. Note: the default - structure printer currently does not work when *PRINT-CIRCLE* is true: you - get #1=#1#. - -- *PRINT-LEVEL* abbreviation now works automatically inside structure - printers. - -- XP has been replaced with a native pretty printer that is fully - integrated with the rest of the system. This Supports the ANSI - pretty-printing interface instead of the old Waters XP interface. Existing - uses of the old interface will need to be updated to use the new names. - -- The pretty-printer now unparses backquote forms on printing. To retain - this information, the backqoute read macro no longer expands into LIST, - CONS, etc. Internal functions are used instead. - -- The macros WITH-STANDARD-IO-SYNTAX and PRINT-UNREADABLE-OBJECT have - been added. - -- All new format. Supports the FORMATTER macro and all the pretty-printing - directives. FORMAT has extended to accept a function as the format control - (as an alternative to a string.) - -- Added support for READTABLE-CASE in symbol printing. Printing when - *PRINT-CASE* is :CAPITALIZE and *PRINT-ESCAPE* is NIL is now slightly - different than before. Added some missing array type declarations in - symbol printing. - -Bug fixes: - -- Fixed a bug which caused some float printing format directives to - infinitely loop when a fixed-width field overflowed. - -- Specify stream when printing unbound marker. - -- Fixed FORMAT to override printer control variables when printing float - exponents so that they are always printed in decimal, etc. - - -Reader: - -ANSI Cleanups: - -- *READ-EVAL* is now supported. If a #. is encountered while *READ-EVAL* - is NIL (default T), an error is signaled. This intended to allow - ``secure'' READ-based command interfaces to be written. - -- READTABLE-CASE is now supported. - -- The reader now signals the correct type of error when things go wrong - instead of always signaling a simple-error. - -- Changed the return value of SET-SYNTAX-FROM-CHAR from NIL to T as per X3J13 - cleanup RETURN-VALUES-UNSPECIFIED:SPECIFY. [Hard to believe nobody has - complained about not conforming to this one.] - -Bug fixes: - -- Fixes to several bugs with respect to #+, #-. In particular, stacked - conditionals like "#+foo #-bar baz" now work - -- #n= and #n# now detect more error conditions and work on structures. - -- # is now a non-terminating macro character, so foo#bar is read as a - symbol. - -- Added Ted's changes to make INTERNAL-READ-EXTENDED-TOKEN work when there - are `|' escapes. The main significance of this is that #+nil '|foo;bar| - and #:|foobar| now work properly. Also changed this function to recognize - unquoted colons so that #:foo:bar will error, but not #:foo\:bar. - -Enhancement: - -- Export new variable *ignore-extra-close-parentheses* if true (the default), - extra close parens are only a warning, not an error. Previously unmatched - close parens were quietly ignored. - - -Pathnames: - -This release supports all the new CltL2 pathname features except for logical -pathnames. Following is an overview of the new pathname support. - -Programs that actually conform to the CLtL1 pathname spec will have very few -problems. However, the CLtL1 spec was extremely vague, and CMU CL did not -make use of much of the allowed flexibility, so many technically non-portable -programs previously worked under CMU CL. - -The main incompatible changes from CLtL1 to CLtL2: - -- Symbols are no longer acceptable filenames. - -- PATHNAME-HOST may be any object. - -- :UNSPECIFIC is now a legal pathname component. - -- MERGE-PATHNAMES now recognizes relative pathnames and treats them - specially. - -The format of directories is now specified (to be a list in a certain format.) -This required an incompatible change from the previous practice of using a -vector PATHNAME-DIRECTORY and using "DEFAULT" or :ABSOLUTE in the -PATHNAME-DEVICE to indicate relative and absolute pathnames. - -In a related change, the CMU SEARCH-LIST extension was changed so that the -search-list now appears in the PATHNAME-DIRECTORY as: - (:ABSOLUTE #<Search-list "name"> ...) - -Other changes to search-lists: - -- (SETF SEARCH-LIST) now accepts a string or pathname, and converts it into - a one-element list. - -- Search-list elements are now canonicalized to pathnames rather than to - strings. - -- Instead of returning NIL, SEARCH-LIST now signals an error when it is - called on an undefined search list. - -- SEARCH-LIST-DEFINED-P is a predicate that tells if the search list is - currently defined. - -New features which are now supported: - -- Wildcard pathnames are now fully supported. In addition to allowing :WILD - in any pathname component, "extended wildcards" such as "foo*.*" are also - supported. A consequence of this is that PATTERN objects may appear in - wildcard pathname components instead of strings. See PATHNAME-MATCH-P and - TRANSLATE-PATHNAME. - -- As a CMU CL extension, a wildcard pathname may be used as the argument to - any filesystem interface (like OPEN) as long as it matches only one file. - -- The pathname :COMMON case mechanism provides a way around the problems of - portably specifying string pathname components in the presence of operating - systems with differing preferred case in their filesystem. An uppercase - string "LISP" is mapped to the "customary case" (lowercase on unix.) - Lowercase is also inverted: "readme" becomes "README". Mixed case is left - alone. Note that this mechanism is explicitly enabled by supplying :CASE - :COMMON to functions such as MAKE-PATHNAME. The default is the old - behavior (:CASE :LOCAL). - -Also, DIRECTORY now actually returns the TRUENAME of each file (as it was -always supposed to do.) If a matched file is a symbolic link, the truename may -be a file in some other directory that doesn't even match the pattern. The old -behavior can be obtained by specifying :FOLLOW-LINKS NIL. - -The new wildcard pathname mechanism has not yet been used to replace the old -single-wildcard matching in Hemlock DIRED, etc. - - -Debugger: - -- Added Miles' changes to keep errors and warnings on one line if they fit. - -- The debugger now starts up with the error frame as the current frame, so - it is no longer necessary to manually skip over internal frames resulting - from the error system invocation. - -- Fixed some debugger bugs that appeared when debugging interpreted code. - -- Added ``DESCRIBE'' debugger command. - -- Merged Miles' changes that allow the use of restart names as debugger - commands. - -- Changed SHOW-RESTARTS to also display the restart name (but only if it's - not shadowed by a higher priority restart). Changed the restart command - to look for restarts by name if a symbol is typed. - -- Bind *CURRENT-LEVEL* to 0, *PRINT-READABLY* to nil, and *READ-EVAL* to T - when entering the debugger to make sure things print as expected. - -The debugger programmer (DEBUG-INTERNALS) interface is now documented in the -User's Manual. This interface allows the coding of debuggers and debugger -extensions without requiring an intimate understanding of the compiler and -run-time system. Be warned that DI features (such as breakpoints) not used by -the current debugger may not work very well (wait for version 17.) - -Debug internals changes: - -- DI:DEBUG-FUNCTION-FUNCTION is now implemented. - -- Added DI:FLUSH-FRAMES-ABOVE for cleaning up frames to be bound to - DEBUG:*STACK-TOP-HINT*. - - -Defstruct: - -Various fixes and enhancements to defstruct slot parsing and inclusion. -It now works to define structures such as: - (defstruct super a) - (defstruct (sub1 (:conc-name super)) one) - (defstruct (sub2 (:conc-name super)) two) - (super-a (make-sub1)) - -previously, a definition such as for SUB2 would define SUPER-A to be a -SUB2-specific function, which could then no longer be used on other types. The -spec doesn't clearly say that such a construct is legal, but its use seems -fairly common. - -Also, slot parsing is now more rigorous. Unrecognized slot options cause an -error, as does a slot spec like: (defstruct foo (a :type t)) - -Fasl dumping of constant structures has been fixed to conform to X3J13. The -main significance of this is that DEFSTRUCT structures are no longer dumpable -by default. However, the generic function MAKE-LOAD-FORM isn't really used. -Instead, a new defstruct option, :MAKE-LOAD-FORM-FUN, has been added that can -be used to specify a function that acts like a MAKE-LOAD-FORM method. When we -have a CLOS that supports STRUCTURE-CLASS, the default method for -MAKE-LOAD-FORM will use this information instead of having the compiler use it -directly. The old behavior can be enabled on a structure by structure basis by -using the :MAKE-LOAD-FORM-FUN defstruct option: - (defstruct (foo (:make-load-form-fun :just-dump-it-normally)) - ...) - - -Compiler: - -Cleanups: - -- Added the LOAD-TIME-VALUE support special form. - -- Displaced or adjustable arrays and vectors with fill pointers can now be - dumped in fasl files, but are converted to simple array with the same - elements. - -- Arrays of floats are left as arrays of floats instead of being - converted into arrays of element-type T that just so happen to hold a - bunch of floats. - -- Changed IGNORE and IGNORABLE to recognize #'fn-name for declaring that - local functions are not used. Exported IGNORABLE from LISP. - -New optimizations: - -- Iterations written using tail recursion are now optimized through a - special-casing of local functions where all calls but one are - tail-recursive self-calls. Such functions are compiled with no - environment manipulation, resulting in the same code as explicit - iteration. - -- Loop rotation (Knuth "while" loop optimization) been added. This is the - optimization that negates the loop exit test and places it at the end of - the loop, and then jumps there at loop entry. Note that this is part of - control optimization, and not simply a recoding of certain iteration - macros. In fact, for historical reasons DO, etc. already had the exit - test negated, but the compiler was cleverly un-negating the test. - -- Flow analysis now recognizes function calls and special forms which do - not yield any value because they unwind or signal an error. This results - in improved code for error checks, since the compiler can get by with - fewer unconditional branches. A function can be declared not to return by - declaring its result type to be NIL (not to be confused with NULL). If a - function declared NIL does return, an error will be signalled. - -- Added derive-type methods for ASIN, ACOS, ACOSH, ATANH and SQRT which - figure out whether the result type is real on the basis of the argument - range. Also, the result of ATAN is always real, so we don't need a result - type assertion. - -- Added optimization which deletes MULTIPLE-VALUE-BINDs when all - variables have been deleted. - -- Eliminated some spurious checking of the result types of safe VOPs (such - as the SPARC tadd for fixnum arithmetic.) - -- Transform uses of the SEARCH generic sequence function on simple strings - into a call to a more efficient string-specific function. - -- Added multiplier recoding of (UNSIGNED-BYTE 32) multiplication. This - converts 32 bit (or smaller) unsigned multiplication by any compile-time - constant into a shift-add sequence. This is much faster when the constant - is a near power of two or when general multiplication is slow (as on the - SPARC.) - -- Added comprehensive handling of arithmetic and logical identities when - an arg is -1, 0 or +1. - -- Added a RANDOM derive-type method: (random 13) is (integer 0 12). - - -Enhancements: - -- Changed the compiler to temporarily increase *BYTES-CONSED- - BETWEEN-GCS* by a factor of 4 during compilation of each top-level form, - instead of turning off all garbage collection. - -- Bind *PRINT-LINES* around compiler error output to - *ERROR-PRINT-LINES*. - -- Do not warn about undefined variables, functions or types when the - INHIBIT-WARNINGS OPTIMIZE quality is 3. - -- Some optimizations are now considered "important"; failure of important - optimizations causes an efficiency note even when speed=inhibit-warnings - (i.e. by default.) - -- Print a error summary even when *COMPILE-VERBOSE* is false. (This is only - printed when there are errors, so this doesn't seem a violation of the - spirit of the spec.) - -Bug fixes: - -- Merged Miles' fix to disassembly of the MIPS coprocessor move instructions. - -- Fixed spelling of "efficency" in exported variables such as - *EFFICIENCY-NOTE-COST-THRESHOLD* - -- Fixed some cases where incomplete optimization could happen. - -- Fixed some arithmetic "identities" that failed to preserve the sign of - -0.0. - -- Fixed TYPES-INTERSECT to consider any supertype of T to definitely - intersect with anything (even an unknown type.) - -- Fixed a problem where inconsistent declarations could fail to be detected - at compile time. - -- Fixed the VALUES transform (which discards unused subforms) to work - on (VALUES). - -- More bug fixes to dead code deletion. - -- Fixed a problem where a special binding would not be removed on exit from - the scope if there was no code in the scope (e.g. it had all been - deleted.) - -- Fixed handling of named (DEFCONSTANT) constants so that EQ - relationships are properly preserved. - - -Extensions: - - -- Export FEATUREP from EXT. This takes a feature expression and tests it - against the value of *FEATURES*. Allow LISP:AND, LISP:OR, and LISP:NOT in - features lists in addition to :AND, :OR, and :NOT. This makes featurep - useful outside of #+ and #-. - -- The encapsulation mechanism (similar to advise facilities) has been - revamped to work on SETF function names as well as symbols. - EXT:ENCAPSULATED-DEFINITION - Returns whatever definition is stored for name, regardless of whether - it is encapsulated. Unlike FDEFINITION, this does not strip off the - encapsulation. This is SETF'able. - EXT:ENCAPSULATE - Replaces the definition of name with a function that binds name's - arguments a variable named argument-list, binds name's definition to a - variable named basic-definition, and EVAL's body in that context. Type - is whatever you would like to associate with this encapsulation for - identification in case you need multiple encapsuations of the same - name. - EXT:UNENCAPSULATE - Removes name's most recent encapsulation of the specified type. - EXT:ENCAPSULATED-P - Returns t if name has an encapsulation of the given type, otherwise - nil. - EXT:*SETF-FDEFINITION-HOOK* - A list of functions invoked by (SETF FDEFINITION) before storing the - new value. Each hook function must take the function name and the - new-value. - -Hemlock: - -- Fixed the :FILE branch of "Help on Parse" to trim leading directory - components off the pathname if it wouldn't otherwise fit on the screen. - -- Fixed GET-EDITOR-TTY-INPUT to not assume that UNIX-READ will always work. - -- When we reallocate string table vectors to grow them, clear the old vector - so that it won't hold onto garbage (in case the vector was in static space, - but pointed to dynamic values.) This was a major cause of memory leakage - in Hemlock. - -- Added a (setf (ts-stream-char-pos stream) 0) to the accept-input function - so that char-pos will be reset to zero whenever the user presses enter. - -PCL: - -- The version has been updated to "5/1/90 May Day PCL (REV 4b)". - -- The Code walker now understands the real SYMBOL-MACROLET, and the PCL macro - definition is no longer used. - -- Fixed a bug in WALK-ARGLIST where it would ignore the rest of the current - arglist if the current arg destructured. This was causing it to compile - forms like: - (macrolet ((foo ((a b) c) ...)) ...) - as: - (macrolet ((foo ((a b)) ...)) ...) - note the loss of the arg c. - - -System: - - -- All the SAP-REF-<n> functions now take byte offsets. Previously, the - 16 and 32bit versions were scaled by the element size. - -- Fixed UNIX-IOCTL to not flame out of the cmd is a ub-32 instead of a sb-32. - -- Added Miles' TCSETPGRP, TCGETPGRP, and TTY-PROCESS-GROUP. - -- Unix syscalls are now more restrictive in the kind of arguments that they - accept. In particular, UNIX:UNIX-READ, etc., no longer automatically - accept a vector (or string) argument. You must use VECTOR-SAP to convert - the vector to a system area pointer. Note that WITHOUT-GCING should be - wrapped around any syscall which is passed a pointer to the Lisp heap, - since the object might otherwise move doing the syscall. - -- Changed LOAD-FOREIGN to be exported from ALIEN. Changed it have keyword - args instead of optionals. Deleted obsolete linker argument. diff --git a/general-info/bugs.txt b/general-info/bugs.txt deleted file mode 100644 index e1b4a1a11515ed98840889bc56fc50d2dd3c4b2b..0000000000000000000000000000000000000000 --- a/general-info/bugs.txt +++ /dev/null @@ -1,20 +0,0 @@ -;;; -*- Mode: Text, Spell, Fill -*- - - - -;;;; Randomness - -The results of (machine-type) are not machine-type specific. - - - -;;;; Garbage Collector - -GC doesn't fix the LIP correctly if it is a raw function address and nobody -else has a handle on the real function object. (This can happen during -call.) GC needs to check to see if any of the descriptor objects are a -symbol with the same value as the LIP for the raw-function address. - -When GC is trying to find the descriptor object the LIP points into, it -should verify that the LIP points before the end, not just after the start. - diff --git a/general-info/cmu-README.txt b/general-info/cmu-README.txt deleted file mode 100644 index 5e2f3a0c70e61d0ab35f5b228a9ec0d293997df3..0000000000000000000000000000000000000000 --- a/general-info/cmu-README.txt +++ /dev/null @@ -1,38 +0,0 @@ -To get CMU Common Lisp, run: - /usr/cs/etc/modmisc - cs.misc.cmucl - -This establishes /usr/misc/.cmucl as a symbolic link to the release area. -In your .login, add CMU CL to your path: - setpath -i /usr/misc/.cmucl - -Then run "lisp". Note that the first time you run Lisp, it will take AFS -several minutes to copy the image into its local cache. Subsequent starts -will be much faster. - -Or, you can run directly out of the AFS release area (which may be necessary on -SunOS machines). Put this in your .login shell script: - setenv CMUCLLIB "/afs/cs/misc/cmucl/@sys/beta/lib" - setpath -i /afs/cs/misc/cmucl/@sys/beta - -After setting your path, "man cmucl" will give an introduction to CMU CL and -"man lisp" will describe command line options. For SunOS installation notes, -see the README file in the SunOS release area. - -See /usr/misc/.cmucl/doc for release notes and documentation. Rather old -hardcopy documentation is available as tech reports in the document room. - -Send bug reports and questions to cmucl-bugs@cs.cmu.edu. If you